changeset 2329:30c606bec7a8

[project @ 1996-07-19 01:29:05 by jwe] Initial revision
author jwe
date Fri, 19 Jul 1996 01:29:55 +0000
parents b44c3b2a5fce
children 12ff450cbb1f
files libcruft/balgen/balgen.f libcruft/balgen/gradeq.f libcruft/balgen/reduce.f libcruft/balgen/scaleg.f libcruft/blas/dasum.f libcruft/blas/daxpy.f libcruft/blas/dcabs1.f libcruft/blas/dcopy.f libcruft/blas/ddot.f libcruft/blas/dgemm.f libcruft/blas/dgemv.f libcruft/blas/dger.f libcruft/blas/dmach.f libcruft/blas/dnrm2.f libcruft/blas/drot.f libcruft/blas/dscal.f libcruft/blas/dswap.f libcruft/blas/dsyr.f libcruft/blas/dsyrk.f libcruft/blas/dtrmm.f libcruft/blas/dtrmv.f libcruft/blas/dtrsm.f libcruft/blas/dtrsv.f libcruft/blas/dzasum.f libcruft/blas/dznrm2.f libcruft/blas/idamax.f libcruft/blas/izamax.f libcruft/blas/lsame.f libcruft/blas/sdot.f libcruft/blas/xerbla.f libcruft/blas/zaxpy.f libcruft/blas/zcopy.f libcruft/blas/zdotc.f libcruft/blas/zdotu.f libcruft/blas/zdrot.f libcruft/blas/zdscal.f libcruft/blas/zgemm.f libcruft/blas/zgemv.f libcruft/blas/zgerc.f libcruft/blas/zgeru.f libcruft/blas/zherk.f libcruft/blas/zscal.f libcruft/blas/zswap.f libcruft/blas/ztrmm.f libcruft/blas/ztrmv.f libcruft/blas/ztrsm.f libcruft/blas/ztrsv.f libcruft/dassl/ddaini.f libcruft/dassl/ddajac.f libcruft/dassl/ddanrm.f libcruft/dassl/ddaslv.f libcruft/dassl/ddassl.f libcruft/dassl/ddastp.f libcruft/dassl/ddatrp.f libcruft/dassl/ddawts.f libcruft/dassl/dpotf2.f libcruft/dassl/dpotrf.f libcruft/dassl/xerhlt.f libcruft/dassl/xermsg.f libcruft/dassl/xerprn.f libcruft/dassl/xgetua.f libcruft/dassl/xsetua.f libcruft/eispack/epslon.f libcruft/eispack/qzhes.f libcruft/eispack/qzit.f libcruft/eispack/qzval.f libcruft/fftpack/cfftb.f libcruft/fftpack/cfftf.f libcruft/fftpack/cffti.f libcruft/fftpack/passb.f libcruft/fftpack/passb2.f libcruft/fftpack/passb3.f libcruft/fftpack/passb4.f libcruft/fftpack/passb5.f libcruft/fftpack/passf.f libcruft/fftpack/passf2.f libcruft/fftpack/passf3.f libcruft/fftpack/passf4.f libcruft/fftpack/passf5.f libcruft/fsqp/check.f libcruft/fsqp/di1.f libcruft/fsqp/diagnl.f libcruft/fsqp/dir.f libcruft/fsqp/dqp.f libcruft/fsqp/error.f libcruft/fsqp/estlam.f libcruft/fsqp/fool.f libcruft/fsqp/fsqpd.f libcruft/fsqp/fsqpd1.f libcruft/fsqp/grcnfd.f libcruft/fsqp/grobfd.f libcruft/fsqp/hesian.f libcruft/fsqp/indexs.f libcruft/fsqp/initpt.f libcruft/fsqp/lfuscp.f libcruft/fsqp/matrcp.f libcruft/fsqp/matrvc.f libcruft/fsqp/nullvc.f libcruft/fsqp/out.f libcruft/fsqp/ql0001.f libcruft/fsqp/ql0002.f libcruft/fsqp/resign.f libcruft/fsqp/sbout1.f libcruft/fsqp/sbout2.f libcruft/fsqp/scaprd.f libcruft/fsqp/shift.f libcruft/fsqp/slope.f libcruft/fsqp/small.f libcruft/fsqp/step.f libcruft/lapack/dbdsqr.f libcruft/lapack/dgebak.f libcruft/lapack/dgebal.f libcruft/lapack/dgebd2.f libcruft/lapack/dgebrd.f libcruft/lapack/dgeesx.f libcruft/lapack/dgeev.f libcruft/lapack/dgehd2.f libcruft/lapack/dgehrd.f libcruft/lapack/dgelq2.f libcruft/lapack/dgelqf.f libcruft/lapack/dgelss.f libcruft/lapack/dgeqpf.f libcruft/lapack/dgeqr2.f libcruft/lapack/dgeqrf.f libcruft/lapack/dgesv.f libcruft/lapack/dgesvd.f libcruft/lapack/dgetf2.f libcruft/lapack/dgetrf.f libcruft/lapack/dgetrs.f libcruft/lapack/dhseqr.f libcruft/lapack/dlabad.f libcruft/lapack/dlabrd.f libcruft/lapack/dlacon.f libcruft/lapack/dlacpy.f libcruft/lapack/dladiv.f libcruft/lapack/dlaexc.f libcruft/lapack/dlahqr.f libcruft/lapack/dlahrd.f libcruft/lapack/dlaln2.f libcruft/lapack/dlamc1.f libcruft/lapack/dlamc2.f libcruft/lapack/dlamc3.f libcruft/lapack/dlamc4.f libcruft/lapack/dlamc5.f libcruft/lapack/dlamch.f libcruft/lapack/dlange.f libcruft/lapack/dlanhs.f libcruft/lapack/dlanv2.f libcruft/lapack/dlapy2.f libcruft/lapack/dlapy3.f libcruft/lapack/dlarf.f libcruft/lapack/dlarfb.f libcruft/lapack/dlarfg.f libcruft/lapack/dlarft.f libcruft/lapack/dlarfx.f libcruft/lapack/dlartg.f libcruft/lapack/dlas2.f libcruft/lapack/dlascl.f libcruft/lapack/dlaset.f libcruft/lapack/dlasq1.f libcruft/lapack/dlasq2.f libcruft/lapack/dlasq3.f libcruft/lapack/dlasq4.f libcruft/lapack/dlasr.f libcruft/lapack/dlasrt.f libcruft/lapack/dlassq.f libcruft/lapack/dlasv2.f libcruft/lapack/dlaswp.f libcruft/lapack/dlasy2.f libcruft/lapack/dorg2r.f libcruft/lapack/dorgbr.f libcruft/lapack/dorghr.f libcruft/lapack/dorgl2.f libcruft/lapack/dorglq.f libcruft/lapack/dorgqr.f libcruft/lapack/dorm2r.f libcruft/lapack/dormbr.f libcruft/lapack/dorml2.f libcruft/lapack/dormlq.f libcruft/lapack/dormqr.f libcruft/lapack/drscl.f libcruft/lapack/dtrevc.f libcruft/lapack/dtrexc.f libcruft/lapack/dtrsen.f libcruft/lapack/dtrsyl.f libcruft/lapack/dzsum1.f libcruft/lapack/ilaenv.f libcruft/lapack/izmax1.f libcruft/lapack/zbdsqr.f libcruft/lapack/zdrscl.f libcruft/lapack/zgebak.f libcruft/lapack/zgebal.f libcruft/lapack/zgebd2.f libcruft/lapack/zgebrd.f libcruft/lapack/zgeesx.f libcruft/lapack/zgeev.f libcruft/lapack/zgehd2.f libcruft/lapack/zgehrd.f libcruft/lapack/zgelq2.f libcruft/lapack/zgelqf.f libcruft/lapack/zgelss.f libcruft/lapack/zgeqpf.f libcruft/lapack/zgeqr2.f libcruft/lapack/zgeqrf.f libcruft/lapack/zgesv.f libcruft/lapack/zgesvd.f libcruft/lapack/zgetf2.f libcruft/lapack/zgetrf.f libcruft/lapack/zgetrs.f libcruft/lapack/zhseqr.f libcruft/lapack/zlabrd.f libcruft/lapack/zlacgv.f libcruft/lapack/zlacon.f libcruft/lapack/zlacpy.f libcruft/lapack/zladiv.f libcruft/lapack/zlahqr.f libcruft/lapack/zlahrd.f libcruft/lapack/zlange.f libcruft/lapack/zlanhs.f libcruft/lapack/zlarf.f libcruft/lapack/zlarfb.f libcruft/lapack/zlarfg.f libcruft/lapack/zlarft.f libcruft/lapack/zlarfx.f libcruft/lapack/zlartg.f libcruft/lapack/zlascl.f libcruft/lapack/zlaset.f libcruft/lapack/zlasr.f libcruft/lapack/zlassq.f libcruft/lapack/zlaswp.f libcruft/lapack/zlatrs.f libcruft/lapack/zpotf2.f libcruft/lapack/zpotrf.f libcruft/lapack/zrot.f libcruft/lapack/ztrevc.f libcruft/lapack/ztrexc.f libcruft/lapack/ztrsen.f libcruft/lapack/ztrsyl.f libcruft/lapack/zung2r.f libcruft/lapack/zungbr.f libcruft/lapack/zunghr.f libcruft/lapack/zungl2.f libcruft/lapack/zunglq.f libcruft/lapack/zungqr.f libcruft/lapack/zunm2r.f libcruft/lapack/zunmbr.f libcruft/lapack/zunml2.f libcruft/lapack/zunmlq.f libcruft/lapack/zunmqr.f libcruft/linpack/dgbfa.f libcruft/linpack/dgbsl.f libcruft/linpack/dgeco.f libcruft/linpack/dgedi.f libcruft/linpack/dgefa.f libcruft/linpack/dgesl.f libcruft/linpack/spofa.f libcruft/linpack/zgeco.f libcruft/linpack/zgedi.f libcruft/linpack/zgefa.f libcruft/linpack/zgesl.f libcruft/minpack/dogleg.f libcruft/minpack/dpmpar.f libcruft/minpack/enorm.f libcruft/minpack/fdjac1.f libcruft/minpack/hybrd.f libcruft/minpack/hybrd1.f libcruft/minpack/hybrj.f libcruft/minpack/hybrj1.f libcruft/minpack/qform.f libcruft/minpack/qrfac.f libcruft/minpack/r1mpyq.f libcruft/minpack/r1updt.f libcruft/npsol/chcore.f libcruft/npsol/chfd.f libcruft/npsol/chkgrd.f libcruft/npsol/chkjac.f libcruft/npsol/cmalf.f libcruft/npsol/cmalf1.f libcruft/npsol/cmchk.f libcruft/npsol/cmperm.f libcruft/npsol/cmprt.f libcruft/npsol/cmqmul.f libcruft/npsol/cmr1md.f libcruft/npsol/cmrswp.f libcruft/npsol/cmtsol.f libcruft/npsol/dcond.f libcruft/npsol/dddiv.f libcruft/npsol/ddiv.f libcruft/npsol/ddscl.f libcruft/npsol/dgeap.f libcruft/npsol/dgeapq.f libcruft/npsol/dgeqr.f libcruft/npsol/dgeqrp.f libcruft/npsol/dgrfg.f libcruft/npsol/dload.f libcruft/npsol/dnorm.f libcruft/npsol/drot3.f libcruft/npsol/drot3g.f libcruft/npsol/dssq.f libcruft/npsol/icopy.f libcruft/npsol/idrank.f libcruft/npsol/iload.f libcruft/npsol/lsadd.f libcruft/npsol/lsadds.f libcruft/npsol/lsbnds.f libcruft/npsol/lschol.f libcruft/npsol/lscore.f libcruft/npsol/lscrsh.f libcruft/npsol/lsdel.f libcruft/npsol/lsdflt.f libcruft/npsol/lsfeas.f libcruft/npsol/lsfile.f libcruft/npsol/lsgetp.f libcruft/npsol/lsgset.f libcruft/npsol/lskey.f libcruft/npsol/lsloc.f libcruft/npsol/lsmove.f libcruft/npsol/lsmuls.f libcruft/npsol/lsoptn.f libcruft/npsol/lsprt.f libcruft/npsol/lssetx.f libcruft/npsol/lssol.f libcruft/npsol/mcenv1.f libcruft/npsol/mcenv2.f libcruft/npsol/mceps.f libcruft/npsol/mchpar.f libcruft/npsol/mcmin.f libcruft/npsol/mcsmal.f libcruft/npsol/mcstor.f libcruft/npsol/npalf.f libcruft/npsol/npchkd.f libcruft/npsol/npcore.f libcruft/npsol/npcrsh.f libcruft/npsol/npdflt.f libcruft/npsol/npfd.f libcruft/npsol/npfeas.f libcruft/npsol/npfile.f libcruft/npsol/npiqp.f libcruft/npsol/npkey.f libcruft/npsol/nploc.f libcruft/npsol/npmrt.f libcruft/npsol/npoptn.f libcruft/npsol/npprt.f libcruft/npsol/nprset.f libcruft/npsol/npsetx.f libcruft/npsol/npsol.f libcruft/npsol/npsrch.f libcruft/npsol/npupdt.f libcruft/npsol/opfile.f libcruft/npsol/oplook.f libcruft/npsol/opnumb.f libcruft/npsol/opscan.f libcruft/npsol/optokn.f libcruft/npsol/opuppr.f libcruft/npsol/srchc.f libcruft/npsol/srchq.f libcruft/odepack/cfode.f libcruft/odepack/ewset.f libcruft/odepack/intdy.f libcruft/odepack/lsode.f libcruft/odepack/vnorm.f libcruft/odepack/xerrwv.f libcruft/qpsol/addcon.f libcruft/qpsol/alloc.f libcruft/qpsol/axpy.f libcruft/qpsol/bdpert.f libcruft/qpsol/bndalf.f libcruft/qpsol/chkdat.f libcruft/qpsol/condvc.f libcruft/qpsol/copymx.f libcruft/qpsol/copyvc.f libcruft/qpsol/delcon.f libcruft/qpsol/dot.f libcruft/qpsol/dscale.f libcruft/qpsol/elm.f libcruft/qpsol/elmgen.f libcruft/qpsol/etagen.f libcruft/qpsol/findp.f libcruft/qpsol/getlam.f libcruft/qpsol/lpbgst.f libcruft/qpsol/lpcore.f libcruft/qpsol/lpcrsh.f libcruft/qpsol/lpdump.f libcruft/qpsol/lpgrad.f libcruft/qpsol/lpprt.f libcruft/qpsol/prtsol.f libcruft/qpsol/qpchkp.f libcruft/qpsol/qpcolr.f libcruft/qpsol/qpcore.f libcruft/qpsol/qpcrsh.f libcruft/qpsol/qpdump.f libcruft/qpsol/qpgrad.f libcruft/qpsol/qpprt.f libcruft/qpsol/qpsol.f libcruft/qpsol/quotnt.f libcruft/qpsol/refgen.f libcruft/qpsol/rot3.f libcruft/qpsol/rotgen.f libcruft/qpsol/rsolve.f libcruft/qpsol/sscale.f libcruft/qpsol/tqadd.f libcruft/qpsol/tsolve.f libcruft/qpsol/v2norm.f libcruft/qpsol/zerovc.f libcruft/qpsol/zyprod.f libcruft/quadpack/dqagi.f libcruft/quadpack/dqagie.f libcruft/quadpack/dqagp.f libcruft/quadpack/dqagpe.f libcruft/quadpack/dqelg.f libcruft/quadpack/dqk15i.f libcruft/quadpack/dqk21.f libcruft/quadpack/dqpsrt.f libcruft/quadpack/xerror.f libcruft/ranlib/advnst.f libcruft/ranlib/genbet.f libcruft/ranlib/genchi.f libcruft/ranlib/genexp.f libcruft/ranlib/genf.f libcruft/ranlib/gengam.f libcruft/ranlib/genmn.f libcruft/ranlib/gennch.f libcruft/ranlib/gennf.f libcruft/ranlib/gennor.f libcruft/ranlib/genprm.f libcruft/ranlib/genunf.f libcruft/ranlib/getcgn.f libcruft/ranlib/getsd.f libcruft/ranlib/ignbin.f libcruft/ranlib/ignlgi.f libcruft/ranlib/ignpoi.f libcruft/ranlib/initgn.f libcruft/ranlib/inrgcm.f libcruft/ranlib/lennob.f libcruft/ranlib/mltmod.f libcruft/ranlib/phrtsd.f libcruft/ranlib/qrgnin.f libcruft/ranlib/ranf.f libcruft/ranlib/setall.f libcruft/ranlib/setant.f libcruft/ranlib/setgmn.f libcruft/ranlib/setsd.f libcruft/ranlib/sexpo.f libcruft/ranlib/sgamma.f libcruft/ranlib/snorm.f libcruft/ranlib/wrap.f libcruft/slatec-fn/d9lgmc.f libcruft/slatec-fn/dacosh.f libcruft/slatec-fn/dasinh.f libcruft/slatec-fn/datanh.f libcruft/slatec-fn/dcsevl.f libcruft/slatec-fn/derf.f libcruft/slatec-fn/derfc.f libcruft/slatec-fn/dgamlm.f libcruft/slatec-fn/dgamma.f libcruft/slatec-fn/dlgams.f libcruft/slatec-fn/dlngam.f libcruft/slatec-fn/initds.f libcruft/villad/dfopr.f libcruft/villad/dif.f libcruft/villad/intrp.f libcruft/villad/jcobi.f libcruft/villad/radau.f libcruft/villad/vilerr.f
diffstat 464 files changed, 92048 insertions(+), 0 deletions(-) [+]
line wrap: on
line diff
new file mode 100644
--- /dev/null
+++ b/libcruft/balgen/balgen.f
@@ -0,0 +1,102 @@
+      subroutine balgen (n,ma,a,mb,b,low,igh,cscale,cperm,wk)
+c
+c     *****parameters:
+      integer igh,low,ma,mb,n
+      double precision a(ma,n),b(mb,n),cperm(n),cscale(n),wk(n,6)
+c
+c     *****local variables:
+c     none
+c
+c     *****functions:
+c     none
+c
+c     *****subroutines called:
+c     reduce, scaleg, gradeq
+c
+c     ---------------------------------------------------------------
+c
+c     *****purpose:
+c     this subroutine balances the matrices a and b to improve the
+c     accuracy of computing the eigensystem of the generalized
+c     eigenproblem a*x = (lambda)*b*x.  the algorithm is specifically
+c     designed to precede qz type algorithms, but improved performance
+c     is expected from most eigensystem solvers.
+c     ref.:  ward, r. c., balancing the generalized eigenvalue
+c     problem, siam j. sci. stat. comput., vol. 2, no. 2, june 1981,
+c     141-152.
+c
+c     *****parameter description:
+c
+c     on input:
+c
+c       ma,mb   integer
+c               row dimensions of the arrays containing matrices
+c               a and b respectively, as declared in the main calling
+c               program dimension statement;
+c
+c       n       integer
+c               order of the matrices a and b;
+c
+c       a       real(ma,n)
+c               contains the a matrix of the generalized eigenproblem
+c               defined above;
+c
+c       b       real(mb,n)
+c               contains the b matrix of the generalized eigenproblem
+c               defined above;
+c
+c       wk      real(n,6)
+c               work array that must contain at least 6*n storage
+c               locations.  wk is altered by this subroutine.
+c
+c     on output:
+c
+c       a,b     contain the balanced a and b matrices;
+c
+c       low     integer
+c               beginning -1 of the submatrices of a and b
+c               containing the non-isolated eigenvalues;
+c
+c       igh     integer
+c               ending -1 of the submatrices of a and b
+c               containing the non-isolated eigenvalues.  if
+c               igh = 1 (low = 1 also), the a and b matrices have
+c               been permuted into upper triangular form and have
+c               not been balanced;
+c
+c       cscale  real(n)
+c               contains the exponents of the column scaling factors
+c               in its low through igh locations and the reducing
+c               column permutations in its first low-1 and its
+c               igh+1 through n locations;
+c
+c       cperm   real(n)
+c               contains the column permutations applied in grading
+c               the a and b submatrices in its low through igh
+c               locations;
+c
+c       wk      contains the exponents of the row scaling factors
+c               in its low through igh locations, the reducing row
+c               permutations in its first low-1 and its igh+1
+c               through n locations, and the row permutations
+c               applied in grading the a and b submatrices in its
+c               n+low through n+igh locations.
+c
+c     *****algorithm notes:
+c     none
+c
+c     *****history:
+c     written by r. c. ward.......
+c
+c     ---------------------------------------------------------------
+c
+      call reduce (n,ma,a,mb,b,low,igh,cscale,wk)
+      if (low .eq. igh) go to 10
+      call scaleg (n,ma,a,mb,b,low,igh,cscale,cperm,wk)
+      call gradeq (n,ma,a,mb,b,low,igh,cperm,wk(1,2))
+   10 continue
+      return
+c
+c     last line of balgen
+c
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/balgen/gradeq.f
@@ -0,0 +1,177 @@
+      subroutine gradeq (n,ma,a,mb,b,low,igh,cperm,wk)
+c
+c     *****parameters:
+      integer igh,low,ma,mb,n
+      double precision a(ma,n),b(mb,n),cperm(n),wk(n,2)
+c
+c     *****local variables:
+      integer i,ighm1,im,ip1,j,jm,jp1,k
+      double precision cmax,rmax,suma,sumb,temp
+c
+c     *****fortran functions:
+      double precision dabs
+c
+c     *****subroutines called:
+c     none
+c
+c     ---------------------------------------------------------------
+c
+c     *****purpose:
+c     this subroutine grades the submatrices of a and b given by
+c     starting -1 low and ending -1 igh in the generalized
+c     eigenvalue problem a*x = (lambda)*b*x by permuting rows and
+c     columns such that the norm of the i-th row (column) of the
+c     a submatrix divided by the norm of the i-th row (column) of
+c     the b submatrix becomes smaller as i increases.
+c     ref.:  ward, r. c., balancing the generalized eigenvalue
+c     problem, siam j. sci. stat. comput., vol. 2, no. 2, june 1981,
+c     141-152.
+c
+c     *****parameter description:
+c
+c     on input:
+c
+c       ma,mb   integer
+c               row dimensions of the arrays containing matrices
+c               a and b respectively, as declared in the main calling
+c               program dimension statement;
+c
+c       n       integer
+c               order of the matrices a and b;
+c
+c       a       real(ma,n)
+c               contains the a matrix of the generalized eigenproblem
+c               defined above;
+c
+c       b       real(mb,n)
+c               contains the b matrix of the generalized eigenproblem
+c               defined above;
+c
+c       low     integer
+c               specifies the beginning -1 for the rows and
+c               columns of a and b to be graded;
+c
+c       igh     integer
+c               specifies the ending -1 for the rows and columns
+c               of a and b to be graded;
+c
+c       wk      real(n,2)
+c               work array that must contain at least 2*n locations.
+c               only locations low through igh and n+low through
+c               n+igh are referenced by this subroutine.
+c
+c     on output:
+c
+c       a,b     contain the permuted and graded a and b matrices;
+c
+c       cperm   real(n)
+c               contains in its low through igh locations the
+c               column permutations applied in grading the
+c               submatrices.  the other locations are not referenced
+c               by this subroutine;
+c
+c       wk      contains in its low through igh locations the row
+c               permutations applied in grading the submatrices.
+c
+c     *****algorithm notes:
+c     none.
+c
+c     *****history:
+c     written by r. c. ward.......
+c
+c     ---------------------------------------------------------------
+c
+      if (low .eq. igh) go to 510
+      ighm1 = igh-1
+c
+c     compute column norms of a / those of b
+c
+      do 420 j = low,igh
+         suma = 0.0d0
+         sumb = 0.0d0
+         do 410 i = low,igh
+            suma = suma + dabs(a(i,j))
+            sumb = sumb + dabs(b(i,j))
+  410    continue
+         if (sumb .eq. 0.0d0) go to 415
+         wk(j,2) = suma / sumb
+         go to 420
+  415    continue
+         wk(j,2) = 1.0d38
+  420 continue
+c
+c     permute columns to order them by decreasing quotients
+c
+      do 450 j = low,ighm1
+         cmax = wk(j,2)
+         jm = j
+         jp1 = j+1
+         do 430 k = jp1,igh
+            if (cmax .ge. wk(k,2)) go to 430
+            jm = k
+            cmax = wk(k,2)
+  430    continue
+         cperm(j) = jm
+         if (jm .eq. j) go to 450
+         temp = wk(j,2)
+         wk(j,2) = wk(jm,2)
+         wk(jm,2) = temp
+         do 440 i = 1,igh
+            temp = b(i,j)
+            b(i,j) = b(i,jm)
+            b(i,jm) = temp
+            temp = a(i,j)
+            a(i,j) = a(i,jm)
+            a(i,jm) = temp
+  440    continue
+  450 continue
+      cperm(igh) = igh
+c
+c     compute row norms of a / those of b
+c
+      do 470 i = low,igh
+         suma = 0.0d0
+         sumb = 0.0d0
+         do 460 j = low,igh
+            suma = suma + dabs(a(i,j))
+            sumb = sumb + dabs(b(i,j))
+  460    continue
+         if (sumb .eq. 0.0d0) go to 465
+         wk(i,2) = suma / sumb
+         go to 470
+  465    continue
+         wk(i,2) = 1.0d38
+c
+c     permute rows to order them by decreasing quotients
+c
+  470 continue
+      do 500 i = low,ighm1
+         rmax = wk(i,2)
+         im = i
+         ip1 = i+1
+         do 480 k = ip1,igh
+            if (rmax .ge. wk(k,2)) go to 480
+            im = k
+            rmax = wk(k,2)
+  480    continue
+         wk(i,1) = im
+         if (im .eq. i) go to 500
+         temp = wk(i,2)
+         wk(i,2) = wk(im,2)
+         wk(im,2) = temp
+         do 490 j = low,n
+            temp = b(i,j)
+            b(i,j) = b(im,j)
+            b(im,j) = temp
+            temp = a(i,j)
+            a(i,j) = a(im,j)
+            a(im,j) = temp
+  490    continue
+  500 continue
+      wk(igh,1) = igh
+  510 continue
+      return
+c
+c     last line of gradeq
+c
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/balgen/reduce.f
@@ -0,0 +1,181 @@
+      subroutine reduce (n,ma,a,mb,b,low,igh,cscale,wk)
+c
+c     *****parameters:
+      integer igh,low,ma,mb,n
+      double precision a(ma,n),b(mb,n),cscale(n),wk(n)
+c
+c     *****local variables:
+      integer i,iflow,ii,ip1,is,j,jp1,k,l,lm1,m
+      double precision f
+c
+c     *****functions:
+c     none
+c
+c     *****subroutines called:
+c     none
+c
+c     ---------------------------------------------------------------
+c
+c     *****purpose:
+c     this subroutine reduces, if possible, the order of the
+c     generalized eigenvalue problem a*x = (lambda)*b*x by permuting
+c     the rows and columns of a and b so that they each have the
+c     form
+c                       u  x  y
+c                       0  c  z
+c                       0  0  r
+c
+c     where u and r are upper triangular and c, x, y, and z are
+c     arbitrary.  thus, the isolated eigenvalues corresponding to
+c     the triangular matrices are obtained by a division, leaving
+c     only eigenvalues corresponding to the center matrices to be
+c     computed.
+c     ref.:  ward, r. c., balancing the generalized eigenvalue
+c     problem, siam j. sci. stat. comput., vol. 2, no. 2, june 1981,
+c     141-152.
+c
+c     *****parameter description:
+c
+c     on input:
+c
+c       ma,mb   integer
+c               row dimensions of the arrays containing matrices
+c               a and b respectively, as declared in the main calling
+c               program dimension statement;
+c
+c       n       integer
+c               order of the matrices a and b;
+c
+c       a       real(ma,n)
+c               contains the a matrix of the generalized eigenproblem
+c               defined above;
+c
+c       b       real(mb,n)
+c               contains the b matrix of the generalized eigenproblem
+c               defined above.
+c
+c     on output:
+c
+c       a,b     contain the permuted a and b matrices;
+c
+c       low     integer
+c               beginning -1 of the submatrices of a and b
+c               containing the non-isolated eigenvalues;
+c
+c       igh     integer
+c               ending -1 of the submatrices of a and b
+c               containing the non-isolated eigenvalues.  if
+c               igh = 1 (low = 1 also), the permuted a and b
+c               matrices are upper triangular;
+c
+c       cscale  real(n)
+c               contains the required column permutations in its
+c               first low-1 and its igh+1 through n locations;
+c
+c       wk      real(n)
+c               contains the required row permutations in its first
+c               low-1 and its igh+1 through n locations.
+c
+c     *****algorithm notes:
+c     none
+c
+c     *****history:
+c     written by r. c. ward.......
+c
+c     ---------------------------------------------------------------
+c
+      k = 1
+      l = n
+      go to 20
+c
+c     find row with one nonzero in columns 1 through l
+c
+   10 continue
+      l = lm1
+      if (l .ne. 1) go to 20
+      wk(1) = 1
+      cscale(1) = 1
+      go to 200
+   20 continue
+      lm1 = l-1
+      do 70 ii = 1,l
+         i = l+1-ii
+         do 30 j = 1,lm1
+            jp1 = j+1
+            if (a(i,j) .ne. 0.0d0 .or. b(i,j) .ne. 0.0d0) go to 40
+   30    continue
+         j = l
+         go to 60
+   40    continue
+         do 50 j = jp1,l
+            if (a(i,j) .ne. 0.0d0 .or. b(i,j) .ne. 0.0d0) go to 70
+   50    continue
+         j = jp1-1
+   60    continue
+         m = l
+         iflow = 1
+         go to 150
+   70 continue
+      go to 90
+c
+c     find column with one nonzero in rows k through n
+c
+   80 continue
+      k = k+1
+   90 continue
+      do 140 j = k,l
+         do 100 i = k,lm1
+            ip1 = i+1
+            if (a(i,j) .ne. 0.0d0 .or. b(i,j) .ne. 0.0d0) go to 110
+  100    continue
+         i = l
+         go to 130
+  110    continue
+         do 120 i = ip1,l
+            if (a(i,j) .ne. 0.0d0 .or. b(i,j) .ne. 0.0d0) go to 140
+  120    continue
+         i = ip1-1
+  130    continue
+         m = k
+         iflow = 2
+         go to 150
+  140 continue
+      go to 200
+c
+c     permute rows m and i
+c
+  150 continue
+      wk(m) = i
+      if (i .eq. m) go to 170
+      do 160 is = k,n
+         f = a(i,is)
+         a(i,is) = a(m,is)
+         a(m,is) = f
+         f = b(i,is)
+         b(i,is) = b(m,is)
+         b(m,is) = f
+  160 continue
+c
+c     permute columns m and j
+c
+  170 continue
+      cscale(m) = j
+      if (j .eq. m) go to 190
+      do 180 is = 1,l
+         f = a(is,j)
+         a(is,j) = a(is,m)
+         a(is,m) = f
+         f = b(is,j)
+         b(is,j) = b(is,m)
+         b(is,m) = f
+  180 continue
+  190 continue
+      go to (10,80), iflow
+  200 continue
+      low = k
+      igh = l
+      return
+c
+c     last line of reduce
+c
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/balgen/scaleg.f
@@ -0,0 +1,236 @@
+      subroutine scaleg (n,ma,a,mb,b,low,igh,cscale,cperm,wk)
+c
+c     *****parameters:
+      integer igh,low,ma,mb,n
+      double precision a(ma,n),b(mb,n),cperm(n),cscale(n),wk(n,6)
+c
+c     *****local variables:
+      integer i,ir,it,j,jc,kount,nr,nrp2
+      double precision alpha,basl,beta,cmax,coef,coef2,coef5,cor,
+     *                 ew,ewc,fi,fj,gamma,pgamma,sum,t,ta,tb,tc
+c
+c     *****fortran functions:
+      double precision dabs, dlog10, dsign
+c     float
+c
+c     *****subroutines called:
+c     none
+c
+c     ---------------------------------------------------------------
+c
+c     *****purpose:
+c     scales the matrices a and b in the generalized eigenvalue
+c     problem a*x = (lambda)*b*x such that the magnitudes of the
+c     elements of the submatrices of a and b (as specified by low
+c     and igh) are close to unity in the least squares sense.
+c     ref.:  ward, r. c., balancing the generalized eigenvalue
+c     problem, siam j. sci. stat. comput., vol. 2, no. 2, june 1981,
+c     141-152.
+c
+c     *****parameter description:
+c
+c     on input:
+c
+c       ma,mb   integer
+c               row dimensions of the arrays containing matrices
+c               a and b respectively, as declared in the main calling
+c               program dimension statement;
+c
+c       n       integer
+c               order of the matrices a and b;
+c
+c       a       real(ma,n)
+c               contains the a matrix of the generalized eigenproblem
+c               defined above;
+c
+c       b       real(mb,n)
+c               contains the b matrix of the generalized eigenproblem
+c               defined above;
+c
+c       low     integer
+c               specifies the beginning -1 for the rows and
+c               columns of a and b to be scaled;
+c
+c       igh     integer
+c               specifies the ending -1 for the rows and columns
+c               of a and b to be scaled;
+c
+c       cperm   real(n)
+c               work array.  only locations low through igh are
+c               referenced and altered by this subroutine;
+c
+c       wk      real(n,6)
+c               work array that must contain at least 6*n locations.
+c               only locations low through igh, n+low through n+igh,
+c               ..., 5*n+low through 5*n+igh are referenced and
+c               altered by this subroutine.
+c
+c     on output:
+c
+c       a,b     contain the scaled a and b matrices;
+c
+c       cscale  real(n)
+c               contains in its low through igh locations the integer
+c               exponents of 2 used for the column scaling factors.
+c               the other locations are not referenced;
+c
+c       wk      contains in its low through igh locations the integer
+c               exponents of 2 used for the row scaling factors.
+c
+c     *****algorithm notes:
+c     none.
+c
+c     *****history:
+c     written by r. c. ward.......
+c     modified 8/86 by bobby bodenheimer so that if
+c       sum = 0 (corresponding to the case where the matrix
+c       doesn't need to be scaled) the routine returns.
+c
+c     ---------------------------------------------------------------
+c
+      if (low .eq. igh) go to 410
+      do 210 i = low,igh
+         wk(i,1) = 0.0d0
+         wk(i,2) = 0.0d0
+         wk(i,3) = 0.0d0
+         wk(i,4) = 0.0d0
+         wk(i,5) = 0.0d0
+         wk(i,6) = 0.0d0
+         cscale(i) = 0.0d0
+         cperm(i) = 0.0d0
+  210 continue
+c
+c     compute right side vector in resulting linear equations
+c
+      basl = dlog10(2.0d0)
+      do 240 i = low,igh
+         do 240 j = low,igh
+            tb = b(i,j)
+            ta = a(i,j)
+            if (ta .eq. 0.0d0) go to 220
+            ta = dlog10(dabs(ta)) / basl
+  220       continue
+            if (tb .eq. 0.0d0) go to 230
+            tb = dlog10(dabs(tb)) / basl
+  230       continue
+            wk(i,5) = wk(i,5) - ta - tb
+            wk(j,6) = wk(j,6) - ta - tb
+  240 continue
+      nr = igh-low+1
+      coef = 1.0d0/float(2*nr)
+      coef2 = coef*coef
+      coef5 = 0.5d0*coef2
+      nrp2 = nr+2
+      beta = 0.0d0
+      it = 1
+c
+c     start generalized conjugate gradient iteration
+c
+  250 continue
+      ew = 0.0d0
+      ewc = 0.0d0
+      gamma = 0.0d0
+      do 260 i = low,igh
+         gamma = gamma + wk(i,5)*wk(i,5) + wk(i,6)*wk(i,6)
+         ew = ew + wk(i,5)
+         ewc = ewc + wk(i,6)
+  260 continue
+      gamma = coef*gamma - coef2*(ew**2 + ewc**2)
+     +        - coef5*(ew - ewc)**2
+      if (it .ne. 1) beta = gamma / pgamma
+      t = coef5*(ewc - 3.0d0*ew)
+      tc = coef5*(ew - 3.0d0*ewc)
+      do 270 i = low,igh
+         wk(i,2) = beta*wk(i,2) + coef*wk(i,5) + t
+         cperm(i) = beta*cperm(i) + coef*wk(i,6) + tc
+  270 continue
+c
+c     apply matrix to vector
+c
+      do 300 i = low,igh
+         kount = 0
+         sum = 0.0d0
+         do 290 j = low,igh
+            if (a(i,j) .eq. 0.0d0) go to 280
+            kount = kount+1
+            sum = sum + cperm(j)
+  280       continue
+            if (b(i,j) .eq. 0.0d0) go to 290
+            kount = kount+1
+            sum = sum + cperm(j)
+  290    continue
+         wk(i,3) = float(kount)*wk(i,2) + sum
+  300 continue
+      do 330 j = low,igh
+         kount = 0
+         sum = 0.0d0
+         do 320 i = low,igh
+            if (a(i,j) .eq. 0.0d0) go to 310
+            kount = kount+1
+            sum = sum + wk(i,2)
+  310       continue
+            if (b(i,j) .eq. 0.0d0) go to 320
+            kount = kount+1
+            sum = sum + wk(i,2)
+  320    continue
+         wk(j,4) = float(kount)*cperm(j) + sum
+  330 continue
+      sum = 0.0d0
+      do 340 i = low,igh
+         sum = sum + wk(i,2)*wk(i,3) + cperm(i)*wk(i,4)
+  340 continue
+      if(sum.eq.0.0d0) return
+      alpha = gamma / sum
+c
+c     determine correction to current iterate
+c
+      cmax = 0.0d0
+      do 350 i = low,igh
+         cor = alpha * wk(i,2)
+         if (dabs(cor) .gt. cmax) cmax = dabs(cor)
+         wk(i,1) = wk(i,1) + cor
+         cor = alpha * cperm(i)
+         if (dabs(cor) .gt. cmax) cmax = dabs(cor)
+         cscale(i) = cscale(i) + cor
+  350 continue
+      if (cmax .lt. 0.5d0) go to 370
+      do 360 i = low,igh
+         wk(i,5) = wk(i,5) - alpha*wk(i,3)
+         wk(i,6) = wk(i,6) - alpha*wk(i,4)
+  360 continue
+      pgamma = gamma
+      it = it+1
+      if (it .le. nrp2) go to 250
+c
+c     end generalized conjugate gradient iteration
+c
+  370 continue
+      do 380 i = low,igh
+         ir = wk(i,1) + dsign(0.5d0,wk(i,1))
+         wk(i,1) = ir
+         jc = cscale(i) + dsign(0.5d0,cscale(i))
+         cscale(i) = jc
+  380 continue
+c
+c     scale a and b
+c
+      do 400 i = 1,igh
+         ir = wk(i,1)
+         fi = 2.0d0**ir
+         if (i .lt. low) fi = 1.0d0
+         do 400 j =low,n
+            jc = cscale(j)
+            fj = 2.0d0**jc
+            if (j .le. igh) go to 390
+            if (i .lt. low) go to 400
+            fj = 1.0d0
+  390       continue
+            a(i,j) = a(i,j)*fi*fj
+            b(i,j) = b(i,j)*fi*fj
+  400 continue
+  410 continue
+      return
+c
+c     last line of scaleg
+c
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/dasum.f
@@ -0,0 +1,41 @@
+      DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX)
+C
+C     TAKES THE SUM OF THE ABSOLUTE VALUES.
+C     JACK DONGARRA, LINPACK, 3/11/78.
+C
+      DOUBLE PRECISION DX(1),DTEMP
+      INTEGER I,INCX,M,MP1,N,NINCX
+C
+      DASUM = 0.0D0
+      DTEMP = 0.0D0
+      IF(N.LE.0)RETURN
+      IF(INCX.EQ.1)GO TO 20
+C
+C        CODE FOR INCREMENT NOT EQUAL TO 1
+C
+      NINCX = N*INCX
+      DO 10 I = 1,NINCX,INCX
+        DTEMP = DTEMP + DABS(DX(I))
+   10 CONTINUE
+      DASUM = DTEMP
+      RETURN
+C
+C        CODE FOR INCREMENT EQUAL TO 1
+C
+C
+C        CLEAN-UP LOOP
+C
+   20 M = MOD(N,6)
+      IF( M .EQ. 0 ) GO TO 40
+      DO 30 I = 1,M
+        DTEMP = DTEMP + DABS(DX(I))
+   30 CONTINUE
+      IF( N .LT. 6 ) GO TO 60
+   40 MP1 = M + 1
+      DO 50 I = MP1,N,6
+        DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I + 1)) + DABS(DX(I + 2))
+     *  + DABS(DX(I + 3)) + DABS(DX(I + 4)) + DABS(DX(I + 5))
+   50 CONTINUE
+   60 DASUM = DTEMP
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/daxpy.f
@@ -0,0 +1,47 @@
+      SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
+C
+C     CONSTANT TIMES A VECTOR PLUS A VECTOR.
+C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
+C     JACK DONGARRA, LINPACK, 3/11/78.
+C
+      DOUBLE PRECISION DX(1),DY(1),DA
+      INTEGER I,INCX,INCY,IXIY,M,MP1,N
+C
+      IF(N.LE.0)RETURN
+      IF (DA .EQ. 0.0D0) RETURN
+      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
+C
+C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
+C          NOT EQUAL TO 1
+C
+      IX = 1
+      IY = 1
+      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
+      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
+      DO 10 I = 1,N
+        DY(IY) = DY(IY) + DA*DX(IX)
+        IX = IX + INCX
+        IY = IY + INCY
+   10 CONTINUE
+      RETURN
+C
+C        CODE FOR BOTH INCREMENTS EQUAL TO 1
+C
+C
+C        CLEAN-UP LOOP
+C
+   20 M = MOD(N,4)
+      IF( M .EQ. 0 ) GO TO 40
+      DO 30 I = 1,M
+        DY(I) = DY(I) + DA*DX(I)
+   30 CONTINUE
+      IF( N .LT. 4 ) RETURN
+   40 MP1 = M + 1
+      DO 50 I = MP1,N,4
+        DY(I) = DY(I) + DA*DX(I)
+        DY(I + 1) = DY(I + 1) + DA*DX(I + 1)
+        DY(I + 2) = DY(I + 2) + DA*DX(I + 2)
+        DY(I + 3) = DY(I + 3) + DA*DX(I + 3)
+   50 CONTINUE
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/dcabs1.f
@@ -0,0 +1,8 @@
+      double precision function dcabs1(z)
+      double complex z,zz
+      double precision t(2)
+      equivalence (zz,t(1))
+      zz = z
+      dcabs1 = dabs(t(1)) + dabs(t(2))
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/dcopy.f
@@ -0,0 +1,49 @@
+      SUBROUTINE  DCOPY(N,DX,INCX,DY,INCY)
+C
+C     COPIES A VECTOR, X, TO A VECTOR, Y.
+C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
+C     JACK DONGARRA, LINPACK, 3/11/78.
+C
+      DOUBLE PRECISION DX(1),DY(1)
+      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
+C
+      IF(N.LE.0)RETURN
+      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
+C
+C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
+C          NOT EQUAL TO 1
+C
+      IX = 1
+      IY = 1
+      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
+      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
+      DO 10 I = 1,N
+        DY(IY) = DX(IX)
+        IX = IX + INCX
+        IY = IY + INCY
+   10 CONTINUE
+      RETURN
+C
+C        CODE FOR BOTH INCREMENTS EQUAL TO 1
+C
+C
+C        CLEAN-UP LOOP
+C
+   20 M = MOD(N,7)
+      IF( M .EQ. 0 ) GO TO 40
+      DO 30 I = 1,M
+        DY(I) = DX(I)
+   30 CONTINUE
+      IF( N .LT. 7 ) RETURN
+   40 MP1 = M + 1
+      DO 50 I = MP1,N,7
+        DY(I) = DX(I)
+        DY(I + 1) = DX(I + 1)
+        DY(I + 2) = DX(I + 2)
+        DY(I + 3) = DX(I + 3)
+        DY(I + 4) = DX(I + 4)
+        DY(I + 5) = DX(I + 5)
+        DY(I + 6) = DX(I + 6)
+   50 CONTINUE
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/ddot.f
@@ -0,0 +1,48 @@
+      DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
+C
+C     FORMS THE DOT PRODUCT OF TWO VECTORS.
+C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
+C     JACK DONGARRA, LINPACK, 3/11/78.
+C
+      DOUBLE PRECISION DX(1),DY(1),DTEMP
+      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
+C
+      DDOT = 0.0D0
+      DTEMP = 0.0D0
+      IF(N.LE.0)RETURN
+      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
+C
+C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
+C          NOT EQUAL TO 1
+C
+      IX = 1
+      IY = 1
+      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
+      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
+      DO 10 I = 1,N
+        DTEMP = DTEMP + DX(IX)*DY(IY)
+        IX = IX + INCX
+        IY = IY + INCY
+   10 CONTINUE
+      DDOT = DTEMP
+      RETURN
+C
+C        CODE FOR BOTH INCREMENTS EQUAL TO 1
+C
+C
+C        CLEAN-UP LOOP
+C
+   20 M = MOD(N,5)
+      IF( M .EQ. 0 ) GO TO 40
+      DO 30 I = 1,M
+        DTEMP = DTEMP + DX(I)*DY(I)
+   30 CONTINUE
+      IF( N .LT. 5 ) GO TO 60
+   40 MP1 = M + 1
+      DO 50 I = MP1,N,5
+        DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) +
+     *   DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4)
+   50 CONTINUE
+   60 DDOT = DTEMP
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/dgemm.f
@@ -0,0 +1,347 @@
+************************************************************************
+*
+*     File of the DOUBLE PRECISION Level-3 BLAS.
+*     ==========================================
+*
+*     SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
+*    $                   BETA, C, LDC )
+*
+*     SUBROUTINE DSYMM ( SIDE,   UPLO,   M, N,    ALPHA, A, LDA, B, LDB,
+*    $                   BETA, C, LDC )
+*
+*     SUBROUTINE DSYRK ( UPLO,   TRANS,     N, K, ALPHA, A, LDA,
+*    $                   BETA, C, LDC )
+*
+*     SUBROUTINE DSYR2K( UPLO,   TRANS,     N, K, ALPHA, A, LDA, B, LDB,
+*    $                   BETA, C, LDC )
+*
+*     SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
+*    $                   B, LDB )
+*
+*     SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
+*    $                   B, LDB )
+*
+*     See:
+*
+*        Dongarra J. J.,   Du Croz J. J.,   Duff I.  and   Hammarling S.
+*        A set of  Level 3  Basic Linear Algebra Subprograms.  Technical
+*        Memorandum No.88 (Revision 1), Mathematics and Computer Science
+*        Division,  Argonne National Laboratory, 9700 South Cass Avenue,
+*        Argonne, Illinois 60439.
+*
+*
+************************************************************************
+*
+      SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
+     $                   BETA, C, LDC )
+*     .. Scalar Arguments ..
+      CHARACTER*1        TRANSA, TRANSB
+      INTEGER            M, N, K, LDA, LDB, LDC
+      DOUBLE PRECISION   ALPHA, BETA
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEMM  performs one of the matrix-matrix operations
+*
+*     C := alpha*op( A )*op( B ) + beta*C,
+*
+*  where  op( X ) is one of
+*
+*     op( X ) = X   or   op( X ) = X',
+*
+*  alpha and beta are scalars, and A, B and C are matrices, with op( A )
+*  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
+*
+*  Parameters
+*  ==========
+*
+*  TRANSA - CHARACTER*1.
+*           On entry, TRANSA specifies the form of op( A ) to be used in
+*           the matrix multiplication as follows:
+*
+*              TRANSA = 'N' or 'n',  op( A ) = A.
+*
+*              TRANSA = 'T' or 't',  op( A ) = A'.
+*
+*              TRANSA = 'C' or 'c',  op( A ) = A'.
+*
+*           Unchanged on exit.
+*
+*  TRANSB - CHARACTER*1.
+*           On entry, TRANSB specifies the form of op( B ) to be used in
+*           the matrix multiplication as follows:
+*
+*              TRANSB = 'N' or 'n',  op( B ) = B.
+*
+*              TRANSB = 'T' or 't',  op( B ) = B'.
+*
+*              TRANSB = 'C' or 'c',  op( B ) = B'.
+*
+*           Unchanged on exit.
+*
+*  M      - INTEGER.
+*           On entry,  M  specifies  the number  of rows  of the  matrix
+*           op( A )  and of the  matrix  C.  M  must  be at least  zero.
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry,  N  specifies the number  of columns of the matrix
+*           op( B ) and the number of columns of the matrix C. N must be
+*           at least zero.
+*           Unchanged on exit.
+*
+*  K      - INTEGER.
+*           On entry,  K  specifies  the number of columns of the matrix
+*           op( A ) and the number of rows of the matrix op( B ). K must
+*           be at least  zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - DOUBLE PRECISION.
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
+*           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
+*           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
+*           part of the array  A  must contain the matrix  A,  otherwise
+*           the leading  k by m  part of the array  A  must contain  the
+*           matrix A.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
+*           LDA must be at least  max( 1, m ), otherwise  LDA must be at
+*           least  max( 1, k ).
+*           Unchanged on exit.
+*
+*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
+*           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
+*           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
+*           part of the array  B  must contain the matrix  B,  otherwise
+*           the leading  n by k  part of the array  B  must contain  the
+*           matrix B.
+*           Unchanged on exit.
+*
+*  LDB    - INTEGER.
+*           On entry, LDB specifies the first dimension of B as declared
+*           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
+*           LDB must be at least  max( 1, k ), otherwise  LDB must be at
+*           least  max( 1, n ).
+*           Unchanged on exit.
+*
+*  BETA   - DOUBLE PRECISION.
+*           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
+*           supplied as zero then C need not be set on input.
+*           Unchanged on exit.
+*
+*  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
+*           Before entry, the leading  m by n  part of the array  C must
+*           contain the matrix  C,  except when  beta  is zero, in which
+*           case C need not be set on entry.
+*           On exit, the array  C  is overwritten by the  m by n  matrix
+*           ( alpha*op( A )*op( B ) + beta*C ).
+*
+*  LDC    - INTEGER.
+*           On entry, LDC specifies the first dimension of C as declared
+*           in  the  calling  (sub)  program.   LDC  must  be  at  least
+*           max( 1, m ).
+*           Unchanged on exit.
+*
+*
+*  Level 3 Blas routine.
+*
+*  -- Written on 8-February-1989.
+*     Jack Dongarra, Argonne National Laboratory.
+*     Iain Duff, AERE Harwell.
+*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
+*     Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     .. Local Scalars ..
+      LOGICAL            NOTA, NOTB
+      INTEGER            I, INFO, J, L, NCOLA, NROWA, NROWB
+      DOUBLE PRECISION   TEMP
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE         , ZERO
+      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Executable Statements ..
+*
+*     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
+*     transposed and set  NROWA, NCOLA and  NROWB  as the number of rows
+*     and  columns of  A  and the  number of  rows  of  B  respectively.
+*
+      NOTA  = LSAME( TRANSA, 'N' )
+      NOTB  = LSAME( TRANSB, 'N' )
+      IF( NOTA )THEN
+         NROWA = M
+         NCOLA = K
+      ELSE
+         NROWA = K
+         NCOLA = M
+      END IF
+      IF( NOTB )THEN
+         NROWB = K
+      ELSE
+         NROWB = N
+      END IF
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF(      ( .NOT.NOTA                 ).AND.
+     $         ( .NOT.LSAME( TRANSA, 'C' ) ).AND.
+     $         ( .NOT.LSAME( TRANSA, 'T' ) )      )THEN
+         INFO = 1
+      ELSE IF( ( .NOT.NOTB                 ).AND.
+     $         ( .NOT.LSAME( TRANSB, 'C' ) ).AND.
+     $         ( .NOT.LSAME( TRANSB, 'T' ) )      )THEN
+         INFO = 2
+      ELSE IF( M  .LT.0               )THEN
+         INFO = 3
+      ELSE IF( N  .LT.0               )THEN
+         INFO = 4
+      ELSE IF( K  .LT.0               )THEN
+         INFO = 5
+      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
+         INFO = 8
+      ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
+         INFO = 10
+      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
+         INFO = 13
+      END IF
+      IF( INFO.NE.0 )THEN
+         CALL XERBLA( 'DGEMM ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
+     $    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) )
+     $   RETURN
+*
+*     And if  alpha.eq.zero.
+*
+      IF( ALPHA.EQ.ZERO )THEN
+         IF( BETA.EQ.ZERO )THEN
+            DO 20, J = 1, N
+               DO 10, I = 1, M
+                  C( I, J ) = ZERO
+   10          CONTINUE
+   20       CONTINUE
+         ELSE
+            DO 40, J = 1, N
+               DO 30, I = 1, M
+                  C( I, J ) = BETA*C( I, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+         RETURN
+      END IF
+*
+*     Start the operations.
+*
+      IF( NOTB )THEN
+         IF( NOTA )THEN
+*
+*           Form  C := alpha*A*B + beta*C.
+*
+            DO 90, J = 1, N
+               IF( BETA.EQ.ZERO )THEN
+                  DO 50, I = 1, M
+                     C( I, J ) = ZERO
+   50             CONTINUE
+               ELSE IF( BETA.NE.ONE )THEN
+                  DO 60, I = 1, M
+                     C( I, J ) = BETA*C( I, J )
+   60             CONTINUE
+               END IF
+               DO 80, L = 1, K
+                  IF( B( L, J ).NE.ZERO )THEN
+                     TEMP = ALPHA*B( L, J )
+                     DO 70, I = 1, M
+                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
+   70                CONTINUE
+                  END IF
+   80          CONTINUE
+   90       CONTINUE
+         ELSE
+*
+*           Form  C := alpha*A'*B + beta*C
+*
+            DO 120, J = 1, N
+               DO 110, I = 1, M
+                  TEMP = ZERO
+                  DO 100, L = 1, K
+                     TEMP = TEMP + A( L, I )*B( L, J )
+  100             CONTINUE
+                  IF( BETA.EQ.ZERO )THEN
+                     C( I, J ) = ALPHA*TEMP
+                  ELSE
+                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
+                  END IF
+  110          CONTINUE
+  120       CONTINUE
+         END IF
+      ELSE
+         IF( NOTA )THEN
+*
+*           Form  C := alpha*A*B' + beta*C
+*
+            DO 170, J = 1, N
+               IF( BETA.EQ.ZERO )THEN
+                  DO 130, I = 1, M
+                     C( I, J ) = ZERO
+  130             CONTINUE
+               ELSE IF( BETA.NE.ONE )THEN
+                  DO 140, I = 1, M
+                     C( I, J ) = BETA*C( I, J )
+  140             CONTINUE
+               END IF
+               DO 160, L = 1, K
+                  IF( B( J, L ).NE.ZERO )THEN
+                     TEMP = ALPHA*B( J, L )
+                     DO 150, I = 1, M
+                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
+  150                CONTINUE
+                  END IF
+  160          CONTINUE
+  170       CONTINUE
+         ELSE
+*
+*           Form  C := alpha*A'*B' + beta*C
+*
+            DO 200, J = 1, N
+               DO 190, I = 1, M
+                  TEMP = ZERO
+                  DO 180, L = 1, K
+                     TEMP = TEMP + A( L, I )*B( J, L )
+  180             CONTINUE
+                  IF( BETA.EQ.ZERO )THEN
+                     C( I, J ) = ALPHA*TEMP
+                  ELSE
+                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
+                  END IF
+  190          CONTINUE
+  200       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DGEMM .
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/dgemv.f
@@ -0,0 +1,321 @@
+*
+************************************************************************
+*
+*     File of the DOUBLE PRECISION  Level-2 BLAS.
+*     ===========================================
+*
+*     SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
+*    $                   BETA, Y, INCY )
+*
+*     SUBROUTINE DGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX,
+*    $                   BETA, Y, INCY )
+*
+*     SUBROUTINE DSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX,
+*    $                   BETA, Y, INCY )
+*
+*     SUBROUTINE DSBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX,
+*    $                   BETA, Y, INCY )
+*
+*     SUBROUTINE DSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
+*
+*     SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
+*
+*     SUBROUTINE DTBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
+*
+*     SUBROUTINE DTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
+*
+*     SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
+*
+*     SUBROUTINE DTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
+*
+*     SUBROUTINE DTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
+*
+*     SUBROUTINE DGER  ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
+*
+*     SUBROUTINE DSYR  ( UPLO, N, ALPHA, X, INCX, A, LDA )
+*
+*     SUBROUTINE DSPR  ( UPLO, N, ALPHA, X, INCX, AP )
+*
+*     SUBROUTINE DSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
+*
+*     SUBROUTINE DSPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
+*
+*     See:
+*
+*        Dongarra J. J., Du Croz J. J., Hammarling S.  and Hanson R. J..
+*        An  extended  set of Fortran  Basic Linear Algebra Subprograms.
+*
+*        Technical  Memoranda  Nos. 41 (revision 3) and 81,  Mathematics
+*        and  Computer Science  Division,  Argonne  National Laboratory,
+*        9700 South Cass Avenue, Argonne, Illinois 60439, US.
+*
+*        Or
+*
+*        NAG  Technical Reports TR3/87 and TR4/87,  Numerical Algorithms
+*        Group  Ltd.,  NAG  Central  Office,  256  Banbury  Road, Oxford
+*        OX2 7DE, UK,  and  Numerical Algorithms Group Inc.,  1101  31st
+*        Street,  Suite 100,  Downers Grove,  Illinois 60515-1263,  USA.
+*
+************************************************************************
+*
+      SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
+     $                   BETA, Y, INCY )
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   ALPHA, BETA
+      INTEGER            INCX, INCY, LDA, M, N
+      CHARACTER*1        TRANS
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEMV  performs one of the matrix-vector operations
+*
+*     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,
+*
+*  where alpha and beta are scalars, x and y are vectors and A is an
+*  m by n matrix.
+*
+*  Parameters
+*  ==========
+*
+*  TRANS  - CHARACTER*1.
+*           On entry, TRANS specifies the operation to be performed as
+*           follows:
+*
+*              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.
+*
+*              TRANS = 'T' or 't'   y := alpha*A'*x + beta*y.
+*
+*              TRANS = 'C' or 'c'   y := alpha*A'*x + beta*y.
+*
+*           Unchanged on exit.
+*
+*  M      - INTEGER.
+*           On entry, M specifies the number of rows of the matrix A.
+*           M must be at least zero.
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the number of columns of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - DOUBLE PRECISION.
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+*           Before entry, the leading m by n part of the array A must
+*           contain the matrix of coefficients.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, m ).
+*           Unchanged on exit.
+*
+*  X      - DOUBLE PRECISION array of DIMENSION at least
+*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
+*           and at least
+*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
+*           Before entry, the incremented array X must contain the
+*           vector x.
+*           Unchanged on exit.
+*
+*  INCX   - INTEGER.
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  BETA   - DOUBLE PRECISION.
+*           On entry, BETA specifies the scalar beta. When BETA is
+*           supplied as zero then Y need not be set on input.
+*           Unchanged on exit.
+*
+*  Y      - DOUBLE PRECISION array of DIMENSION at least
+*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
+*           and at least
+*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
+*           Before entry with BETA non-zero, the incremented array Y
+*           must contain the vector y. On exit, Y is overwritten by the
+*           updated vector y.
+*
+*  INCY   - INTEGER.
+*           On entry, INCY specifies the increment for the elements of
+*           Y. INCY must not be zero.
+*           Unchanged on exit.
+*
+*
+*  Level 2 Blas routine.
+*
+*  -- Written on 22-October-1986.
+*     Jack Dongarra, Argonne National Lab.
+*     Jeremy Du Croz, Nag Central Office.
+*     Sven Hammarling, Nag Central Office.
+*     Richard Hanson, Sandia National Labs.
+*
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE         , ZERO
+      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     .. Local Scalars ..
+      DOUBLE PRECISION   TEMP
+      INTEGER            I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF     ( .NOT.LSAME( TRANS, 'N' ).AND.
+     $         .NOT.LSAME( TRANS, 'T' ).AND.
+     $         .NOT.LSAME( TRANS, 'C' )      )THEN
+         INFO = 1
+      ELSE IF( M.LT.0 )THEN
+         INFO = 2
+      ELSE IF( N.LT.0 )THEN
+         INFO = 3
+      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
+         INFO = 6
+      ELSE IF( INCX.EQ.0 )THEN
+         INFO = 8
+      ELSE IF( INCY.EQ.0 )THEN
+         INFO = 11
+      END IF
+      IF( INFO.NE.0 )THEN
+         CALL XERBLA( 'DGEMV ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
+     $    ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
+     $   RETURN
+*
+*     Set  LENX  and  LENY, the lengths of the vectors x and y, and set
+*     up the start points in  X  and  Y.
+*
+      IF( LSAME( TRANS, 'N' ) )THEN
+         LENX = N
+         LENY = M
+      ELSE
+         LENX = M
+         LENY = N
+      END IF
+      IF( INCX.GT.0 )THEN
+         KX = 1
+      ELSE
+         KX = 1 - ( LENX - 1 )*INCX
+      END IF
+      IF( INCY.GT.0 )THEN
+         KY = 1
+      ELSE
+         KY = 1 - ( LENY - 1 )*INCY
+      END IF
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through A.
+*
+*     First form  y := beta*y.
+*
+      IF( BETA.NE.ONE )THEN
+         IF( INCY.EQ.1 )THEN
+            IF( BETA.EQ.ZERO )THEN
+               DO 10, I = 1, LENY
+                  Y( I ) = ZERO
+   10          CONTINUE
+            ELSE
+               DO 20, I = 1, LENY
+                  Y( I ) = BETA*Y( I )
+   20          CONTINUE
+            END IF
+         ELSE
+            IY = KY
+            IF( BETA.EQ.ZERO )THEN
+               DO 30, I = 1, LENY
+                  Y( IY ) = ZERO
+                  IY      = IY   + INCY
+   30          CONTINUE
+            ELSE
+               DO 40, I = 1, LENY
+                  Y( IY ) = BETA*Y( IY )
+                  IY      = IY           + INCY
+   40          CONTINUE
+            END IF
+         END IF
+      END IF
+      IF( ALPHA.EQ.ZERO )
+     $   RETURN
+      IF( LSAME( TRANS, 'N' ) )THEN
+*
+*        Form  y := alpha*A*x + y.
+*
+         JX = KX
+         IF( INCY.EQ.1 )THEN
+            DO 60, J = 1, N
+               IF( X( JX ).NE.ZERO )THEN
+                  TEMP = ALPHA*X( JX )
+                  DO 50, I = 1, M
+                     Y( I ) = Y( I ) + TEMP*A( I, J )
+   50             CONTINUE
+               END IF
+               JX = JX + INCX
+   60       CONTINUE
+         ELSE
+            DO 80, J = 1, N
+               IF( X( JX ).NE.ZERO )THEN
+                  TEMP = ALPHA*X( JX )
+                  IY   = KY
+                  DO 70, I = 1, M
+                     Y( IY ) = Y( IY ) + TEMP*A( I, J )
+                     IY      = IY      + INCY
+   70             CONTINUE
+               END IF
+               JX = JX + INCX
+   80       CONTINUE
+         END IF
+      ELSE
+*
+*        Form  y := alpha*A'*x + y.
+*
+         JY = KY
+         IF( INCX.EQ.1 )THEN
+            DO 100, J = 1, N
+               TEMP = ZERO
+               DO 90, I = 1, M
+                  TEMP = TEMP + A( I, J )*X( I )
+   90          CONTINUE
+               Y( JY ) = Y( JY ) + ALPHA*TEMP
+               JY      = JY      + INCY
+  100       CONTINUE
+         ELSE
+            DO 120, J = 1, N
+               TEMP = ZERO
+               IX   = KX
+               DO 110, I = 1, M
+                  TEMP = TEMP + A( I, J )*X( IX )
+                  IX   = IX   + INCX
+  110          CONTINUE
+               Y( JY ) = Y( JY ) + ALPHA*TEMP
+               JY      = JY      + INCY
+  120       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DGEMV .
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/dger.f
@@ -0,0 +1,160 @@
+*
+************************************************************************
+*
+      SUBROUTINE DGER  ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   ALPHA
+      INTEGER            INCX, INCY, LDA, M, N
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGER   performs the rank 1 operation
+*
+*     A := alpha*x*y' + A,
+*
+*  where alpha is a scalar, x is an m element vector, y is an n element
+*  vector and A is an m by n matrix.
+*
+*  Parameters
+*  ==========
+*
+*  M      - INTEGER.
+*           On entry, M specifies the number of rows of the matrix A.
+*           M must be at least zero.
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the number of columns of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - DOUBLE PRECISION.
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  X      - DOUBLE PRECISION array of dimension at least
+*           ( 1 + ( m - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the m
+*           element vector x.
+*           Unchanged on exit.
+*
+*  INCX   - INTEGER.
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  Y      - DOUBLE PRECISION array of dimension at least
+*           ( 1 + ( n - 1 )*abs( INCY ) ).
+*           Before entry, the incremented array Y must contain the n
+*           element vector y.
+*           Unchanged on exit.
+*
+*  INCY   - INTEGER.
+*           On entry, INCY specifies the increment for the elements of
+*           Y. INCY must not be zero.
+*           Unchanged on exit.
+*
+*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+*           Before entry, the leading m by n part of the array A must
+*           contain the matrix of coefficients. On exit, A is
+*           overwritten by the updated matrix.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, m ).
+*           Unchanged on exit.
+*
+*
+*  Level 2 Blas routine.
+*
+*  -- Written on 22-October-1986.
+*     Jack Dongarra, Argonne National Lab.
+*     Jeremy Du Croz, Nag Central Office.
+*     Sven Hammarling, Nag Central Office.
+*     Richard Hanson, Sandia National Labs.
+*
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER        ( ZERO = 0.0D+0 )
+*     .. Local Scalars ..
+      DOUBLE PRECISION   TEMP
+      INTEGER            I, INFO, IX, J, JY, KX
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF     ( M.LT.0 )THEN
+         INFO = 1
+      ELSE IF( N.LT.0 )THEN
+         INFO = 2
+      ELSE IF( INCX.EQ.0 )THEN
+         INFO = 5
+      ELSE IF( INCY.EQ.0 )THEN
+         INFO = 7
+      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
+         INFO = 9
+      END IF
+      IF( INFO.NE.0 )THEN
+         CALL XERBLA( 'DGER  ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
+     $   RETURN
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through A.
+*
+      IF( INCY.GT.0 )THEN
+         JY = 1
+      ELSE
+         JY = 1 - ( N - 1 )*INCY
+      END IF
+      IF( INCX.EQ.1 )THEN
+         DO 20, J = 1, N
+            IF( Y( JY ).NE.ZERO )THEN
+               TEMP = ALPHA*Y( JY )
+               DO 10, I = 1, M
+                  A( I, J ) = A( I, J ) + X( I )*TEMP
+   10          CONTINUE
+            END IF
+            JY = JY + INCY
+   20    CONTINUE
+      ELSE
+         IF( INCX.GT.0 )THEN
+            KX = 1
+         ELSE
+            KX = 1 - ( M - 1 )*INCX
+         END IF
+         DO 40, J = 1, N
+            IF( Y( JY ).NE.ZERO )THEN
+               TEMP = ALPHA*Y( JY )
+               IX   = KX
+               DO 30, I = 1, M
+                  A( I, J ) = A( I, J ) + X( IX )*TEMP
+                  IX        = IX        + INCX
+   30          CONTINUE
+            END IF
+            JY = JY + INCY
+   40    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DGER  .
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/dmach.f
@@ -0,0 +1,58 @@
+      DOUBLE PRECISION FUNCTION DMACH(JOB)
+      INTEGER JOB
+C
+C     SMACH COMPUTES MACHINE PARAMETERS OF FLOATING POINT
+C     ARITHMETIC FOR USE IN TESTING ONLY.  NOT REQUIRED BY
+C     LINPACK PROPER.
+C
+C     IF TROUBLE WITH AUTOMATIC COMPUTATION OF THESE QUANTITIES,
+C     THEY CAN BE SET BY DIRECT ASSIGNMENT STATEMENTS.
+C     ASSUME THE COMPUTER HAS
+C
+C        B = BASE OF ARITHMETIC
+C        T = NUMBER OF BASE  B  DIGITS
+C        L = SMALLEST POSSIBLE EXPONENT
+C        U = LARGEST POSSIBLE EXPONENT
+C
+C     THEN
+C
+C        EPS = B**(1-T)
+C        TINY = 100.0*B**(-L+T)
+C        HUGE = 0.01*B**(U-T)
+C
+C     DMACH SAME AS SMACH EXCEPT T, L, U APPLY TO
+C     DOUBLE PRECISION.
+C
+C     CMACH SAME AS SMACH EXCEPT IF COMPLEX DIVISION
+C     IS DONE BY
+C
+C        1/(X+I*Y) = (X-I*Y)/(X**2+Y**2)
+C
+C     THEN
+C
+C        TINY = SQRT(TINY)
+C        HUGE = SQRT(HUGE)
+C
+C
+C     JOB IS 1, 2 OR 3 FOR EPSILON, TINY AND HUGE, RESPECTIVELY.
+C
+      DOUBLE PRECISION EPS,TINY,HUGE,S
+C
+      EPS = 1.0D0
+   10 EPS = EPS/2.0D0
+      S = 1.0D0 + EPS
+      IF (S .GT. 1.0D0) GO TO 10
+      EPS = 2.0D0*EPS
+C
+      S = 1.0D0
+   20 TINY = S
+      S = S/16.0D0
+      IF (S*1.0 .NE. 0.0D0) GO TO 20
+      TINY = (TINY/EPS)*100.0
+      HUGE = 1.0D0/TINY
+C
+      IF (JOB .EQ. 1) DMACH = EPS
+      IF (JOB .EQ. 2) DMACH = TINY
+      IF (JOB .EQ. 3) DMACH = HUGE
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/dnrm2.f
@@ -0,0 +1,122 @@
+      DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX)
+      INTEGER          NEXT
+      DOUBLE PRECISION   DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE
+      DATA   ZERO, ONE /0.0D0, 1.0D0/
+C
+C     EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE
+C     INCREMENT INCX .
+C     IF    N .LE. 0 RETURN WITH RESULT = 0.
+C     IF N .GE. 1 THEN INCX MUST BE .GE. 1
+C
+C           C.L.LAWSON, 1978 JAN 08
+C
+C     FOUR PHASE METHOD     USING TWO BUILT-IN CONSTANTS THAT ARE
+C     HOPEFULLY APPLICABLE TO ALL MACHINES.
+C         CUTLO = MAXIMUM OF  DSQRT(U/EPS)  OVER ALL KNOWN MACHINES.
+C         CUTHI = MINIMUM OF  DSQRT(V)      OVER ALL KNOWN MACHINES.
+C     WHERE
+C         EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1.
+C         U   = SMALLEST POSITIVE NO.   (UNDERFLOW LIMIT)
+C         V   = LARGEST  NO.            (OVERFLOW  LIMIT)
+C
+C     BRIEF OUTLINE OF ALGORITHM..
+C
+C     PHASE 1    SCANS ZERO COMPONENTS.
+C     MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO
+C     MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO
+C     MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M
+C     WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX.
+C
+C     VALUES FOR CUTLO AND CUTHI..
+C     FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER
+C     DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS..
+C     CUTLO, S.P.   U/EPS = 2**(-102) FOR  HONEYWELL.  CLOSE SECONDS ARE
+C                   UNIVAC AND DEC AT 2**(-103)
+C                   THUS CUTLO = 2**(-51) = 4.44089E-16
+C     CUTHI, S.P.   V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC.
+C                   THUS CUTHI = 2**(63.5) = 1.30438E19
+C     CUTLO, D.P.   U/EPS = 2**(-67) FOR HONEYWELL AND DEC.
+C                   THUS CUTLO = 2**(-33.5) = 8.23181D-11
+C     CUTHI, D.P.   SAME AS S.P.  CUTHI = 1.30438D19
+C     DATA CUTLO, CUTHI / 8.232D-11,  1.304D19 /
+C     DATA CUTLO, CUTHI / 4.441E-16,  1.304E19 /
+      DATA CUTLO, CUTHI / 8.232D-11,  1.304D19 /
+C
+      IF(N .GT. 0) GO TO 10
+         DNRM2  = ZERO
+         GO TO 300
+C
+   10 ASSIGN 30 TO NEXT
+      SUM = ZERO
+      NN = N * INCX
+C                                                 BEGIN MAIN LOOP
+      I = 1
+   20    GO TO NEXT,(30, 50, 70, 110)
+   30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
+      ASSIGN 50 TO NEXT
+      XMAX = ZERO
+C
+C                        PHASE 1.  SUM IS ZERO
+C
+   50 IF( DX(I) .EQ. ZERO) GO TO 200
+      IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
+C
+C                                PREPARE FOR PHASE 2.
+      ASSIGN 70 TO NEXT
+      GO TO 105
+C
+C                                PREPARE FOR PHASE 4.
+C
+  100 I = J
+      ASSIGN 110 TO NEXT
+      SUM = (SUM / DX(I)) / DX(I)
+  105 XMAX = DABS(DX(I))
+      GO TO 115
+C
+C                   PHASE 2.  SUM IS SMALL.
+C                             SCALE TO AVOID DESTRUCTIVE UNDERFLOW.
+C
+   70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75
+C
+C                     COMMON CODE FOR PHASES 2 AND 4.
+C                     IN PHASE 4 SUM IS LARGE.  SCALE TO AVOID OVERFLOW.
+C
+  110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115
+         SUM = ONE + SUM * (XMAX / DX(I))**2
+         XMAX = DABS(DX(I))
+         GO TO 200
+C
+  115 SUM = SUM + (DX(I)/XMAX)**2
+      GO TO 200
+C
+C
+C                  PREPARE FOR PHASE 3.
+C
+   75 SUM = (SUM * XMAX) * XMAX
+C
+C
+C     FOR REAL OR D.P. SET HITEST = CUTHI/N
+C     FOR COMPLEX      SET HITEST = CUTHI/(2*N)
+C
+   85 HITEST = CUTHI/FLOAT( N )
+C
+C                   PHASE 3.  SUM IS MID-RANGE.  NO SCALING.
+C
+      DO 95 J =I,NN,INCX
+      IF(DABS(DX(J)) .GE. HITEST) GO TO 100
+   95    SUM = SUM + DX(J)**2
+      DNRM2 = DSQRT( SUM )
+      GO TO 300
+C
+  200 CONTINUE
+      I = I + INCX
+      IF ( I .LE. NN ) GO TO 20
+C
+C              END OF MAIN LOOP.
+C
+C              COMPUTE SQUARE ROOT AND ADJUST FOR SCALING.
+C
+      DNRM2 = XMAX * DSQRT(SUM)
+  300 CONTINUE
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/drot.f
@@ -0,0 +1,36 @@
+      SUBROUTINE  DROT (N,DX,INCX,DY,INCY,C,S)
+C
+C     APPLIES A PLANE ROTATION.
+C     JACK DONGARRA, LINPACK, 3/11/78.
+C
+      DOUBLE PRECISION DX(1),DY(1),DTEMP,C,S
+      INTEGER I,INCX,INCY,IX,IY,N
+C
+      IF(N.LE.0)RETURN
+      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
+C
+C       CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL
+C         TO 1
+C
+      IX = 1
+      IY = 1
+      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
+      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
+      DO 10 I = 1,N
+        DTEMP = C*DX(IX) + S*DY(IY)
+        DY(IY) = C*DY(IY) - S*DX(IX)
+        DX(IX) = DTEMP
+        IX = IX + INCX
+        IY = IY + INCY
+   10 CONTINUE
+      RETURN
+C
+C       CODE FOR BOTH INCREMENTS EQUAL TO 1
+C
+   20 DO 30 I = 1,N
+        DTEMP = C*DX(I) + S*DY(I)
+        DY(I) = C*DY(I) - S*DX(I)
+        DX(I) = DTEMP
+   30 CONTINUE
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/dscal.f
@@ -0,0 +1,41 @@
+      SUBROUTINE  DSCAL(N,DA,DX,INCX)
+C
+C     SCALES A VECTOR BY A CONSTANT.
+C     USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE.
+C     JACK DONGARRA, LINPACK, 3/11/78.
+C
+      DOUBLE PRECISION DA,DX(1)
+      INTEGER I,INCX,M,MP1,N,NINCX
+C
+      IF(N.LE.0)RETURN
+      IF(INCX.EQ.1)GO TO 20
+C
+C        CODE FOR INCREMENT NOT EQUAL TO 1
+C
+      NINCX = N*INCX
+      DO 10 I = 1,NINCX,INCX
+        DX(I) = DA*DX(I)
+   10 CONTINUE
+      RETURN
+C
+C        CODE FOR INCREMENT EQUAL TO 1
+C
+C
+C        CLEAN-UP LOOP
+C
+   20 M = MOD(N,5)
+      IF( M .EQ. 0 ) GO TO 40
+      DO 30 I = 1,M
+        DX(I) = DA*DX(I)
+   30 CONTINUE
+      IF( N .LT. 5 ) RETURN
+   40 MP1 = M + 1
+      DO 50 I = MP1,N,5
+        DX(I) = DA*DX(I)
+        DX(I + 1) = DA*DX(I + 1)
+        DX(I + 2) = DA*DX(I + 2)
+        DX(I + 3) = DA*DX(I + 3)
+        DX(I + 4) = DA*DX(I + 4)
+   50 CONTINUE
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/dswap.f
@@ -0,0 +1,55 @@
+      SUBROUTINE  DSWAP (N,DX,INCX,DY,INCY)
+C
+C     INTERCHANGES TWO VECTORS.
+C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL ONE.
+C     JACK DONGARRA, LINPACK, 3/11/78.
+C
+      DOUBLE PRECISION DX(1),DY(1),DTEMP
+      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
+C
+      IF(N.LE.0)RETURN
+      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
+C
+C       CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL
+C         TO 1
+C
+      IX = 1
+      IY = 1
+      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
+      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
+      DO 10 I = 1,N
+        DTEMP = DX(IX)
+        DX(IX) = DY(IY)
+        DY(IY) = DTEMP
+        IX = IX + INCX
+        IY = IY + INCY
+   10 CONTINUE
+      RETURN
+C
+C       CODE FOR BOTH INCREMENTS EQUAL TO 1
+C
+C
+C       CLEAN-UP LOOP
+C
+   20 M = MOD(N,3)
+      IF( M .EQ. 0 ) GO TO 40
+      DO 30 I = 1,M
+        DTEMP = DX(I)
+        DX(I) = DY(I)
+        DY(I) = DTEMP
+   30 CONTINUE
+      IF( N .LT. 3 ) RETURN
+   40 MP1 = M + 1
+      DO 50 I = MP1,N,3
+        DTEMP = DX(I)
+        DX(I) = DY(I)
+        DY(I) = DTEMP
+        DTEMP = DX(I + 1)
+        DX(I + 1) = DY(I + 1)
+        DY(I + 1) = DTEMP
+        DTEMP = DX(I + 2)
+        DX(I + 2) = DY(I + 2)
+        DY(I + 2) = DTEMP
+   50 CONTINUE
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/dsyr.f
@@ -0,0 +1,200 @@
+*
+************************************************************************
+*
+      SUBROUTINE DSYR  ( UPLO, N, ALPHA, X, INCX, A, LDA )
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   ALPHA
+      INTEGER            INCX, LDA, N
+      CHARACTER*1        UPLO
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYR   performs the symmetric rank 1 operation
+*
+*     A := alpha*x*x' + A,
+*
+*  where alpha is a real scalar, x is an n element vector and A is an
+*  n by n symmetric matrix.
+*
+*  Parameters
+*  ==========
+*
+*  UPLO   - CHARACTER*1.
+*           On entry, UPLO specifies whether the upper or lower
+*           triangular part of the array A is to be referenced as
+*           follows:
+*
+*              UPLO = 'U' or 'u'   Only the upper triangular part of A
+*                                  is to be referenced.
+*
+*              UPLO = 'L' or 'l'   Only the lower triangular part of A
+*                                  is to be referenced.
+*
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the order of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - DOUBLE PRECISION.
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  X      - DOUBLE PRECISION array of dimension at least
+*           ( 1 + ( n - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the n
+*           element vector x.
+*           Unchanged on exit.
+*
+*  INCX   - INTEGER.
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+*           Before entry with  UPLO = 'U' or 'u', the leading n by n
+*           upper triangular part of the array A must contain the upper
+*           triangular part of the symmetric matrix and the strictly
+*           lower triangular part of A is not referenced. On exit, the
+*           upper triangular part of the array A is overwritten by the
+*           upper triangular part of the updated matrix.
+*           Before entry with UPLO = 'L' or 'l', the leading n by n
+*           lower triangular part of the array A must contain the lower
+*           triangular part of the symmetric matrix and the strictly
+*           upper triangular part of A is not referenced. On exit, the
+*           lower triangular part of the array A is overwritten by the
+*           lower triangular part of the updated matrix.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, n ).
+*           Unchanged on exit.
+*
+*
+*  Level 2 Blas routine.
+*
+*  -- Written on 22-October-1986.
+*     Jack Dongarra, Argonne National Lab.
+*     Jeremy Du Croz, Nag Central Office.
+*     Sven Hammarling, Nag Central Office.
+*     Richard Hanson, Sandia National Labs.
+*
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER        ( ZERO = 0.0D+0 )
+*     .. Local Scalars ..
+      DOUBLE PRECISION   TEMP
+      INTEGER            I, INFO, IX, J, JX, KX
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF     ( .NOT.LSAME( UPLO, 'U' ).AND.
+     $         .NOT.LSAME( UPLO, 'L' )      )THEN
+         INFO = 1
+      ELSE IF( N.LT.0 )THEN
+         INFO = 2
+      ELSE IF( INCX.EQ.0 )THEN
+         INFO = 5
+      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
+         INFO = 7
+      END IF
+      IF( INFO.NE.0 )THEN
+         CALL XERBLA( 'DSYR  ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
+     $   RETURN
+*
+*     Set the start point in X if the increment is not unity.
+*
+      IF( INCX.LE.0 )THEN
+         KX = 1 - ( N - 1 )*INCX
+      ELSE IF( INCX.NE.1 )THEN
+         KX = 1
+      END IF
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through the triangular part
+*     of A.
+*
+      IF( LSAME( UPLO, 'U' ) )THEN
+*
+*        Form  A  when A is stored in upper triangle.
+*
+         IF( INCX.EQ.1 )THEN
+            DO 20, J = 1, N
+               IF( X( J ).NE.ZERO )THEN
+                  TEMP = ALPHA*X( J )
+                  DO 10, I = 1, J
+                     A( I, J ) = A( I, J ) + X( I )*TEMP
+   10             CONTINUE
+               END IF
+   20       CONTINUE
+         ELSE
+            JX = KX
+            DO 40, J = 1, N
+               IF( X( JX ).NE.ZERO )THEN
+                  TEMP = ALPHA*X( JX )
+                  IX   = KX
+                  DO 30, I = 1, J
+                     A( I, J ) = A( I, J ) + X( IX )*TEMP
+                     IX        = IX        + INCX
+   30             CONTINUE
+               END IF
+               JX = JX + INCX
+   40       CONTINUE
+         END IF
+      ELSE
+*
+*        Form  A  when A is stored in lower triangle.
+*
+         IF( INCX.EQ.1 )THEN
+            DO 60, J = 1, N
+               IF( X( J ).NE.ZERO )THEN
+                  TEMP = ALPHA*X( J )
+                  DO 50, I = J, N
+                     A( I, J ) = A( I, J ) + X( I )*TEMP
+   50             CONTINUE
+               END IF
+   60       CONTINUE
+         ELSE
+            JX = KX
+            DO 80, J = 1, N
+               IF( X( JX ).NE.ZERO )THEN
+                  TEMP = ALPHA*X( JX )
+                  IX   = JX
+                  DO 70, I = J, N
+                     A( I, J ) = A( I, J ) + X( IX )*TEMP
+                     IX        = IX        + INCX
+   70             CONTINUE
+               END IF
+               JX = JX + INCX
+   80       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DSYR  .
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/dsyrk.f
@@ -0,0 +1,297 @@
+*
+************************************************************************
+*
+      SUBROUTINE DSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA,
+     $                   BETA, C, LDC )
+*     .. Scalar Arguments ..
+      CHARACTER*1        UPLO, TRANS
+      INTEGER            N, K, LDA, LDC
+      DOUBLE PRECISION   ALPHA, BETA
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( LDC, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYRK  performs one of the symmetric rank k operations
+*
+*     C := alpha*A*A' + beta*C,
+*
+*  or
+*
+*     C := alpha*A'*A + beta*C,
+*
+*  where  alpha and beta  are scalars, C is an  n by n  symmetric matrix
+*  and  A  is an  n by k  matrix in the first case and a  k by n  matrix
+*  in the second case.
+*
+*  Parameters
+*  ==========
+*
+*  UPLO   - CHARACTER*1.
+*           On  entry,   UPLO  specifies  whether  the  upper  or  lower
+*           triangular  part  of the  array  C  is to be  referenced  as
+*           follows:
+*
+*              UPLO = 'U' or 'u'   Only the  upper triangular part of  C
+*                                  is to be referenced.
+*
+*              UPLO = 'L' or 'l'   Only the  lower triangular part of  C
+*                                  is to be referenced.
+*
+*           Unchanged on exit.
+*
+*  TRANS  - CHARACTER*1.
+*           On entry,  TRANS  specifies the operation to be performed as
+*           follows:
+*
+*              TRANS = 'N' or 'n'   C := alpha*A*A' + beta*C.
+*
+*              TRANS = 'T' or 't'   C := alpha*A'*A + beta*C.
+*
+*              TRANS = 'C' or 'c'   C := alpha*A'*A + beta*C.
+*
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry,  N specifies the order of the matrix C.  N must be
+*           at least zero.
+*           Unchanged on exit.
+*
+*  K      - INTEGER.
+*           On entry with  TRANS = 'N' or 'n',  K  specifies  the number
+*           of  columns   of  the   matrix   A,   and  on   entry   with
+*           TRANS = 'T' or 't' or 'C' or 'c',  K  specifies  the  number
+*           of rows of the matrix  A.  K must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - DOUBLE PRECISION.
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
+*           k  when  TRANS = 'N' or 'n',  and is  n  otherwise.
+*           Before entry with  TRANS = 'N' or 'n',  the  leading  n by k
+*           part of the array  A  must contain the matrix  A,  otherwise
+*           the leading  k by n  part of the array  A  must contain  the
+*           matrix A.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
+*           then  LDA must be at least  max( 1, n ), otherwise  LDA must
+*           be at least  max( 1, k ).
+*           Unchanged on exit.
+*
+*  BETA   - DOUBLE PRECISION.
+*           On entry, BETA specifies the scalar beta.
+*           Unchanged on exit.
+*
+*  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
+*           Before entry  with  UPLO = 'U' or 'u',  the leading  n by n
+*           upper triangular part of the array C must contain the upper
+*           triangular part  of the  symmetric matrix  and the strictly
+*           lower triangular part of C is not referenced.  On exit, the
+*           upper triangular part of the array  C is overwritten by the
+*           upper triangular part of the updated matrix.
+*           Before entry  with  UPLO = 'L' or 'l',  the leading  n by n
+*           lower triangular part of the array C must contain the lower
+*           triangular part  of the  symmetric matrix  and the strictly
+*           upper triangular part of C is not referenced.  On exit, the
+*           lower triangular part of the array  C is overwritten by the
+*           lower triangular part of the updated matrix.
+*
+*  LDC    - INTEGER.
+*           On entry, LDC specifies the first dimension of C as declared
+*           in  the  calling  (sub)  program.   LDC  must  be  at  least
+*           max( 1, n ).
+*           Unchanged on exit.
+*
+*
+*  Level 3 Blas routine.
+*
+*  -- Written on 8-February-1989.
+*     Jack Dongarra, Argonne National Laboratory.
+*     Iain Duff, AERE Harwell.
+*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
+*     Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, INFO, J, L, NROWA
+      DOUBLE PRECISION   TEMP
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE ,         ZERO
+      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      IF( LSAME( TRANS, 'N' ) )THEN
+         NROWA = N
+      ELSE
+         NROWA = K
+      END IF
+      UPPER = LSAME( UPLO, 'U' )
+*
+      INFO = 0
+      IF(      ( .NOT.UPPER               ).AND.
+     $         ( .NOT.LSAME( UPLO , 'L' ) )      )THEN
+         INFO = 1
+      ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND.
+     $         ( .NOT.LSAME( TRANS, 'T' ) ).AND.
+     $         ( .NOT.LSAME( TRANS, 'C' ) )      )THEN
+         INFO = 2
+      ELSE IF( N  .LT.0               )THEN
+         INFO = 3
+      ELSE IF( K  .LT.0               )THEN
+         INFO = 4
+      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
+         INFO = 7
+      ELSE IF( LDC.LT.MAX( 1, N     ) )THEN
+         INFO = 10
+      END IF
+      IF( INFO.NE.0 )THEN
+         CALL XERBLA( 'DSYRK ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( ( N.EQ.0 ).OR.
+     $    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) )
+     $   RETURN
+*
+*     And when  alpha.eq.zero.
+*
+      IF( ALPHA.EQ.ZERO )THEN
+         IF( UPPER )THEN
+            IF( BETA.EQ.ZERO )THEN
+               DO 20, J = 1, N
+                  DO 10, I = 1, J
+                     C( I, J ) = ZERO
+   10             CONTINUE
+   20          CONTINUE
+            ELSE
+               DO 40, J = 1, N
+                  DO 30, I = 1, J
+                     C( I, J ) = BETA*C( I, J )
+   30             CONTINUE
+   40          CONTINUE
+            END IF
+         ELSE
+            IF( BETA.EQ.ZERO )THEN
+               DO 60, J = 1, N
+                  DO 50, I = J, N
+                     C( I, J ) = ZERO
+   50             CONTINUE
+   60          CONTINUE
+            ELSE
+               DO 80, J = 1, N
+                  DO 70, I = J, N
+                     C( I, J ) = BETA*C( I, J )
+   70             CONTINUE
+   80          CONTINUE
+            END IF
+         END IF
+         RETURN
+      END IF
+*
+*     Start the operations.
+*
+      IF( LSAME( TRANS, 'N' ) )THEN
+*
+*        Form  C := alpha*A*A' + beta*C.
+*
+         IF( UPPER )THEN
+            DO 130, J = 1, N
+               IF( BETA.EQ.ZERO )THEN
+                  DO 90, I = 1, J
+                     C( I, J ) = ZERO
+   90             CONTINUE
+               ELSE IF( BETA.NE.ONE )THEN
+                  DO 100, I = 1, J
+                     C( I, J ) = BETA*C( I, J )
+  100             CONTINUE
+               END IF
+               DO 120, L = 1, K
+                  IF( A( J, L ).NE.ZERO )THEN
+                     TEMP = ALPHA*A( J, L )
+                     DO 110, I = 1, J
+                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
+  110                CONTINUE
+                  END IF
+  120          CONTINUE
+  130       CONTINUE
+         ELSE
+            DO 180, J = 1, N
+               IF( BETA.EQ.ZERO )THEN
+                  DO 140, I = J, N
+                     C( I, J ) = ZERO
+  140             CONTINUE
+               ELSE IF( BETA.NE.ONE )THEN
+                  DO 150, I = J, N
+                     C( I, J ) = BETA*C( I, J )
+  150             CONTINUE
+               END IF
+               DO 170, L = 1, K
+                  IF( A( J, L ).NE.ZERO )THEN
+                     TEMP      = ALPHA*A( J, L )
+                     DO 160, I = J, N
+                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
+  160                CONTINUE
+                  END IF
+  170          CONTINUE
+  180       CONTINUE
+         END IF
+      ELSE
+*
+*        Form  C := alpha*A'*A + beta*C.
+*
+         IF( UPPER )THEN
+            DO 210, J = 1, N
+               DO 200, I = 1, J
+                  TEMP = ZERO
+                  DO 190, L = 1, K
+                     TEMP = TEMP + A( L, I )*A( L, J )
+  190             CONTINUE
+                  IF( BETA.EQ.ZERO )THEN
+                     C( I, J ) = ALPHA*TEMP
+                  ELSE
+                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
+                  END IF
+  200          CONTINUE
+  210       CONTINUE
+         ELSE
+            DO 240, J = 1, N
+               DO 230, I = J, N
+                  TEMP = ZERO
+                  DO 220, L = 1, K
+                     TEMP = TEMP + A( L, I )*A( L, J )
+  220             CONTINUE
+                  IF( BETA.EQ.ZERO )THEN
+                     C( I, J ) = ALPHA*TEMP
+                  ELSE
+                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
+                  END IF
+  230          CONTINUE
+  240       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DSYRK .
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/dtrmm.f
@@ -0,0 +1,358 @@
+*
+************************************************************************
+*
+      SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
+     $                   B, LDB )
+*     .. Scalar Arguments ..
+      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
+      INTEGER            M, N, LDA, LDB
+      DOUBLE PRECISION   ALPHA
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTRMM  performs one of the matrix-matrix operations
+*
+*     B := alpha*op( A )*B,   or   B := alpha*B*op( A ),
+*
+*  where  alpha  is a scalar,  B  is an m by n matrix,  A  is a unit, or
+*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
+*
+*     op( A ) = A   or   op( A ) = A'.
+*
+*  Parameters
+*  ==========
+*
+*  SIDE   - CHARACTER*1.
+*           On entry,  SIDE specifies whether  op( A ) multiplies B from
+*           the left or right as follows:
+*
+*              SIDE = 'L' or 'l'   B := alpha*op( A )*B.
+*
+*              SIDE = 'R' or 'r'   B := alpha*B*op( A ).
+*
+*           Unchanged on exit.
+*
+*  UPLO   - CHARACTER*1.
+*           On entry, UPLO specifies whether the matrix A is an upper or
+*           lower triangular matrix as follows:
+*
+*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
+*
+*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
+*
+*           Unchanged on exit.
+*
+*  TRANSA - CHARACTER*1.
+*           On entry, TRANSA specifies the form of op( A ) to be used in
+*           the matrix multiplication as follows:
+*
+*              TRANSA = 'N' or 'n'   op( A ) = A.
+*
+*              TRANSA = 'T' or 't'   op( A ) = A'.
+*
+*              TRANSA = 'C' or 'c'   op( A ) = A'.
+*
+*           Unchanged on exit.
+*
+*  DIAG   - CHARACTER*1.
+*           On entry, DIAG specifies whether or not A is unit triangular
+*           as follows:
+*
+*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
+*
+*              DIAG = 'N' or 'n'   A is not assumed to be unit
+*                                  triangular.
+*
+*           Unchanged on exit.
+*
+*  M      - INTEGER.
+*           On entry, M specifies the number of rows of B. M must be at
+*           least zero.
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the number of columns of B.  N must be
+*           at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - DOUBLE PRECISION.
+*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
+*           zero then  A is not referenced and  B need not be set before
+*           entry.
+*           Unchanged on exit.
+*
+*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
+*           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
+*           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
+*           upper triangular part of the array  A must contain the upper
+*           triangular matrix  and the strictly lower triangular part of
+*           A is not referenced.
+*           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
+*           lower triangular part of the array  A must contain the lower
+*           triangular matrix  and the strictly upper triangular part of
+*           A is not referenced.
+*           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
+*           A  are not referenced either,  but are assumed to be  unity.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
+*           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
+*           then LDA must be at least max( 1, n ).
+*           Unchanged on exit.
+*
+*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
+*           Before entry,  the leading  m by n part of the array  B must
+*           contain the matrix  B,  and  on exit  is overwritten  by the
+*           transformed matrix.
+*
+*  LDB    - INTEGER.
+*           On entry, LDB specifies the first dimension of B as declared
+*           in  the  calling  (sub)  program.   LDB  must  be  at  least
+*           max( 1, m ).
+*           Unchanged on exit.
+*
+*
+*  Level 3 Blas routine.
+*
+*  -- Written on 8-February-1989.
+*     Jack Dongarra, Argonne National Laboratory.
+*     Iain Duff, AERE Harwell.
+*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
+*     Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     .. Local Scalars ..
+      LOGICAL            LSIDE, NOUNIT, UPPER
+      INTEGER            I, INFO, J, K, NROWA
+      DOUBLE PRECISION   TEMP
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE         , ZERO
+      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      LSIDE  = LSAME( SIDE  , 'L' )
+      IF( LSIDE )THEN
+         NROWA = M
+      ELSE
+         NROWA = N
+      END IF
+      NOUNIT = LSAME( DIAG  , 'N' )
+      UPPER  = LSAME( UPLO  , 'U' )
+*
+      INFO   = 0
+      IF(      ( .NOT.LSIDE                ).AND.
+     $         ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
+         INFO = 1
+      ELSE IF( ( .NOT.UPPER                ).AND.
+     $         ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
+         INFO = 2
+      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.
+     $         ( .NOT.LSAME( TRANSA, 'T' ) ).AND.
+     $         ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
+         INFO = 3
+      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND.
+     $         ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
+         INFO = 4
+      ELSE IF( M  .LT.0               )THEN
+         INFO = 5
+      ELSE IF( N  .LT.0               )THEN
+         INFO = 6
+      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
+         INFO = 9
+      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
+         INFO = 11
+      END IF
+      IF( INFO.NE.0 )THEN
+         CALL XERBLA( 'DTRMM ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     And when  alpha.eq.zero.
+*
+      IF( ALPHA.EQ.ZERO )THEN
+         DO 20, J = 1, N
+            DO 10, I = 1, M
+               B( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+         RETURN
+      END IF
+*
+*     Start the operations.
+*
+      IF( LSIDE )THEN
+         IF( LSAME( TRANSA, 'N' ) )THEN
+*
+*           Form  B := alpha*A*B.
+*
+            IF( UPPER )THEN
+               DO 50, J = 1, N
+                  DO 40, K = 1, M
+                     IF( B( K, J ).NE.ZERO )THEN
+                        TEMP = ALPHA*B( K, J )
+                        DO 30, I = 1, K - 1
+                           B( I, J ) = B( I, J ) + TEMP*A( I, K )
+   30                   CONTINUE
+                        IF( NOUNIT )
+     $                     TEMP = TEMP*A( K, K )
+                        B( K, J ) = TEMP
+                     END IF
+   40             CONTINUE
+   50          CONTINUE
+            ELSE
+               DO 80, J = 1, N
+                  DO 70 K = M, 1, -1
+                     IF( B( K, J ).NE.ZERO )THEN
+                        TEMP      = ALPHA*B( K, J )
+                        B( K, J ) = TEMP
+                        IF( NOUNIT )
+     $                     B( K, J ) = B( K, J )*A( K, K )
+                        DO 60, I = K + 1, M
+                           B( I, J ) = B( I, J ) + TEMP*A( I, K )
+   60                   CONTINUE
+                     END IF
+   70             CONTINUE
+   80          CONTINUE
+            END IF
+         ELSE
+*
+*           Form  B := alpha*B*A'.
+*
+            IF( UPPER )THEN
+               DO 110, J = 1, N
+                  DO 100, I = M, 1, -1
+                     TEMP = B( I, J )
+                     IF( NOUNIT )
+     $                  TEMP = TEMP*A( I, I )
+                     DO 90, K = 1, I - 1
+                        TEMP = TEMP + A( K, I )*B( K, J )
+   90                CONTINUE
+                     B( I, J ) = ALPHA*TEMP
+  100             CONTINUE
+  110          CONTINUE
+            ELSE
+               DO 140, J = 1, N
+                  DO 130, I = 1, M
+                     TEMP = B( I, J )
+                     IF( NOUNIT )
+     $                  TEMP = TEMP*A( I, I )
+                     DO 120, K = I + 1, M
+                        TEMP = TEMP + A( K, I )*B( K, J )
+  120                CONTINUE
+                     B( I, J ) = ALPHA*TEMP
+  130             CONTINUE
+  140          CONTINUE
+            END IF
+         END IF
+      ELSE
+         IF( LSAME( TRANSA, 'N' ) )THEN
+*
+*           Form  B := alpha*B*A.
+*
+            IF( UPPER )THEN
+               DO 180, J = N, 1, -1
+                  TEMP = ALPHA
+                  IF( NOUNIT )
+     $               TEMP = TEMP*A( J, J )
+                  DO 150, I = 1, M
+                     B( I, J ) = TEMP*B( I, J )
+  150             CONTINUE
+                  DO 170, K = 1, J - 1
+                     IF( A( K, J ).NE.ZERO )THEN
+                        TEMP = ALPHA*A( K, J )
+                        DO 160, I = 1, M
+                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
+  160                   CONTINUE
+                     END IF
+  170             CONTINUE
+  180          CONTINUE
+            ELSE
+               DO 220, J = 1, N
+                  TEMP = ALPHA
+                  IF( NOUNIT )
+     $               TEMP = TEMP*A( J, J )
+                  DO 190, I = 1, M
+                     B( I, J ) = TEMP*B( I, J )
+  190             CONTINUE
+                  DO 210, K = J + 1, N
+                     IF( A( K, J ).NE.ZERO )THEN
+                        TEMP = ALPHA*A( K, J )
+                        DO 200, I = 1, M
+                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
+  200                   CONTINUE
+                     END IF
+  210             CONTINUE
+  220          CONTINUE
+            END IF
+         ELSE
+*
+*           Form  B := alpha*B*A'.
+*
+            IF( UPPER )THEN
+               DO 260, K = 1, N
+                  DO 240, J = 1, K - 1
+                     IF( A( J, K ).NE.ZERO )THEN
+                        TEMP = ALPHA*A( J, K )
+                        DO 230, I = 1, M
+                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
+  230                   CONTINUE
+                     END IF
+  240             CONTINUE
+                  TEMP = ALPHA
+                  IF( NOUNIT )
+     $               TEMP = TEMP*A( K, K )
+                  IF( TEMP.NE.ONE )THEN
+                     DO 250, I = 1, M
+                        B( I, K ) = TEMP*B( I, K )
+  250                CONTINUE
+                  END IF
+  260          CONTINUE
+            ELSE
+               DO 300, K = N, 1, -1
+                  DO 280, J = K + 1, N
+                     IF( A( J, K ).NE.ZERO )THEN
+                        TEMP = ALPHA*A( J, K )
+                        DO 270, I = 1, M
+                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
+  270                   CONTINUE
+                     END IF
+  280             CONTINUE
+                  TEMP = ALPHA
+                  IF( NOUNIT )
+     $               TEMP = TEMP*A( K, K )
+                  IF( TEMP.NE.ONE )THEN
+                     DO 290, I = 1, M
+                        B( I, K ) = TEMP*B( I, K )
+  290                CONTINUE
+                  END IF
+  300          CONTINUE
+            END IF
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DTRMM .
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/dtrmv.f
@@ -0,0 +1,289 @@
+*
+************************************************************************
+*
+      SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
+*     .. Scalar Arguments ..
+      INTEGER            INCX, LDA, N
+      CHARACTER*1        DIAG, TRANS, UPLO
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTRMV  performs one of the matrix-vector operations
+*
+*     x := A*x,   or   x := A'*x,
+*
+*  where x is an n element vector and  A is an n by n unit, or non-unit,
+*  upper or lower triangular matrix.
+*
+*  Parameters
+*  ==========
+*
+*  UPLO   - CHARACTER*1.
+*           On entry, UPLO specifies whether the matrix is an upper or
+*           lower triangular matrix as follows:
+*
+*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
+*
+*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
+*
+*           Unchanged on exit.
+*
+*  TRANS  - CHARACTER*1.
+*           On entry, TRANS specifies the operation to be performed as
+*           follows:
+*
+*              TRANS = 'N' or 'n'   x := A*x.
+*
+*              TRANS = 'T' or 't'   x := A'*x.
+*
+*              TRANS = 'C' or 'c'   x := A'*x.
+*
+*           Unchanged on exit.
+*
+*  DIAG   - CHARACTER*1.
+*           On entry, DIAG specifies whether or not A is unit
+*           triangular as follows:
+*
+*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
+*
+*              DIAG = 'N' or 'n'   A is not assumed to be unit
+*                                  triangular.
+*
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the order of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+*           Before entry with  UPLO = 'U' or 'u', the leading n by n
+*           upper triangular part of the array A must contain the upper
+*           triangular matrix and the strictly lower triangular part of
+*           A is not referenced.
+*           Before entry with UPLO = 'L' or 'l', the leading n by n
+*           lower triangular part of the array A must contain the lower
+*           triangular matrix and the strictly upper triangular part of
+*           A is not referenced.
+*           Note that when  DIAG = 'U' or 'u', the diagonal elements of
+*           A are not referenced either, but are assumed to be unity.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, n ).
+*           Unchanged on exit.
+*
+*  X      - DOUBLE PRECISION array of dimension at least
+*           ( 1 + ( n - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the n
+*           element vector x. On exit, X is overwritten with the
+*           tranformed vector x.
+*
+*  INCX   - INTEGER.
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*
+*  Level 2 Blas routine.
+*
+*  -- Written on 22-October-1986.
+*     Jack Dongarra, Argonne National Lab.
+*     Jeremy Du Croz, Nag Central Office.
+*     Sven Hammarling, Nag Central Office.
+*     Richard Hanson, Sandia National Labs.
+*
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER        ( ZERO = 0.0D+0 )
+*     .. Local Scalars ..
+      DOUBLE PRECISION   TEMP
+      INTEGER            I, INFO, IX, J, JX, KX
+      LOGICAL            NOUNIT
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF     ( .NOT.LSAME( UPLO , 'U' ).AND.
+     $         .NOT.LSAME( UPLO , 'L' )      )THEN
+         INFO = 1
+      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
+     $         .NOT.LSAME( TRANS, 'T' ).AND.
+     $         .NOT.LSAME( TRANS, 'C' )      )THEN
+         INFO = 2
+      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
+     $         .NOT.LSAME( DIAG , 'N' )      )THEN
+         INFO = 3
+      ELSE IF( N.LT.0 )THEN
+         INFO = 4
+      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
+         INFO = 6
+      ELSE IF( INCX.EQ.0 )THEN
+         INFO = 8
+      END IF
+      IF( INFO.NE.0 )THEN
+         CALL XERBLA( 'DTRMV ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+*     Set up the start point in X if the increment is not unity. This
+*     will be  ( N - 1 )*INCX  too small for descending loops.
+*
+      IF( INCX.LE.0 )THEN
+         KX = 1 - ( N - 1 )*INCX
+      ELSE IF( INCX.NE.1 )THEN
+         KX = 1
+      END IF
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through A.
+*
+      IF( LSAME( TRANS, 'N' ) )THEN
+*
+*        Form  x := A*x.
+*
+         IF( LSAME( UPLO, 'U' ) )THEN
+            IF( INCX.EQ.1 )THEN
+               DO 20, J = 1, N
+                  IF( X( J ).NE.ZERO )THEN
+                     TEMP = X( J )
+                     DO 10, I = 1, J - 1
+                        X( I ) = X( I ) + TEMP*A( I, J )
+   10                CONTINUE
+                     IF( NOUNIT )
+     $                  X( J ) = X( J )*A( J, J )
+                  END IF
+   20          CONTINUE
+            ELSE
+               JX = KX
+               DO 40, J = 1, N
+                  IF( X( JX ).NE.ZERO )THEN
+                     TEMP = X( JX )
+                     IX   = KX
+                     DO 30, I = 1, J - 1
+                        X( IX ) = X( IX ) + TEMP*A( I, J )
+                        IX      = IX      + INCX
+   30                CONTINUE
+                     IF( NOUNIT )
+     $                  X( JX ) = X( JX )*A( J, J )
+                  END IF
+                  JX = JX + INCX
+   40          CONTINUE
+            END IF
+         ELSE
+            IF( INCX.EQ.1 )THEN
+               DO 60, J = N, 1, -1
+                  IF( X( J ).NE.ZERO )THEN
+                     TEMP = X( J )
+                     DO 50, I = N, J + 1, -1
+                        X( I ) = X( I ) + TEMP*A( I, J )
+   50                CONTINUE
+                     IF( NOUNIT )
+     $                  X( J ) = X( J )*A( J, J )
+                  END IF
+   60          CONTINUE
+            ELSE
+               KX = KX + ( N - 1 )*INCX
+               JX = KX
+               DO 80, J = N, 1, -1
+                  IF( X( JX ).NE.ZERO )THEN
+                     TEMP = X( JX )
+                     IX   = KX
+                     DO 70, I = N, J + 1, -1
+                        X( IX ) = X( IX ) + TEMP*A( I, J )
+                        IX      = IX      - INCX
+   70                CONTINUE
+                     IF( NOUNIT )
+     $                  X( JX ) = X( JX )*A( J, J )
+                  END IF
+                  JX = JX - INCX
+   80          CONTINUE
+            END IF
+         END IF
+      ELSE
+*
+*        Form  x := A'*x.
+*
+         IF( LSAME( UPLO, 'U' ) )THEN
+            IF( INCX.EQ.1 )THEN
+               DO 100, J = N, 1, -1
+                  TEMP = X( J )
+                  IF( NOUNIT )
+     $               TEMP = TEMP*A( J, J )
+                  DO 90, I = J - 1, 1, -1
+                     TEMP = TEMP + A( I, J )*X( I )
+   90             CONTINUE
+                  X( J ) = TEMP
+  100          CONTINUE
+            ELSE
+               JX = KX + ( N - 1 )*INCX
+               DO 120, J = N, 1, -1
+                  TEMP = X( JX )
+                  IX   = JX
+                  IF( NOUNIT )
+     $               TEMP = TEMP*A( J, J )
+                  DO 110, I = J - 1, 1, -1
+                     IX   = IX   - INCX
+                     TEMP = TEMP + A( I, J )*X( IX )
+  110             CONTINUE
+                  X( JX ) = TEMP
+                  JX      = JX   - INCX
+  120          CONTINUE
+            END IF
+         ELSE
+            IF( INCX.EQ.1 )THEN
+               DO 140, J = 1, N
+                  TEMP = X( J )
+                  IF( NOUNIT )
+     $               TEMP = TEMP*A( J, J )
+                  DO 130, I = J + 1, N
+                     TEMP = TEMP + A( I, J )*X( I )
+  130             CONTINUE
+                  X( J ) = TEMP
+  140          CONTINUE
+            ELSE
+               JX = KX
+               DO 160, J = 1, N
+                  TEMP = X( JX )
+                  IX   = JX
+                  IF( NOUNIT )
+     $               TEMP = TEMP*A( J, J )
+                  DO 150, I = J + 1, N
+                     IX   = IX   + INCX
+                     TEMP = TEMP + A( I, J )*X( IX )
+  150             CONTINUE
+                  X( JX ) = TEMP
+                  JX      = JX   + INCX
+  160          CONTINUE
+            END IF
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DTRMV .
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/dtrsm.f
@@ -0,0 +1,381 @@
+*
+************************************************************************
+*
+      SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
+     $                   B, LDB )
+*     .. Scalar Arguments ..
+      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
+      INTEGER            M, N, LDA, LDB
+      DOUBLE PRECISION   ALPHA
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTRSM  solves one of the matrix equations
+*
+*     op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,
+*
+*  where alpha is a scalar, X and B are m by n matrices, A is a unit, or
+*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
+*
+*     op( A ) = A   or   op( A ) = A'.
+*
+*  The matrix X is overwritten on B.
+*
+*  Parameters
+*  ==========
+*
+*  SIDE   - CHARACTER*1.
+*           On entry, SIDE specifies whether op( A ) appears on the left
+*           or right of X as follows:
+*
+*              SIDE = 'L' or 'l'   op( A )*X = alpha*B.
+*
+*              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.
+*
+*           Unchanged on exit.
+*
+*  UPLO   - CHARACTER*1.
+*           On entry, UPLO specifies whether the matrix A is an upper or
+*           lower triangular matrix as follows:
+*
+*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
+*
+*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
+*
+*           Unchanged on exit.
+*
+*  TRANSA - CHARACTER*1.
+*           On entry, TRANSA specifies the form of op( A ) to be used in
+*           the matrix multiplication as follows:
+*
+*              TRANSA = 'N' or 'n'   op( A ) = A.
+*
+*              TRANSA = 'T' or 't'   op( A ) = A'.
+*
+*              TRANSA = 'C' or 'c'   op( A ) = A'.
+*
+*           Unchanged on exit.
+*
+*  DIAG   - CHARACTER*1.
+*           On entry, DIAG specifies whether or not A is unit triangular
+*           as follows:
+*
+*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
+*
+*              DIAG = 'N' or 'n'   A is not assumed to be unit
+*                                  triangular.
+*
+*           Unchanged on exit.
+*
+*  M      - INTEGER.
+*           On entry, M specifies the number of rows of B. M must be at
+*           least zero.
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the number of columns of B.  N must be
+*           at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - DOUBLE PRECISION.
+*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
+*           zero then  A is not referenced and  B need not be set before
+*           entry.
+*           Unchanged on exit.
+*
+*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
+*           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
+*           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
+*           upper triangular part of the array  A must contain the upper
+*           triangular matrix  and the strictly lower triangular part of
+*           A is not referenced.
+*           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
+*           lower triangular part of the array  A must contain the lower
+*           triangular matrix  and the strictly upper triangular part of
+*           A is not referenced.
+*           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
+*           A  are not referenced either,  but are assumed to be  unity.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
+*           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
+*           then LDA must be at least max( 1, n ).
+*           Unchanged on exit.
+*
+*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
+*           Before entry,  the leading  m by n part of the array  B must
+*           contain  the  right-hand  side  matrix  B,  and  on exit  is
+*           overwritten by the solution matrix  X.
+*
+*  LDB    - INTEGER.
+*           On entry, LDB specifies the first dimension of B as declared
+*           in  the  calling  (sub)  program.   LDB  must  be  at  least
+*           max( 1, m ).
+*           Unchanged on exit.
+*
+*
+*  Level 3 Blas routine.
+*
+*
+*  -- Written on 8-February-1989.
+*     Jack Dongarra, Argonne National Laboratory.
+*     Iain Duff, AERE Harwell.
+*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
+*     Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     .. Local Scalars ..
+      LOGICAL            LSIDE, NOUNIT, UPPER
+      INTEGER            I, INFO, J, K, NROWA
+      DOUBLE PRECISION   TEMP
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE         , ZERO
+      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      LSIDE  = LSAME( SIDE  , 'L' )
+      IF( LSIDE )THEN
+         NROWA = M
+      ELSE
+         NROWA = N
+      END IF
+      NOUNIT = LSAME( DIAG  , 'N' )
+      UPPER  = LSAME( UPLO  , 'U' )
+*
+      INFO   = 0
+      IF(      ( .NOT.LSIDE                ).AND.
+     $         ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
+         INFO = 1
+      ELSE IF( ( .NOT.UPPER                ).AND.
+     $         ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
+         INFO = 2
+      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.
+     $         ( .NOT.LSAME( TRANSA, 'T' ) ).AND.
+     $         ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
+         INFO = 3
+      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND.
+     $         ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
+         INFO = 4
+      ELSE IF( M  .LT.0               )THEN
+         INFO = 5
+      ELSE IF( N  .LT.0               )THEN
+         INFO = 6
+      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
+         INFO = 9
+      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
+         INFO = 11
+      END IF
+      IF( INFO.NE.0 )THEN
+         CALL XERBLA( 'DTRSM ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     And when  alpha.eq.zero.
+*
+      IF( ALPHA.EQ.ZERO )THEN
+         DO 20, J = 1, N
+            DO 10, I = 1, M
+               B( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+         RETURN
+      END IF
+*
+*     Start the operations.
+*
+      IF( LSIDE )THEN
+         IF( LSAME( TRANSA, 'N' ) )THEN
+*
+*           Form  B := alpha*inv( A )*B.
+*
+            IF( UPPER )THEN
+               DO 60, J = 1, N
+                  IF( ALPHA.NE.ONE )THEN
+                     DO 30, I = 1, M
+                        B( I, J ) = ALPHA*B( I, J )
+   30                CONTINUE
+                  END IF
+                  DO 50, K = M, 1, -1
+                     IF( B( K, J ).NE.ZERO )THEN
+                        IF( NOUNIT )
+     $                     B( K, J ) = B( K, J )/A( K, K )
+                        DO 40, I = 1, K - 1
+                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
+   40                   CONTINUE
+                     END IF
+   50             CONTINUE
+   60          CONTINUE
+            ELSE
+               DO 100, J = 1, N
+                  IF( ALPHA.NE.ONE )THEN
+                     DO 70, I = 1, M
+                        B( I, J ) = ALPHA*B( I, J )
+   70                CONTINUE
+                  END IF
+                  DO 90 K = 1, M
+                     IF( B( K, J ).NE.ZERO )THEN
+                        IF( NOUNIT )
+     $                     B( K, J ) = B( K, J )/A( K, K )
+                        DO 80, I = K + 1, M
+                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
+   80                   CONTINUE
+                     END IF
+   90             CONTINUE
+  100          CONTINUE
+            END IF
+         ELSE
+*
+*           Form  B := alpha*inv( A' )*B.
+*
+            IF( UPPER )THEN
+               DO 130, J = 1, N
+                  DO 120, I = 1, M
+                     TEMP = ALPHA*B( I, J )
+                     DO 110, K = 1, I - 1
+                        TEMP = TEMP - A( K, I )*B( K, J )
+  110                CONTINUE
+                     IF( NOUNIT )
+     $                  TEMP = TEMP/A( I, I )
+                     B( I, J ) = TEMP
+  120             CONTINUE
+  130          CONTINUE
+            ELSE
+               DO 160, J = 1, N
+                  DO 150, I = M, 1, -1
+                     TEMP = ALPHA*B( I, J )
+                     DO 140, K = I + 1, M
+                        TEMP = TEMP - A( K, I )*B( K, J )
+  140                CONTINUE
+                     IF( NOUNIT )
+     $                  TEMP = TEMP/A( I, I )
+                     B( I, J ) = TEMP
+  150             CONTINUE
+  160          CONTINUE
+            END IF
+         END IF
+      ELSE
+         IF( LSAME( TRANSA, 'N' ) )THEN
+*
+*           Form  B := alpha*B*inv( A ).
+*
+            IF( UPPER )THEN
+               DO 210, J = 1, N
+                  IF( ALPHA.NE.ONE )THEN
+                     DO 170, I = 1, M
+                        B( I, J ) = ALPHA*B( I, J )
+  170                CONTINUE
+                  END IF
+                  DO 190, K = 1, J - 1
+                     IF( A( K, J ).NE.ZERO )THEN
+                        DO 180, I = 1, M
+                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
+  180                   CONTINUE
+                     END IF
+  190             CONTINUE
+                  IF( NOUNIT )THEN
+                     TEMP = ONE/A( J, J )
+                     DO 200, I = 1, M
+                        B( I, J ) = TEMP*B( I, J )
+  200                CONTINUE
+                  END IF
+  210          CONTINUE
+            ELSE
+               DO 260, J = N, 1, -1
+                  IF( ALPHA.NE.ONE )THEN
+                     DO 220, I = 1, M
+                        B( I, J ) = ALPHA*B( I, J )
+  220                CONTINUE
+                  END IF
+                  DO 240, K = J + 1, N
+                     IF( A( K, J ).NE.ZERO )THEN
+                        DO 230, I = 1, M
+                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
+  230                   CONTINUE
+                     END IF
+  240             CONTINUE
+                  IF( NOUNIT )THEN
+                     TEMP = ONE/A( J, J )
+                     DO 250, I = 1, M
+                       B( I, J ) = TEMP*B( I, J )
+  250                CONTINUE
+                  END IF
+  260          CONTINUE
+            END IF
+         ELSE
+*
+*           Form  B := alpha*B*inv( A' ).
+*
+            IF( UPPER )THEN
+               DO 310, K = N, 1, -1
+                  IF( NOUNIT )THEN
+                     TEMP = ONE/A( K, K )
+                     DO 270, I = 1, M
+                        B( I, K ) = TEMP*B( I, K )
+  270                CONTINUE
+                  END IF
+                  DO 290, J = 1, K - 1
+                     IF( A( J, K ).NE.ZERO )THEN
+                        TEMP = A( J, K )
+                        DO 280, I = 1, M
+                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
+  280                   CONTINUE
+                     END IF
+  290             CONTINUE
+                  IF( ALPHA.NE.ONE )THEN
+                     DO 300, I = 1, M
+                        B( I, K ) = ALPHA*B( I, K )
+  300                CONTINUE
+                  END IF
+  310          CONTINUE
+            ELSE
+               DO 360, K = 1, N
+                  IF( NOUNIT )THEN
+                     TEMP = ONE/A( K, K )
+                     DO 320, I = 1, M
+                        B( I, K ) = TEMP*B( I, K )
+  320                CONTINUE
+                  END IF
+                  DO 340, J = K + 1, N
+                     IF( A( J, K ).NE.ZERO )THEN
+                        TEMP = A( J, K )
+                        DO 330, I = 1, M
+                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
+  330                   CONTINUE
+                     END IF
+  340             CONTINUE
+                  IF( ALPHA.NE.ONE )THEN
+                     DO 350, I = 1, M
+                        B( I, K ) = ALPHA*B( I, K )
+  350                CONTINUE
+                  END IF
+  360          CONTINUE
+            END IF
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DTRSM .
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/dtrsv.f
@@ -0,0 +1,292 @@
+*
+************************************************************************
+*
+      SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
+*     .. Scalar Arguments ..
+      INTEGER            INCX, LDA, N
+      CHARACTER*1        DIAG, TRANS, UPLO
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTRSV  solves one of the systems of equations
+*
+*     A*x = b,   or   A'*x = b,
+*
+*  where b and x are n element vectors and A is an n by n unit, or
+*  non-unit, upper or lower triangular matrix.
+*
+*  No test for singularity or near-singularity is included in this
+*  routine. Such tests must be performed before calling this routine.
+*
+*  Parameters
+*  ==========
+*
+*  UPLO   - CHARACTER*1.
+*           On entry, UPLO specifies whether the matrix is an upper or
+*           lower triangular matrix as follows:
+*
+*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
+*
+*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
+*
+*           Unchanged on exit.
+*
+*  TRANS  - CHARACTER*1.
+*           On entry, TRANS specifies the equations to be solved as
+*           follows:
+*
+*              TRANS = 'N' or 'n'   A*x = b.
+*
+*              TRANS = 'T' or 't'   A'*x = b.
+*
+*              TRANS = 'C' or 'c'   A'*x = b.
+*
+*           Unchanged on exit.
+*
+*  DIAG   - CHARACTER*1.
+*           On entry, DIAG specifies whether or not A is unit
+*           triangular as follows:
+*
+*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
+*
+*              DIAG = 'N' or 'n'   A is not assumed to be unit
+*                                  triangular.
+*
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the order of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+*           Before entry with  UPLO = 'U' or 'u', the leading n by n
+*           upper triangular part of the array A must contain the upper
+*           triangular matrix and the strictly lower triangular part of
+*           A is not referenced.
+*           Before entry with UPLO = 'L' or 'l', the leading n by n
+*           lower triangular part of the array A must contain the lower
+*           triangular matrix and the strictly upper triangular part of
+*           A is not referenced.
+*           Note that when  DIAG = 'U' or 'u', the diagonal elements of
+*           A are not referenced either, but are assumed to be unity.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, n ).
+*           Unchanged on exit.
+*
+*  X      - DOUBLE PRECISION array of dimension at least
+*           ( 1 + ( n - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the n
+*           element right-hand side vector b. On exit, X is overwritten
+*           with the solution vector x.
+*
+*  INCX   - INTEGER.
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*
+*  Level 2 Blas routine.
+*
+*  -- Written on 22-October-1986.
+*     Jack Dongarra, Argonne National Lab.
+*     Jeremy Du Croz, Nag Central Office.
+*     Sven Hammarling, Nag Central Office.
+*     Richard Hanson, Sandia National Labs.
+*
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER        ( ZERO = 0.0D+0 )
+*     .. Local Scalars ..
+      DOUBLE PRECISION   TEMP
+      INTEGER            I, INFO, IX, J, JX, KX
+      LOGICAL            NOUNIT
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF     ( .NOT.LSAME( UPLO , 'U' ).AND.
+     $         .NOT.LSAME( UPLO , 'L' )      )THEN
+         INFO = 1
+      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
+     $         .NOT.LSAME( TRANS, 'T' ).AND.
+     $         .NOT.LSAME( TRANS, 'C' )      )THEN
+         INFO = 2
+      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
+     $         .NOT.LSAME( DIAG , 'N' )      )THEN
+         INFO = 3
+      ELSE IF( N.LT.0 )THEN
+         INFO = 4
+      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
+         INFO = 6
+      ELSE IF( INCX.EQ.0 )THEN
+         INFO = 8
+      END IF
+      IF( INFO.NE.0 )THEN
+         CALL XERBLA( 'DTRSV ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+*     Set up the start point in X if the increment is not unity. This
+*     will be  ( N - 1 )*INCX  too small for descending loops.
+*
+      IF( INCX.LE.0 )THEN
+         KX = 1 - ( N - 1 )*INCX
+      ELSE IF( INCX.NE.1 )THEN
+         KX = 1
+      END IF
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through A.
+*
+      IF( LSAME( TRANS, 'N' ) )THEN
+*
+*        Form  x := inv( A )*x.
+*
+         IF( LSAME( UPLO, 'U' ) )THEN
+            IF( INCX.EQ.1 )THEN
+               DO 20, J = N, 1, -1
+                  IF( X( J ).NE.ZERO )THEN
+                     IF( NOUNIT )
+     $                  X( J ) = X( J )/A( J, J )
+                     TEMP = X( J )
+                     DO 10, I = J - 1, 1, -1
+                        X( I ) = X( I ) - TEMP*A( I, J )
+   10                CONTINUE
+                  END IF
+   20          CONTINUE
+            ELSE
+               JX = KX + ( N - 1 )*INCX
+               DO 40, J = N, 1, -1
+                  IF( X( JX ).NE.ZERO )THEN
+                     IF( NOUNIT )
+     $                  X( JX ) = X( JX )/A( J, J )
+                     TEMP = X( JX )
+                     IX   = JX
+                     DO 30, I = J - 1, 1, -1
+                        IX      = IX      - INCX
+                        X( IX ) = X( IX ) - TEMP*A( I, J )
+   30                CONTINUE
+                  END IF
+                  JX = JX - INCX
+   40          CONTINUE
+            END IF
+         ELSE
+            IF( INCX.EQ.1 )THEN
+               DO 60, J = 1, N
+                  IF( X( J ).NE.ZERO )THEN
+                     IF( NOUNIT )
+     $                  X( J ) = X( J )/A( J, J )
+                     TEMP = X( J )
+                     DO 50, I = J + 1, N
+                        X( I ) = X( I ) - TEMP*A( I, J )
+   50                CONTINUE
+                  END IF
+   60          CONTINUE
+            ELSE
+               JX = KX
+               DO 80, J = 1, N
+                  IF( X( JX ).NE.ZERO )THEN
+                     IF( NOUNIT )
+     $                  X( JX ) = X( JX )/A( J, J )
+                     TEMP = X( JX )
+                     IX   = JX
+                     DO 70, I = J + 1, N
+                        IX      = IX      + INCX
+                        X( IX ) = X( IX ) - TEMP*A( I, J )
+   70                CONTINUE
+                  END IF
+                  JX = JX + INCX
+   80          CONTINUE
+            END IF
+         END IF
+      ELSE
+*
+*        Form  x := inv( A' )*x.
+*
+         IF( LSAME( UPLO, 'U' ) )THEN
+            IF( INCX.EQ.1 )THEN
+               DO 100, J = 1, N
+                  TEMP = X( J )
+                  DO 90, I = 1, J - 1
+                     TEMP = TEMP - A( I, J )*X( I )
+   90             CONTINUE
+                  IF( NOUNIT )
+     $               TEMP = TEMP/A( J, J )
+                  X( J ) = TEMP
+  100          CONTINUE
+            ELSE
+               JX = KX
+               DO 120, J = 1, N
+                  TEMP = X( JX )
+                  IX   = KX
+                  DO 110, I = 1, J - 1
+                     TEMP = TEMP - A( I, J )*X( IX )
+                     IX   = IX   + INCX
+  110             CONTINUE
+                  IF( NOUNIT )
+     $               TEMP = TEMP/A( J, J )
+                  X( JX ) = TEMP
+                  JX      = JX   + INCX
+  120          CONTINUE
+            END IF
+         ELSE
+            IF( INCX.EQ.1 )THEN
+               DO 140, J = N, 1, -1
+                  TEMP = X( J )
+                  DO 130, I = N, J + 1, -1
+                     TEMP = TEMP - A( I, J )*X( I )
+  130             CONTINUE
+                  IF( NOUNIT )
+     $               TEMP = TEMP/A( J, J )
+                  X( J ) = TEMP
+  140          CONTINUE
+            ELSE
+               KX = KX + ( N - 1 )*INCX
+               JX = KX
+               DO 160, J = N, 1, -1
+                  TEMP = X( JX )
+                  IX   = KX
+                  DO 150, I = N, J + 1, -1
+                     TEMP = TEMP - A( I, J )*X( IX )
+                     IX   = IX   - INCX
+  150             CONTINUE
+                  IF( NOUNIT )
+     $               TEMP = TEMP/A( J, J )
+                  X( JX ) = TEMP
+                  JX      = JX   - INCX
+  160          CONTINUE
+            END IF
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DTRSV .
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/dzasum.f
@@ -0,0 +1,34 @@
+      double precision function dzasum(n,zx,incx)
+c
+c     takes the sum of the absolute values.
+c     jack dongarra, 3/11/78.
+c     modified to correct problem with negative increment, 8/21/90.
+c
+      double complex zx(1)
+      double precision stemp,dcabs1
+      integer i,incx,ix,n
+c
+      dzasum = 0.0d0
+      stemp = 0.0d0
+      if(n.le.0)return
+      if(incx.eq.1)go to 20
+c
+c        code for increment not equal to 1
+c
+      ix = 1
+      if(incx.lt.0)ix = (-n+1)*incx + 1
+      do 10 i = 1,n
+        stemp = stemp + dcabs1(zx(ix))
+        ix = ix + incx
+   10 continue
+      dzasum = stemp
+      return
+c
+c        code for increment equal to 1
+c
+   20 do 30 i = 1,n
+        stemp = stemp + dcabs1(zx(i))
+   30 continue
+      dzasum = stemp
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/dznrm2.f
@@ -0,0 +1,138 @@
+      double precision function dznrm2( n, zx, incx)
+      logical imag, scale
+      integer i, incx, ix, n, next
+      double precision cutlo, cuthi, hitest, sum, xmax, absx, zero, one
+      double complex      zx(1)
+      double precision dreal,dimag
+      double complex zdumr,zdumi
+      dreal(zdumr) = zdumr
+      dimag(zdumi) = (0.0d0,-1.0d0)*zdumi
+      data         zero, one /0.0d0, 1.0d0/
+c
+c     unitary norm of the complex n-vector stored in zx() with storage
+c     increment incx .
+c     if    n .le. 0 return with result = 0.
+c     if n .ge. 1 then incx must be .ge. 1
+c
+c           c.l.lawson , 1978 jan 08
+c     modified to correct problem with negative increment, 8/21/90.
+c
+c     four phase method     using two built-in constants that are
+c     hopefully applicable to all machines.
+c         cutlo = maximum of  sqrt(u/eps)  over all known machines.
+c         cuthi = minimum of  sqrt(v)      over all known machines.
+c     where
+c         eps = smallest no. such that eps + 1. .gt. 1.
+c         u   = smallest positive no.   (underflow limit)
+c         v   = largest  no.            (overflow  limit)
+c
+c     brief outline of algorithm..
+c
+c     phase 1    scans zero components.
+c     move to phase 2 when a component is nonzero and .le. cutlo
+c     move to phase 3 when a component is .gt. cutlo
+c     move to phase 4 when a component is .ge. cuthi/m
+c     where m = n for x() real and m = 2*n for complex.
+c
+c     values for cutlo and cuthi..
+c     from the environmental parameters listed in the imsl converter
+c     document the limiting values are as follows..
+c     cutlo, s.p.   u/eps = 2**(-102) for  honeywell.  close seconds are
+c                   univac and dec at 2**(-103)
+c                   thus cutlo = 2**(-51) = 4.44089e-16
+c     cuthi, s.p.   v = 2**127 for univac, honeywell, and dec.
+c                   thus cuthi = 2**(63.5) = 1.30438e19
+c     cutlo, d.p.   u/eps = 2**(-67) for honeywell and dec.
+c                   thus cutlo = 2**(-33.5) = 8.23181d-11
+c     cuthi, d.p.   same as s.p.  cuthi = 1.30438d19
+c     data cutlo, cuthi / 8.232d-11,  1.304d19 /
+c     data cutlo, cuthi / 4.441e-16,  1.304e19 /
+      data cutlo, cuthi / 8.232d-11,  1.304d19 /
+c
+      if(n .gt. 0) go to 10
+         dznrm2  = zero
+         go to 300
+c
+   10 assign 30 to next
+      sum = zero
+      i = 1
+      if( incx .lt. 0 )i = (-n+1)*incx + 1
+c                                                 begin main loop
+      do 220 ix = 1,n
+         absx = dabs(dreal(zx(i)))
+         imag = .false.
+         go to next,(30, 50, 70, 90, 110)
+   30 if( absx .gt. cutlo) go to 85
+      assign 50 to next
+      scale = .false.
+c
+c                        phase 1.  sum is zero
+c
+   50 if( absx .eq. zero) go to 200
+      if( absx .gt. cutlo) go to 85
+c
+c                                prepare for phase 2.
+      assign 70 to next
+      go to 105
+c
+c                                prepare for phase 4.
+c
+  100 assign 110 to next
+      sum = (sum / absx) / absx
+  105 scale = .true.
+      xmax = absx
+      go to 115
+c
+c                   phase 2.  sum is small.
+c                             scale to avoid destructive underflow.
+c
+   70 if( absx .gt. cutlo ) go to 75
+c
+c                     common code for phases 2 and 4.
+c                     in phase 4 sum is large.  scale to avoid overflow.
+c
+  110 if( absx .le. xmax ) go to 115
+         sum = one + sum * (xmax / absx)**2
+         xmax = absx
+         go to 200
+c
+  115 sum = sum + (absx/xmax)**2
+      go to 200
+c
+c
+c                  prepare for phase 3.
+c
+   75 sum = (sum * xmax) * xmax
+c
+   85 assign 90 to next
+      scale = .false.
+c
+c     for real or d.p. set hitest = cuthi/n
+c     for complex      set hitest = cuthi/(2*n)
+c
+      hitest = cuthi/dble( 2*n )
+c
+c                   phase 3.  sum is mid-range.  no scaling.
+c
+   90 if(absx .ge. hitest) go to 100
+         sum = sum + absx**2
+  200 continue
+c                  control selection of real and imaginary parts.
+c
+      if(imag) go to 210
+         absx = dabs(dimag(zx(i)))
+         imag = .true.
+      go to next,(  50, 70, 90, 110 )
+c
+  210 continue
+      i = i + incx
+  220 continue
+c
+c              end of main loop.
+c              compute square root and adjust for scaling.
+c
+      dznrm2 = dsqrt(sum)
+      if(scale) dznrm2 = dznrm2 * xmax
+  300 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/idamax.f
@@ -0,0 +1,37 @@
+      INTEGER FUNCTION IDAMAX(N,DX,INCX)
+C
+C     FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE.
+C     JACK DONGARRA, LINPACK, 3/11/78.
+C
+      DOUBLE PRECISION DX(1),DMAX
+      INTEGER I,INCX,IX,N
+C
+      IDAMAX = 0
+      IF( N .LT. 1 ) RETURN
+      IDAMAX = 1
+      IF(N.EQ.1)RETURN
+      IF(INCX.EQ.1)GO TO 20
+C
+C        CODE FOR INCREMENT NOT EQUAL TO 1
+C
+      IX = 1
+      DMAX = DABS(DX(1))
+      IX = IX + INCX
+      DO 10 I = 2,N
+         IF(DABS(DX(IX)).LE.DMAX) GO TO 5
+         IDAMAX = I
+         DMAX = DABS(DX(IX))
+    5    IX = IX + INCX
+   10 CONTINUE
+      RETURN
+C
+C        CODE FOR INCREMENT EQUAL TO 1
+C
+   20 DMAX = DABS(DX(1))
+      DO 30 I = 2,N
+         IF(DABS(DX(I)).LE.DMAX) GO TO 30
+         IDAMAX = I
+         DMAX = DABS(DX(I))
+   30 CONTINUE
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/izamax.f
@@ -0,0 +1,41 @@
+      integer function izamax(n,zx,incx)
+c
+c     finds the index of element having max. absolute value.
+c     jack dongarra, 1/15/85.
+c     modified to correct problem with negative increment, 8/21/90.
+c
+      double complex zx(1)
+      double precision smax
+      integer i,incx,ix,n
+      double precision dcabs1
+c
+      izamax = 0
+      if(n.lt.1)return
+      izamax = 1
+      if(n.eq.1)return
+      if(incx.eq.1)go to 20
+c
+c        code for increment not equal to 1
+c
+      ix = 1
+      if(incx.lt.0)ix = (-n+1)*incx + 1
+      smax = dcabs1(zx(ix))
+      ix = ix + incx
+      do 10 i = 2,n
+         if(dcabs1(zx(ix)).le.smax) go to 5
+         izamax = i
+         smax = dcabs1(zx(ix))
+    5    ix = ix + incx
+   10 continue
+      return
+c
+c        code for increment equal to 1
+c
+   20 smax = dcabs1(zx(1))
+      do 30 i = 2,n
+         if(dcabs1(zx(i)).le.smax) go to 30
+         izamax = i
+         smax = dcabs1(zx(i))
+   30 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/lsame.f
@@ -0,0 +1,89 @@
+      LOGICAL FUNCTION LSAME ( CA, CB )
+*     .. Scalar Arguments ..
+      CHARACTER*1            CA, CB
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  LSAME  tests if CA is the same letter as CB regardless of case.
+*  CB is assumed to be an upper case letter. LSAME returns .TRUE. if
+*  CA is either the same as CB or the equivalent lower case letter.
+*
+*  N.B. This version of the routine is only correct for ASCII code.
+*       Installers must modify the routine for other character-codes.
+*
+*       For EBCDIC systems the constant IOFF must be changed to -64.
+*       For CDC systems using 6-12 bit representations, the system-
+*       specific code in comments must be activated.
+*
+*  Parameters
+*  ==========
+*
+*  CA     - CHARACTER*1
+*  CB     - CHARACTER*1
+*           On entry, CA and CB specify characters to be compared.
+*           Unchanged on exit.
+*
+*
+*  Auxiliary routine for Level 2 Blas.
+*
+*  -- Written on 20-July-1986
+*     Richard Hanson, Sandia National Labs.
+*     Jeremy Du Croz, Nag Central Office.
+*
+*     .. Parameters ..
+      INTEGER                IOFF
+      PARAMETER            ( IOFF=32 )
+*     .. Intrinsic Functions ..
+      INTRINSIC              ICHAR
+*     .. Executable Statements ..
+*
+*     Test if the characters are equal
+*
+      LSAME = CA .EQ. CB
+*
+*     Now test for equivalence
+*
+      IF ( .NOT.LSAME ) THEN
+         LSAME = ICHAR(CA) - IOFF .EQ. ICHAR(CB)
+      END IF
+*
+      RETURN
+*
+*  The following comments contain code for CDC systems using 6-12 bit
+*  representations.
+*
+*     .. Parameters ..
+*     INTEGER                ICIRFX
+*     PARAMETER            ( ICIRFX=62 )
+*     .. Scalar Arguments ..
+*     CHARACTER*1            CB
+*     .. Array Arguments ..
+*     CHARACTER*1            CA(*)
+*     .. Local Scalars ..
+*     INTEGER                IVAL
+*     .. Intrinsic Functions ..
+*     INTRINSIC              ICHAR, CHAR
+*     .. Executable Statements ..
+*
+*     See if the first character in string CA equals string CB.
+*
+*     LSAME = CA(1) .EQ. CB .AND. CA(1) .NE. CHAR(ICIRFX)
+*
+*     IF (LSAME) RETURN
+*
+*     The characters are not identical. Now check them for equivalence.
+*     Look for the 'escape' character, circumflex, followed by the
+*     letter.
+*
+*     IVAL = ICHAR(CA(2))
+*     IF (IVAL.GE.ICHAR('A') .AND. IVAL.LE.ICHAR('Z')) THEN
+*        LSAME = CA(1) .EQ. CHAR(ICIRFX) .AND. CA(2) .EQ. CB
+*     END IF
+*
+*     RETURN
+*
+*     End of LSAME.
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/sdot.f
@@ -0,0 +1,48 @@
+      REAL FUNCTION SDOT(N,SX,INCX,SY,INCY)
+C
+C     FORMS THE DOT PRODUCT OF TWO VECTORS.
+C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
+C     JACK DONGARRA, LINPACK, 3/11/78.
+C
+      REAL SX(1),SY(1),STEMP
+      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
+C
+      STEMP = 0.0E0
+      SDOT = 0.0E0
+      IF(N.LE.0)RETURN
+      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
+C
+C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
+C          NOT EQUAL TO 1
+C
+      IX = 1
+      IY = 1
+      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
+      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
+      DO 10 I = 1,N
+        STEMP = STEMP + SX(IX)*SY(IY)
+        IX = IX + INCX
+        IY = IY + INCY
+   10 CONTINUE
+      SDOT = STEMP
+      RETURN
+C
+C        CODE FOR BOTH INCREMENTS EQUAL TO 1
+C
+C
+C        CLEAN-UP LOOP
+C
+   20 M = MOD(N,5)
+      IF( M .EQ. 0 ) GO TO 40
+      DO 30 I = 1,M
+        STEMP = STEMP + SX(I)*SY(I)
+   30 CONTINUE
+      IF( N .LT. 5 ) GO TO 60
+   40 MP1 = M + 1
+      DO 50 I = MP1,N,5
+        STEMP = STEMP + SX(I)*SY(I) + SX(I + 1)*SY(I + 1) +
+     *   SX(I + 2)*SY(I + 2) + SX(I + 3)*SY(I + 3) + SX(I + 4)*SY(I + 4)
+   50 CONTINUE
+   60 SDOT = STEMP
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/xerbla.f
@@ -0,0 +1,45 @@
+      SUBROUTINE XERBLA ( SRNAME, INFO )
+*     ..    Scalar Arguments ..
+      INTEGER            INFO
+      CHARACTER*6        SRNAME
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  XERBLA  is an error handler for the Level 2 BLAS routines.
+*
+*  It is called by the Level 2 BLAS routines if an input parameter is
+*  invalid.
+*
+*  Installers should consider modifying the STOP statement in order to
+*  call system-specific exception-handling facilities.
+*
+*  Parameters
+*  ==========
+*
+*  SRNAME - CHARACTER*6.
+*           On entry, SRNAME specifies the name of the routine which
+*           called XERBLA.
+*
+*  INFO   - INTEGER.
+*           On entry, INFO specifies the position of the invalid
+*           parameter in the parameter-list of the calling routine.
+*
+*
+*  Auxiliary routine for Level 2 Blas.
+*
+*  Written on 20-July-1986.
+*
+*     .. Executable Statements ..
+*
+      WRITE (*,99999) SRNAME, INFO
+*
+      CALL XSTOPX (' ')
+*
+99999 FORMAT ( ' ** On entry to ', A6, ' parameter number ', I2,
+     $         ' had an illegal value' )
+*
+*     End of XERBLA.
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/zaxpy.f
@@ -0,0 +1,33 @@
+      subroutine zaxpy(n,za,zx,incx,zy,incy)
+c
+c     constant times a vector plus a vector.
+c     jack dongarra, 3/11/78.
+c
+      double complex zx(1),zy(1),za
+      integer i,incx,incy,ix,iy,n
+      double precision dcabs1
+      if(n.le.0)return
+      if (dcabs1(za) .eq. 0.0d0) return
+      if (incx.eq.1.and.incy.eq.1)go to 20
+c
+c        code for unequal increments or equal increments
+c          not equal to 1
+c
+      ix = 1
+      iy = 1
+      if(incx.lt.0)ix = (-n+1)*incx + 1
+      if(incy.lt.0)iy = (-n+1)*incy + 1
+      do 10 i = 1,n
+        zy(iy) = zy(iy) + za*zx(ix)
+        ix = ix + incx
+        iy = iy + incy
+   10 continue
+      return
+c
+c        code for both increments equal to 1
+c
+   20 do 30 i = 1,n
+        zy(i) = zy(i) + za*zx(i)
+   30 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/zcopy.f
@@ -0,0 +1,32 @@
+      subroutine  zcopy(n,zx,incx,zy,incy)
+c
+c     copies a vector, x, to a vector, y.
+c     jack dongarra, linpack, 4/11/78.
+c
+      double complex zx(1),zy(1)
+      integer i,incx,incy,ix,iy,n
+c
+      if(n.le.0)return
+      if(incx.eq.1.and.incy.eq.1)go to 20
+c
+c        code for unequal increments or equal increments
+c          not equal to 1
+c
+      ix = 1
+      iy = 1
+      if(incx.lt.0)ix = (-n+1)*incx + 1
+      if(incy.lt.0)iy = (-n+1)*incy + 1
+      do 10 i = 1,n
+        zy(iy) = zx(ix)
+        ix = ix + incx
+        iy = iy + incy
+   10 continue
+      return
+c
+c        code for both increments equal to 1
+c
+   20 do 30 i = 1,n
+        zy(i) = zx(i)
+   30 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/zdotc.f
@@ -0,0 +1,35 @@
+      double complex function zdotc(n,zx,incx,zy,incy)
+c
+c     forms the dot product of a vector.
+c     jack dongarra, 3/11/78.
+c
+      double complex zx(1),zy(1),ztemp
+      integer i,incx,incy,ix,iy,n
+      ztemp = (0.0d0,0.0d0)
+      zdotc = (0.0d0,0.0d0)
+      if(n.le.0)return
+      if(incx.eq.1.and.incy.eq.1)go to 20
+c
+c        code for unequal increments or equal increments
+c          not equal to 1
+c
+      ix = 1
+      iy = 1
+      if(incx.lt.0)ix = (-n+1)*incx + 1
+      if(incy.lt.0)iy = (-n+1)*incy + 1
+      do 10 i = 1,n
+        ztemp = ztemp + dconjg(zx(ix))*zy(iy)
+        ix = ix + incx
+        iy = iy + incy
+   10 continue
+      zdotc = ztemp
+      return
+c
+c        code for both increments equal to 1
+c
+   20 do 30 i = 1,n
+        ztemp = ztemp + dconjg(zx(i))*zy(i)
+   30 continue
+      zdotc = ztemp
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/zdotu.f
@@ -0,0 +1,35 @@
+      double complex function zdotu(n,zx,incx,zy,incy)
+c
+c     forms the dot product of two vectors.
+c     jack dongarra, 3/11/78.
+c
+      double complex zx(1),zy(1),ztemp
+      integer i,incx,incy,ix,iy,n
+      ztemp = (0.0d0,0.0d0)
+      zdotu = (0.0d0,0.0d0)
+      if(n.le.0)return
+      if(incx.eq.1.and.incy.eq.1)go to 20
+c
+c        code for unequal increments or equal increments
+c          not equal to 1
+c
+      ix = 1
+      iy = 1
+      if(incx.lt.0)ix = (-n+1)*incx + 1
+      if(incy.lt.0)iy = (-n+1)*incy + 1
+      do 10 i = 1,n
+        ztemp = ztemp + zx(ix)*zy(iy)
+        ix = ix + incx
+        iy = iy + incy
+   10 continue
+      zdotu = ztemp
+      return
+c
+c        code for both increments equal to 1
+c
+   20 do 30 i = 1,n
+        ztemp = ztemp + zx(i)*zy(i)
+   30 continue
+      zdotu = ztemp
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/zdrot.f
@@ -0,0 +1,38 @@
+      subroutine  zdrot (n,zx,incx,zy,incy,c,s)
+c
+c     applies a plane rotation, where the cos and sin (c and s) are
+c     double precision and the vectors zx and zy are double complex.
+c     jack dongarra, linpack, 3/11/78.
+c
+      double complex zx(1),zy(1),ztemp
+      double precision c,s
+      integer i,incx,incy,ix,iy,n
+c
+      if(n.le.0)return
+      if(incx.eq.1.and.incy.eq.1)go to 20
+c
+c       code for unequal increments or equal increments not equal
+c         to 1
+c
+      ix = 1
+      iy = 1
+      if(incx.lt.0)ix = (-n+1)*incx + 1
+      if(incy.lt.0)iy = (-n+1)*incy + 1
+      do 10 i = 1,n
+        ztemp = c*zx(ix) + s*zy(iy)
+        zy(iy) = c*zy(iy) - s*zx(ix)
+        zx(ix) = ztemp
+        ix = ix + incx
+        iy = iy + incy
+   10 continue
+      return
+c
+c       code for both increments equal to 1
+c
+   20 do 30 i = 1,n
+        ztemp = c*zx(i) + s*zy(i)
+        zy(i) = c*zy(i) - s*zx(i)
+        zx(i) = ztemp
+   30 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/zdscal.f
@@ -0,0 +1,30 @@
+      subroutine  zdscal(n,da,zx,incx)
+c
+c     scales a vector by a constant.
+c     jack dongarra, 3/11/78.
+c     modified to correct problem with negative increment, 8/21/90.
+c
+      double complex zx(1)
+      double precision da
+      integer i,incx,ix,n
+c
+      if(n.le.0)return
+      if(incx.eq.1)go to 20
+c
+c        code for increment not equal to 1
+c
+      ix = 1
+      if(incx.lt.0)ix = (-n+1)*incx + 1
+      do 10 i = 1,n
+        zx(ix) = dcmplx(da,0.0d0)*zx(ix)
+        ix = ix + incx
+   10 continue
+      return
+c
+c        code for increment equal to 1
+c
+   20 do 30 i = 1,n
+        zx(i) = dcmplx(da,0.0d0)*zx(i)
+   30 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/zgemm.f
@@ -0,0 +1,415 @@
+      SUBROUTINE ZGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
+     $                   BETA, C, LDC )
+*     .. Scalar Arguments ..
+      CHARACTER*1        TRANSA, TRANSB
+      INTEGER            M, N, K, LDA, LDB, LDC
+      COMPLEX*16         ALPHA, BETA
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEMM  performs one of the matrix-matrix operations
+*
+*     C := alpha*op( A )*op( B ) + beta*C,
+*
+*  where  op( X ) is one of
+*
+*     op( X ) = X   or   op( X ) = X'   or   op( X ) = conjg( X' ),
+*
+*  alpha and beta are scalars, and A, B and C are matrices, with op( A )
+*  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
+*
+*  Parameters
+*  ==========
+*
+*  TRANSA - CHARACTER*1.
+*           On entry, TRANSA specifies the form of op( A ) to be used in
+*           the matrix multiplication as follows:
+*
+*              TRANSA = 'N' or 'n',  op( A ) = A.
+*
+*              TRANSA = 'T' or 't',  op( A ) = A'.
+*
+*              TRANSA = 'C' or 'c',  op( A ) = conjg( A' ).
+*
+*           Unchanged on exit.
+*
+*  TRANSB - CHARACTER*1.
+*           On entry, TRANSB specifies the form of op( B ) to be used in
+*           the matrix multiplication as follows:
+*
+*              TRANSB = 'N' or 'n',  op( B ) = B.
+*
+*              TRANSB = 'T' or 't',  op( B ) = B'.
+*
+*              TRANSB = 'C' or 'c',  op( B ) = conjg( B' ).
+*
+*           Unchanged on exit.
+*
+*  M      - INTEGER.
+*           On entry,  M  specifies  the number  of rows  of the  matrix
+*           op( A )  and of the  matrix  C.  M  must  be at least  zero.
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry,  N  specifies the number  of columns of the matrix
+*           op( B ) and the number of columns of the matrix C. N must be
+*           at least zero.
+*           Unchanged on exit.
+*
+*  K      - INTEGER.
+*           On entry,  K  specifies  the number of columns of the matrix
+*           op( A ) and the number of rows of the matrix op( B ). K must
+*           be at least  zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - COMPLEX*16      .
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  A      - COMPLEX*16       array of DIMENSION ( LDA, ka ), where ka is
+*           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
+*           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
+*           part of the array  A  must contain the matrix  A,  otherwise
+*           the leading  k by m  part of the array  A  must contain  the
+*           matrix A.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
+*           LDA must be at least  max( 1, m ), otherwise  LDA must be at
+*           least  max( 1, k ).
+*           Unchanged on exit.
+*
+*  B      - COMPLEX*16       array of DIMENSION ( LDB, kb ), where kb is
+*           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
+*           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
+*           part of the array  B  must contain the matrix  B,  otherwise
+*           the leading  n by k  part of the array  B  must contain  the
+*           matrix B.
+*           Unchanged on exit.
+*
+*  LDB    - INTEGER.
+*           On entry, LDB specifies the first dimension of B as declared
+*           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
+*           LDB must be at least  max( 1, k ), otherwise  LDB must be at
+*           least  max( 1, n ).
+*           Unchanged on exit.
+*
+*  BETA   - COMPLEX*16      .
+*           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
+*           supplied as zero then C need not be set on input.
+*           Unchanged on exit.
+*
+*  C      - COMPLEX*16       array of DIMENSION ( LDC, n ).
+*           Before entry, the leading  m by n  part of the array  C must
+*           contain the matrix  C,  except when  beta  is zero, in which
+*           case C need not be set on entry.
+*           On exit, the array  C  is overwritten by the  m by n  matrix
+*           ( alpha*op( A )*op( B ) + beta*C ).
+*
+*  LDC    - INTEGER.
+*           On entry, LDC specifies the first dimension of C as declared
+*           in  the  calling  (sub)  program.   LDC  must  be  at  least
+*           max( 1, m ).
+*           Unchanged on exit.
+*
+*
+*  Level 3 Blas routine.
+*
+*  -- Written on 8-February-1989.
+*     Jack Dongarra, Argonne National Laboratory.
+*     Iain Duff, AERE Harwell.
+*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
+*     Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG, MAX
+*     .. Local Scalars ..
+      LOGICAL            CONJA, CONJB, NOTA, NOTB
+      INTEGER            I, INFO, J, L, NCOLA, NROWA, NROWB
+      COMPLEX*16         TEMP
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER        ( ONE  = ( 1.0D+0, 0.0D+0 ) )
+      COMPLEX*16         ZERO
+      PARAMETER        ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
+*     conjugated or transposed, set  CONJA and CONJB  as true if  A  and
+*     B  respectively are to be  transposed but  not conjugated  and set
+*     NROWA, NCOLA and  NROWB  as the number of rows and  columns  of  A
+*     and the number of rows of  B  respectively.
+*
+      NOTA  = LSAME( TRANSA, 'N' )
+      NOTB  = LSAME( TRANSB, 'N' )
+      CONJA = LSAME( TRANSA, 'C' )
+      CONJB = LSAME( TRANSB, 'C' )
+      IF( NOTA )THEN
+         NROWA = M
+         NCOLA = K
+      ELSE
+         NROWA = K
+         NCOLA = M
+      END IF
+      IF( NOTB )THEN
+         NROWB = K
+      ELSE
+         NROWB = N
+      END IF
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF(      ( .NOT.NOTA                 ).AND.
+     $         ( .NOT.CONJA                ).AND.
+     $         ( .NOT.LSAME( TRANSA, 'T' ) )      )THEN
+         INFO = 1
+      ELSE IF( ( .NOT.NOTB                 ).AND.
+     $         ( .NOT.CONJB                ).AND.
+     $         ( .NOT.LSAME( TRANSB, 'T' ) )      )THEN
+         INFO = 2
+      ELSE IF( M  .LT.0               )THEN
+         INFO = 3
+      ELSE IF( N  .LT.0               )THEN
+         INFO = 4
+      ELSE IF( K  .LT.0               )THEN
+         INFO = 5
+      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
+         INFO = 8
+      ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
+         INFO = 10
+      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
+         INFO = 13
+      END IF
+      IF( INFO.NE.0 )THEN
+         CALL XERBLA( 'ZGEMM ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
+     $    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) )
+     $   RETURN
+*
+*     And when  alpha.eq.zero.
+*
+      IF( ALPHA.EQ.ZERO )THEN
+         IF( BETA.EQ.ZERO )THEN
+            DO 20, J = 1, N
+               DO 10, I = 1, M
+                  C( I, J ) = ZERO
+   10          CONTINUE
+   20       CONTINUE
+         ELSE
+            DO 40, J = 1, N
+               DO 30, I = 1, M
+                  C( I, J ) = BETA*C( I, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+         RETURN
+      END IF
+*
+*     Start the operations.
+*
+      IF( NOTB )THEN
+         IF( NOTA )THEN
+*
+*           Form  C := alpha*A*B + beta*C.
+*
+            DO 90, J = 1, N
+               IF( BETA.EQ.ZERO )THEN
+                  DO 50, I = 1, M
+                     C( I, J ) = ZERO
+   50             CONTINUE
+               ELSE IF( BETA.NE.ONE )THEN
+                  DO 60, I = 1, M
+                     C( I, J ) = BETA*C( I, J )
+   60             CONTINUE
+               END IF
+               DO 80, L = 1, K
+                  IF( B( L, J ).NE.ZERO )THEN
+                     TEMP = ALPHA*B( L, J )
+                     DO 70, I = 1, M
+                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
+   70                CONTINUE
+                  END IF
+   80          CONTINUE
+   90       CONTINUE
+         ELSE IF( CONJA )THEN
+*
+*           Form  C := alpha*conjg( A' )*B + beta*C.
+*
+            DO 120, J = 1, N
+               DO 110, I = 1, M
+                  TEMP = ZERO
+                  DO 100, L = 1, K
+                     TEMP = TEMP + DCONJG( A( L, I ) )*B( L, J )
+  100             CONTINUE
+                  IF( BETA.EQ.ZERO )THEN
+                     C( I, J ) = ALPHA*TEMP
+                  ELSE
+                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
+                  END IF
+  110          CONTINUE
+  120       CONTINUE
+         ELSE
+*
+*           Form  C := alpha*A'*B + beta*C
+*
+            DO 150, J = 1, N
+               DO 140, I = 1, M
+                  TEMP = ZERO
+                  DO 130, L = 1, K
+                     TEMP = TEMP + A( L, I )*B( L, J )
+  130             CONTINUE
+                  IF( BETA.EQ.ZERO )THEN
+                     C( I, J ) = ALPHA*TEMP
+                  ELSE
+                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
+                  END IF
+  140          CONTINUE
+  150       CONTINUE
+         END IF
+      ELSE IF( NOTA )THEN
+         IF( CONJB )THEN
+*
+*           Form  C := alpha*A*conjg( B' ) + beta*C.
+*
+            DO 200, J = 1, N
+               IF( BETA.EQ.ZERO )THEN
+                  DO 160, I = 1, M
+                     C( I, J ) = ZERO
+  160             CONTINUE
+               ELSE IF( BETA.NE.ONE )THEN
+                  DO 170, I = 1, M
+                     C( I, J ) = BETA*C( I, J )
+  170             CONTINUE
+               END IF
+               DO 190, L = 1, K
+                  IF( B( J, L ).NE.ZERO )THEN
+                     TEMP = ALPHA*DCONJG( B( J, L ) )
+                     DO 180, I = 1, M
+                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
+  180                CONTINUE
+                  END IF
+  190          CONTINUE
+  200       CONTINUE
+         ELSE
+*
+*           Form  C := alpha*A*B'          + beta*C
+*
+            DO 250, J = 1, N
+               IF( BETA.EQ.ZERO )THEN
+                  DO 210, I = 1, M
+                     C( I, J ) = ZERO
+  210             CONTINUE
+               ELSE IF( BETA.NE.ONE )THEN
+                  DO 220, I = 1, M
+                     C( I, J ) = BETA*C( I, J )
+  220             CONTINUE
+               END IF
+               DO 240, L = 1, K
+                  IF( B( J, L ).NE.ZERO )THEN
+                     TEMP = ALPHA*B( J, L )
+                     DO 230, I = 1, M
+                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
+  230                CONTINUE
+                  END IF
+  240          CONTINUE
+  250       CONTINUE
+         END IF
+      ELSE IF( CONJA )THEN
+         IF( CONJB )THEN
+*
+*           Form  C := alpha*conjg( A' )*conjg( B' ) + beta*C.
+*
+            DO 280, J = 1, N
+               DO 270, I = 1, M
+                  TEMP = ZERO
+                  DO 260, L = 1, K
+                     TEMP = TEMP +
+     $                      DCONJG( A( L, I ) )*DCONJG( B( J, L ) )
+  260             CONTINUE
+                  IF( BETA.EQ.ZERO )THEN
+                     C( I, J ) = ALPHA*TEMP
+                  ELSE
+                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
+                  END IF
+  270          CONTINUE
+  280       CONTINUE
+         ELSE
+*
+*           Form  C := alpha*conjg( A' )*B' + beta*C
+*
+            DO 310, J = 1, N
+               DO 300, I = 1, M
+                  TEMP = ZERO
+                  DO 290, L = 1, K
+                     TEMP = TEMP + DCONJG( A( L, I ) )*B( J, L )
+  290             CONTINUE
+                  IF( BETA.EQ.ZERO )THEN
+                     C( I, J ) = ALPHA*TEMP
+                  ELSE
+                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
+                  END IF
+  300          CONTINUE
+  310       CONTINUE
+         END IF
+      ELSE
+         IF( CONJB )THEN
+*
+*           Form  C := alpha*A'*conjg( B' ) + beta*C
+*
+            DO 340, J = 1, N
+               DO 330, I = 1, M
+                  TEMP = ZERO
+                  DO 320, L = 1, K
+                     TEMP = TEMP + A( L, I )*DCONJG( B( J, L ) )
+  320             CONTINUE
+                  IF( BETA.EQ.ZERO )THEN
+                     C( I, J ) = ALPHA*TEMP
+                  ELSE
+                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
+                  END IF
+  330          CONTINUE
+  340       CONTINUE
+         ELSE
+*
+*           Form  C := alpha*A'*B' + beta*C
+*
+            DO 370, J = 1, N
+               DO 360, I = 1, M
+                  TEMP = ZERO
+                  DO 350, L = 1, K
+                     TEMP = TEMP + A( L, I )*B( J, L )
+  350             CONTINUE
+                  IF( BETA.EQ.ZERO )THEN
+                     C( I, J ) = ALPHA*TEMP
+                  ELSE
+                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
+                  END IF
+  360          CONTINUE
+  370       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZGEMM .
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/zgemv.f
@@ -0,0 +1,281 @@
+      SUBROUTINE ZGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
+     $                   BETA, Y, INCY )
+*     .. Scalar Arguments ..
+      COMPLEX*16         ALPHA, BETA
+      INTEGER            INCX, INCY, LDA, M, N
+      CHARACTER*1        TRANS
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEMV  performs one of the matrix-vector operations
+*
+*     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,   or
+*
+*     y := alpha*conjg( A' )*x + beta*y,
+*
+*  where alpha and beta are scalars, x and y are vectors and A is an
+*  m by n matrix.
+*
+*  Parameters
+*  ==========
+*
+*  TRANS  - CHARACTER*1.
+*           On entry, TRANS specifies the operation to be performed as
+*           follows:
+*
+*              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.
+*
+*              TRANS = 'T' or 't'   y := alpha*A'*x + beta*y.
+*
+*              TRANS = 'C' or 'c'   y := alpha*conjg( A' )*x + beta*y.
+*
+*           Unchanged on exit.
+*
+*  M      - INTEGER.
+*           On entry, M specifies the number of rows of the matrix A.
+*           M must be at least zero.
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the number of columns of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - COMPLEX*16      .
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  A      - COMPLEX*16       array of DIMENSION ( LDA, n ).
+*           Before entry, the leading m by n part of the array A must
+*           contain the matrix of coefficients.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, m ).
+*           Unchanged on exit.
+*
+*  X      - COMPLEX*16       array of DIMENSION at least
+*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
+*           and at least
+*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
+*           Before entry, the incremented array X must contain the
+*           vector x.
+*           Unchanged on exit.
+*
+*  INCX   - INTEGER.
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  BETA   - COMPLEX*16      .
+*           On entry, BETA specifies the scalar beta. When BETA is
+*           supplied as zero then Y need not be set on input.
+*           Unchanged on exit.
+*
+*  Y      - COMPLEX*16       array of DIMENSION at least
+*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
+*           and at least
+*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
+*           Before entry with BETA non-zero, the incremented array Y
+*           must contain the vector y. On exit, Y is overwritten by the
+*           updated vector y.
+*
+*  INCY   - INTEGER.
+*           On entry, INCY specifies the increment for the elements of
+*           Y. INCY must not be zero.
+*           Unchanged on exit.
+*
+*
+*  Level 2 Blas routine.
+*
+*  -- Written on 22-October-1986.
+*     Jack Dongarra, Argonne National Lab.
+*     Jeremy Du Croz, Nag Central Office.
+*     Sven Hammarling, Nag Central Office.
+*     Richard Hanson, Sandia National Labs.
+*
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER        ( ONE  = ( 1.0D+0, 0.0D+0 ) )
+      COMPLEX*16         ZERO
+      PARAMETER        ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     .. Local Scalars ..
+      COMPLEX*16         TEMP
+      INTEGER            I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
+      LOGICAL            NOCONJ
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF     ( .NOT.LSAME( TRANS, 'N' ).AND.
+     $         .NOT.LSAME( TRANS, 'T' ).AND.
+     $         .NOT.LSAME( TRANS, 'C' )      )THEN
+         INFO = 1
+      ELSE IF( M.LT.0 )THEN
+         INFO = 2
+      ELSE IF( N.LT.0 )THEN
+         INFO = 3
+      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
+         INFO = 6
+      ELSE IF( INCX.EQ.0 )THEN
+         INFO = 8
+      ELSE IF( INCY.EQ.0 )THEN
+         INFO = 11
+      END IF
+      IF( INFO.NE.0 )THEN
+         CALL XERBLA( 'ZGEMV ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
+     $    ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
+     $   RETURN
+*
+      NOCONJ = LSAME( TRANS, 'T' )
+*
+*     Set  LENX  and  LENY, the lengths of the vectors x and y, and set
+*     up the start points in  X  and  Y.
+*
+      IF( LSAME( TRANS, 'N' ) )THEN
+         LENX = N
+         LENY = M
+      ELSE
+         LENX = M
+         LENY = N
+      END IF
+      IF( INCX.GT.0 )THEN
+         KX = 1
+      ELSE
+         KX = 1 - ( LENX - 1 )*INCX
+      END IF
+      IF( INCY.GT.0 )THEN
+         KY = 1
+      ELSE
+         KY = 1 - ( LENY - 1 )*INCY
+      END IF
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through A.
+*
+*     First form  y := beta*y.
+*
+      IF( BETA.NE.ONE )THEN
+         IF( INCY.EQ.1 )THEN
+            IF( BETA.EQ.ZERO )THEN
+               DO 10, I = 1, LENY
+                  Y( I ) = ZERO
+   10          CONTINUE
+            ELSE
+               DO 20, I = 1, LENY
+                  Y( I ) = BETA*Y( I )
+   20          CONTINUE
+            END IF
+         ELSE
+            IY = KY
+            IF( BETA.EQ.ZERO )THEN
+               DO 30, I = 1, LENY
+                  Y( IY ) = ZERO
+                  IY      = IY   + INCY
+   30          CONTINUE
+            ELSE
+               DO 40, I = 1, LENY
+                  Y( IY ) = BETA*Y( IY )
+                  IY      = IY           + INCY
+   40          CONTINUE
+            END IF
+         END IF
+      END IF
+      IF( ALPHA.EQ.ZERO )
+     $   RETURN
+      IF( LSAME( TRANS, 'N' ) )THEN
+*
+*        Form  y := alpha*A*x + y.
+*
+         JX = KX
+         IF( INCY.EQ.1 )THEN
+            DO 60, J = 1, N
+               IF( X( JX ).NE.ZERO )THEN
+                  TEMP = ALPHA*X( JX )
+                  DO 50, I = 1, M
+                     Y( I ) = Y( I ) + TEMP*A( I, J )
+   50             CONTINUE
+               END IF
+               JX = JX + INCX
+   60       CONTINUE
+         ELSE
+            DO 80, J = 1, N
+               IF( X( JX ).NE.ZERO )THEN
+                  TEMP = ALPHA*X( JX )
+                  IY   = KY
+                  DO 70, I = 1, M
+                     Y( IY ) = Y( IY ) + TEMP*A( I, J )
+                     IY      = IY      + INCY
+   70             CONTINUE
+               END IF
+               JX = JX + INCX
+   80       CONTINUE
+         END IF
+      ELSE
+*
+*        Form  y := alpha*A'*x + y  or  y := alpha*conjg( A' )*x + y.
+*
+         JY = KY
+         IF( INCX.EQ.1 )THEN
+            DO 110, J = 1, N
+               TEMP = ZERO
+               IF( NOCONJ )THEN
+                  DO 90, I = 1, M
+                     TEMP = TEMP + A( I, J )*X( I )
+   90             CONTINUE
+               ELSE
+                  DO 100, I = 1, M
+                     TEMP = TEMP + DCONJG( A( I, J ) )*X( I )
+  100             CONTINUE
+               END IF
+               Y( JY ) = Y( JY ) + ALPHA*TEMP
+               JY      = JY      + INCY
+  110       CONTINUE
+         ELSE
+            DO 140, J = 1, N
+               TEMP = ZERO
+               IX   = KX
+               IF( NOCONJ )THEN
+                  DO 120, I = 1, M
+                     TEMP = TEMP + A( I, J )*X( IX )
+                     IX   = IX   + INCX
+  120             CONTINUE
+               ELSE
+                  DO 130, I = 1, M
+                     TEMP = TEMP + DCONJG( A( I, J ) )*X( IX )
+                     IX   = IX   + INCX
+  130             CONTINUE
+               END IF
+               Y( JY ) = Y( JY ) + ALPHA*TEMP
+               JY      = JY      + INCY
+  140       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZGEMV .
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/zgerc.f
@@ -0,0 +1,157 @@
+      SUBROUTINE ZGERC ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
+*     .. Scalar Arguments ..
+      COMPLEX*16         ALPHA
+      INTEGER            INCX, INCY, LDA, M, N
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGERC  performs the rank 1 operation
+*
+*     A := alpha*x*conjg( y' ) + A,
+*
+*  where alpha is a scalar, x is an m element vector, y is an n element
+*  vector and A is an m by n matrix.
+*
+*  Parameters
+*  ==========
+*
+*  M      - INTEGER.
+*           On entry, M specifies the number of rows of the matrix A.
+*           M must be at least zero.
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the number of columns of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - COMPLEX*16      .
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  X      - COMPLEX*16       array of dimension at least
+*           ( 1 + ( m - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the m
+*           element vector x.
+*           Unchanged on exit.
+*
+*  INCX   - INTEGER.
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  Y      - COMPLEX*16       array of dimension at least
+*           ( 1 + ( n - 1 )*abs( INCY ) ).
+*           Before entry, the incremented array Y must contain the n
+*           element vector y.
+*           Unchanged on exit.
+*
+*  INCY   - INTEGER.
+*           On entry, INCY specifies the increment for the elements of
+*           Y. INCY must not be zero.
+*           Unchanged on exit.
+*
+*  A      - COMPLEX*16       array of DIMENSION ( LDA, n ).
+*           Before entry, the leading m by n part of the array A must
+*           contain the matrix of coefficients. On exit, A is
+*           overwritten by the updated matrix.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, m ).
+*           Unchanged on exit.
+*
+*
+*  Level 2 Blas routine.
+*
+*  -- Written on 22-October-1986.
+*     Jack Dongarra, Argonne National Lab.
+*     Jeremy Du Croz, Nag Central Office.
+*     Sven Hammarling, Nag Central Office.
+*     Richard Hanson, Sandia National Labs.
+*
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO
+      PARAMETER        ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     .. Local Scalars ..
+      COMPLEX*16         TEMP
+      INTEGER            I, INFO, IX, J, JY, KX
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF     ( M.LT.0 )THEN
+         INFO = 1
+      ELSE IF( N.LT.0 )THEN
+         INFO = 2
+      ELSE IF( INCX.EQ.0 )THEN
+         INFO = 5
+      ELSE IF( INCY.EQ.0 )THEN
+         INFO = 7
+      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
+         INFO = 9
+      END IF
+      IF( INFO.NE.0 )THEN
+         CALL XERBLA( 'ZGERC ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
+     $   RETURN
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through A.
+*
+      IF( INCY.GT.0 )THEN
+         JY = 1
+      ELSE
+         JY = 1 - ( N - 1 )*INCY
+      END IF
+      IF( INCX.EQ.1 )THEN
+         DO 20, J = 1, N
+            IF( Y( JY ).NE.ZERO )THEN
+               TEMP = ALPHA*DCONJG( Y( JY ) )
+               DO 10, I = 1, M
+                  A( I, J ) = A( I, J ) + X( I )*TEMP
+   10          CONTINUE
+            END IF
+            JY = JY + INCY
+   20    CONTINUE
+      ELSE
+         IF( INCX.GT.0 )THEN
+            KX = 1
+         ELSE
+            KX = 1 - ( M - 1 )*INCX
+         END IF
+         DO 40, J = 1, N
+            IF( Y( JY ).NE.ZERO )THEN
+               TEMP = ALPHA*DCONJG( Y( JY ) )
+               IX   = KX
+               DO 30, I = 1, M
+                  A( I, J ) = A( I, J ) + X( IX )*TEMP
+                  IX        = IX        + INCX
+   30          CONTINUE
+            END IF
+            JY = JY + INCY
+   40    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZGERC .
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/zgeru.f
@@ -0,0 +1,157 @@
+      SUBROUTINE ZGERU ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
+*     .. Scalar Arguments ..
+      COMPLEX*16         ALPHA
+      INTEGER            INCX, INCY, LDA, M, N
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), X( * ), Y( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGERU  performs the rank 1 operation
+*
+*     A := alpha*x*y' + A,
+*
+*  where alpha is a scalar, x is an m element vector, y is an n element
+*  vector and A is an m by n matrix.
+*
+*  Parameters
+*  ==========
+*
+*  M      - INTEGER.
+*           On entry, M specifies the number of rows of the matrix A.
+*           M must be at least zero.
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the number of columns of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - COMPLEX*16      .
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  X      - COMPLEX*16       array of dimension at least
+*           ( 1 + ( m - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the m
+*           element vector x.
+*           Unchanged on exit.
+*
+*  INCX   - INTEGER.
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  Y      - COMPLEX*16       array of dimension at least
+*           ( 1 + ( n - 1 )*abs( INCY ) ).
+*           Before entry, the incremented array Y must contain the n
+*           element vector y.
+*           Unchanged on exit.
+*
+*  INCY   - INTEGER.
+*           On entry, INCY specifies the increment for the elements of
+*           Y. INCY must not be zero.
+*           Unchanged on exit.
+*
+*  A      - COMPLEX*16       array of DIMENSION ( LDA, n ).
+*           Before entry, the leading m by n part of the array A must
+*           contain the matrix of coefficients. On exit, A is
+*           overwritten by the updated matrix.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, m ).
+*           Unchanged on exit.
+*
+*
+*  Level 2 Blas routine.
+*
+*  -- Written on 22-October-1986.
+*     Jack Dongarra, Argonne National Lab.
+*     Jeremy Du Croz, Nag Central Office.
+*     Sven Hammarling, Nag Central Office.
+*     Richard Hanson, Sandia National Labs.
+*
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO
+      PARAMETER        ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     .. Local Scalars ..
+      COMPLEX*16         TEMP
+      INTEGER            I, INFO, IX, J, JY, KX
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF     ( M.LT.0 )THEN
+         INFO = 1
+      ELSE IF( N.LT.0 )THEN
+         INFO = 2
+      ELSE IF( INCX.EQ.0 )THEN
+         INFO = 5
+      ELSE IF( INCY.EQ.0 )THEN
+         INFO = 7
+      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
+         INFO = 9
+      END IF
+      IF( INFO.NE.0 )THEN
+         CALL XERBLA( 'ZGERU ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
+     $   RETURN
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through A.
+*
+      IF( INCY.GT.0 )THEN
+         JY = 1
+      ELSE
+         JY = 1 - ( N - 1 )*INCY
+      END IF
+      IF( INCX.EQ.1 )THEN
+         DO 20, J = 1, N
+            IF( Y( JY ).NE.ZERO )THEN
+               TEMP = ALPHA*Y( JY )
+               DO 10, I = 1, M
+                  A( I, J ) = A( I, J ) + X( I )*TEMP
+   10          CONTINUE
+            END IF
+            JY = JY + INCY
+   20    CONTINUE
+      ELSE
+         IF( INCX.GT.0 )THEN
+            KX = 1
+         ELSE
+            KX = 1 - ( M - 1 )*INCX
+         END IF
+         DO 40, J = 1, N
+            IF( Y( JY ).NE.ZERO )THEN
+               TEMP = ALPHA*Y( JY )
+               IX   = KX
+               DO 30, I = 1, M
+                  A( I, J ) = A( I, J ) + X( IX )*TEMP
+                  IX        = IX        + INCX
+   30          CONTINUE
+            END IF
+            JY = JY + INCY
+   40    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZGERU .
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/zherk.f
@@ -0,0 +1,321 @@
+      SUBROUTINE ZHERK ( UPLO, TRANS, N, K, ALPHA, A, LDA,
+     $                   BETA, C, LDC )
+*     .. Scalar Arguments ..
+      CHARACTER*1        UPLO, TRANS
+      INTEGER            N, K, LDA, LDC
+      DOUBLE PRECISION   ALPHA, BETA
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), C( LDC, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHERK  performs one of the hermitian rank k operations
+*
+*     C := alpha*A*conjg( A' ) + beta*C,
+*
+*  or
+*
+*     C := alpha*conjg( A' )*A + beta*C,
+*
+*  where  alpha and beta  are  real scalars,  C is an  n by n  hermitian
+*  matrix and  A  is an  n by k  matrix in the  first case and a  k by n
+*  matrix in the second case.
+*
+*  Parameters
+*  ==========
+*
+*  UPLO   - CHARACTER*1.
+*           On  entry,   UPLO  specifies  whether  the  upper  or  lower
+*           triangular  part  of the  array  C  is to be  referenced  as
+*           follows:
+*
+*              UPLO = 'U' or 'u'   Only the  upper triangular part of  C
+*                                  is to be referenced.
+*
+*              UPLO = 'L' or 'l'   Only the  lower triangular part of  C
+*                                  is to be referenced.
+*
+*           Unchanged on exit.
+*
+*  TRANS  - CHARACTER*1.
+*           On entry,  TRANS  specifies the operation to be performed as
+*           follows:
+*
+*              TRANS = 'N' or 'n'   C := alpha*A*conjg( A' ) + beta*C.
+*
+*              TRANS = 'C' or 'c'   C := alpha*conjg( A' )*A + beta*C.
+*
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry,  N specifies the order of the matrix C.  N must be
+*           at least zero.
+*           Unchanged on exit.
+*
+*  K      - INTEGER.
+*           On entry with  TRANS = 'N' or 'n',  K  specifies  the number
+*           of  columns   of  the   matrix   A,   and  on   entry   with
+*           TRANS = 'C' or 'c',  K  specifies  the number of rows of the
+*           matrix A.  K must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - DOUBLE PRECISION.
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  A      - COMPLEX*16       array of DIMENSION ( LDA, ka ), where ka is
+*           k  when  TRANS = 'N' or 'n',  and is  n  otherwise.
+*           Before entry with  TRANS = 'N' or 'n',  the  leading  n by k
+*           part of the array  A  must contain the matrix  A,  otherwise
+*           the leading  k by n  part of the array  A  must contain  the
+*           matrix A.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
+*           then  LDA must be at least  max( 1, n ), otherwise  LDA must
+*           be at least  max( 1, k ).
+*           Unchanged on exit.
+*
+*  BETA   - DOUBLE PRECISION.
+*           On entry, BETA specifies the scalar beta.
+*           Unchanged on exit.
+*
+*  C      - COMPLEX*16       array of DIMENSION ( LDC, n ).
+*           Before entry  with  UPLO = 'U' or 'u',  the leading  n by n
+*           upper triangular part of the array C must contain the upper
+*           triangular part  of the  hermitian matrix  and the strictly
+*           lower triangular part of C is not referenced.  On exit, the
+*           upper triangular part of the array  C is overwritten by the
+*           upper triangular part of the updated matrix.
+*           Before entry  with  UPLO = 'L' or 'l',  the leading  n by n
+*           lower triangular part of the array C must contain the lower
+*           triangular part  of the  hermitian matrix  and the strictly
+*           upper triangular part of C is not referenced.  On exit, the
+*           lower triangular part of the array  C is overwritten by the
+*           lower triangular part of the updated matrix.
+*           Note that the imaginary parts of the diagonal elements need
+*           not be set,  they are assumed to be zero,  and on exit they
+*           are set to zero.
+*
+*  LDC    - INTEGER.
+*           On entry, LDC specifies the first dimension of C as declared
+*           in  the  calling  (sub)  program.   LDC  must  be  at  least
+*           max( 1, n ).
+*           Unchanged on exit.
+*
+*
+*  Level 3 Blas routine.
+*
+*  -- Written on 8-February-1989.
+*     Jack Dongarra, Argonne National Laboratory.
+*     Iain Duff, AERE Harwell.
+*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
+*     Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCMPLX, DCONJG, MAX, DBLE
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, INFO, J, L, NROWA
+      DOUBLE PRECISION   RTEMP
+      COMPLEX*16         TEMP
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE ,         ZERO
+      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      IF( LSAME( TRANS, 'N' ) )THEN
+         NROWA = N
+      ELSE
+         NROWA = K
+      END IF
+      UPPER = LSAME( UPLO, 'U' )
+*
+      INFO = 0
+      IF(      ( .NOT.UPPER               ).AND.
+     $         ( .NOT.LSAME( UPLO , 'L' ) )      )THEN
+         INFO = 1
+      ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND.
+     $         ( .NOT.LSAME( TRANS, 'C' ) )      )THEN
+         INFO = 2
+      ELSE IF( N  .LT.0               )THEN
+         INFO = 3
+      ELSE IF( K  .LT.0               )THEN
+         INFO = 4
+      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
+         INFO = 7
+      ELSE IF( LDC.LT.MAX( 1, N     ) )THEN
+         INFO = 10
+      END IF
+      IF( INFO.NE.0 )THEN
+         CALL XERBLA( 'ZHERK ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( ( N.EQ.0 ).OR.
+     $    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) )
+     $   RETURN
+*
+*     And when  alpha.eq.zero.
+*
+      IF( ALPHA.EQ.ZERO )THEN
+         IF( UPPER )THEN
+            IF( BETA.EQ.ZERO )THEN
+               DO 20, J = 1, N
+                  DO 10, I = 1, J
+                     C( I, J ) = ZERO
+   10             CONTINUE
+   20          CONTINUE
+            ELSE
+               DO 40, J = 1, N
+                  DO 30, I = 1, J - 1
+                     C( I, J ) = BETA*C( I, J )
+   30             CONTINUE
+                  C( J, J ) = BETA*DBLE( C( J, J ) )
+   40          CONTINUE
+            END IF
+         ELSE
+            IF( BETA.EQ.ZERO )THEN
+               DO 60, J = 1, N
+                  DO 50, I = J, N
+                     C( I, J ) = ZERO
+   50             CONTINUE
+   60          CONTINUE
+            ELSE
+               DO 80, J = 1, N
+                  C( J, J ) = BETA*DBLE( C( J, J ) )
+                  DO 70, I = J + 1, N
+                     C( I, J ) = BETA*C( I, J )
+   70             CONTINUE
+   80          CONTINUE
+            END IF
+         END IF
+         RETURN
+      END IF
+*
+*     Start the operations.
+*
+      IF( LSAME( TRANS, 'N' ) )THEN
+*
+*        Form  C := alpha*A*conjg( A' ) + beta*C.
+*
+         IF( UPPER )THEN
+            DO 130, J = 1, N
+               IF( BETA.EQ.ZERO )THEN
+                  DO 90, I = 1, J
+                     C( I, J ) = ZERO
+   90             CONTINUE
+               ELSE IF( BETA.NE.ONE )THEN
+                  DO 100, I = 1, J - 1
+                     C( I, J ) = BETA*C( I, J )
+  100             CONTINUE
+                  C( J, J ) = BETA*DBLE( C( J, J ) )
+               END IF
+               DO 120, L = 1, K
+                  IF( A( J, L ).NE.DCMPLX( ZERO ) )THEN
+                     TEMP = ALPHA*DCONJG( A( J, L ) )
+                     DO 110, I = 1, J - 1
+                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
+  110                CONTINUE
+                     C( J, J ) = DBLE( C( J, J )      ) +
+     $                           DBLE( TEMP*A( I, L ) )
+                  END IF
+  120          CONTINUE
+  130       CONTINUE
+         ELSE
+            DO 180, J = 1, N
+               IF( BETA.EQ.ZERO )THEN
+                  DO 140, I = J, N
+                     C( I, J ) = ZERO
+  140             CONTINUE
+               ELSE IF( BETA.NE.ONE )THEN
+                  C( J, J ) = BETA*DBLE( C( J, J ) )
+                  DO 150, I = J + 1, N
+                     C( I, J ) = BETA*C( I, J )
+  150             CONTINUE
+               END IF
+               DO 170, L = 1, K
+                  IF( A( J, L ).NE.DCMPLX( ZERO ) )THEN
+                     TEMP      = ALPHA*DCONJG( A( J, L ) )
+                     C( J, J ) = DBLE( C( J, J )      )    +
+     $                           DBLE( TEMP*A( J, L ) )
+                     DO 160, I = J + 1, N
+                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
+  160                CONTINUE
+                  END IF
+  170          CONTINUE
+  180       CONTINUE
+         END IF
+      ELSE
+*
+*        Form  C := alpha*conjg( A' )*A + beta*C.
+*
+         IF( UPPER )THEN
+            DO 220, J = 1, N
+               DO 200, I = 1, J - 1
+                  TEMP = ZERO
+                  DO 190, L = 1, K
+                     TEMP = TEMP + DCONJG( A( L, I ) )*A( L, J )
+  190             CONTINUE
+                  IF( BETA.EQ.ZERO )THEN
+                     C( I, J ) = ALPHA*TEMP
+                  ELSE
+                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
+                  END IF
+  200          CONTINUE
+               RTEMP = ZERO
+               DO 210, L = 1, K
+                  RTEMP = RTEMP + DCONJG( A( L, J ) )*A( L, J )
+  210          CONTINUE
+               IF( BETA.EQ.ZERO )THEN
+                  C( J, J ) = ALPHA*RTEMP
+               ELSE
+                  C( J, J ) = ALPHA*RTEMP + BETA*DBLE( C( J, J ) )
+               END IF
+  220       CONTINUE
+         ELSE
+            DO 260, J = 1, N
+               RTEMP = ZERO
+               DO 230, L = 1, K
+                  RTEMP = RTEMP + DCONJG( A( L, J ) )*A( L, J )
+  230          CONTINUE
+               IF( BETA.EQ.ZERO )THEN
+                  C( J, J ) = ALPHA*RTEMP
+               ELSE
+                  C( J, J ) = ALPHA*RTEMP + BETA*DBLE( C( J, J ) )
+               END IF
+               DO 250, I = J + 1, N
+                  TEMP = ZERO
+                  DO 240, L = 1, K
+                     TEMP = TEMP + DCONJG( A( L, I ) )*A( L, J )
+  240             CONTINUE
+                  IF( BETA.EQ.ZERO )THEN
+                     C( I, J ) = ALPHA*TEMP
+                  ELSE
+                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
+                  END IF
+  250          CONTINUE
+  260       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZHERK .
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/zscal.f
@@ -0,0 +1,29 @@
+      subroutine  zscal(n,za,zx,incx)
+c
+c     scales a vector by a constant.
+c     jack dongarra, 3/11/78.
+c     modified to correct problem with negative increment, 8/21/90.
+c
+      double complex za,zx(1)
+      integer i,incx,ix,n
+c
+      if(n.le.0)return
+      if(incx.eq.1)go to 20
+c
+c        code for increment not equal to 1
+c
+      ix = 1
+      if(incx.lt.0)ix = (-n+1)*incx + 1
+      do 10 i = 1,n
+        zx(ix) = za*zx(ix)
+        ix = ix + incx
+   10 continue
+      return
+c
+c        code for increment equal to 1
+c
+   20 do 30 i = 1,n
+        zx(i) = za*zx(i)
+   30 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/zswap.f
@@ -0,0 +1,35 @@
+      subroutine  zswap (n,zx,incx,zy,incy)
+c
+c     interchanges two vectors.
+c     jack dongarra, 3/11/78.
+c
+      double complex zx(1),zy(1),ztemp
+      integer i,incx,incy,ix,iy,n
+c
+      if(n.le.0)return
+      if(incx.eq.1.and.incy.eq.1)go to 20
+c
+c       code for unequal increments or equal increments not equal
+c         to 1
+c
+      ix = 1
+      iy = 1
+      if(incx.lt.0)ix = (-n+1)*incx + 1
+      if(incy.lt.0)iy = (-n+1)*incy + 1
+      do 10 i = 1,n
+        ztemp = zx(ix)
+        zx(ix) = zy(iy)
+        zy(iy) = ztemp
+        ix = ix + incx
+        iy = iy + incy
+   10 continue
+      return
+c
+c       code for both increments equal to 1
+   20 do 30 i = 1,n
+        ztemp = zx(i)
+        zx(i) = zy(i)
+        zy(i) = ztemp
+   30 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/ztrmm.f
@@ -0,0 +1,392 @@
+      SUBROUTINE ZTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
+     $                   B, LDB )
+*     .. Scalar Arguments ..
+      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
+      INTEGER            M, N, LDA, LDB
+      COMPLEX*16         ALPHA
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTRMM  performs one of the matrix-matrix operations
+*
+*     B := alpha*op( A )*B,   or   B := alpha*B*op( A )
+*
+*  where  alpha  is a scalar,  B  is an m by n matrix,  A  is a unit, or
+*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
+*
+*     op( A ) = A   or   op( A ) = A'   or   op( A ) = conjg( A' ).
+*
+*  Parameters
+*  ==========
+*
+*  SIDE   - CHARACTER*1.
+*           On entry,  SIDE specifies whether  op( A ) multiplies B from
+*           the left or right as follows:
+*
+*              SIDE = 'L' or 'l'   B := alpha*op( A )*B.
+*
+*              SIDE = 'R' or 'r'   B := alpha*B*op( A ).
+*
+*           Unchanged on exit.
+*
+*  UPLO   - CHARACTER*1.
+*           On entry, UPLO specifies whether the matrix A is an upper or
+*           lower triangular matrix as follows:
+*
+*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
+*
+*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
+*
+*           Unchanged on exit.
+*
+*  TRANSA - CHARACTER*1.
+*           On entry, TRANSA specifies the form of op( A ) to be used in
+*           the matrix multiplication as follows:
+*
+*              TRANSA = 'N' or 'n'   op( A ) = A.
+*
+*              TRANSA = 'T' or 't'   op( A ) = A'.
+*
+*              TRANSA = 'C' or 'c'   op( A ) = conjg( A' ).
+*
+*           Unchanged on exit.
+*
+*  DIAG   - CHARACTER*1.
+*           On entry, DIAG specifies whether or not A is unit triangular
+*           as follows:
+*
+*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
+*
+*              DIAG = 'N' or 'n'   A is not assumed to be unit
+*                                  triangular.
+*
+*           Unchanged on exit.
+*
+*  M      - INTEGER.
+*           On entry, M specifies the number of rows of B. M must be at
+*           least zero.
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the number of columns of B.  N must be
+*           at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - COMPLEX*16      .
+*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
+*           zero then  A is not referenced and  B need not be set before
+*           entry.
+*           Unchanged on exit.
+*
+*  A      - COMPLEX*16       array of DIMENSION ( LDA, k ), where k is m
+*           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
+*           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
+*           upper triangular part of the array  A must contain the upper
+*           triangular matrix  and the strictly lower triangular part of
+*           A is not referenced.
+*           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
+*           lower triangular part of the array  A must contain the lower
+*           triangular matrix  and the strictly upper triangular part of
+*           A is not referenced.
+*           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
+*           A  are not referenced either,  but are assumed to be  unity.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
+*           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
+*           then LDA must be at least max( 1, n ).
+*           Unchanged on exit.
+*
+*  B      - COMPLEX*16       array of DIMENSION ( LDB, n ).
+*           Before entry,  the leading  m by n part of the array  B must
+*           contain the matrix  B,  and  on exit  is overwritten  by the
+*           transformed matrix.
+*
+*  LDB    - INTEGER.
+*           On entry, LDB specifies the first dimension of B as declared
+*           in  the  calling  (sub)  program.   LDB  must  be  at  least
+*           max( 1, m ).
+*           Unchanged on exit.
+*
+*
+*  Level 3 Blas routine.
+*
+*  -- Written on 8-February-1989.
+*     Jack Dongarra, Argonne National Laboratory.
+*     Iain Duff, AERE Harwell.
+*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
+*     Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG, MAX
+*     .. Local Scalars ..
+      LOGICAL            LSIDE, NOCONJ, NOUNIT, UPPER
+      INTEGER            I, INFO, J, K, NROWA
+      COMPLEX*16         TEMP
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER        ( ONE  = ( 1.0D+0, 0.0D+0 ) )
+      COMPLEX*16         ZERO
+      PARAMETER        ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      LSIDE  = LSAME( SIDE  , 'L' )
+      IF( LSIDE )THEN
+         NROWA = M
+      ELSE
+         NROWA = N
+      END IF
+      NOCONJ = LSAME( TRANSA, 'T' )
+      NOUNIT = LSAME( DIAG  , 'N' )
+      UPPER  = LSAME( UPLO  , 'U' )
+*
+      INFO   = 0
+      IF(      ( .NOT.LSIDE                ).AND.
+     $         ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
+         INFO = 1
+      ELSE IF( ( .NOT.UPPER                ).AND.
+     $         ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
+         INFO = 2
+      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.
+     $         ( .NOT.LSAME( TRANSA, 'T' ) ).AND.
+     $         ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
+         INFO = 3
+      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND.
+     $         ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
+         INFO = 4
+      ELSE IF( M  .LT.0               )THEN
+         INFO = 5
+      ELSE IF( N  .LT.0               )THEN
+         INFO = 6
+      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
+         INFO = 9
+      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
+         INFO = 11
+      END IF
+      IF( INFO.NE.0 )THEN
+         CALL XERBLA( 'ZTRMM ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     And when  alpha.eq.zero.
+*
+      IF( ALPHA.EQ.ZERO )THEN
+         DO 20, J = 1, N
+            DO 10, I = 1, M
+               B( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+         RETURN
+      END IF
+*
+*     Start the operations.
+*
+      IF( LSIDE )THEN
+         IF( LSAME( TRANSA, 'N' ) )THEN
+*
+*           Form  B := alpha*A*B.
+*
+            IF( UPPER )THEN
+               DO 50, J = 1, N
+                  DO 40, K = 1, M
+                     IF( B( K, J ).NE.ZERO )THEN
+                        TEMP = ALPHA*B( K, J )
+                        DO 30, I = 1, K - 1
+                           B( I, J ) = B( I, J ) + TEMP*A( I, K )
+   30                   CONTINUE
+                        IF( NOUNIT )
+     $                     TEMP = TEMP*A( K, K )
+                        B( K, J ) = TEMP
+                     END IF
+   40             CONTINUE
+   50          CONTINUE
+            ELSE
+               DO 80, J = 1, N
+                  DO 70 K = M, 1, -1
+                     IF( B( K, J ).NE.ZERO )THEN
+                        TEMP      = ALPHA*B( K, J )
+                        B( K, J ) = TEMP
+                        IF( NOUNIT )
+     $                     B( K, J ) = B( K, J )*A( K, K )
+                        DO 60, I = K + 1, M
+                           B( I, J ) = B( I, J ) + TEMP*A( I, K )
+   60                   CONTINUE
+                     END IF
+   70             CONTINUE
+   80          CONTINUE
+            END IF
+         ELSE
+*
+*           Form  B := alpha*B*A'   or   B := alpha*B*conjg( A' ).
+*
+            IF( UPPER )THEN
+               DO 120, J = 1, N
+                  DO 110, I = M, 1, -1
+                     TEMP = B( I, J )
+                     IF( NOCONJ )THEN
+                        IF( NOUNIT )
+     $                     TEMP = TEMP*A( I, I )
+                        DO 90, K = 1, I - 1
+                           TEMP = TEMP + A( K, I )*B( K, J )
+   90                   CONTINUE
+                     ELSE
+                        IF( NOUNIT )
+     $                     TEMP = TEMP*DCONJG( A( I, I ) )
+                        DO 100, K = 1, I - 1
+                           TEMP = TEMP + DCONJG( A( K, I ) )*B( K, J )
+  100                   CONTINUE
+                     END IF
+                     B( I, J ) = ALPHA*TEMP
+  110             CONTINUE
+  120          CONTINUE
+            ELSE
+               DO 160, J = 1, N
+                  DO 150, I = 1, M
+                     TEMP = B( I, J )
+                     IF( NOCONJ )THEN
+                        IF( NOUNIT )
+     $                     TEMP = TEMP*A( I, I )
+                        DO 130, K = I + 1, M
+                           TEMP = TEMP + A( K, I )*B( K, J )
+  130                   CONTINUE
+                     ELSE
+                        IF( NOUNIT )
+     $                     TEMP = TEMP*DCONJG( A( I, I ) )
+                        DO 140, K = I + 1, M
+                           TEMP = TEMP + DCONJG( A( K, I ) )*B( K, J )
+  140                   CONTINUE
+                     END IF
+                     B( I, J ) = ALPHA*TEMP
+  150             CONTINUE
+  160          CONTINUE
+            END IF
+         END IF
+      ELSE
+         IF( LSAME( TRANSA, 'N' ) )THEN
+*
+*           Form  B := alpha*B*A.
+*
+            IF( UPPER )THEN
+               DO 200, J = N, 1, -1
+                  TEMP = ALPHA
+                  IF( NOUNIT )
+     $               TEMP = TEMP*A( J, J )
+                  DO 170, I = 1, M
+                     B( I, J ) = TEMP*B( I, J )
+  170             CONTINUE
+                  DO 190, K = 1, J - 1
+                     IF( A( K, J ).NE.ZERO )THEN
+                        TEMP = ALPHA*A( K, J )
+                        DO 180, I = 1, M
+                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
+  180                   CONTINUE
+                     END IF
+  190             CONTINUE
+  200          CONTINUE
+            ELSE
+               DO 240, J = 1, N
+                  TEMP = ALPHA
+                  IF( NOUNIT )
+     $               TEMP = TEMP*A( J, J )
+                  DO 210, I = 1, M
+                     B( I, J ) = TEMP*B( I, J )
+  210             CONTINUE
+                  DO 230, K = J + 1, N
+                     IF( A( K, J ).NE.ZERO )THEN
+                        TEMP = ALPHA*A( K, J )
+                        DO 220, I = 1, M
+                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
+  220                   CONTINUE
+                     END IF
+  230             CONTINUE
+  240          CONTINUE
+            END IF
+         ELSE
+*
+*           Form  B := alpha*B*A'   or   B := alpha*B*conjg( A' ).
+*
+            IF( UPPER )THEN
+               DO 280, K = 1, N
+                  DO 260, J = 1, K - 1
+                     IF( A( J, K ).NE.ZERO )THEN
+                        IF( NOCONJ )THEN
+                           TEMP = ALPHA*A( J, K )
+                        ELSE
+                           TEMP = ALPHA*DCONJG( A( J, K ) )
+                        END IF
+                        DO 250, I = 1, M
+                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
+  250                   CONTINUE
+                     END IF
+  260             CONTINUE
+                  TEMP = ALPHA
+                  IF( NOUNIT )THEN
+                     IF( NOCONJ )THEN
+                        TEMP = TEMP*A( K, K )
+                     ELSE
+                        TEMP = TEMP*DCONJG( A( K, K ) )
+                     END IF
+                  END IF
+                  IF( TEMP.NE.ONE )THEN
+                     DO 270, I = 1, M
+                        B( I, K ) = TEMP*B( I, K )
+  270                CONTINUE
+                  END IF
+  280          CONTINUE
+            ELSE
+               DO 320, K = N, 1, -1
+                  DO 300, J = K + 1, N
+                     IF( A( J, K ).NE.ZERO )THEN
+                        IF( NOCONJ )THEN
+                           TEMP = ALPHA*A( J, K )
+                        ELSE
+                           TEMP = ALPHA*DCONJG( A( J, K ) )
+                        END IF
+                        DO 290, I = 1, M
+                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
+  290                   CONTINUE
+                     END IF
+  300             CONTINUE
+                  TEMP = ALPHA
+                  IF( NOUNIT )THEN
+                     IF( NOCONJ )THEN
+                        TEMP = TEMP*A( K, K )
+                     ELSE
+                        TEMP = TEMP*DCONJG( A( K, K ) )
+                     END IF
+                  END IF
+                  IF( TEMP.NE.ONE )THEN
+                     DO 310, I = 1, M
+                        B( I, K ) = TEMP*B( I, K )
+  310                CONTINUE
+                  END IF
+  320          CONTINUE
+            END IF
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZTRMM .
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/ztrmv.f
@@ -0,0 +1,321 @@
+      SUBROUTINE ZTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
+*     .. Scalar Arguments ..
+      INTEGER            INCX, LDA, N
+      CHARACTER*1        DIAG, TRANS, UPLO
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTRMV  performs one of the matrix-vector operations
+*
+*     x := A*x,   or   x := A'*x,   or   x := conjg( A' )*x,
+*
+*  where x is an n element vector and  A is an n by n unit, or non-unit,
+*  upper or lower triangular matrix.
+*
+*  Parameters
+*  ==========
+*
+*  UPLO   - CHARACTER*1.
+*           On entry, UPLO specifies whether the matrix is an upper or
+*           lower triangular matrix as follows:
+*
+*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
+*
+*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
+*
+*           Unchanged on exit.
+*
+*  TRANS  - CHARACTER*1.
+*           On entry, TRANS specifies the operation to be performed as
+*           follows:
+*
+*              TRANS = 'N' or 'n'   x := A*x.
+*
+*              TRANS = 'T' or 't'   x := A'*x.
+*
+*              TRANS = 'C' or 'c'   x := conjg( A' )*x.
+*
+*           Unchanged on exit.
+*
+*  DIAG   - CHARACTER*1.
+*           On entry, DIAG specifies whether or not A is unit
+*           triangular as follows:
+*
+*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
+*
+*              DIAG = 'N' or 'n'   A is not assumed to be unit
+*                                  triangular.
+*
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the order of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  A      - COMPLEX*16       array of DIMENSION ( LDA, n ).
+*           Before entry with  UPLO = 'U' or 'u', the leading n by n
+*           upper triangular part of the array A must contain the upper
+*           triangular matrix and the strictly lower triangular part of
+*           A is not referenced.
+*           Before entry with UPLO = 'L' or 'l', the leading n by n
+*           lower triangular part of the array A must contain the lower
+*           triangular matrix and the strictly upper triangular part of
+*           A is not referenced.
+*           Note that when  DIAG = 'U' or 'u', the diagonal elements of
+*           A are not referenced either, but are assumed to be unity.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, n ).
+*           Unchanged on exit.
+*
+*  X      - COMPLEX*16       array of dimension at least
+*           ( 1 + ( n - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the n
+*           element vector x. On exit, X is overwritten with the
+*           tranformed vector x.
+*
+*  INCX   - INTEGER.
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*
+*  Level 2 Blas routine.
+*
+*  -- Written on 22-October-1986.
+*     Jack Dongarra, Argonne National Lab.
+*     Jeremy Du Croz, Nag Central Office.
+*     Sven Hammarling, Nag Central Office.
+*     Richard Hanson, Sandia National Labs.
+*
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO
+      PARAMETER        ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     .. Local Scalars ..
+      COMPLEX*16         TEMP
+      INTEGER            I, INFO, IX, J, JX, KX
+      LOGICAL            NOCONJ, NOUNIT
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF     ( .NOT.LSAME( UPLO , 'U' ).AND.
+     $         .NOT.LSAME( UPLO , 'L' )      )THEN
+         INFO = 1
+      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
+     $         .NOT.LSAME( TRANS, 'T' ).AND.
+     $         .NOT.LSAME( TRANS, 'C' )      )THEN
+         INFO = 2
+      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
+     $         .NOT.LSAME( DIAG , 'N' )      )THEN
+         INFO = 3
+      ELSE IF( N.LT.0 )THEN
+         INFO = 4
+      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
+         INFO = 6
+      ELSE IF( INCX.EQ.0 )THEN
+         INFO = 8
+      END IF
+      IF( INFO.NE.0 )THEN
+         CALL XERBLA( 'ZTRMV ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      NOCONJ = LSAME( TRANS, 'T' )
+      NOUNIT = LSAME( DIAG , 'N' )
+*
+*     Set up the start point in X if the increment is not unity. This
+*     will be  ( N - 1 )*INCX  too small for descending loops.
+*
+      IF( INCX.LE.0 )THEN
+         KX = 1 - ( N - 1 )*INCX
+      ELSE IF( INCX.NE.1 )THEN
+         KX = 1
+      END IF
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through A.
+*
+      IF( LSAME( TRANS, 'N' ) )THEN
+*
+*        Form  x := A*x.
+*
+         IF( LSAME( UPLO, 'U' ) )THEN
+            IF( INCX.EQ.1 )THEN
+               DO 20, J = 1, N
+                  IF( X( J ).NE.ZERO )THEN
+                     TEMP = X( J )
+                     DO 10, I = 1, J - 1
+                        X( I ) = X( I ) + TEMP*A( I, J )
+   10                CONTINUE
+                     IF( NOUNIT )
+     $                  X( J ) = X( J )*A( J, J )
+                  END IF
+   20          CONTINUE
+            ELSE
+               JX = KX
+               DO 40, J = 1, N
+                  IF( X( JX ).NE.ZERO )THEN
+                     TEMP = X( JX )
+                     IX   = KX
+                     DO 30, I = 1, J - 1
+                        X( IX ) = X( IX ) + TEMP*A( I, J )
+                        IX      = IX      + INCX
+   30                CONTINUE
+                     IF( NOUNIT )
+     $                  X( JX ) = X( JX )*A( J, J )
+                  END IF
+                  JX = JX + INCX
+   40          CONTINUE
+            END IF
+         ELSE
+            IF( INCX.EQ.1 )THEN
+               DO 60, J = N, 1, -1
+                  IF( X( J ).NE.ZERO )THEN
+                     TEMP = X( J )
+                     DO 50, I = N, J + 1, -1
+                        X( I ) = X( I ) + TEMP*A( I, J )
+   50                CONTINUE
+                     IF( NOUNIT )
+     $                  X( J ) = X( J )*A( J, J )
+                  END IF
+   60          CONTINUE
+            ELSE
+               KX = KX + ( N - 1 )*INCX
+               JX = KX
+               DO 80, J = N, 1, -1
+                  IF( X( JX ).NE.ZERO )THEN
+                     TEMP = X( JX )
+                     IX   = KX
+                     DO 70, I = N, J + 1, -1
+                        X( IX ) = X( IX ) + TEMP*A( I, J )
+                        IX      = IX      - INCX
+   70                CONTINUE
+                     IF( NOUNIT )
+     $                  X( JX ) = X( JX )*A( J, J )
+                  END IF
+                  JX = JX - INCX
+   80          CONTINUE
+            END IF
+         END IF
+      ELSE
+*
+*        Form  x := A'*x  or  x := conjg( A' )*x.
+*
+         IF( LSAME( UPLO, 'U' ) )THEN
+            IF( INCX.EQ.1 )THEN
+               DO 110, J = N, 1, -1
+                  TEMP = X( J )
+                  IF( NOCONJ )THEN
+                     IF( NOUNIT )
+     $                  TEMP = TEMP*A( J, J )
+                     DO 90, I = J - 1, 1, -1
+                        TEMP = TEMP + A( I, J )*X( I )
+   90                CONTINUE
+                  ELSE
+                     IF( NOUNIT )
+     $                  TEMP = TEMP*DCONJG( A( J, J ) )
+                     DO 100, I = J - 1, 1, -1
+                        TEMP = TEMP + DCONJG( A( I, J ) )*X( I )
+  100                CONTINUE
+                  END IF
+                  X( J ) = TEMP
+  110          CONTINUE
+            ELSE
+               JX = KX + ( N - 1 )*INCX
+               DO 140, J = N, 1, -1
+                  TEMP = X( JX )
+                  IX   = JX
+                  IF( NOCONJ )THEN
+                     IF( NOUNIT )
+     $                  TEMP = TEMP*A( J, J )
+                     DO 120, I = J - 1, 1, -1
+                        IX   = IX   - INCX
+                        TEMP = TEMP + A( I, J )*X( IX )
+  120                CONTINUE
+                  ELSE
+                     IF( NOUNIT )
+     $                  TEMP = TEMP*DCONJG( A( J, J ) )
+                     DO 130, I = J - 1, 1, -1
+                        IX   = IX   - INCX
+                        TEMP = TEMP + DCONJG( A( I, J ) )*X( IX )
+  130                CONTINUE
+                  END IF
+                  X( JX ) = TEMP
+                  JX      = JX   - INCX
+  140          CONTINUE
+            END IF
+         ELSE
+            IF( INCX.EQ.1 )THEN
+               DO 170, J = 1, N
+                  TEMP = X( J )
+                  IF( NOCONJ )THEN
+                     IF( NOUNIT )
+     $                  TEMP = TEMP*A( J, J )
+                     DO 150, I = J + 1, N
+                        TEMP = TEMP + A( I, J )*X( I )
+  150                CONTINUE
+                  ELSE
+                     IF( NOUNIT )
+     $                  TEMP = TEMP*DCONJG( A( J, J ) )
+                     DO 160, I = J + 1, N
+                        TEMP = TEMP + DCONJG( A( I, J ) )*X( I )
+  160                CONTINUE
+                  END IF
+                  X( J ) = TEMP
+  170          CONTINUE
+            ELSE
+               JX = KX
+               DO 200, J = 1, N
+                  TEMP = X( JX )
+                  IX   = JX
+                  IF( NOCONJ )THEN
+                     IF( NOUNIT )
+     $                  TEMP = TEMP*A( J, J )
+                     DO 180, I = J + 1, N
+                        IX   = IX   + INCX
+                        TEMP = TEMP + A( I, J )*X( IX )
+  180                CONTINUE
+                  ELSE
+                     IF( NOUNIT )
+     $                  TEMP = TEMP*DCONJG( A( J, J ) )
+                     DO 190, I = J + 1, N
+                        IX   = IX   + INCX
+                        TEMP = TEMP + DCONJG( A( I, J ) )*X( IX )
+  190                CONTINUE
+                  END IF
+                  X( JX ) = TEMP
+                  JX      = JX   + INCX
+  200          CONTINUE
+            END IF
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZTRMV .
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/ztrsm.f
@@ -0,0 +1,414 @@
+      SUBROUTINE ZTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
+     $                   B, LDB )
+*     .. Scalar Arguments ..
+      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
+      INTEGER            M, N, LDA, LDB
+      COMPLEX*16         ALPHA
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTRSM  solves one of the matrix equations
+*
+*     op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,
+*
+*  where alpha is a scalar, X and B are m by n matrices, A is a unit, or
+*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
+*
+*     op( A ) = A   or   op( A ) = A'   or   op( A ) = conjg( A' ).
+*
+*  The matrix X is overwritten on B.
+*
+*  Parameters
+*  ==========
+*
+*  SIDE   - CHARACTER*1.
+*           On entry, SIDE specifies whether op( A ) appears on the left
+*           or right of X as follows:
+*
+*              SIDE = 'L' or 'l'   op( A )*X = alpha*B.
+*
+*              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.
+*
+*           Unchanged on exit.
+*
+*  UPLO   - CHARACTER*1.
+*           On entry, UPLO specifies whether the matrix A is an upper or
+*           lower triangular matrix as follows:
+*
+*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
+*
+*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
+*
+*           Unchanged on exit.
+*
+*  TRANSA - CHARACTER*1.
+*           On entry, TRANSA specifies the form of op( A ) to be used in
+*           the matrix multiplication as follows:
+*
+*              TRANSA = 'N' or 'n'   op( A ) = A.
+*
+*              TRANSA = 'T' or 't'   op( A ) = A'.
+*
+*              TRANSA = 'C' or 'c'   op( A ) = conjg( A' ).
+*
+*           Unchanged on exit.
+*
+*  DIAG   - CHARACTER*1.
+*           On entry, DIAG specifies whether or not A is unit triangular
+*           as follows:
+*
+*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
+*
+*              DIAG = 'N' or 'n'   A is not assumed to be unit
+*                                  triangular.
+*
+*           Unchanged on exit.
+*
+*  M      - INTEGER.
+*           On entry, M specifies the number of rows of B. M must be at
+*           least zero.
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the number of columns of B.  N must be
+*           at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - COMPLEX*16      .
+*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
+*           zero then  A is not referenced and  B need not be set before
+*           entry.
+*           Unchanged on exit.
+*
+*  A      - COMPLEX*16       array of DIMENSION ( LDA, k ), where k is m
+*           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
+*           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
+*           upper triangular part of the array  A must contain the upper
+*           triangular matrix  and the strictly lower triangular part of
+*           A is not referenced.
+*           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
+*           lower triangular part of the array  A must contain the lower
+*           triangular matrix  and the strictly upper triangular part of
+*           A is not referenced.
+*           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
+*           A  are not referenced either,  but are assumed to be  unity.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
+*           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
+*           then LDA must be at least max( 1, n ).
+*           Unchanged on exit.
+*
+*  B      - COMPLEX*16       array of DIMENSION ( LDB, n ).
+*           Before entry,  the leading  m by n part of the array  B must
+*           contain  the  right-hand  side  matrix  B,  and  on exit  is
+*           overwritten by the solution matrix  X.
+*
+*  LDB    - INTEGER.
+*           On entry, LDB specifies the first dimension of B as declared
+*           in  the  calling  (sub)  program.   LDB  must  be  at  least
+*           max( 1, m ).
+*           Unchanged on exit.
+*
+*
+*  Level 3 Blas routine.
+*
+*  -- Written on 8-February-1989.
+*     Jack Dongarra, Argonne National Laboratory.
+*     Iain Duff, AERE Harwell.
+*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
+*     Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG, MAX
+*     .. Local Scalars ..
+      LOGICAL            LSIDE, NOCONJ, NOUNIT, UPPER
+      INTEGER            I, INFO, J, K, NROWA
+      COMPLEX*16         TEMP
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER        ( ONE  = ( 1.0D+0, 0.0D+0 ) )
+      COMPLEX*16         ZERO
+      PARAMETER        ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      LSIDE  = LSAME( SIDE  , 'L' )
+      IF( LSIDE )THEN
+         NROWA = M
+      ELSE
+         NROWA = N
+      END IF
+      NOCONJ = LSAME( TRANSA, 'T' )
+      NOUNIT = LSAME( DIAG  , 'N' )
+      UPPER  = LSAME( UPLO  , 'U' )
+*
+      INFO   = 0
+      IF(      ( .NOT.LSIDE                ).AND.
+     $         ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
+         INFO = 1
+      ELSE IF( ( .NOT.UPPER                ).AND.
+     $         ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
+         INFO = 2
+      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.
+     $         ( .NOT.LSAME( TRANSA, 'T' ) ).AND.
+     $         ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
+         INFO = 3
+      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND.
+     $         ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
+         INFO = 4
+      ELSE IF( M  .LT.0               )THEN
+         INFO = 5
+      ELSE IF( N  .LT.0               )THEN
+         INFO = 6
+      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
+         INFO = 9
+      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
+         INFO = 11
+      END IF
+      IF( INFO.NE.0 )THEN
+         CALL XERBLA( 'ZTRSM ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     And when  alpha.eq.zero.
+*
+      IF( ALPHA.EQ.ZERO )THEN
+         DO 20, J = 1, N
+            DO 10, I = 1, M
+               B( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+         RETURN
+      END IF
+*
+*     Start the operations.
+*
+      IF( LSIDE )THEN
+         IF( LSAME( TRANSA, 'N' ) )THEN
+*
+*           Form  B := alpha*inv( A )*B.
+*
+            IF( UPPER )THEN
+               DO 60, J = 1, N
+                  IF( ALPHA.NE.ONE )THEN
+                     DO 30, I = 1, M
+                        B( I, J ) = ALPHA*B( I, J )
+   30                CONTINUE
+                  END IF
+                  DO 50, K = M, 1, -1
+                     IF( B( K, J ).NE.ZERO )THEN
+                        IF( NOUNIT )
+     $                     B( K, J ) = B( K, J )/A( K, K )
+                        DO 40, I = 1, K - 1
+                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
+   40                   CONTINUE
+                     END IF
+   50             CONTINUE
+   60          CONTINUE
+            ELSE
+               DO 100, J = 1, N
+                  IF( ALPHA.NE.ONE )THEN
+                     DO 70, I = 1, M
+                        B( I, J ) = ALPHA*B( I, J )
+   70                CONTINUE
+                  END IF
+                  DO 90 K = 1, M
+                     IF( B( K, J ).NE.ZERO )THEN
+                        IF( NOUNIT )
+     $                     B( K, J ) = B( K, J )/A( K, K )
+                        DO 80, I = K + 1, M
+                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
+   80                   CONTINUE
+                     END IF
+   90             CONTINUE
+  100          CONTINUE
+            END IF
+         ELSE
+*
+*           Form  B := alpha*inv( A' )*B
+*           or    B := alpha*inv( conjg( A' ) )*B.
+*
+            IF( UPPER )THEN
+               DO 140, J = 1, N
+                  DO 130, I = 1, M
+                     TEMP = ALPHA*B( I, J )
+                     IF( NOCONJ )THEN
+                        DO 110, K = 1, I - 1
+                           TEMP = TEMP - A( K, I )*B( K, J )
+  110                   CONTINUE
+                        IF( NOUNIT )
+     $                     TEMP = TEMP/A( I, I )
+                     ELSE
+                        DO 120, K = 1, I - 1
+                           TEMP = TEMP - DCONJG( A( K, I ) )*B( K, J )
+  120                   CONTINUE
+                        IF( NOUNIT )
+     $                     TEMP = TEMP/DCONJG( A( I, I ) )
+                     END IF
+                     B( I, J ) = TEMP
+  130             CONTINUE
+  140          CONTINUE
+            ELSE
+               DO 180, J = 1, N
+                  DO 170, I = M, 1, -1
+                     TEMP = ALPHA*B( I, J )
+                     IF( NOCONJ )THEN
+                        DO 150, K = I + 1, M
+                           TEMP = TEMP - A( K, I )*B( K, J )
+  150                   CONTINUE
+                        IF( NOUNIT )
+     $                     TEMP = TEMP/A( I, I )
+                     ELSE
+                        DO 160, K = I + 1, M
+                           TEMP = TEMP - DCONJG( A( K, I ) )*B( K, J )
+  160                   CONTINUE
+                        IF( NOUNIT )
+     $                     TEMP = TEMP/DCONJG( A( I, I ) )
+                     END IF
+                     B( I, J ) = TEMP
+  170             CONTINUE
+  180          CONTINUE
+            END IF
+         END IF
+      ELSE
+         IF( LSAME( TRANSA, 'N' ) )THEN
+*
+*           Form  B := alpha*B*inv( A ).
+*
+            IF( UPPER )THEN
+               DO 230, J = 1, N
+                  IF( ALPHA.NE.ONE )THEN
+                     DO 190, I = 1, M
+                        B( I, J ) = ALPHA*B( I, J )
+  190                CONTINUE
+                  END IF
+                  DO 210, K = 1, J - 1
+                     IF( A( K, J ).NE.ZERO )THEN
+                        DO 200, I = 1, M
+                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
+  200                   CONTINUE
+                     END IF
+  210             CONTINUE
+                  IF( NOUNIT )THEN
+                     TEMP = ONE/A( J, J )
+                     DO 220, I = 1, M
+                        B( I, J ) = TEMP*B( I, J )
+  220                CONTINUE
+                  END IF
+  230          CONTINUE
+            ELSE
+               DO 280, J = N, 1, -1
+                  IF( ALPHA.NE.ONE )THEN
+                     DO 240, I = 1, M
+                        B( I, J ) = ALPHA*B( I, J )
+  240                CONTINUE
+                  END IF
+                  DO 260, K = J + 1, N
+                     IF( A( K, J ).NE.ZERO )THEN
+                        DO 250, I = 1, M
+                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
+  250                   CONTINUE
+                     END IF
+  260             CONTINUE
+                  IF( NOUNIT )THEN
+                     TEMP = ONE/A( J, J )
+                     DO 270, I = 1, M
+                       B( I, J ) = TEMP*B( I, J )
+  270                CONTINUE
+                  END IF
+  280          CONTINUE
+            END IF
+         ELSE
+*
+*           Form  B := alpha*B*inv( A' )
+*           or    B := alpha*B*inv( conjg( A' ) ).
+*
+            IF( UPPER )THEN
+               DO 330, K = N, 1, -1
+                  IF( NOUNIT )THEN
+                     IF( NOCONJ )THEN
+                        TEMP = ONE/A( K, K )
+                     ELSE
+                        TEMP = ONE/DCONJG( A( K, K ) )
+                     END IF
+                     DO 290, I = 1, M
+                        B( I, K ) = TEMP*B( I, K )
+  290                CONTINUE
+                  END IF
+                  DO 310, J = 1, K - 1
+                     IF( A( J, K ).NE.ZERO )THEN
+                        IF( NOCONJ )THEN
+                           TEMP = A( J, K )
+                        ELSE
+                           TEMP = DCONJG( A( J, K ) )
+                        END IF
+                        DO 300, I = 1, M
+                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
+  300                   CONTINUE
+                     END IF
+  310             CONTINUE
+                  IF( ALPHA.NE.ONE )THEN
+                     DO 320, I = 1, M
+                        B( I, K ) = ALPHA*B( I, K )
+  320                CONTINUE
+                  END IF
+  330          CONTINUE
+            ELSE
+               DO 380, K = 1, N
+                  IF( NOUNIT )THEN
+                     IF( NOCONJ )THEN
+                        TEMP = ONE/A( K, K )
+                     ELSE
+                        TEMP = ONE/DCONJG( A( K, K ) )
+                     END IF
+                     DO 340, I = 1, M
+                        B( I, K ) = TEMP*B( I, K )
+  340                CONTINUE
+                  END IF
+                  DO 360, J = K + 1, N
+                     IF( A( J, K ).NE.ZERO )THEN
+                        IF( NOCONJ )THEN
+                           TEMP = A( J, K )
+                        ELSE
+                           TEMP = DCONJG( A( J, K ) )
+                        END IF
+                        DO 350, I = 1, M
+                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
+  350                   CONTINUE
+                     END IF
+  360             CONTINUE
+                  IF( ALPHA.NE.ONE )THEN
+                     DO 370, I = 1, M
+                        B( I, K ) = ALPHA*B( I, K )
+  370                CONTINUE
+                  END IF
+  380          CONTINUE
+            END IF
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZTRSM .
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/blas/ztrsv.f
@@ -0,0 +1,324 @@
+      SUBROUTINE ZTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
+*     .. Scalar Arguments ..
+      INTEGER            INCX, LDA, N
+      CHARACTER*1        DIAG, TRANS, UPLO
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTRSV  solves one of the systems of equations
+*
+*     A*x = b,   or   A'*x = b,   or   conjg( A' )*x = b,
+*
+*  where b and x are n element vectors and A is an n by n unit, or
+*  non-unit, upper or lower triangular matrix.
+*
+*  No test for singularity or near-singularity is included in this
+*  routine. Such tests must be performed before calling this routine.
+*
+*  Parameters
+*  ==========
+*
+*  UPLO   - CHARACTER*1.
+*           On entry, UPLO specifies whether the matrix is an upper or
+*           lower triangular matrix as follows:
+*
+*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
+*
+*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
+*
+*           Unchanged on exit.
+*
+*  TRANS  - CHARACTER*1.
+*           On entry, TRANS specifies the equations to be solved as
+*           follows:
+*
+*              TRANS = 'N' or 'n'   A*x = b.
+*
+*              TRANS = 'T' or 't'   A'*x = b.
+*
+*              TRANS = 'C' or 'c'   conjg( A' )*x = b.
+*
+*           Unchanged on exit.
+*
+*  DIAG   - CHARACTER*1.
+*           On entry, DIAG specifies whether or not A is unit
+*           triangular as follows:
+*
+*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
+*
+*              DIAG = 'N' or 'n'   A is not assumed to be unit
+*                                  triangular.
+*
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the order of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  A      - COMPLEX*16       array of DIMENSION ( LDA, n ).
+*           Before entry with  UPLO = 'U' or 'u', the leading n by n
+*           upper triangular part of the array A must contain the upper
+*           triangular matrix and the strictly lower triangular part of
+*           A is not referenced.
+*           Before entry with UPLO = 'L' or 'l', the leading n by n
+*           lower triangular part of the array A must contain the lower
+*           triangular matrix and the strictly upper triangular part of
+*           A is not referenced.
+*           Note that when  DIAG = 'U' or 'u', the diagonal elements of
+*           A are not referenced either, but are assumed to be unity.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, n ).
+*           Unchanged on exit.
+*
+*  X      - COMPLEX*16       array of dimension at least
+*           ( 1 + ( n - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the n
+*           element right-hand side vector b. On exit, X is overwritten
+*           with the solution vector x.
+*
+*  INCX   - INTEGER.
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*
+*  Level 2 Blas routine.
+*
+*  -- Written on 22-October-1986.
+*     Jack Dongarra, Argonne National Lab.
+*     Jeremy Du Croz, Nag Central Office.
+*     Sven Hammarling, Nag Central Office.
+*     Richard Hanson, Sandia National Labs.
+*
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO
+      PARAMETER        ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     .. Local Scalars ..
+      COMPLEX*16         TEMP
+      INTEGER            I, INFO, IX, J, JX, KX
+      LOGICAL            NOCONJ, NOUNIT
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF     ( .NOT.LSAME( UPLO , 'U' ).AND.
+     $         .NOT.LSAME( UPLO , 'L' )      )THEN
+         INFO = 1
+      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
+     $         .NOT.LSAME( TRANS, 'T' ).AND.
+     $         .NOT.LSAME( TRANS, 'C' )      )THEN
+         INFO = 2
+      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
+     $         .NOT.LSAME( DIAG , 'N' )      )THEN
+         INFO = 3
+      ELSE IF( N.LT.0 )THEN
+         INFO = 4
+      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
+         INFO = 6
+      ELSE IF( INCX.EQ.0 )THEN
+         INFO = 8
+      END IF
+      IF( INFO.NE.0 )THEN
+         CALL XERBLA( 'ZTRSV ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      NOCONJ = LSAME( TRANS, 'T' )
+      NOUNIT = LSAME( DIAG , 'N' )
+*
+*     Set up the start point in X if the increment is not unity. This
+*     will be  ( N - 1 )*INCX  too small for descending loops.
+*
+      IF( INCX.LE.0 )THEN
+         KX = 1 - ( N - 1 )*INCX
+      ELSE IF( INCX.NE.1 )THEN
+         KX = 1
+      END IF
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through A.
+*
+      IF( LSAME( TRANS, 'N' ) )THEN
+*
+*        Form  x := inv( A )*x.
+*
+         IF( LSAME( UPLO, 'U' ) )THEN
+            IF( INCX.EQ.1 )THEN
+               DO 20, J = N, 1, -1
+                  IF( X( J ).NE.ZERO )THEN
+                     IF( NOUNIT )
+     $                  X( J ) = X( J )/A( J, J )
+                     TEMP = X( J )
+                     DO 10, I = J - 1, 1, -1
+                        X( I ) = X( I ) - TEMP*A( I, J )
+   10                CONTINUE
+                  END IF
+   20          CONTINUE
+            ELSE
+               JX = KX + ( N - 1 )*INCX
+               DO 40, J = N, 1, -1
+                  IF( X( JX ).NE.ZERO )THEN
+                     IF( NOUNIT )
+     $                  X( JX ) = X( JX )/A( J, J )
+                     TEMP = X( JX )
+                     IX   = JX
+                     DO 30, I = J - 1, 1, -1
+                        IX      = IX      - INCX
+                        X( IX ) = X( IX ) - TEMP*A( I, J )
+   30                CONTINUE
+                  END IF
+                  JX = JX - INCX
+   40          CONTINUE
+            END IF
+         ELSE
+            IF( INCX.EQ.1 )THEN
+               DO 60, J = 1, N
+                  IF( X( J ).NE.ZERO )THEN
+                     IF( NOUNIT )
+     $                  X( J ) = X( J )/A( J, J )
+                     TEMP = X( J )
+                     DO 50, I = J + 1, N
+                        X( I ) = X( I ) - TEMP*A( I, J )
+   50                CONTINUE
+                  END IF
+   60          CONTINUE
+            ELSE
+               JX = KX
+               DO 80, J = 1, N
+                  IF( X( JX ).NE.ZERO )THEN
+                     IF( NOUNIT )
+     $                  X( JX ) = X( JX )/A( J, J )
+                     TEMP = X( JX )
+                     IX   = JX
+                     DO 70, I = J + 1, N
+                        IX      = IX      + INCX
+                        X( IX ) = X( IX ) - TEMP*A( I, J )
+   70                CONTINUE
+                  END IF
+                  JX = JX + INCX
+   80          CONTINUE
+            END IF
+         END IF
+      ELSE
+*
+*        Form  x := inv( A' )*x  or  x := inv( conjg( A' ) )*x.
+*
+         IF( LSAME( UPLO, 'U' ) )THEN
+            IF( INCX.EQ.1 )THEN
+               DO 110, J = 1, N
+                  TEMP = X( J )
+                  IF( NOCONJ )THEN
+                     DO 90, I = 1, J - 1
+                        TEMP = TEMP - A( I, J )*X( I )
+   90                CONTINUE
+                     IF( NOUNIT )
+     $                  TEMP = TEMP/A( J, J )
+                  ELSE
+                     DO 100, I = 1, J - 1
+                        TEMP = TEMP - DCONJG( A( I, J ) )*X( I )
+  100                CONTINUE
+                     IF( NOUNIT )
+     $                  TEMP = TEMP/DCONJG( A( J, J ) )
+                  END IF
+                  X( J ) = TEMP
+  110          CONTINUE
+            ELSE
+               JX = KX
+               DO 140, J = 1, N
+                  IX   = KX
+                  TEMP = X( JX )
+                  IF( NOCONJ )THEN
+                     DO 120, I = 1, J - 1
+                        TEMP = TEMP - A( I, J )*X( IX )
+                        IX   = IX   + INCX
+  120                CONTINUE
+                     IF( NOUNIT )
+     $                  TEMP = TEMP/A( J, J )
+                  ELSE
+                     DO 130, I = 1, J - 1
+                        TEMP = TEMP - DCONJG( A( I, J ) )*X( IX )
+                        IX   = IX   + INCX
+  130                CONTINUE
+                     IF( NOUNIT )
+     $                  TEMP = TEMP/DCONJG( A( J, J ) )
+                  END IF
+                  X( JX ) = TEMP
+                  JX      = JX   + INCX
+  140          CONTINUE
+            END IF
+         ELSE
+            IF( INCX.EQ.1 )THEN
+               DO 170, J = N, 1, -1
+                  TEMP = X( J )
+                  IF( NOCONJ )THEN
+                     DO 150, I = N, J + 1, -1
+                        TEMP = TEMP - A( I, J )*X( I )
+  150                CONTINUE
+                     IF( NOUNIT )
+     $                  TEMP = TEMP/A( J, J )
+                  ELSE
+                     DO 160, I = N, J + 1, -1
+                        TEMP = TEMP - DCONJG( A( I, J ) )*X( I )
+  160                CONTINUE
+                     IF( NOUNIT )
+     $                  TEMP = TEMP/DCONJG( A( J, J ) )
+                  END IF
+                  X( J ) = TEMP
+  170          CONTINUE
+            ELSE
+               KX = KX + ( N - 1 )*INCX
+               JX = KX
+               DO 200, J = N, 1, -1
+                  IX   = KX
+                  TEMP = X( JX )
+                  IF( NOCONJ )THEN
+                     DO 180, I = N, J + 1, -1
+                        TEMP = TEMP - A( I, J )*X( IX )
+                        IX   = IX   - INCX
+  180                CONTINUE
+                     IF( NOUNIT )
+     $                  TEMP = TEMP/A( J, J )
+                  ELSE
+                     DO 190, I = N, J + 1, -1
+                        TEMP = TEMP - DCONJG( A( I, J ) )*X( IX )
+                        IX   = IX   - INCX
+  190                CONTINUE
+                     IF( NOUNIT )
+     $                  TEMP = TEMP/DCONJG( A( J, J ) )
+                  END IF
+                  X( JX ) = TEMP
+                  JX      = JX   - INCX
+  200          CONTINUE
+            END IF
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZTRSV .
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/dassl/ddaini.f
@@ -0,0 +1,257 @@
+      SUBROUTINE DDAINI (X, Y, YPRIME, NEQ, RES, JAC, H, WT, IDID, RPAR,
+     +   IPAR, PHI, DELTA, E, WM, IWM, HMIN, UROUND, NONNEG, NTEMP)
+C***BEGIN PROLOGUE  DDAINI
+C***SUBSIDIARY
+C***PURPOSE  Initialization routine for DDASSL.
+C***LIBRARY   SLATEC (DASSL)
+C***TYPE      DOUBLE PRECISION (SDAINI-S, DDAINI-D)
+C***AUTHOR  PETZOLD, LINDA R., (LLNL)
+C***DESCRIPTION
+C-----------------------------------------------------------------
+C     DDAINI TAKES ONE STEP OF SIZE H OR SMALLER
+C     WITH THE BACKWARD EULER METHOD, TO
+C     FIND YPRIME.  X AND Y ARE UPDATED TO BE CONSISTENT WITH THE
+C     NEW STEP.  A MODIFIED DAMPED NEWTON ITERATION IS USED TO
+C     SOLVE THE CORRECTOR ITERATION.
+C
+C     THE INITIAL GUESS FOR YPRIME IS USED IN THE
+C     PREDICTION, AND IN FORMING THE ITERATION
+C     MATRIX, BUT IS NOT INVOLVED IN THE
+C     ERROR TEST. THIS MAY HAVE TROUBLE
+C     CONVERGING IF THE INITIAL GUESS IS NO
+C     GOOD, OR IF G(X,Y,YPRIME) DEPENDS
+C     NONLINEARLY ON YPRIME.
+C
+C     THE PARAMETERS REPRESENT:
+C     X --         INDEPENDENT VARIABLE
+C     Y --         SOLUTION VECTOR AT X
+C     YPRIME --    DERIVATIVE OF SOLUTION VECTOR
+C     NEQ --       NUMBER OF EQUATIONS
+C     H --         STEPSIZE. IMDER MAY USE A STEPSIZE
+C                  SMALLER THAN H.
+C     WT --        VECTOR OF WEIGHTS FOR ERROR
+C                  CRITERION
+C     IDID --      COMPLETION CODE WITH THE FOLLOWING MEANINGS
+C                  IDID= 1 -- YPRIME WAS FOUND SUCCESSFULLY
+C                  IDID=-12 -- DDAINI FAILED TO FIND YPRIME
+C     RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS
+C                  THAT ARE NOT ALTERED BY DDAINI
+C     PHI --       WORK SPACE FOR DDAINI
+C     DELTA,E --   WORK SPACE FOR DDAINI
+C     WM,IWM --    REAL AND INTEGER ARRAYS STORING
+C                  MATRIX INFORMATION
+C
+C-----------------------------------------------------------------
+C***ROUTINES CALLED  DDAJAC, DDANRM, DDASLV
+C***REVISION HISTORY  (YYMMDD)
+C   830315  DATE WRITTEN
+C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
+C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
+C   901026  Added explicit declarations for all variables and minor
+C           cosmetic changes to prologue.  (FNF)
+C   901030  Minor corrections to declarations.  (FNF)
+C***END PROLOGUE  DDAINI
+C
+      INTEGER  NEQ, IDID, IPAR(*), IWM(*), NONNEG, NTEMP
+      DOUBLE PRECISION
+     *   X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*),
+     *   E(*), WM(*), HMIN, UROUND
+      EXTERNAL  RES, JAC
+C
+      EXTERNAL  DDAJAC, DDANRM, DDASLV
+      DOUBLE PRECISION  DDANRM
+C
+      INTEGER  I, IER, IRES, JCALC, LNJE, LNRE, M, MAXIT, MJAC, NCF,
+     *   NEF, NSF
+      DOUBLE PRECISION
+     *   CJ, DAMP, DELNRM, ERR, OLDNRM, R, RATE, S, XOLD, YNORM
+      LOGICAL  CONVGD
+C
+      PARAMETER (LNRE=12)
+      PARAMETER (LNJE=13)
+C
+      DATA MAXIT/10/,MJAC/5/
+      DATA DAMP/0.75D0/
+C
+C
+C---------------------------------------------------
+C     BLOCK 1.
+C     INITIALIZATIONS.
+C---------------------------------------------------
+C
+C***FIRST EXECUTABLE STATEMENT  DDAINI
+      IDID=1
+      NEF=0
+      NCF=0
+      NSF=0
+      XOLD=X
+      YNORM=DDANRM(NEQ,Y,WT,RPAR,IPAR)
+C
+C     SAVE Y AND YPRIME IN PHI
+      DO 100 I=1,NEQ
+         PHI(I,1)=Y(I)
+100      PHI(I,2)=YPRIME(I)
+C
+C
+C----------------------------------------------------
+C     BLOCK 2.
+C     DO ONE BACKWARD EULER STEP.
+C----------------------------------------------------
+C
+C     SET UP FOR START OF CORRECTOR ITERATION
+200   CJ=1.0D0/H
+      X=X+H
+C
+C     PREDICT SOLUTION AND DERIVATIVE
+      DO 250 I=1,NEQ
+250     Y(I)=Y(I)+H*YPRIME(I)
+C
+      JCALC=-1
+      M=0
+      CONVGD=.TRUE.
+C
+C
+C     CORRECTOR LOOP.
+300   IWM(LNRE)=IWM(LNRE)+1
+      IRES=0
+C
+      CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
+      IF (IRES.LT.0) GO TO 430
+C
+C
+C     EVALUATE THE ITERATION MATRIX
+      IF (JCALC.NE.-1) GO TO 310
+      IWM(LNJE)=IWM(LNJE)+1
+      JCALC=0
+      CALL DDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H,
+     *   IER,WT,E,WM,IWM,RES,IRES,
+     *   UROUND,JAC,RPAR,IPAR,NTEMP)
+C
+      S=1000000.D0
+      IF (IRES.LT.0) GO TO 430
+      IF (IER.NE.0) GO TO 430
+      NSF=0
+C
+C
+C
+C     MULTIPLY RESIDUAL BY DAMPING FACTOR
+310   CONTINUE
+      DO 320 I=1,NEQ
+320      DELTA(I)=DELTA(I)*DAMP
+C
+C     COMPUTE A NEW ITERATE (BACK SUBSTITUTION)
+C     STORE THE CORRECTION IN DELTA
+C
+      CALL DDASLV(NEQ,DELTA,WM,IWM)
+C
+C     UPDATE Y AND YPRIME
+      DO 330 I=1,NEQ
+         Y(I)=Y(I)-DELTA(I)
+330      YPRIME(I)=YPRIME(I)-CJ*DELTA(I)
+C
+C     TEST FOR CONVERGENCE OF THE ITERATION.
+C
+      DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
+      IF (DELNRM.LE.100.D0*UROUND*YNORM)
+     *   GO TO 400
+C
+      IF (M.GT.0) GO TO 340
+         OLDNRM=DELNRM
+         GO TO 350
+C
+340   RATE=(DELNRM/OLDNRM)**(1.0D0/M)
+      IF (RATE.GT.0.90D0) GO TO 430
+      S=RATE/(1.0D0-RATE)
+C
+350   IF (S*DELNRM .LE. 0.33D0) GO TO 400
+C
+C
+C     THE CORRECTOR HAS NOT YET CONVERGED. UPDATE
+C     M AND AND TEST WHETHER THE MAXIMUM
+C     NUMBER OF ITERATIONS HAVE BEEN TRIED.
+C     EVERY MJAC ITERATIONS, GET A NEW
+C     ITERATION MATRIX.
+C
+      M=M+1
+      IF (M.GE.MAXIT) GO TO 430
+C
+      IF ((M/MJAC)*MJAC.EQ.M) JCALC=-1
+      GO TO 300
+C
+C
+C     THE ITERATION HAS CONVERGED.
+C     CHECK NONNEGATIVITY CONSTRAINTS
+400   IF (NONNEG.EQ.0) GO TO 450
+      DO 410 I=1,NEQ
+410      DELTA(I)=MIN(Y(I),0.0D0)
+C
+      DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
+      IF (DELNRM.GT.0.33D0) GO TO 430
+C
+      DO 420 I=1,NEQ
+         Y(I)=Y(I)-DELTA(I)
+420      YPRIME(I)=YPRIME(I)-CJ*DELTA(I)
+      GO TO 450
+C
+C
+C     EXITS FROM CORRECTOR LOOP.
+430   CONVGD=.FALSE.
+450   IF (.NOT.CONVGD) GO TO 600
+C
+C
+C
+C-----------------------------------------------------
+C     BLOCK 3.
+C     THE CORRECTOR ITERATION CONVERGED.
+C     DO ERROR TEST.
+C-----------------------------------------------------
+C
+      DO 510 I=1,NEQ
+510      E(I)=Y(I)-PHI(I,1)
+      ERR=DDANRM(NEQ,E,WT,RPAR,IPAR)
+C
+      IF (ERR.LE.1.0D0) RETURN
+C
+C
+C
+C--------------------------------------------------------
+C     BLOCK 4.
+C     THE BACKWARD EULER STEP FAILED. RESTORE X, Y
+C     AND YPRIME TO THEIR ORIGINAL VALUES.
+C     REDUCE STEPSIZE AND TRY AGAIN, IF
+C     POSSIBLE.
+C---------------------------------------------------------
+C
+600   CONTINUE
+      X = XOLD
+      DO 610 I=1,NEQ
+         Y(I)=PHI(I,1)
+610      YPRIME(I)=PHI(I,2)
+C
+      IF (CONVGD) GO TO 640
+      IF (IER.EQ.0) GO TO 620
+         NSF=NSF+1
+         H=H*0.25D0
+         IF (NSF.LT.3.AND.ABS(H).GE.HMIN) GO TO 690
+         IDID=-12
+         RETURN
+620   IF (IRES.GT.-2) GO TO 630
+         IDID=-12
+         RETURN
+630   NCF=NCF+1
+      H=H*0.25D0
+      IF (NCF.LT.10.AND.ABS(H).GE.HMIN) GO TO 690
+         IDID=-12
+         RETURN
+C
+640   NEF=NEF+1
+      R=0.90D0/(2.0D0*ERR+0.0001D0)
+      R=MAX(0.1D0,MIN(0.5D0,R))
+      H=H*R
+      IF (ABS(H).GE.HMIN.AND.NEF.LT.10) GO TO 690
+         IDID=-12
+         RETURN
+690      GO TO 200
+C
+C-------------END OF SUBROUTINE DDAINI----------------------
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/dassl/ddajac.f
@@ -0,0 +1,177 @@
+      SUBROUTINE DDAJAC (NEQ, X, Y, YPRIME, DELTA, CJ, H,
+     +   IER, WT, E, WM, IWM, RES, IRES, UROUND, JAC, RPAR,
+     +   IPAR, NTEMP)
+C***BEGIN PROLOGUE  DDAJAC
+C***SUBSIDIARY
+C***PURPOSE  Compute the iteration matrix for DDASSL and form the
+C            LU-decomposition.
+C***LIBRARY   SLATEC (DASSL)
+C***TYPE      DOUBLE PRECISION (SDAJAC-S, DDAJAC-D)
+C***AUTHOR  PETZOLD, LINDA R., (LLNL)
+C***DESCRIPTION
+C-----------------------------------------------------------------------
+C     THIS ROUTINE COMPUTES THE ITERATION MATRIX
+C     PD=DG/DY+CJ*DG/DYPRIME (WHERE G(X,Y,YPRIME)=0).
+C     HERE PD IS COMPUTED BY THE USER-SUPPLIED
+C     ROUTINE JAC IF IWM(MTYPE) IS 1 OR 4, AND
+C     IT IS COMPUTED BY NUMERICAL FINITE DIFFERENCING
+C     IF IWM(MTYPE)IS 2 OR 5
+C     THE PARAMETERS HAVE THE FOLLOWING MEANINGS.
+C     Y        = ARRAY CONTAINING PREDICTED VALUES
+C     YPRIME   = ARRAY CONTAINING PREDICTED DERIVATIVES
+C     DELTA    = RESIDUAL EVALUATED AT (X,Y,YPRIME)
+C                (USED ONLY IF IWM(MTYPE)=2 OR 5)
+C     CJ       = SCALAR PARAMETER DEFINING ITERATION MATRIX
+C     H        = CURRENT STEPSIZE IN INTEGRATION
+C     IER      = VARIABLE WHICH IS .NE. 0
+C                IF ITERATION MATRIX IS SINGULAR,
+C                AND 0 OTHERWISE.
+C     WT       = VECTOR OF WEIGHTS FOR COMPUTING NORMS
+C     E        = WORK SPACE (TEMPORARY) OF LENGTH NEQ
+C     WM       = REAL WORK SPACE FOR MATRICES. ON
+C                OUTPUT IT CONTAINS THE LU DECOMPOSITION
+C                OF THE ITERATION MATRIX.
+C     IWM      = INTEGER WORK SPACE CONTAINING
+C                MATRIX INFORMATION
+C     RES      = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE
+C                TO EVALUATE THE RESIDUAL FUNCTION G(X,Y,YPRIME)
+C     IRES     = FLAG WHICH IS EQUAL TO ZERO IF NO ILLEGAL VALUES
+C                IN RES, AND LESS THAN ZERO OTHERWISE.  (IF IRES
+C                IS LESS THAN ZERO, THE MATRIX WAS NOT COMPLETED)
+C                IN THIS CASE (IF IRES .LT. 0), THEN IER = 0.
+C     UROUND   = THE UNIT ROUNDOFF ERROR OF THE MACHINE BEING USED.
+C     JAC      = NAME OF THE EXTERNAL USER-SUPPLIED ROUTINE
+C                TO EVALUATE THE ITERATION MATRIX (THIS ROUTINE
+C                IS ONLY USED IF IWM(MTYPE) IS 1 OR 4)
+C-----------------------------------------------------------------------
+C***ROUTINES CALLED  DGBFA, DGEFA
+C***REVISION HISTORY  (YYMMDD)
+C   830315  DATE WRITTEN
+C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
+C   901010  Modified three MAX calls to be all on one line.  (FNF)
+C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
+C   901026  Added explicit declarations for all variables and minor
+C           cosmetic changes to prologue.  (FNF)
+C   901101  Corrected PURPOSE.  (FNF)
+C***END PROLOGUE  DDAJAC
+C
+      INTEGER  NEQ, IER, IWM(*), IRES, IPAR(*), NTEMP
+      DOUBLE PRECISION
+     *   X, Y(*), YPRIME(*), DELTA(*), CJ, H, WT(*), E(*), WM(*),
+     *   UROUND, RPAR(*)
+      EXTERNAL  RES, JAC
+C
+      EXTERNAL  DGBFA, DGEFA
+C
+      INTEGER  I, I1, I2, II, IPSAVE, ISAVE, J, K, L, LENPD, LIPVT,
+     *   LML, LMTYPE, LMU, MBA, MBAND, MEB1, MEBAND, MSAVE, MTYPE, N,
+     *   NPD, NPDM1, NROW
+      DOUBLE PRECISION  DEL, DELINV, SQUR, YPSAVE, YSAVE
+C
+      PARAMETER (NPD=1)
+      PARAMETER (LML=1)
+      PARAMETER (LMU=2)
+      PARAMETER (LMTYPE=4)
+      PARAMETER (LIPVT=21)
+C
+C***FIRST EXECUTABLE STATEMENT  DDAJAC
+      IER = 0
+      NPDM1=NPD-1
+      MTYPE=IWM(LMTYPE)
+      GO TO (100,200,300,400,500),MTYPE
+C
+C
+C     DENSE USER-SUPPLIED MATRIX
+100   LENPD=NEQ*NEQ
+      DO 110 I=1,LENPD
+110      WM(NPDM1+I)=0.0D0
+      CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR)
+      GO TO 230
+C
+C
+C     DENSE FINITE-DIFFERENCE-GENERATED MATRIX
+200   IRES=0
+      NROW=NPDM1
+      SQUR = SQRT(UROUND)
+      DO 210 I=1,NEQ
+         DEL=SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I)),ABS(WT(I)))
+         DEL=SIGN(DEL,H*YPRIME(I))
+         DEL=(Y(I)+DEL)-Y(I)
+         YSAVE=Y(I)
+         YPSAVE=YPRIME(I)
+         Y(I)=Y(I)+DEL
+         YPRIME(I)=YPRIME(I)+CJ*DEL
+         CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR)
+         IF (IRES .LT. 0) RETURN
+         DELINV=1.0D0/DEL
+         DO 220 L=1,NEQ
+220      WM(NROW+L)=(E(L)-DELTA(L))*DELINV
+      NROW=NROW+NEQ
+      Y(I)=YSAVE
+      YPRIME(I)=YPSAVE
+210   CONTINUE
+C
+C
+C     DO DENSE-MATRIX LU DECOMPOSITION ON PD
+230      CALL DGEFA(WM(NPD),NEQ,NEQ,IWM(LIPVT),IER)
+      RETURN
+C
+C
+C     DUMMY SECTION FOR IWM(MTYPE)=3
+300   RETURN
+C
+C
+C     BANDED USER-SUPPLIED MATRIX
+400   LENPD=(2*IWM(LML)+IWM(LMU)+1)*NEQ
+      DO 410 I=1,LENPD
+410      WM(NPDM1+I)=0.0D0
+      CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR)
+      MEBAND=2*IWM(LML)+IWM(LMU)+1
+      GO TO 550
+C
+C
+C     BANDED FINITE-DIFFERENCE-GENERATED MATRIX
+500   MBAND=IWM(LML)+IWM(LMU)+1
+      MBA=MIN(MBAND,NEQ)
+      MEBAND=MBAND+IWM(LML)
+      MEB1=MEBAND-1
+      MSAVE=(NEQ/MBAND)+1
+      ISAVE=NTEMP-1
+      IPSAVE=ISAVE+MSAVE
+      IRES=0
+      SQUR=SQRT(UROUND)
+      DO 540 J=1,MBA
+         DO 510 N=J,NEQ,MBAND
+          K= (N-J)/MBAND + 1
+          WM(ISAVE+K)=Y(N)
+          WM(IPSAVE+K)=YPRIME(N)
+          DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N)))
+          DEL=SIGN(DEL,H*YPRIME(N))
+          DEL=(Y(N)+DEL)-Y(N)
+          Y(N)=Y(N)+DEL
+510       YPRIME(N)=YPRIME(N)+CJ*DEL
+      CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR)
+      IF (IRES .LT. 0) RETURN
+      DO 530 N=J,NEQ,MBAND
+          K= (N-J)/MBAND + 1
+          Y(N)=WM(ISAVE+K)
+          YPRIME(N)=WM(IPSAVE+K)
+          DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N)))
+          DEL=SIGN(DEL,H*YPRIME(N))
+          DEL=(Y(N)+DEL)-Y(N)
+          DELINV=1.0D0/DEL
+          I1=MAX(1,(N-IWM(LMU)))
+          I2=MIN(NEQ,(N+IWM(LML)))
+          II=N*MEB1-IWM(LML)+NPDM1
+          DO 520 I=I1,I2
+520         WM(II+I)=(E(I)-DELTA(I))*DELINV
+530      CONTINUE
+540   CONTINUE
+C
+C
+C     DO LU DECOMPOSITION OF BANDED PD
+550   CALL DGBFA(WM(NPD),MEBAND,NEQ,
+     *    IWM(LML),IWM(LMU),IWM(LIPVT),IER)
+      RETURN
+C------END OF SUBROUTINE DDAJAC------
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/dassl/ddanrm.f
@@ -0,0 +1,45 @@
+      DOUBLE PRECISION FUNCTION DDANRM (NEQ, V, WT, RPAR, IPAR)
+C***BEGIN PROLOGUE  DDANRM
+C***SUBSIDIARY
+C***PURPOSE  Compute vector norm for DDASSL.
+C***LIBRARY   SLATEC (DASSL)
+C***TYPE      DOUBLE PRECISION (SDANRM-S, DDANRM-D)
+C***AUTHOR  PETZOLD, LINDA R., (LLNL)
+C***DESCRIPTION
+C-----------------------------------------------------------------------
+C     THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED
+C     ROOT-MEAN-SQUARE NORM OF THE VECTOR OF LENGTH
+C     NEQ CONTAINED IN THE ARRAY V,WITH WEIGHTS
+C     CONTAINED IN THE ARRAY WT OF LENGTH NEQ.
+C        DDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2)
+C-----------------------------------------------------------------------
+C***ROUTINES CALLED  (NONE)
+C***REVISION HISTORY  (YYMMDD)
+C   830315  DATE WRITTEN
+C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
+C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
+C   901026  Added explicit declarations for all variables and minor
+C           cosmetic changes to prologue.  (FNF)
+C***END PROLOGUE  DDANRM
+C
+      INTEGER  NEQ, IPAR(*)
+      DOUBLE PRECISION  V(NEQ), WT(NEQ), RPAR(*)
+C
+      INTEGER  I
+      DOUBLE PRECISION  SUM, VMAX
+C
+C***FIRST EXECUTABLE STATEMENT  DDANRM
+      DDANRM = 0.0D0
+      VMAX = 0.0D0
+      DO 10 I = 1,NEQ
+        IF(ABS(V(I)/WT(I)) .GT. VMAX) VMAX = ABS(V(I)/WT(I))
+10      CONTINUE
+      IF(VMAX .LE. 0.0D0) GO TO 30
+      SUM = 0.0D0
+      DO 20 I = 1,NEQ
+20      SUM = SUM + ((V(I)/WT(I))/VMAX)**2
+      DDANRM = VMAX*SQRT(SUM/NEQ)
+30    CONTINUE
+      RETURN
+C------END OF FUNCTION DDANRM------
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/dassl/ddaslv.f
@@ -0,0 +1,60 @@
+      SUBROUTINE DDASLV (NEQ, DELTA, WM, IWM)
+C***BEGIN PROLOGUE  DDASLV
+C***SUBSIDIARY
+C***PURPOSE  Linear system solver for DDASSL.
+C***LIBRARY   SLATEC (DASSL)
+C***TYPE      DOUBLE PRECISION (SDASLV-S, DDASLV-D)
+C***AUTHOR  PETZOLD, LINDA R., (LLNL)
+C***DESCRIPTION
+C-----------------------------------------------------------------------
+C     THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR
+C     SYSTEM ARISING IN THE NEWTON ITERATION.
+C     MATRICES AND REAL TEMPORARY STORAGE AND
+C     REAL INFORMATION ARE STORED IN THE ARRAY WM.
+C     INTEGER MATRIX INFORMATION IS STORED IN
+C     THE ARRAY IWM.
+C     FOR A DENSE MATRIX, THE LINPACK ROUTINE
+C     DGESL IS CALLED.
+C     FOR A BANDED MATRIX,THE LINPACK ROUTINE
+C     DGBSL IS CALLED.
+C-----------------------------------------------------------------------
+C***ROUTINES CALLED  DGBSL, DGESL
+C***REVISION HISTORY  (YYMMDD)
+C   830315  DATE WRITTEN
+C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
+C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
+C   901026  Added explicit declarations for all variables and minor
+C           cosmetic changes to prologue.  (FNF)
+C***END PROLOGUE  DDASLV
+C
+      INTEGER  NEQ, IWM(*)
+      DOUBLE PRECISION  DELTA(*), WM(*)
+C
+      EXTERNAL  DGBSL, DGESL
+C
+      INTEGER  LIPVT, LML, LMU, LMTYPE, MEBAND, MTYPE, NPD
+      PARAMETER (NPD=1)
+      PARAMETER (LML=1)
+      PARAMETER (LMU=2)
+      PARAMETER (LMTYPE=4)
+      PARAMETER (LIPVT=21)
+C
+C***FIRST EXECUTABLE STATEMENT  DDASLV
+      MTYPE=IWM(LMTYPE)
+      GO TO(100,100,300,400,400),MTYPE
+C
+C     DENSE MATRIX
+100   CALL DGESL(WM(NPD),NEQ,NEQ,IWM(LIPVT),DELTA,0)
+      RETURN
+C
+C     DUMMY SECTION FOR MTYPE=3
+300   CONTINUE
+      RETURN
+C
+C     BANDED MATRIX
+400   MEBAND=2*IWM(LML)+IWM(LMU)+1
+      CALL DGBSL(WM(NPD),MEBAND,NEQ,IWM(LML),
+     *  IWM(LMU),IWM(LIPVT),DELTA,0)
+      RETURN
+C------END OF SUBROUTINE DDASLV------
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/dassl/ddassl.f
@@ -0,0 +1,1604 @@
+      SUBROUTINE DDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL,
+     +   IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC)
+C***BEGIN PROLOGUE  DDASSL
+C***PURPOSE  This code solves a system of differential/algebraic
+C            equations of the form G(T,Y,YPRIME) = 0.
+C***LIBRARY   SLATEC (DASSL)
+C***CATEGORY  I1A2
+C***TYPE      DOUBLE PRECISION (SDASSL-S, DDASSL-D)
+C***KEYWORDS  DIFFERENTIAL/ALGEBRAIC, BACKWARD DIFFERENTIATION FORMULAS,
+C             IMPLICIT DIFFERENTIAL SYSTEMS
+C***AUTHOR  PETZOLD, LINDA R., (LLNL)
+C             COMPUTING AND MATHEMATICS RESEARCH DIVISION
+C             LAWRENCE LIVERMORE NATIONAL LABORATORY
+C             L - 316, P.O. BOX 808,
+C             LIVERMORE, CA.    94550
+C***DESCRIPTION
+C
+C *Usage:
+C
+C      EXTERNAL RES, JAC
+C      INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR
+C      DOUBLE PRECISION T, Y(NEQ), YPRIME(NEQ), TOUT, RTOL, ATOL,
+C     *   RWORK(LRW), RPAR
+C
+C      CALL DDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL,
+C     *   IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC)
+C
+C
+C *Arguments:
+C  (In the following, all real arrays should be type DOUBLE PRECISION.)
+C
+C  RES:EXT     This is a subroutine which you provide to define the
+C              differential/algebraic system.
+C
+C  NEQ:IN      This is the number of equations to be solved.
+C
+C  T:INOUT     This is the current value of the independent variable.
+C
+C  Y(*):INOUT  This array contains the solution components at T.
+C
+C  YPRIME(*):INOUT  This array contains the derivatives of the solution
+C              components at T.
+C
+C  TOUT:IN     This is a point at which a solution is desired.
+C
+C  INFO(N):IN  The basic task of the code is to solve the system from T
+C              to TOUT and return an answer at TOUT.  INFO is an integer
+C              array which is used to communicate exactly how you want
+C              this task to be carried out.  (See below for details.)
+C              N must be greater than or equal to 15.
+C
+C  RTOL,ATOL:INOUT  These quantities represent relative and absolute
+C              error tolerances which you provide to indicate how
+C              accurately you wish the solution to be computed.  You
+C              may choose them to be both scalars or else both vectors.
+C              Caution:  In Fortran 77, a scalar is not the same as an
+C                        array of length 1.  Some compilers may object
+C                        to using scalars for RTOL,ATOL.
+C
+C  IDID:OUT    This scalar quantity is an indicator reporting what the
+C              code did.  You must monitor this integer variable to
+C              decide  what action to take next.
+C
+C  RWORK:WORK  A real work array of length LRW which provides the
+C              code with needed storage space.
+C
+C  LRW:IN      The length of RWORK.  (See below for required length.)
+C
+C  IWORK:WORK  An integer work array of length LIW which probides the
+C              code with needed storage space.
+C
+C  LIW:IN      The length of IWORK.  (See below for required length.)
+C
+C  RPAR,IPAR:IN  These are real and integer parameter arrays which
+C              you can use for communication between your calling
+C              program and the RES subroutine (and the JAC subroutine)
+C
+C  JAC:EXT     This is the name of a subroutine which you may choose
+C              to provide for defining a matrix of partial derivatives
+C              described below.
+C
+C  Quantities which may be altered by DDASSL are:
+C     T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL,
+C     IDID, RWORK(*) AND IWORK(*)
+C
+C *Description
+C
+C  Subroutine DDASSL uses the backward differentiation formulas of
+C  orders one through five to solve a system of the above form for Y and
+C  YPRIME.  Values for Y and YPRIME at the initial time must be given as
+C  input.  These values must be consistent, (that is, if T,Y,YPRIME are
+C  the given initial values, they must satisfy G(T,Y,YPRIME) = 0.).  The
+C  subroutine solves the system from T to TOUT.  It is easy to continue
+C  the solution to get results at additional TOUT.  This is the interval
+C  mode of operation.  Intermediate results can also be obtained easily
+C  by using the intermediate-output capability.
+C
+C  The following detailed description is divided into subsections:
+C    1. Input required for the first call to DDASSL.
+C    2. Output after any return from DDASSL.
+C    3. What to do to continue the integration.
+C    4. Error messages.
+C
+C
+C  -------- INPUT -- WHAT TO DO ON THE FIRST CALL TO DDASSL ------------
+C
+C  The first call of the code is defined to be the start of each new
+C  problem. Read through the descriptions of all the following items,
+C  provide sufficient storage space for designated arrays, set
+C  appropriate variables for the initialization of the problem, and
+C  give information about how you want the problem to be solved.
+C
+C
+C  RES -- Provide a subroutine of the form
+C             SUBROUTINE RES(T,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
+C         to define the system of differential/algebraic
+C         equations which is to be solved. For the given values
+C         of T,Y and YPRIME, the subroutine should
+C         return the residual of the defferential/algebraic
+C         system
+C             DELTA = G(T,Y,YPRIME)
+C         (DELTA(*) is a vector of length NEQ which is
+C         output for RES.)
+C
+C         Subroutine RES must not alter T,Y or YPRIME.
+C         You must declare the name RES in an external
+C         statement in your program that calls DDASSL.
+C         You must dimension Y,YPRIME and DELTA in RES.
+C
+C         IRES is an integer flag which is always equal to
+C         zero on input. Subroutine RES should alter IRES
+C         only if it encounters an illegal value of Y or
+C         a stop condition. Set IRES = -1 if an input value
+C         is illegal, and DDASSL will try to solve the problem
+C         without getting IRES = -1. If IRES = -2, DDASSL
+C         will return control to the calling program
+C         with IDID = -11.
+C
+C         RPAR and IPAR are real and integer parameter arrays which
+C         you can use for communication between your calling program
+C         and subroutine RES. They are not altered by DDASSL. If you
+C         do not need RPAR or IPAR, ignore these parameters by treat-
+C         ing them as dummy arguments. If you do choose to use them,
+C         dimension them in your calling program and in RES as arrays
+C         of appropriate length.
+C
+C  NEQ -- Set it to the number of differential equations.
+C         (NEQ .GE. 1)
+C
+C  T -- Set it to the initial point of the integration.
+C         T must be defined as a variable.
+C
+C  Y(*) -- Set this vector to the initial values of the NEQ solution
+C         components at the initial point. You must dimension Y of
+C         length at least NEQ in your calling program.
+C
+C  YPRIME(*) -- Set this vector to the initial values of the NEQ
+C         first derivatives of the solution components at the initial
+C         point.  You must dimension YPRIME at least NEQ in your
+C         calling program. If you do not know initial values of some
+C         of the solution components, see the explanation of INFO(11).
+C
+C  TOUT -- Set it to the first point at which a solution
+C         is desired. You can not take TOUT = T.
+C         integration either forward in T (TOUT .GT. T) or
+C         backward in T (TOUT .LT. T) is permitted.
+C
+C         The code advances the solution from T to TOUT using
+C         step sizes which are automatically selected so as to
+C         achieve the desired accuracy. If you wish, the code will
+C         return with the solution and its derivative at
+C         intermediate steps (intermediate-output mode) so that
+C         you can monitor them, but you still must provide TOUT in
+C         accord with the basic aim of the code.
+C
+C         The first step taken by the code is a critical one
+C         because it must reflect how fast the solution changes near
+C         the initial point. The code automatically selects an
+C         initial step size which is practically always suitable for
+C         the problem. By using the fact that the code will not step
+C         past TOUT in the first step, you could, if necessary,
+C         restrict the length of the initial step size.
+C
+C         For some problems it may not be permissible to integrate
+C         past a point TSTOP because a discontinuity occurs there
+C         or the solution or its derivative is not defined beyond
+C         TSTOP. When you have declared a TSTOP point (SEE INFO(4)
+C         and RWORK(1)), you have told the code not to integrate
+C         past TSTOP. In this case any TOUT beyond TSTOP is invalid
+C         input.
+C
+C  INFO(*) -- Use the INFO array to give the code more details about
+C         how you want your problem solved.  This array should be
+C         dimensioned of length 15, though DDASSL uses only the first
+C         eleven entries.  You must respond to all of the following
+C         items, which are arranged as questions.  The simplest use
+C         of the code corresponds to answering all questions as yes,
+C         i.e. setting all entries of INFO to 0.
+C
+C       INFO(1) - This parameter enables the code to initialize
+C              itself. You must set it to indicate the start of every
+C              new problem.
+C
+C          **** Is this the first call for this problem ...
+C                Yes - Set INFO(1) = 0
+C                 No - Not applicable here.
+C                      See below for continuation calls.  ****
+C
+C       INFO(2) - How much accuracy you want of your solution
+C              is specified by the error tolerances RTOL and ATOL.
+C              The simplest use is to take them both to be scalars.
+C              To obtain more flexibility, they can both be vectors.
+C              The code must be told your choice.
+C
+C          **** Are both error tolerances RTOL, ATOL scalars ...
+C                Yes - Set INFO(2) = 0
+C                      and input scalars for both RTOL and ATOL
+C                 No - Set INFO(2) = 1
+C                      and input arrays for both RTOL and ATOL ****
+C
+C       INFO(3) - The code integrates from T in the direction
+C              of TOUT by steps. If you wish, it will return the
+C              computed solution and derivative at the next
+C              intermediate step (the intermediate-output mode) or
+C              TOUT, whichever comes first. This is a good way to
+C              proceed if you want to see the behavior of the solution.
+C              If you must have solutions at a great many specific
+C              TOUT points, this code will compute them efficiently.
+C
+C          **** Do you want the solution only at
+C                TOUT (and not at the next intermediate step) ...
+C                 Yes - Set INFO(3) = 0
+C                  No - Set INFO(3) = 1 ****
+C
+C       INFO(4) - To handle solutions at a great many specific
+C              values TOUT efficiently, this code may integrate past
+C              TOUT and interpolate to obtain the result at TOUT.
+C              Sometimes it is not possible to integrate beyond some
+C              point TSTOP because the equation changes there or it is
+C              not defined past TSTOP. Then you must tell the code
+C              not to go past.
+C
+C           **** Can the integration be carried out without any
+C                restrictions on the independent variable T ...
+C                 Yes - Set INFO(4)=0
+C                  No - Set INFO(4)=1
+C                       and define the stopping point TSTOP by
+C                       setting RWORK(1)=TSTOP ****
+C
+C       INFO(5) - To solve differential/algebraic problems it is
+C              necessary to use a matrix of partial derivatives of the
+C              system of differential equations. If you do not
+C              provide a subroutine to evaluate it analytically (see
+C              description of the item JAC in the call list), it will
+C              be approximated by numerical differencing in this code.
+C              although it is less trouble for you to have the code
+C              compute partial derivatives by numerical differencing,
+C              the solution will be more reliable if you provide the
+C              derivatives via JAC. Sometimes numerical differencing
+C              is cheaper than evaluating derivatives in JAC and
+C              sometimes it is not - this depends on your problem.
+C
+C           **** Do you want the code to evaluate the partial
+C                derivatives automatically by numerical differences ...
+C                   Yes - Set INFO(5)=0
+C                    No - Set INFO(5)=1
+C                  and provide subroutine JAC for evaluating the
+C                  matrix of partial derivatives ****
+C
+C       INFO(6) - DDASSL will perform much better if the matrix of
+C              partial derivatives, DG/DY + CJ*DG/DYPRIME,
+C              (here CJ is a scalar determined by DDASSL)
+C              is banded and the code is told this. In this
+C              case, the storage needed will be greatly reduced,
+C              numerical differencing will be performed much cheaper,
+C              and a number of important algorithms will execute much
+C              faster. The differential equation is said to have
+C              half-bandwidths ML (lower) and MU (upper) if equation i
+C              involves only unknowns Y(J) with
+C                             I-ML .LE. J .LE. I+MU
+C              for all I=1,2,...,NEQ. Thus, ML and MU are the widths
+C              of the lower and upper parts of the band, respectively,
+C              with the main diagonal being excluded. If you do not
+C              indicate that the equation has a banded matrix of partial
+C              derivatives, the code works with a full matrix of NEQ**2
+C              elements (stored in the conventional way). Computations
+C              with banded matrices cost less time and storage than with
+C              full matrices if 2*ML+MU .LT. NEQ. If you tell the
+C              code that the matrix of partial derivatives has a banded
+C              structure and you want to provide subroutine JAC to
+C              compute the partial derivatives, then you must be careful
+C              to store the elements of the matrix in the special form
+C              indicated in the description of JAC.
+C
+C          **** Do you want to solve the problem using a full
+C               (dense) matrix (and not a special banded
+C               structure) ...
+C                Yes - Set INFO(6)=0
+C                 No - Set INFO(6)=1
+C                       and provide the lower (ML) and upper (MU)
+C                       bandwidths by setting
+C                       IWORK(1)=ML
+C                       IWORK(2)=MU ****
+C
+C
+C        INFO(7) -- You can specify a maximum (absolute value of)
+C              stepsize, so that the code
+C              will avoid passing over very
+C              large regions.
+C
+C          ****  Do you want the code to decide
+C                on its own maximum stepsize?
+C                Yes - Set INFO(7)=0
+C                 No - Set INFO(7)=1
+C                      and define HMAX by setting
+C                      RWORK(2)=HMAX ****
+C
+C        INFO(8) -- Differential/algebraic problems
+C              may occaisionally suffer from
+C              severe scaling difficulties on the
+C              first step. If you know a great deal
+C              about the scaling of your problem, you can
+C              help to alleviate this problem by
+C              specifying an initial stepsize HO.
+C
+C          ****  Do you want the code to define
+C                its own initial stepsize?
+C                Yes - Set INFO(8)=0
+C                 No - Set INFO(8)=1
+C                      and define HO by setting
+C                      RWORK(3)=HO ****
+C
+C        INFO(9) -- If storage is a severe problem,
+C              you can save some locations by
+C              restricting the maximum order MAXORD.
+C              the default value is 5. for each
+C              order decrease below 5, the code
+C              requires NEQ fewer locations, however
+C              it is likely to be slower. In any
+C              case, you must have 1 .LE. MAXORD .LE. 5
+C          ****  Do you want the maximum order to
+C                default to 5?
+C                Yes - Set INFO(9)=0
+C                 No - Set INFO(9)=1
+C                      and define MAXORD by setting
+C                      IWORK(3)=MAXORD ****
+C
+C        INFO(10) --If you know that the solutions to your equations
+C               will always be nonnegative, it may help to set this
+C               parameter. However, it is probably best to
+C               try the code without using this option first,
+C               and only to use this option if that doesn't
+C               work very well.
+C           ****  Do you want the code to solve the problem without
+C                 invoking any special nonnegativity constraints?
+C                  Yes - Set INFO(10)=0
+C                   No - Set INFO(10)=1
+C
+C        INFO(11) --DDASSL normally requires the initial T,
+C               Y, and YPRIME to be consistent. That is,
+C               you must have G(T,Y,YPRIME) = 0 at the initial
+C               time. If you do not know the initial
+C               derivative precisely, you can let DDASSL try
+C               to compute it.
+C          ****   Are the initialHE INITIAL T, Y, YPRIME consistent?
+C                 Yes - Set INFO(11) = 0
+C                  No - Set INFO(11) = 1,
+C                       and set YPRIME to an initial approximation
+C                       to YPRIME.  (If you have no idea what
+C                       YPRIME should be, set it to zero. Note
+C                       that the initial Y should be such
+C                       that there must exist a YPRIME so that
+C                       G(T,Y,YPRIME) = 0.)
+C
+C  RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL
+C         error tolerances to tell the code how accurately you
+C         want the solution to be computed.  They must be defined
+C         as variables because the code may change them.  You
+C         have two choices --
+C               Both RTOL and ATOL are scalars. (INFO(2)=0)
+C               Both RTOL and ATOL are vectors. (INFO(2)=1)
+C         in either case all components must be non-negative.
+C
+C         The tolerances are used by the code in a local error
+C         test at each step which requires roughly that
+C               ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL
+C         for each vector component.
+C         (More specifically, a root-mean-square norm is used to
+C         measure the size of vectors, and the error test uses the
+C         magnitude of the solution at the beginning of the step.)
+C
+C         The true (global) error is the difference between the
+C         true solution of the initial value problem and the
+C         computed approximation.  Practically all present day
+C         codes, including this one, control the local error at
+C         each step and do not even attempt to control the global
+C         error directly.
+C         Usually, but not always, the true accuracy of the
+C         computed Y is comparable to the error tolerances. This
+C         code will usually, but not always, deliver a more
+C         accurate solution if you reduce the tolerances and
+C         integrate again.  By comparing two such solutions you
+C         can get a fairly reliable idea of the true error in the
+C         solution at the bigger tolerances.
+C
+C         Setting ATOL=0. results in a pure relative error test on
+C         that component.  Setting RTOL=0. results in a pure
+C         absolute error test on that component.  A mixed test
+C         with non-zero RTOL and ATOL corresponds roughly to a
+C         relative error test when the solution component is much
+C         bigger than ATOL and to an absolute error test when the
+C         solution component is smaller than the threshhold ATOL.
+C
+C         The code will not attempt to compute a solution at an
+C         accuracy unreasonable for the machine being used.  It will
+C         advise you if you ask for too much accuracy and inform
+C         you as to the maximum accuracy it believes possible.
+C
+C  RWORK(*) --  Dimension this real work array of length LRW in your
+C         calling program.
+C
+C  LRW -- Set it to the declared length of the RWORK array.
+C               You must have
+C                    LRW .GE. 40+(MAXORD+4)*NEQ+NEQ**2
+C               for the full (dense) JACOBIAN case (when INFO(6)=0), or
+C                    LRW .GE. 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ
+C               for the banded user-defined JACOBIAN case
+C               (when INFO(5)=1 and INFO(6)=1), or
+C                     LRW .GE. 40+(MAXORD+4)*NEQ+(2*ML+MU+1)*NEQ
+C                           +2*(NEQ/(ML+MU+1)+1)
+C               for the banded finite-difference-generated JACOBIAN case
+C               (when INFO(5)=0 and INFO(6)=1)
+C
+C  IWORK(*) --  Dimension this integer work array of length LIW in
+C         your calling program.
+C
+C  LIW -- Set it to the declared length of the IWORK array.
+C               You must have LIW .GE. 20+NEQ
+C
+C  RPAR, IPAR -- These are parameter arrays, of real and integer
+C         type, respectively.  You can use them for communication
+C         between your program that calls DDASSL and the
+C         RES subroutine (and the JAC subroutine).  They are not
+C         altered by DDASSL.  If you do not need RPAR or IPAR,
+C         ignore these parameters by treating them as dummy
+C         arguments.  If you do choose to use them, dimension
+C         them in your calling program and in RES (and in JAC)
+C         as arrays of appropriate length.
+C
+C  JAC -- If you have set INFO(5)=0, you can ignore this parameter
+C         by treating it as a dummy argument.  Otherwise, you must
+C         provide a subroutine of the form
+C             SUBROUTINE JAC(T,Y,YPRIME,PD,CJ,RPAR,IPAR)
+C         to define the matrix of partial derivatives
+C             PD=DG/DY+CJ*DG/DYPRIME
+C         CJ is a scalar which is input to JAC.
+C         For the given values of T,Y,YPRIME, the
+C         subroutine must evaluate the non-zero partial
+C         derivatives for each equation and each solution
+C         component, and store these values in the
+C         matrix PD.  The elements of PD are set to zero
+C         before each call to JAC so only non-zero elements
+C         need to be defined.
+C
+C         Subroutine JAC must not alter T,Y,(*),YPRIME(*), or CJ.
+C         You must declare the name JAC in an EXTERNAL statement in
+C         your program that calls DDASSL.  You must dimension Y,
+C         YPRIME and PD in JAC.
+C
+C         The way you must store the elements into the PD matrix
+C         depends on the structure of the matrix which you
+C         indicated by INFO(6).
+C               *** INFO(6)=0 -- Full (dense) matrix ***
+C                   Give PD a first dimension of NEQ.
+C                   When you evaluate the (non-zero) partial derivative
+C                   of equation I with respect to variable J, you must
+C                   store it in PD according to
+C                   PD(I,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)"
+C               *** INFO(6)=1 -- Banded JACOBIAN with ML lower and MU
+C                   upper diagonal bands (refer to INFO(6) description
+C                   of ML and MU) ***
+C                   Give PD a first dimension of 2*ML+MU+1.
+C                   when you evaluate the (non-zero) partial derivative
+C                   of equation I with respect to variable J, you must
+C                   store it in PD according to
+C                   IROW = I - J + ML + MU + 1
+C                   PD(IROW,J) = "DG(I)/DY(J)+CJ*DG(I)/DYPRIME(J)"
+C
+C         RPAR and IPAR are real and integer parameter arrays
+C         which you can use for communication between your calling
+C         program and your JACOBIAN subroutine JAC. They are not
+C         altered by DDASSL. If you do not need RPAR or IPAR,
+C         ignore these parameters by treating them as dummy
+C         arguments. If you do choose to use them, dimension
+C         them in your calling program and in JAC as arrays of
+C         appropriate length.
+C
+C
+C  OPTIONALLY REPLACEABLE NORM ROUTINE:
+C
+C     DDASSL uses a weighted norm DDANRM to measure the size
+C     of vectors such as the estimated error in each step.
+C     A FUNCTION subprogram
+C       DOUBLE PRECISION FUNCTION DDANRM(NEQ,V,WT,RPAR,IPAR)
+C       DIMENSION V(NEQ),WT(NEQ)
+C     is used to define this norm. Here, V is the vector
+C     whose norm is to be computed, and WT is a vector of
+C     weights.  A DDANRM routine has been included with DDASSL
+C     which computes the weighted root-mean-square norm
+C     given by
+C       DDANRM=SQRT((1/NEQ)*SUM(V(I)/WT(I))**2)
+C     this norm is suitable for most problems. In some
+C     special cases, it may be more convenient and/or
+C     efficient to define your own norm by writing a function
+C     subprogram to be called instead of DDANRM. This should,
+C     however, be attempted only after careful thought and
+C     consideration.
+C
+C
+C  -------- OUTPUT -- AFTER ANY RETURN FROM DDASSL ---------------------
+C
+C  The principal aim of the code is to return a computed solution at
+C  TOUT, although it is also possible to obtain intermediate results
+C  along the way. To find out whether the code achieved its goal
+C  or if the integration process was interrupted before the task was
+C  completed, you must check the IDID parameter.
+C
+C
+C  T -- The solution was successfully advanced to the
+C               output value of T.
+C
+C  Y(*) -- Contains the computed solution approximation at T.
+C
+C  YPRIME(*) -- Contains the computed derivative
+C               approximation at T.
+C
+C  IDID -- Reports what the code did.
+C
+C                     *** Task completed ***
+C                Reported by positive values of IDID
+C
+C           IDID = 1 -- A step was successfully taken in the
+C                   intermediate-output mode. The code has not
+C                   yet reached TOUT.
+C
+C           IDID = 2 -- The integration to TSTOP was successfully
+C                   completed (T=TSTOP) by stepping exactly to TSTOP.
+C
+C           IDID = 3 -- The integration to TOUT was successfully
+C                   completed (T=TOUT) by stepping past TOUT.
+C                   Y(*) is obtained by interpolation.
+C                   YPRIME(*) is obtained by interpolation.
+C
+C                    *** Task interrupted ***
+C                Reported by negative values of IDID
+C
+C           IDID = -1 -- A large amount of work has been expended.
+C                   (About 500 steps)
+C
+C           IDID = -2 -- The error tolerances are too stringent.
+C
+C           IDID = -3 -- The local error test cannot be satisfied
+C                   because you specified a zero component in ATOL
+C                   and the corresponding computed solution
+C                   component is zero. Thus, a pure relative error
+C                   test is impossible for this component.
+C
+C           IDID = -6 -- DDASSL had repeated error test
+C                   failures on the last attempted step.
+C
+C           IDID = -7 -- The corrector could not converge.
+C
+C           IDID = -8 -- The matrix of partial derivatives
+C                   is singular.
+C
+C           IDID = -9 -- The corrector could not converge.
+C                   there were repeated error test failures
+C                   in this step.
+C
+C           IDID =-10 -- The corrector could not converge
+C                   because IRES was equal to minus one.
+C
+C           IDID =-11 -- IRES equal to -2 was encountered
+C                   and control is being returned to the
+C                   calling program.
+C
+C           IDID =-12 -- DDASSL failed to compute the initial
+C                   YPRIME.
+C
+C
+C
+C           IDID = -13,..,-32 -- Not applicable for this code
+C
+C                    *** Task terminated ***
+C                Reported by the value of IDID=-33
+C
+C           IDID = -33 -- The code has encountered trouble from which
+C                   it cannot recover. A message is printed
+C                   explaining the trouble and control is returned
+C                   to the calling program. For example, this occurs
+C                   when invalid input is detected.
+C
+C  RTOL, ATOL -- These quantities remain unchanged except when
+C               IDID = -2. In this case, the error tolerances have been
+C               increased by the code to values which are estimated to
+C               be appropriate for continuing the integration. However,
+C               the reported solution at T was obtained using the input
+C               values of RTOL and ATOL.
+C
+C  RWORK, IWORK -- Contain information which is usually of no
+C               interest to the user but necessary for subsequent calls.
+C               However, you may find use for
+C
+C               RWORK(3)--Which contains the step size H to be
+C                       attempted on the next step.
+C
+C               RWORK(4)--Which contains the current value of the
+C                       independent variable, i.e., the farthest point
+C                       integration has reached. This will be different
+C                       from T only when interpolation has been
+C                       performed (IDID=3).
+C
+C               RWORK(7)--Which contains the stepsize used
+C                       on the last successful step.
+C
+C               IWORK(7)--Which contains the order of the method to
+C                       be attempted on the next step.
+C
+C               IWORK(8)--Which contains the order of the method used
+C                       on the last step.
+C
+C               IWORK(11)--Which contains the number of steps taken so
+C                        far.
+C
+C               IWORK(12)--Which contains the number of calls to RES
+C                        so far.
+C
+C               IWORK(13)--Which contains the number of evaluations of
+C                        the matrix of partial derivatives needed so
+C                        far.
+C
+C               IWORK(14)--Which contains the total number
+C                        of error test failures so far.
+C
+C               IWORK(15)--Which contains the total number
+C                        of convergence test failures so far.
+C                        (includes singular iteration matrix
+C                        failures.)
+C
+C
+C  -------- INPUT -- WHAT TO DO TO CONTINUE THE INTEGRATION ------------
+C                    (CALLS AFTER THE FIRST)
+C
+C  This code is organized so that subsequent calls to continue the
+C  integration involve little (if any) additional effort on your
+C  part. You must monitor the IDID parameter in order to determine
+C  what to do next.
+C
+C  Recalling that the principal task of the code is to integrate
+C  from T to TOUT (the interval mode), usually all you will need
+C  to do is specify a new TOUT upon reaching the current TOUT.
+C
+C  Do not alter any quantity not specifically permitted below,
+C  in particular do not alter NEQ,T,Y(*),YPRIME(*),RWORK(*),IWORK(*)
+C  or the differential equation in subroutine RES. Any such
+C  alteration constitutes a new problem and must be treated as such,
+C  i.e., you must start afresh.
+C
+C  You cannot change from vector to scalar error control or vice
+C  versa (INFO(2)), but you can change the size of the entries of
+C  RTOL, ATOL. Increasing a tolerance makes the equation easier
+C  to integrate. Decreasing a tolerance will make the equation
+C  harder to integrate and should generally be avoided.
+C
+C  You can switch from the intermediate-output mode to the
+C  interval mode (INFO(3)) or vice versa at any time.
+C
+C  If it has been necessary to prevent the integration from going
+C  past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the
+C  code will not integrate to any TOUT beyond the currently
+C  specified TSTOP. Once TSTOP has been reached you must change
+C  the value of TSTOP or set INFO(4)=0. You may change INFO(4)
+C  or TSTOP at any time but you must supply the value of TSTOP in
+C  RWORK(1) whenever you set INFO(4)=1.
+C
+C  Do not change INFO(5), INFO(6), IWORK(1), or IWORK(2)
+C  unless you are going to restart the code.
+C
+C                 *** Following a completed task ***
+C  If
+C     IDID = 1, call the code again to continue the integration
+C                  another step in the direction of TOUT.
+C
+C     IDID = 2 or 3, define a new TOUT and call the code again.
+C                  TOUT must be different from T. You cannot change
+C                  the direction of integration without restarting.
+C
+C                 *** Following an interrupted task ***
+C               To show the code that you realize the task was
+C               interrupted and that you want to continue, you
+C               must take appropriate action and set INFO(1) = 1
+C  If
+C    IDID = -1, The code has taken about 500 steps.
+C                  If you want to continue, set INFO(1) = 1 and
+C                  call the code again. An additional 500 steps
+C                  will be allowed.
+C
+C    IDID = -2, The error tolerances RTOL, ATOL have been
+C                  increased to values the code estimates appropriate
+C                  for continuing. You may want to change them
+C                  yourself. If you are sure you want to continue
+C                  with relaxed error tolerances, set INFO(1)=1 and
+C                  call the code again.
+C
+C    IDID = -3, A solution component is zero and you set the
+C                  corresponding component of ATOL to zero. If you
+C                  are sure you want to continue, you must first
+C                  alter the error criterion to use positive values
+C                  for those components of ATOL corresponding to zero
+C                  solution components, then set INFO(1)=1 and call
+C                  the code again.
+C
+C    IDID = -4,-5  --- Cannot occur with this code.
+C
+C    IDID = -6, Repeated error test failures occurred on the
+C                  last attempted step in DDASSL. A singularity in the
+C                  solution may be present. If you are absolutely
+C                  certain you want to continue, you should restart
+C                  the integration. (Provide initial values of Y and
+C                  YPRIME which are consistent)
+C
+C    IDID = -7, Repeated convergence test failures occurred
+C                  on the last attempted step in DDASSL. An inaccurate
+C                  or ill-conditioned JACOBIAN may be the problem. If
+C                  you are absolutely certain you want to continue, you
+C                  should restart the integration.
+C
+C    IDID = -8, The matrix of partial derivatives is singular.
+C                  Some of your equations may be redundant.
+C                  DDASSL cannot solve the problem as stated.
+C                  It is possible that the redundant equations
+C                  could be removed, and then DDASSL could
+C                  solve the problem. It is also possible
+C                  that a solution to your problem either
+C                  does not exist or is not unique.
+C
+C    IDID = -9, DDASSL had multiple convergence test
+C                  failures, preceeded by multiple error
+C                  test failures, on the last attempted step.
+C                  It is possible that your problem
+C                  is ill-posed, and cannot be solved
+C                  using this code. Or, there may be a
+C                  discontinuity or a singularity in the
+C                  solution. If you are absolutely certain
+C                  you want to continue, you should restart
+C                  the integration.
+C
+C    IDID =-10, DDASSL had multiple convergence test failures
+C                  because IRES was equal to minus one.
+C                  If you are absolutely certain you want
+C                  to continue, you should restart the
+C                  integration.
+C
+C    IDID =-11, IRES=-2 was encountered, and control is being
+C                  returned to the calling program.
+C
+C    IDID =-12, DDASSL failed to compute the initial YPRIME.
+C                  This could happen because the initial
+C                  approximation to YPRIME was not very good, or
+C                  if a YPRIME consistent with the initial Y
+C                  does not exist. The problem could also be caused
+C                  by an inaccurate or singular iteration matrix.
+C
+C    IDID = -13,..,-32  --- Cannot occur with this code.
+C
+C
+C                 *** Following a terminated task ***
+C
+C  If IDID= -33, you cannot continue the solution of this problem.
+C                  An attempt to do so will result in your
+C                  run being terminated.
+C
+C
+C  -------- ERROR MESSAGES ---------------------------------------------
+C
+C      The SLATEC error print routine XERMSG is called in the event of
+C   unsuccessful completion of a task.  Most of these are treated as
+C   "recoverable errors", which means that (unless the user has directed
+C   otherwise) control will be returned to the calling program for
+C   possible action after the message has been printed.
+C
+C   In the event of a negative value of IDID other than -33, an appro-
+C   priate message is printed and the "error number" printed by XERMSG
+C   is the value of IDID.  There are quite a number of illegal input
+C   errors that can lead to a returned value IDID=-33.  The conditions
+C   and their printed "error numbers" are as follows:
+C
+C   Error number       Condition
+C
+C        1       Some element of INFO vector is not zero or one.
+C        2       NEQ .le. 0
+C        3       MAXORD not in range.
+C        4       LRW is less than the required length for RWORK.
+C        5       LIW is less than the required length for IWORK.
+C        6       Some element of RTOL is .lt. 0
+C        7       Some element of ATOL is .lt. 0
+C        8       All elements of RTOL and ATOL are zero.
+C        9       INFO(4)=1 and TSTOP is behind TOUT.
+C       10       HMAX .lt. 0.0
+C       11       TOUT is behind T.
+C       12       INFO(8)=1 and H0=0.0
+C       13       Some element of WT is .le. 0.0
+C       14       TOUT is too close to T to start integration.
+C       15       INFO(4)=1 and TSTOP is behind T.
+C       16       --( Not used in this version )--
+C       17       ML illegal.  Either .lt. 0 or .gt. NEQ
+C       18       MU illegal.  Either .lt. 0 or .gt. NEQ
+C       19       TOUT = T.
+C
+C   If DDASSL is called again without any action taken to remove the
+C   cause of an unsuccessful return, XERMSG will be called with a fatal
+C   error flag, which will cause unconditional termination of the
+C   program.  There are two such fatal errors:
+C
+C   Error number -998:  The last step was terminated with a negative
+C       value of IDID other than -33, and no appropriate action was
+C       taken.
+C
+C   Error number -999:  The previous call was terminated because of
+C       illegal input (IDID=-33) and there is illegal input in the
+C       present call, as well.  (Suspect infinite loop.)
+C
+C  ---------------------------------------------------------------------
+C
+C***REFERENCES  A DESCRIPTION OF DASSL: A DIFFERENTIAL/ALGEBRAIC
+C                 SYSTEM SOLVER, L. R. PETZOLD, SAND82-8637,
+C                 SANDIA NATIONAL LABORATORIES, SEPTEMBER 1982.
+C***ROUTINES CALLED  D1MACH, DDAINI, DDANRM, DDASTP, DDATRP, DDAWTS,
+C                    XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   830315  DATE WRITTEN
+C   880387  Code changes made.  All common statements have been
+C           replaced by a DATA statement, which defines pointers into
+C           RWORK, and PARAMETER statements which define pointers
+C           into IWORK.  As well the documentation has gone through
+C           grammatical changes.
+C   881005  The prologue has been changed to mixed case.
+C           The subordinate routines had revision dates changed to
+C           this date, although the documentation for these routines
+C           is all upper case.  No code changes.
+C   890511  Code changes made.  The DATA statement in the declaration
+C           section of DDASSL was replaced with a PARAMETER
+C           statement.  Also the statement S = 100.D0 was removed
+C           from the top of the Newton iteration in DDASTP.
+C           The subordinate routines had revision dates changed to
+C           this date.
+C   890517  The revision date syntax was replaced with the revision
+C           history syntax.  Also the "DECK" comment was added to
+C           the top of all subroutines.  These changes are consistent
+C           with new SLATEC guidelines.
+C           The subordinate routines had revision dates changed to
+C           this date.  No code changes.
+C   891013  Code changes made.
+C           Removed all occurrances of FLOAT or DBLE.  All operations
+C           are now performed with "mixed-mode" arithmetic.
+C           Also, specific function names were replaced with generic
+C           function names to be consistent with new SLATEC guidelines.
+C           In particular:
+C              Replaced DSQRT with SQRT everywhere.
+C              Replaced DABS with ABS everywhere.
+C              Replaced DMIN1 with MIN everywhere.
+C              Replaced MIN0 with MIN everywhere.
+C              Replaced DMAX1 with MAX everywhere.
+C              Replaced MAX0 with MAX everywhere.
+C              Replaced DSIGN with SIGN everywhere.
+C           Also replaced REVISION DATE with REVISION HISTORY in all
+C           subordinate routines.
+C  901004  Miscellaneous changes to prologue to complete conversion
+C          to SLATEC 4.0 format.  No code changes.  (F.N.Fritsch)
+C  901009  Corrected GAMS classification code and converted subsidiary
+C          routines to 4.0 format.  No code changes.  (F.N.Fritsch)
+C  901010  Converted XERRWV calls to XERMSG calls.  (R.Clemens,AFWL)
+C  901019  Code changes made.
+C          Merged SLATEC 4.0 changes with previous changes made
+C          by C. Ulrich.  Below is a history of the changes made by
+C          C. Ulrich. (Changes in subsidiary routines are implied
+C          by this history)
+C          891228  Bug was found and repaired inside the DDASSL
+C                  and DDAINI routines.  DDAINI was incorrectly
+C                  returning the initial T with Y and YPRIME
+C                  computed at T+H.  The routine now returns T+H
+C                  rather than the initial T.
+C                  Cosmetic changes made to DDASTP.
+C          900904  Three modifications were made to fix a bug (inside
+C                  DDASSL) re interpolation for continuation calls and
+C                  cases where TN is very close to TSTOP:
+C
+C                  1) In testing for whether H is too large, just
+C                     compare H to (TSTOP - TN), rather than
+C                     (TSTOP - TN) * (1-4*UROUND), and set H to
+C                     TSTOP - TN.  This will force DDASTP to step
+C                     exactly to TSTOP under certain situations
+C                     (i.e. when H returned from DDASTP would otherwise
+C                     take TN beyond TSTOP).
+C
+C                  2) Inside the DDASTP loop, interpolate exactly to
+C                     TSTOP if TN is very close to TSTOP (rather than
+C                     interpolating to within roundoff of TSTOP).
+C
+C                  3) Modified IDID description for IDID = 2 to say that
+C                     the solution is returned by stepping exactly to
+C                     TSTOP, rather than TOUT.  (In some cases the
+C                     solution is actually obtained by extrapolating
+C                     over a distance near unit roundoff to TSTOP,
+C                     but this small distance is deemed acceptable in
+C                     these circumstances.)
+C   901026  Added explicit declarations for all variables and minor
+C           cosmetic changes to prologue, removed unreferenced labels,
+C           and improved XERMSG calls.  (FNF)
+C   901030  Added ERROR MESSAGES section and reworked other sections to
+C           be of more uniform format.  (FNF)
+C   910624  Fixed minor bug related to HMAX (five lines ending in
+C           statement 526 in DDASSL).   (LRP)
+C
+C***END PROLOGUE  DDASSL
+C
+C**End
+C
+C     Declare arguments.
+C
+      INTEGER  NEQ, INFO(15), IDID, LRW, IWORK(*), LIW, IPAR(*)
+      DOUBLE PRECISION
+     *   T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), RWORK(*),
+     *   RPAR(*)
+      EXTERNAL  RES, JAC
+C
+C     Declare externals.
+C
+      EXTERNAL  D1MACH, DDAINI, DDANRM, DDASTP, DDATRP, DDAWTS, XERMSG
+      DOUBLE PRECISION  D1MACH, DDANRM
+C
+C     Declare local variables.
+C
+      INTEGER  I, ITEMP, LALPHA, LBETA, LCJ, LCJOLD, LCTF, LDELTA,
+     *   LENIW, LENPD, LENRW, LE, LETF, LGAMMA, LH, LHMAX, LHOLD, LIPVT,
+     *   LJCALC, LK, LKOLD, LIWM, LML, LMTYPE, LMU, LMXORD, LNJE, LNPD,
+     *   LNRE, LNS, LNST, LNSTL, LPD, LPHASE, LPHI, LPSI, LROUND, LS,
+     *   LSIGMA, LTN, LTSTOP, LWM, LWT, MBAND, MSAVE, MXORD, NPD, NTEMP,
+     *   NZFLG
+      DOUBLE PRECISION
+     *   ATOLI, H, HMAX, HMIN, HO, R, RH, RTOLI, TDIST, TN, TNEXT,
+     *   TSTOP, UROUND, YPNORM
+      LOGICAL  DONE
+C       Auxiliary variables for conversion of values to be included in
+C       error messages.
+      CHARACTER*8  XERN1, XERN2
+      CHARACTER*16 XERN3, XERN4
+C
+C     SET POINTERS INTO IWORK
+      PARAMETER (LML=1, LMU=2, LMXORD=3, LMTYPE=4, LNST=11,
+     *  LNRE=12, LNJE=13, LETF=14, LCTF=15, LNPD=16,
+     *  LIPVT=21, LJCALC=5, LPHASE=6, LK=7, LKOLD=8,
+     *  LNS=9, LNSTL=10, LIWM=1)
+C
+C     SET RELATIVE OFFSET INTO RWORK
+      PARAMETER (NPD=1)
+C
+C     SET POINTERS INTO RWORK
+      PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4,
+     *  LCJ=5, LCJOLD=6, LHOLD=7, LS=8, LROUND=9,
+     *  LALPHA=11, LBETA=17, LGAMMA=23,
+     *  LPSI=29, LSIGMA=35, LDELTA=41)
+C
+C***FIRST EXECUTABLE STATEMENT  DDASSL
+      IF(INFO(1).NE.0)GO TO 100
+C
+C-----------------------------------------------------------------------
+C     THIS BLOCK IS EXECUTED FOR THE INITIAL CALL ONLY.
+C     IT CONTAINS CHECKING OF INPUTS AND INITIALIZATIONS.
+C-----------------------------------------------------------------------
+C
+C     FIRST CHECK INFO ARRAY TO MAKE SURE ALL ELEMENTS OF INFO
+C     ARE EITHER ZERO OR ONE.
+      DO 10 I=2,11
+         IF(INFO(I).NE.0.AND.INFO(I).NE.1)GO TO 701
+10       CONTINUE
+C
+      IF(NEQ.LE.0)GO TO 702
+C
+C     CHECK AND COMPUTE MAXIMUM ORDER
+      MXORD=5
+      IF(INFO(9).EQ.0)GO TO 20
+         MXORD=IWORK(LMXORD)
+         IF(MXORD.LT.1.OR.MXORD.GT.5)GO TO 703
+20       IWORK(LMXORD)=MXORD
+C
+C     COMPUTE MTYPE,LENPD,LENRW.CHECK ML AND MU.
+      IF(INFO(6).NE.0)GO TO 40
+         LENPD=NEQ**2
+         LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD
+         IF(INFO(5).NE.0)GO TO 30
+            IWORK(LMTYPE)=2
+            GO TO 60
+30          IWORK(LMTYPE)=1
+            GO TO 60
+40    IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717
+      IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718
+      LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ
+      IF(INFO(5).NE.0)GO TO 50
+         IWORK(LMTYPE)=5
+         MBAND=IWORK(LML)+IWORK(LMU)+1
+         MSAVE=(NEQ/MBAND)+1
+         LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD+2*MSAVE
+         GO TO 60
+50       IWORK(LMTYPE)=4
+         LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD
+C
+C     CHECK LENGTHS OF RWORK AND IWORK
+60    LENIW=20+NEQ
+      IWORK(LNPD)=LENPD
+      IF(LRW.LT.LENRW)GO TO 704
+      IF(LIW.LT.LENIW)GO TO 705
+C
+C     CHECK TO SEE THAT TOUT IS DIFFERENT FROM T
+      IF(TOUT .EQ. T)GO TO 719
+C
+C     CHECK HMAX
+      IF(INFO(7).EQ.0)GO TO 70
+         HMAX=RWORK(LHMAX)
+         IF(HMAX.LE.0.0D0)GO TO 710
+70    CONTINUE
+C
+C     INITIALIZE COUNTERS
+      IWORK(LNST)=0
+      IWORK(LNRE)=0
+      IWORK(LNJE)=0
+C
+      IWORK(LNSTL)=0
+      IDID=1
+      GO TO 200
+C
+C-----------------------------------------------------------------------
+C     THIS BLOCK IS FOR CONTINUATION CALLS
+C     ONLY. HERE WE CHECK INFO(1),AND IF THE
+C     LAST STEP WAS INTERRUPTED WE CHECK WHETHER
+C     APPROPRIATE ACTION WAS TAKEN.
+C-----------------------------------------------------------------------
+C
+100   CONTINUE
+      IF(INFO(1).EQ.1)GO TO 110
+      IF(INFO(1).NE.-1)GO TO 701
+C
+C     IF WE ARE HERE, THE LAST STEP WAS INTERRUPTED
+C     BY AN ERROR CONDITION FROM DDASTP,AND
+C     APPROPRIATE ACTION WAS NOT TAKEN. THIS
+C     IS A FATAL ERROR.
+      WRITE (XERN1, '(I8)') IDID
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'THE LAST STEP TERMINATED WITH A NEGATIVE VALUE OF IDID = ' //
+     *   XERN1 // ' AND NO APPROPRIATE ACTION WAS TAKEN.  ' //
+     *   'RUN TERMINATED', -998, 2)
+      RETURN
+110   CONTINUE
+      IWORK(LNSTL)=IWORK(LNST)
+C
+C-----------------------------------------------------------------------
+C     THIS BLOCK IS EXECUTED ON ALL CALLS.
+C     THE ERROR TOLERANCE PARAMETERS ARE
+C     CHECKED, AND THE WORK ARRAY POINTERS
+C     ARE SET.
+C-----------------------------------------------------------------------
+C
+200   CONTINUE
+C     CHECK RTOL,ATOL
+      NZFLG=0
+      RTOLI=RTOL(1)
+      ATOLI=ATOL(1)
+      DO 210 I=1,NEQ
+         IF(INFO(2).EQ.1)RTOLI=RTOL(I)
+         IF(INFO(2).EQ.1)ATOLI=ATOL(I)
+         IF(RTOLI.GT.0.0D0.OR.ATOLI.GT.0.0D0)NZFLG=1
+         IF(RTOLI.LT.0.0D0)GO TO 706
+         IF(ATOLI.LT.0.0D0)GO TO 707
+210      CONTINUE
+      IF(NZFLG.EQ.0)GO TO 708
+C
+C     SET UP RWORK STORAGE.IWORK STORAGE IS FIXED
+C     IN DATA STATEMENT.
+      LE=LDELTA+NEQ
+      LWT=LE+NEQ
+      LPHI=LWT+NEQ
+      LPD=LPHI+(IWORK(LMXORD)+1)*NEQ
+      LWM=LPD
+      NTEMP=NPD+IWORK(LNPD)
+      IF(INFO(1).EQ.1)GO TO 400
+C
+C-----------------------------------------------------------------------
+C     THIS BLOCK IS EXECUTED ON THE INITIAL CALL
+C     ONLY. SET THE INITIAL STEP SIZE, AND
+C     THE ERROR WEIGHT VECTOR, AND PHI.
+C     COMPUTE INITIAL YPRIME, IF NECESSARY.
+C-----------------------------------------------------------------------
+C
+      TN=T
+      IDID=1
+C
+C     SET ERROR WEIGHT VECTOR WT
+      CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR)
+      DO 305 I = 1,NEQ
+         IF(RWORK(LWT+I-1).LE.0.0D0) GO TO 713
+305      CONTINUE
+C
+C     COMPUTE UNIT ROUNDOFF AND HMIN
+      UROUND = D1MACH(4)
+      RWORK(LROUND) = UROUND
+      HMIN = 4.0D0*UROUND*MAX(ABS(T),ABS(TOUT))
+C
+C     CHECK INITIAL INTERVAL TO SEE THAT IT IS LONG ENOUGH
+      TDIST = ABS(TOUT - T)
+      IF(TDIST .LT. HMIN) GO TO 714
+C
+C     CHECK HO, IF THIS WAS INPUT
+      IF (INFO(8) .EQ. 0) GO TO 310
+         HO = RWORK(LH)
+         IF ((TOUT - T)*HO .LT. 0.0D0) GO TO 711
+         IF (HO .EQ. 0.0D0) GO TO 712
+         GO TO 320
+310    CONTINUE
+C
+C     COMPUTE INITIAL STEPSIZE, TO BE USED BY EITHER
+C     DDASTP OR DDAINI, DEPENDING ON INFO(11)
+      HO = 0.001D0*TDIST
+      YPNORM = DDANRM(NEQ,YPRIME,RWORK(LWT),RPAR,IPAR)
+      IF (YPNORM .GT. 0.5D0/HO) HO = 0.5D0/YPNORM
+      HO = SIGN(HO,TOUT-T)
+C     ADJUST HO IF NECESSARY TO MEET HMAX BOUND
+320   IF (INFO(7) .EQ. 0) GO TO 330
+         RH = ABS(HO)/RWORK(LHMAX)
+         IF (RH .GT. 1.0D0) HO = HO/RH
+C     COMPUTE TSTOP, IF APPLICABLE
+330   IF (INFO(4) .EQ. 0) GO TO 340
+         TSTOP = RWORK(LTSTOP)
+         IF ((TSTOP - T)*HO .LT. 0.0D0) GO TO 715
+         IF ((T + HO - TSTOP)*HO .GT. 0.0D0) HO = TSTOP - T
+         IF ((TSTOP - TOUT)*HO .LT. 0.0D0) GO TO 709
+C
+C     COMPUTE INITIAL DERIVATIVE, UPDATING TN AND Y, IF APPLICABLE
+340   IF (INFO(11) .EQ. 0) GO TO 350
+      CALL DDAINI(TN,Y,YPRIME,NEQ,
+     *  RES,JAC,HO,RWORK(LWT),IDID,RPAR,IPAR,
+     *  RWORK(LPHI),RWORK(LDELTA),RWORK(LE),
+     *  RWORK(LWM),IWORK(LIWM),HMIN,RWORK(LROUND),
+     *  INFO(10),NTEMP)
+      IF (IDID .LT. 0) GO TO 390
+C
+C     LOAD H WITH HO.  STORE H IN RWORK(LH)
+350   H = HO
+      RWORK(LH) = H
+C
+C     LOAD Y AND H*YPRIME INTO PHI(*,1) AND PHI(*,2)
+      ITEMP = LPHI + NEQ
+      DO 370 I = 1,NEQ
+         RWORK(LPHI + I - 1) = Y(I)
+370      RWORK(ITEMP + I - 1) = H*YPRIME(I)
+C
+390   GO TO 500
+C
+C-------------------------------------------------------
+C     THIS BLOCK IS FOR CONTINUATION CALLS ONLY. ITS
+C     PURPOSE IS TO CHECK STOP CONDITIONS BEFORE
+C     TAKING A STEP.
+C     ADJUST H IF NECESSARY TO MEET HMAX BOUND
+C-------------------------------------------------------
+C
+400   CONTINUE
+      UROUND=RWORK(LROUND)
+      DONE = .FALSE.
+      TN=RWORK(LTN)
+      H=RWORK(LH)
+      IF(INFO(7) .EQ. 0) GO TO 410
+         RH = ABS(H)/RWORK(LHMAX)
+         IF(RH .GT. 1.0D0) H = H/RH
+410   CONTINUE
+      IF(T .EQ. TOUT) GO TO 719
+      IF((T - TOUT)*H .GT. 0.0D0) GO TO 711
+      IF(INFO(4) .EQ. 1) GO TO 430
+      IF(INFO(3) .EQ. 1) GO TO 420
+      IF((TN-TOUT)*H.LT.0.0D0)GO TO 490
+      CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
+     *  RWORK(LPHI),RWORK(LPSI))
+      T=TOUT
+      IDID = 3
+      DONE = .TRUE.
+      GO TO 490
+420   IF((TN-T)*H .LE. 0.0D0) GO TO 490
+      IF((TN - TOUT)*H .GT. 0.0D0) GO TO 425
+      CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD),
+     *  RWORK(LPHI),RWORK(LPSI))
+      T = TN
+      IDID = 1
+      DONE = .TRUE.
+      GO TO 490
+425   CONTINUE
+      CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
+     *  RWORK(LPHI),RWORK(LPSI))
+      T = TOUT
+      IDID = 3
+      DONE = .TRUE.
+      GO TO 490
+430   IF(INFO(3) .EQ. 1) GO TO 440
+      TSTOP=RWORK(LTSTOP)
+      IF((TN-TSTOP)*H.GT.0.0D0) GO TO 715
+      IF((TSTOP-TOUT)*H.LT.0.0D0)GO TO 709
+      IF((TN-TOUT)*H.LT.0.0D0)GO TO 450
+      CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
+     *   RWORK(LPHI),RWORK(LPSI))
+      T=TOUT
+      IDID = 3
+      DONE = .TRUE.
+      GO TO 490
+440   TSTOP = RWORK(LTSTOP)
+      IF((TN-TSTOP)*H .GT. 0.0D0) GO TO 715
+      IF((TSTOP-TOUT)*H .LT. 0.0D0) GO TO 709
+      IF((TN-T)*H .LE. 0.0D0) GO TO 450
+      IF((TN - TOUT)*H .GT. 0.0D0) GO TO 445
+      CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD),
+     *  RWORK(LPHI),RWORK(LPSI))
+      T = TN
+      IDID = 1
+      DONE = .TRUE.
+      GO TO 490
+445   CONTINUE
+      CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD),
+     *  RWORK(LPHI),RWORK(LPSI))
+      T = TOUT
+      IDID = 3
+      DONE = .TRUE.
+      GO TO 490
+450   CONTINUE
+C     CHECK WHETHER WE ARE WITHIN ROUNDOFF OF TSTOP
+      IF(ABS(TN-TSTOP).GT.100.0D0*UROUND*
+     *   (ABS(TN)+ABS(H)))GO TO 460
+      CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD),
+     *  RWORK(LPHI),RWORK(LPSI))
+      IDID=2
+      T=TSTOP
+      DONE = .TRUE.
+      GO TO 490
+460   TNEXT=TN+H
+      IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 490
+      H=TSTOP-TN
+      RWORK(LH)=H
+C
+490   IF (DONE) GO TO 580
+C
+C-------------------------------------------------------
+C     THE NEXT BLOCK CONTAINS THE CALL TO THE
+C     ONE-STEP INTEGRATOR DDASTP.
+C     THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS.
+C     CHECK FOR TOO MANY STEPS.
+C     UPDATE WT.
+C     CHECK FOR TOO MUCH ACCURACY REQUESTED.
+C     COMPUTE MINIMUM STEPSIZE.
+C-------------------------------------------------------
+C
+500   CONTINUE
+C     CHECK FOR FAILURE TO COMPUTE INITIAL YPRIME
+      IF (IDID .EQ. -12) GO TO 527
+C
+C     CHECK FOR TOO MANY STEPS
+      IF((IWORK(LNST)-IWORK(LNSTL)).LT.500)
+     *   GO TO 510
+           IDID=-1
+           GO TO 527
+C
+C     UPDATE WT
+510   CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI),
+     *  RWORK(LWT),RPAR,IPAR)
+      DO 520 I=1,NEQ
+         IF(RWORK(I+LWT-1).GT.0.0D0)GO TO 520
+           IDID=-3
+           GO TO 527
+520   CONTINUE
+C
+C     TEST FOR TOO MUCH ACCURACY REQUESTED.
+      R=DDANRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)*
+     *   100.0D0*UROUND
+      IF(R.LE.1.0D0)GO TO 525
+C     MULTIPLY RTOL AND ATOL BY R AND RETURN
+      IF(INFO(2).EQ.1)GO TO 523
+           RTOL(1)=R*RTOL(1)
+           ATOL(1)=R*ATOL(1)
+           IDID=-2
+           GO TO 527
+523   DO 524 I=1,NEQ
+           RTOL(I)=R*RTOL(I)
+524        ATOL(I)=R*ATOL(I)
+      IDID=-2
+      GO TO 527
+525   CONTINUE
+C
+C     COMPUTE MINIMUM STEPSIZE
+      HMIN=4.0D0*UROUND*MAX(ABS(TN),ABS(TOUT))
+C
+C     TEST H VS. HMAX
+      IF (INFO(7) .EQ. 0) GO TO 526
+         RH = ABS(H)/RWORK(LHMAX)
+         IF (RH .GT. 1.0D0) H = H/RH
+526   CONTINUE           
+C
+      CALL DDASTP(TN,Y,YPRIME,NEQ,
+     *   RES,JAC,H,RWORK(LWT),INFO(1),IDID,RPAR,IPAR,
+     *   RWORK(LPHI),RWORK(LDELTA),RWORK(LE),
+     *   RWORK(LWM),IWORK(LIWM),
+     *   RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA),
+     *   RWORK(LPSI),RWORK(LSIGMA),
+     *   RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),
+     *   RWORK(LS),HMIN,RWORK(LROUND),
+     *   IWORK(LPHASE),IWORK(LJCALC),IWORK(LK),
+     *   IWORK(LKOLD),IWORK(LNS),INFO(10),NTEMP)
+527   IF(IDID.LT.0)GO TO 600
+C
+C--------------------------------------------------------
+C     THIS BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN
+C     FROM DDASTP (IDID=1).  TEST FOR STOP CONDITIONS.
+C--------------------------------------------------------
+C
+      IF(INFO(4).NE.0)GO TO 540
+           IF(INFO(3).NE.0)GO TO 530
+             IF((TN-TOUT)*H.LT.0.0D0)GO TO 500
+             CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,
+     *         IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
+             IDID=3
+             T=TOUT
+             GO TO 580
+530          IF((TN-TOUT)*H.GE.0.0D0)GO TO 535
+             T=TN
+             IDID=1
+             GO TO 580
+535          CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,
+     *         IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
+             IDID=3
+             T=TOUT
+             GO TO 580
+540   IF(INFO(3).NE.0)GO TO 550
+      IF((TN-TOUT)*H.LT.0.0D0)GO TO 542
+         CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,
+     *     IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
+         T=TOUT
+         IDID=3
+         GO TO 580
+542   IF(ABS(TN-TSTOP).LE.100.0D0*UROUND*
+     *   (ABS(TN)+ABS(H)))GO TO 545
+      TNEXT=TN+H
+      IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 500
+      H=TSTOP-TN
+      GO TO 500
+545   CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,
+     *  IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
+      IDID=2
+      T=TSTOP
+      GO TO 580
+550   IF((TN-TOUT)*H.GE.0.0D0)GO TO 555
+      IF(ABS(TN-TSTOP).LE.100.0D0*UROUND*(ABS(TN)+ABS(H)))GO TO 552
+      T=TN
+      IDID=1
+      GO TO 580
+552   CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,
+     *  IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
+      IDID=2
+      T=TSTOP
+      GO TO 580
+555   CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,
+     *   IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI))
+      T=TOUT
+      IDID=3
+      GO TO 580
+C
+C--------------------------------------------------------
+C     ALL SUCCESSFUL RETURNS FROM DDASSL ARE MADE FROM
+C     THIS BLOCK.
+C--------------------------------------------------------
+C
+580   CONTINUE
+      RWORK(LTN)=TN
+      RWORK(LH)=H
+      RETURN
+C
+C-----------------------------------------------------------------------
+C     THIS BLOCK HANDLES ALL UNSUCCESSFUL
+C     RETURNS OTHER THAN FOR ILLEGAL INPUT.
+C-----------------------------------------------------------------------
+C
+600   CONTINUE
+      ITEMP=-IDID
+      GO TO (610,620,630,690,690,640,650,660,670,675,
+     *  680,685), ITEMP
+C
+C     THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE
+C     REACHING TOUT
+610   WRITE (XERN3, '(1P,D15.6)') TN
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'AT CURRENT T = ' // XERN3 // ' 500 STEPS TAKEN ON THIS ' //
+     *   'CALL BEFORE REACHING TOUT', IDID, 1)
+      GO TO 690
+C
+C     TOO MUCH ACCURACY FOR MACHINE PRECISION
+620   WRITE (XERN3, '(1P,D15.6)') TN
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'AT T = ' // XERN3 // ' TOO MUCH ACCURACY REQUESTED FOR ' //
+     *   'PRECISION OF MACHINE. RTOL AND ATOL WERE INCREASED TO ' //
+     *   'APPROPRIATE VALUES', IDID, 1)
+      GO TO 690
+C
+C     WT(I) .LE. 0.0 FOR SOME I (NOT AT START OF PROBLEM)
+630   WRITE (XERN3, '(1P,D15.6)') TN
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'AT T = ' // XERN3 // ' SOME ELEMENT OF WT HAS BECOME .LE. ' //
+     *   '0.0', IDID, 1)
+      GO TO 690
+C
+C     ERROR TEST FAILED REPEATEDLY OR WITH H=HMIN
+640   WRITE (XERN3, '(1P,D15.6)') TN
+      WRITE (XERN4, '(1P,D15.6)') H
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
+     *   ' THE ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN',
+     *   IDID, 1)
+      GO TO 690
+C
+C     CORRECTOR CONVERGENCE FAILED REPEATEDLY OR WITH H=HMIN
+650   WRITE (XERN3, '(1P,D15.6)') TN
+      WRITE (XERN4, '(1P,D15.6)') H
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
+     *   ' THE CORRECTOR FAILED TO CONVERGE REPEATEDLY OR WITH ' //
+     *   'ABS(H)=HMIN', IDID, 1)
+      GO TO 690
+C
+C     THE ITERATION MATRIX IS SINGULAR
+660   WRITE (XERN3, '(1P,D15.6)') TN
+      WRITE (XERN4, '(1P,D15.6)') H
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
+     *   ' THE ITERATION MATRIX IS SINGULAR', IDID, 1)
+      GO TO 690
+C
+C     CORRECTOR FAILURE PRECEEDED BY ERROR TEST FAILURES.
+670   WRITE (XERN3, '(1P,D15.6)') TN
+      WRITE (XERN4, '(1P,D15.6)') H
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
+     *   ' THE CORRECTOR COULD NOT CONVERGE.  ALSO, THE ERROR TEST ' //
+     *   'FAILED REPEATEDLY.', IDID, 1)
+      GO TO 690
+C
+C     CORRECTOR FAILURE BECAUSE IRES = -1
+675   WRITE (XERN3, '(1P,D15.6)') TN
+      WRITE (XERN4, '(1P,D15.6)') H
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
+     *   ' THE CORRECTOR COULD NOT CONVERGE BECAUSE IRES WAS EQUAL ' //
+     *   'TO MINUS ONE', IDID, 1)
+      GO TO 690
+C
+C     FAILURE BECAUSE IRES = -2
+680   WRITE (XERN3, '(1P,D15.6)') TN
+      WRITE (XERN4, '(1P,D15.6)') H
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
+     *   ' IRES WAS EQUAL TO MINUS TWO', IDID, 1)
+      GO TO 690
+C
+C     FAILED TO COMPUTE INITIAL YPRIME
+685   WRITE (XERN3, '(1P,D15.6)') TN
+      WRITE (XERN4, '(1P,D15.6)') HO
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 //
+     *   ' THE INITIAL YPRIME COULD NOT BE COMPUTED', IDID, 1)
+      GO TO 690
+C
+690   CONTINUE
+      INFO(1)=-1
+      T=TN
+      RWORK(LTN)=TN
+      RWORK(LH)=H
+      RETURN
+C
+C-----------------------------------------------------------------------
+C     THIS BLOCK HANDLES ALL ERROR RETURNS DUE
+C     TO ILLEGAL INPUT, AS DETECTED BEFORE CALLING
+C     DDASTP. FIRST THE ERROR MESSAGE ROUTINE IS
+C     CALLED. IF THIS HAPPENS TWICE IN
+C     SUCCESSION, EXECUTION IS TERMINATED
+C
+C-----------------------------------------------------------------------
+701   CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'SOME ELEMENT OF INFO VECTOR IS NOT ZERO OR ONE', 1, 1)
+      GO TO 750
+C
+702   WRITE (XERN1, '(I8)') NEQ
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'NEQ = ' // XERN1 // ' .LE. 0', 2, 1)
+      GO TO 750
+C
+703   WRITE (XERN1, '(I8)') MXORD
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'MAXORD = ' // XERN1 // ' NOT IN RANGE', 3, 1)
+      GO TO 750
+C
+704   WRITE (XERN1, '(I8)') LENRW
+      WRITE (XERN2, '(I8)') LRW
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'RWORK LENGTH NEEDED, LENRW = ' // XERN1 //
+     *   ', EXCEEDS LRW = ' // XERN2, 4, 1)
+      GO TO 750
+C
+705   WRITE (XERN1, '(I8)') LENIW
+      WRITE (XERN2, '(I8)') LIW
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'IWORK LENGTH NEEDED, LENIW = ' // XERN1 //
+     *   ', EXCEEDS LIW = ' // XERN2, 5, 1)
+      GO TO 750
+C
+706   CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'SOME ELEMENT OF RTOL IS .LT. 0', 6, 1)
+      GO TO 750
+C
+707   CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'SOME ELEMENT OF ATOL IS .LT. 0', 7, 1)
+      GO TO 750
+C
+708   CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'ALL ELEMENTS OF RTOL AND ATOL ARE ZERO', 8, 1)
+      GO TO 750
+C
+709   WRITE (XERN3, '(1P,D15.6)') TSTOP
+      WRITE (XERN4, '(1P,D15.6)') TOUT
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'INFO(4) = 1 AND TSTOP = ' // XERN3 // ' BEHIND TOUT = ' //
+     *   XERN4, 9, 1)
+      GO TO 750
+C
+710   WRITE (XERN3, '(1P,D15.6)') HMAX
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'HMAX = ' // XERN3 // ' .LT. 0.0', 10, 1)
+      GO TO 750
+C
+711   WRITE (XERN3, '(1P,D15.6)') TOUT
+      WRITE (XERN4, '(1P,D15.6)') T
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'TOUT = ' // XERN3 // ' BEHIND T = ' // XERN4, 11, 1)
+      GO TO 750
+C
+712   CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'INFO(8)=1 AND H0=0.0', 12, 1)
+      GO TO 750
+C
+713   CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'SOME ELEMENT OF WT IS .LE. 0.0', 13, 1)
+      GO TO 750
+C
+714   WRITE (XERN3, '(1P,D15.6)') TOUT
+      WRITE (XERN4, '(1P,D15.6)') T
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'TOUT = ' // XERN3 // ' TOO CLOSE TO T = ' // XERN4 //
+     *   ' TO START INTEGRATION', 14, 1)
+      GO TO 750
+C
+715   WRITE (XERN3, '(1P,D15.6)') TSTOP
+      WRITE (XERN4, '(1P,D15.6)') T
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'INFO(4)=1 AND TSTOP = ' // XERN3 // ' BEHIND T = ' // XERN4,
+     *   15, 1)
+      GO TO 750
+C
+717   WRITE (XERN1, '(I8)') IWORK(LML)
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'ML = ' // XERN1 // ' ILLEGAL.  EITHER .LT. 0 OR .GT. NEQ',
+     *   17, 1)
+      GO TO 750
+C
+718   WRITE (XERN1, '(I8)') IWORK(LMU)
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *   'MU = ' // XERN1 // ' ILLEGAL.  EITHER .LT. 0 OR .GT. NEQ',
+     *   18, 1)
+      GO TO 750
+C
+719   WRITE (XERN3, '(1P,D15.6)') TOUT
+      CALL XERMSG ('SLATEC', 'DDASSL',
+     *  'TOUT = T = ' // XERN3, 19, 1)
+      GO TO 750
+C
+750   IDID=-33
+      IF(INFO(1).EQ.-1) THEN
+         CALL XERMSG ('SLATEC', 'DDASSL',
+     *      'REPEATED OCCURRENCES OF ILLEGAL INPUT$$' //
+     *      'RUN TERMINATED. APPARENT INFINITE LOOP', -999, 2)
+      ENDIF
+C
+      INFO(1)=-1
+      RETURN
+C-----------END OF SUBROUTINE DDASSL------------------------------------
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/dassl/ddastp.f
@@ -0,0 +1,612 @@
+      SUBROUTINE DDASTP (X, Y, YPRIME, NEQ, RES, JAC, H, WT, JSTART,
+     +   IDID, RPAR, IPAR, PHI, DELTA, E, WM, IWM, ALPHA, BETA, GAMMA,
+     +   PSI, SIGMA, CJ, CJOLD, HOLD, S, HMIN, UROUND, IPHASE, JCALC,
+     +   K, KOLD, NS, NONNEG, NTEMP)
+C***BEGIN PROLOGUE  DDASTP
+C***SUBSIDIARY
+C***PURPOSE  Perform one step of the DDASSL integration.
+C***LIBRARY   SLATEC (DASSL)
+C***TYPE      DOUBLE PRECISION (SDASTP-S, DDASTP-D)
+C***AUTHOR  PETZOLD, LINDA R., (LLNL)
+C***DESCRIPTION
+C-----------------------------------------------------------------------
+C     DDASTP SOLVES A SYSTEM OF DIFFERENTIAL/
+C     ALGEBRAIC EQUATIONS OF THE FORM
+C     G(X,Y,YPRIME) = 0,  FOR ONE STEP (NORMALLY
+C     FROM X TO X+H).
+C
+C     THE METHODS USED ARE MODIFIED DIVIDED
+C     DIFFERENCE,FIXED LEADING COEFFICIENT
+C     FORMS OF BACKWARD DIFFERENTIATION
+C     FORMULAS. THE CODE ADJUSTS THE STEPSIZE
+C     AND ORDER TO CONTROL THE LOCAL ERROR PER
+C     STEP.
+C
+C
+C     THE PARAMETERS REPRESENT
+C     X  --        INDEPENDENT VARIABLE
+C     Y  --        SOLUTION VECTOR AT X
+C     YPRIME --    DERIVATIVE OF SOLUTION VECTOR
+C                  AFTER SUCCESSFUL STEP
+C     NEQ --       NUMBER OF EQUATIONS TO BE INTEGRATED
+C     RES --       EXTERNAL USER-SUPPLIED SUBROUTINE
+C                  TO EVALUATE THE RESIDUAL.  THE CALL IS
+C                  CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
+C                  X,Y,YPRIME ARE INPUT.  DELTA IS OUTPUT.
+C                  ON INPUT, IRES=0.  RES SHOULD ALTER IRES ONLY
+C                  IF IT ENCOUNTERS AN ILLEGAL VALUE OF Y OR A
+C                  STOP CONDITION.  SET IRES=-1 IF AN INPUT VALUE
+C                  OF Y IS ILLEGAL, AND DDASTP WILL TRY TO SOLVE
+C                  THE PROBLEM WITHOUT GETTING IRES = -1.  IF
+C                  IRES=-2, DDASTP RETURNS CONTROL TO THE CALLING
+C                  PROGRAM WITH IDID = -11.
+C     JAC --       EXTERNAL USER-SUPPLIED ROUTINE TO EVALUATE
+C                  THE ITERATION MATRIX (THIS IS OPTIONAL)
+C                  THE CALL IS OF THE FORM
+C                  CALL JAC(X,Y,YPRIME,PD,CJ,RPAR,IPAR)
+C                  PD IS THE MATRIX OF PARTIAL DERIVATIVES,
+C                  PD=DG/DY+CJ*DG/DYPRIME
+C     H --         APPROPRIATE STEP SIZE FOR NEXT STEP.
+C                  NORMALLY DETERMINED BY THE CODE
+C     WT --        VECTOR OF WEIGHTS FOR ERROR CRITERION.
+C     JSTART --    INTEGER VARIABLE SET 0 FOR
+C                  FIRST STEP, 1 OTHERWISE.
+C     IDID --      COMPLETION CODE WITH THE FOLLOWING MEANINGS:
+C                  IDID= 1 -- THE STEP WAS COMPLETED SUCCESSFULLY
+C                  IDID=-6 -- THE ERROR TEST FAILED REPEATEDLY
+C                  IDID=-7 -- THE CORRECTOR COULD NOT CONVERGE
+C                  IDID=-8 -- THE ITERATION MATRIX IS SINGULAR
+C                  IDID=-9 -- THE CORRECTOR COULD NOT CONVERGE.
+C                             THERE WERE REPEATED ERROR TEST
+C                             FAILURES ON THIS STEP.
+C                  IDID=-10-- THE CORRECTOR COULD NOT CONVERGE
+C                             BECAUSE IRES WAS EQUAL TO MINUS ONE
+C                  IDID=-11-- IRES EQUAL TO -2 WAS ENCOUNTERED,
+C                             AND CONTROL IS BEING RETURNED TO
+C                             THE CALLING PROGRAM
+C     RPAR,IPAR -- REAL AND INTEGER PARAMETER ARRAYS THAT
+C                  ARE USED FOR COMMUNICATION BETWEEN THE
+C                  CALLING PROGRAM AND EXTERNAL USER ROUTINES
+C                  THEY ARE NOT ALTERED BY DDASTP
+C     PHI --       ARRAY OF DIVIDED DIFFERENCES USED BY
+C                  DDASTP. THE LENGTH IS NEQ*(K+1),WHERE
+C                  K IS THE MAXIMUM ORDER
+C     DELTA,E --   WORK VECTORS FOR DDASTP OF LENGTH NEQ
+C     WM,IWM --    REAL AND INTEGER ARRAYS STORING
+C                  MATRIX INFORMATION SUCH AS THE MATRIX
+C                  OF PARTIAL DERIVATIVES,PERMUTATION
+C                  VECTOR,AND VARIOUS OTHER INFORMATION.
+C
+C     THE OTHER PARAMETERS ARE INFORMATION
+C     WHICH IS NEEDED INTERNALLY BY DDASTP TO
+C     CONTINUE FROM STEP TO STEP.
+C
+C-----------------------------------------------------------------------
+C***ROUTINES CALLED  DDAJAC, DDANRM, DDASLV, DDATRP
+C***REVISION HISTORY  (YYMMDD)
+C   830315  DATE WRITTEN
+C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
+C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
+C   901026  Added explicit declarations for all variables and minor
+C           cosmetic changes to prologue.  (FNF)
+C***END PROLOGUE  DDASTP
+C
+      INTEGER  NEQ, JSTART, IDID, IPAR(*), IWM(*), IPHASE, JCALC, K,
+     *   KOLD, NS, NONNEG, NTEMP
+      DOUBLE PRECISION
+     *   X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*),
+     *   E(*), WM(*), ALPHA(*), BETA(*), GAMMA(*), PSI(*), SIGMA(*), CJ,
+     *   CJOLD, HOLD, S, HMIN, UROUND
+      EXTERNAL  RES, JAC
+C
+      EXTERNAL  DDAJAC, DDANRM, DDASLV, DDATRP
+      DOUBLE PRECISION  DDANRM
+C
+      INTEGER  I, IER, IRES, J, J1, KDIFF, KM1, KNEW, KP1, KP2, LCTF,
+     *   LETF, LMXORD, LNJE, LNRE, LNST, M, MAXIT, NCF, NEF, NSF, NSP1
+      DOUBLE PRECISION
+     *   ALPHA0, ALPHAS, CJLAST, CK, DELNRM, ENORM, ERK, ERKM1,
+     *   ERKM2, ERKP1, ERR, EST, HNEW, OLDNRM, PNORM, R, RATE, TEMP1,
+     *   TEMP2, TERK, TERKM1, TERKM2, TERKP1, XOLD, XRATE
+      LOGICAL  CONVGD
+C
+      PARAMETER (LMXORD=3)
+      PARAMETER (LNST=11)
+      PARAMETER (LNRE=12)
+      PARAMETER (LNJE=13)
+      PARAMETER (LETF=14)
+      PARAMETER (LCTF=15)
+C
+      DATA MAXIT/4/
+      DATA XRATE/0.25D0/
+C
+C
+C
+C
+C
+C-----------------------------------------------------------------------
+C     BLOCK 1.
+C     INITIALIZE. ON THE FIRST CALL,SET
+C     THE ORDER TO 1 AND INITIALIZE
+C     OTHER VARIABLES.
+C-----------------------------------------------------------------------
+C
+C     INITIALIZATIONS FOR ALL CALLS
+C***FIRST EXECUTABLE STATEMENT  DDASTP
+      IDID=1
+      XOLD=X
+      NCF=0
+      NSF=0
+      NEF=0
+      IF(JSTART .NE. 0) GO TO 120
+C
+C     IF THIS IS THE FIRST STEP,PERFORM
+C     OTHER INITIALIZATIONS
+      IWM(LETF) = 0
+      IWM(LCTF) = 0
+      K=1
+      KOLD=0
+      HOLD=0.0D0
+      JSTART=1
+      PSI(1)=H
+      CJOLD = 1.0D0/H
+      CJ = CJOLD
+      S = 100.D0
+      JCALC = -1
+      DELNRM=1.0D0
+      IPHASE = 0
+      NS=0
+120   CONTINUE
+C
+C
+C
+C
+C
+C-----------------------------------------------------------------------
+C     BLOCK 2
+C     COMPUTE COEFFICIENTS OF FORMULAS FOR
+C     THIS STEP.
+C-----------------------------------------------------------------------
+200   CONTINUE
+      KP1=K+1
+      KP2=K+2
+      KM1=K-1
+      XOLD=X
+      IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0
+      NS=MIN(NS+1,KOLD+2)
+      NSP1=NS+1
+      IF(KP1 .LT. NS)GO TO 230
+C
+      BETA(1)=1.0D0
+      ALPHA(1)=1.0D0
+      TEMP1=H
+      GAMMA(1)=0.0D0
+      SIGMA(1)=1.0D0
+      DO 210 I=2,KP1
+         TEMP2=PSI(I-1)
+         PSI(I-1)=TEMP1
+         BETA(I)=BETA(I-1)*PSI(I-1)/TEMP2
+         TEMP1=TEMP2+H
+         ALPHA(I)=H/TEMP1
+         SIGMA(I)=(I-1)*SIGMA(I-1)*ALPHA(I)
+         GAMMA(I)=GAMMA(I-1)+ALPHA(I-1)/H
+210      CONTINUE
+      PSI(KP1)=TEMP1
+230   CONTINUE
+C
+C     COMPUTE ALPHAS, ALPHA0
+      ALPHAS = 0.0D0
+      ALPHA0 = 0.0D0
+      DO 240 I = 1,K
+        ALPHAS = ALPHAS - 1.0D0/I
+        ALPHA0 = ALPHA0 - ALPHA(I)
+240     CONTINUE
+C
+C     COMPUTE LEADING COEFFICIENT CJ
+      CJLAST = CJ
+      CJ = -ALPHAS/H
+C
+C     COMPUTE VARIABLE STEPSIZE ERROR COEFFICIENT CK
+      CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0)
+      CK = MAX(CK,ALPHA(KP1))
+C
+C     DECIDE WHETHER NEW JACOBIAN IS NEEDED
+      TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE)
+      TEMP2 = 1.0D0/TEMP1
+      IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1
+      IF (CJ .NE. CJLAST) S = 100.D0
+C
+C     CHANGE PHI TO PHI STAR
+      IF(KP1 .LT. NSP1) GO TO 280
+      DO 270 J=NSP1,KP1
+         DO 260 I=1,NEQ
+260         PHI(I,J)=BETA(J)*PHI(I,J)
+270      CONTINUE
+280   CONTINUE
+C
+C     UPDATE TIME
+      X=X+H
+C
+C
+C
+C
+C
+C-----------------------------------------------------------------------
+C     BLOCK 3
+C     PREDICT THE SOLUTION AND DERIVATIVE,
+C     AND SOLVE THE CORRECTOR EQUATION
+C-----------------------------------------------------------------------
+C
+C     FIRST,PREDICT THE SOLUTION AND DERIVATIVE
+300   CONTINUE
+      DO 310 I=1,NEQ
+         Y(I)=PHI(I,1)
+310      YPRIME(I)=0.0D0
+      DO 330 J=2,KP1
+         DO 320 I=1,NEQ
+            Y(I)=Y(I)+PHI(I,J)
+320         YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J)
+330   CONTINUE
+      PNORM = DDANRM (NEQ,Y,WT,RPAR,IPAR)
+C
+C
+C
+C     SOLVE THE CORRECTOR EQUATION USING A
+C     MODIFIED NEWTON SCHEME.
+      CONVGD= .TRUE.
+      M=0
+      IWM(LNRE)=IWM(LNRE)+1
+      IRES = 0
+      CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR)
+      IF (IRES .LT. 0) GO TO 380
+C
+C
+C     IF INDICATED,REEVALUATE THE
+C     ITERATION MATRIX PD = DG/DY + CJ*DG/DYPRIME
+C     (WHERE G(X,Y,YPRIME)=0). SET
+C     JCALC TO 0 AS AN INDICATOR THAT
+C     THIS HAS BEEN DONE.
+      IF(JCALC .NE. -1)GO TO 340
+      IWM(LNJE)=IWM(LNJE)+1
+      JCALC=0
+      CALL DDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H,
+     * IER,WT,E,WM,IWM,RES,IRES,UROUND,JAC,RPAR,
+     * IPAR,NTEMP)
+      CJOLD=CJ
+      S = 100.D0
+      IF (IRES .LT. 0) GO TO 380
+      IF(IER .NE. 0)GO TO 380
+      NSF=0
+C
+C
+C     INITIALIZE THE ERROR ACCUMULATION VECTOR E.
+340   CONTINUE
+      DO 345 I=1,NEQ
+345      E(I)=0.0D0
+C
+C
+C     CORRECTOR LOOP.
+350   CONTINUE
+C
+C     MULTIPLY RESIDUAL BY TEMP1 TO ACCELERATE CONVERGENCE
+      TEMP1 = 2.0D0/(1.0D0 + CJ/CJOLD)
+      DO 355 I = 1,NEQ
+355     DELTA(I) = DELTA(I) * TEMP1
+C
+C     COMPUTE A NEW ITERATE (BACK-SUBSTITUTION).
+C     STORE THE CORRECTION IN DELTA.
+      CALL DDASLV(NEQ,DELTA,WM,IWM)
+C
+C     UPDATE Y,E,AND YPRIME
+      DO 360 I=1,NEQ
+         Y(I)=Y(I)-DELTA(I)
+         E(I)=E(I)-DELTA(I)
+360      YPRIME(I)=YPRIME(I)-CJ*DELTA(I)
+C
+C     TEST FOR CONVERGENCE OF THE ITERATION
+      DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
+      IF (DELNRM .LE. 100.D0*UROUND*PNORM) GO TO 375
+      IF (M .GT. 0) GO TO 365
+         OLDNRM = DELNRM
+         GO TO 367
+365   RATE = (DELNRM/OLDNRM)**(1.0D0/M)
+      IF (RATE .GT. 0.90D0) GO TO 370
+      S = RATE/(1.0D0 - RATE)
+367   IF (S*DELNRM .LE. 0.33D0) GO TO 375
+C
+C     THE CORRECTOR HAS NOT YET CONVERGED.
+C     UPDATE M AND TEST WHETHER THE
+C     MAXIMUM NUMBER OF ITERATIONS HAVE
+C     BEEN TRIED.
+      M=M+1
+      IF(M.GE.MAXIT)GO TO 370
+C
+C     EVALUATE THE RESIDUAL
+C     AND GO BACK TO DO ANOTHER ITERATION
+      IWM(LNRE)=IWM(LNRE)+1
+      IRES = 0
+      CALL RES(X,Y,YPRIME,DELTA,IRES,
+     *  RPAR,IPAR)
+      IF (IRES .LT. 0) GO TO 380
+      GO TO 350
+C
+C
+C     THE CORRECTOR FAILED TO CONVERGE IN MAXIT
+C     ITERATIONS. IF THE ITERATION MATRIX
+C     IS NOT CURRENT,RE-DO THE STEP WITH
+C     A NEW ITERATION MATRIX.
+370   CONTINUE
+      IF(JCALC.EQ.0)GO TO 380
+      JCALC=-1
+      GO TO 300
+C
+C
+C     THE ITERATION HAS CONVERGED.  IF NONNEGATIVITY OF SOLUTION IS
+C     REQUIRED, SET THE SOLUTION NONNEGATIVE, IF THE PERTURBATION
+C     TO DO IT IS SMALL ENOUGH.  IF THE CHANGE IS TOO LARGE, THEN
+C     CONSIDER THE CORRECTOR ITERATION TO HAVE FAILED.
+375   IF(NONNEG .EQ. 0) GO TO 390
+      DO 377 I = 1,NEQ
+377      DELTA(I) = MIN(Y(I),0.0D0)
+      DELNRM = DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
+      IF(DELNRM .GT. 0.33D0) GO TO 380
+      DO 378 I = 1,NEQ
+378      E(I) = E(I) - DELTA(I)
+      GO TO 390
+C
+C
+C     EXITS FROM BLOCK 3
+C     NO CONVERGENCE WITH CURRENT ITERATION
+C     MATRIX,OR SINGULAR ITERATION MATRIX
+380   CONVGD= .FALSE.
+390   JCALC = 1
+      IF(.NOT.CONVGD)GO TO 600
+C
+C
+C
+C
+C
+C-----------------------------------------------------------------------
+C     BLOCK 4
+C     ESTIMATE THE ERRORS AT ORDERS K,K-1,K-2
+C     AS IF CONSTANT STEPSIZE WAS USED. ESTIMATE
+C     THE LOCAL ERROR AT ORDER K AND TEST
+C     WHETHER THE CURRENT STEP IS SUCCESSFUL.
+C-----------------------------------------------------------------------
+C
+C     ESTIMATE ERRORS AT ORDERS K,K-1,K-2
+      ENORM = DDANRM(NEQ,E,WT,RPAR,IPAR)
+      ERK = SIGMA(K+1)*ENORM
+      TERK = (K+1)*ERK
+      EST = ERK
+      KNEW=K
+      IF(K .EQ. 1)GO TO 430
+      DO 405 I = 1,NEQ
+405     DELTA(I) = PHI(I,KP1) + E(I)
+      ERKM1=SIGMA(K)*DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
+      TERKM1 = K*ERKM1
+      IF(K .GT. 2)GO TO 410
+      IF(TERKM1 .LE. 0.5D0*TERK)GO TO 420
+      GO TO 430
+410   CONTINUE
+      DO 415 I = 1,NEQ
+415     DELTA(I) = PHI(I,K) + DELTA(I)
+      ERKM2=SIGMA(K-1)*DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
+      TERKM2 = (K-1)*ERKM2
+      IF(MAX(TERKM1,TERKM2).GT.TERK)GO TO 430
+C     LOWER THE ORDER
+420   CONTINUE
+      KNEW=K-1
+      EST = ERKM1
+C
+C
+C     CALCULATE THE LOCAL ERROR FOR THE CURRENT STEP
+C     TO SEE IF THE STEP WAS SUCCESSFUL
+430   CONTINUE
+      ERR = CK * ENORM
+      IF(ERR .GT. 1.0D0)GO TO 600
+C
+C
+C
+C
+C
+C-----------------------------------------------------------------------
+C     BLOCK 5
+C     THE STEP IS SUCCESSFUL. DETERMINE
+C     THE BEST ORDER AND STEPSIZE FOR
+C     THE NEXT STEP. UPDATE THE DIFFERENCES
+C     FOR THE NEXT STEP.
+C-----------------------------------------------------------------------
+      IDID=1
+      IWM(LNST)=IWM(LNST)+1
+      KDIFF=K-KOLD
+      KOLD=K
+      HOLD=H
+C
+C
+C     ESTIMATE THE ERROR AT ORDER K+1 UNLESS:
+C        ALREADY DECIDED TO LOWER ORDER, OR
+C        ALREADY USING MAXIMUM ORDER, OR
+C        STEPSIZE NOT CONSTANT, OR
+C        ORDER RAISED IN PREVIOUS STEP
+      IF(KNEW.EQ.KM1.OR.K.EQ.IWM(LMXORD))IPHASE=1
+      IF(IPHASE .EQ. 0)GO TO 545
+      IF(KNEW.EQ.KM1)GO TO 540
+      IF(K.EQ.IWM(LMXORD)) GO TO 550
+      IF(KP1.GE.NS.OR.KDIFF.EQ.1)GO TO 550
+      DO 510 I=1,NEQ
+510      DELTA(I)=E(I)-PHI(I,KP2)
+      ERKP1 = (1.0D0/(K+2))*DDANRM(NEQ,DELTA,WT,RPAR,IPAR)
+      TERKP1 = (K+2)*ERKP1
+      IF(K.GT.1)GO TO 520
+      IF(TERKP1.GE.0.5D0*TERK)GO TO 550
+      GO TO 530
+520   IF(TERKM1.LE.MIN(TERK,TERKP1))GO TO 540
+      IF(TERKP1.GE.TERK.OR.K.EQ.IWM(LMXORD))GO TO 550
+C
+C     RAISE ORDER
+530   K=KP1
+      EST = ERKP1
+      GO TO 550
+C
+C     LOWER ORDER
+540   K=KM1
+      EST = ERKM1
+      GO TO 550
+C
+C     IF IPHASE = 0, INCREASE ORDER BY ONE AND MULTIPLY STEPSIZE BY
+C     FACTOR TWO
+545   K = KP1
+      HNEW = H*2.0D0
+      H = HNEW
+      GO TO 575
+C
+C
+C     DETERMINE THE APPROPRIATE STEPSIZE FOR
+C     THE NEXT STEP.
+550   HNEW=H
+      TEMP2=K+1
+      R=(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2)
+      IF(R .LT. 2.0D0) GO TO 555
+      HNEW = 2.0D0*H
+      GO TO 560
+555   IF(R .GT. 1.0D0) GO TO 560
+      R = MAX(0.5D0,MIN(0.9D0,R))
+      HNEW = H*R
+560   H=HNEW
+C
+C
+C     UPDATE DIFFERENCES FOR NEXT STEP
+575   CONTINUE
+      IF(KOLD.EQ.IWM(LMXORD))GO TO 585
+      DO 580 I=1,NEQ
+580      PHI(I,KP2)=E(I)
+585   CONTINUE
+      DO 590 I=1,NEQ
+590      PHI(I,KP1)=PHI(I,KP1)+E(I)
+      DO 595 J1=2,KP1
+         J=KP1-J1+1
+         DO 595 I=1,NEQ
+595      PHI(I,J)=PHI(I,J)+PHI(I,J+1)
+      RETURN
+C
+C
+C
+C
+C
+C-----------------------------------------------------------------------
+C     BLOCK 6
+C     THE STEP IS UNSUCCESSFUL. RESTORE X,PSI,PHI
+C     DETERMINE APPROPRIATE STEPSIZE FOR
+C     CONTINUING THE INTEGRATION, OR EXIT WITH
+C     AN ERROR FLAG IF THERE HAVE BEEN MANY
+C     FAILURES.
+C-----------------------------------------------------------------------
+600   IPHASE = 1
+C
+C     RESTORE X,PHI,PSI
+      X=XOLD
+      IF(KP1.LT.NSP1)GO TO 630
+      DO 620 J=NSP1,KP1
+         TEMP1=1.0D0/BETA(J)
+         DO 610 I=1,NEQ
+610         PHI(I,J)=TEMP1*PHI(I,J)
+620      CONTINUE
+630   CONTINUE
+      DO 640 I=2,KP1
+640      PSI(I-1)=PSI(I)-H
+C
+C
+C     TEST WHETHER FAILURE IS DUE TO CORRECTOR ITERATION
+C     OR ERROR TEST
+      IF(CONVGD)GO TO 660
+      IWM(LCTF)=IWM(LCTF)+1
+C
+C
+C     THE NEWTON ITERATION FAILED TO CONVERGE WITH
+C     A CURRENT ITERATION MATRIX.  DETERMINE THE CAUSE
+C     OF THE FAILURE AND TAKE APPROPRIATE ACTION.
+      IF(IER.EQ.0)GO TO 650
+C
+C     THE ITERATION MATRIX IS SINGULAR. REDUCE
+C     THE STEPSIZE BY A FACTOR OF 4. IF
+C     THIS HAPPENS THREE TIMES IN A ROW ON
+C     THE SAME STEP, RETURN WITH AN ERROR FLAG
+      NSF=NSF+1
+      R = 0.25D0
+      H=H*R
+      IF (NSF .LT. 3 .AND. ABS(H) .GE. HMIN) GO TO 690
+      IDID=-8
+      GO TO 675
+C
+C
+C     THE NEWTON ITERATION FAILED TO CONVERGE FOR A REASON
+C     OTHER THAN A SINGULAR ITERATION MATRIX.  IF IRES = -2, THEN
+C     RETURN.  OTHERWISE, REDUCE THE STEPSIZE AND TRY AGAIN, UNLESS
+C     TOO MANY FAILURES HAVE OCCURED.
+650   CONTINUE
+      IF (IRES .GT. -2) GO TO 655
+      IDID = -11
+      GO TO 675
+655   NCF = NCF + 1
+      R = 0.25D0
+      H = H*R
+      IF (NCF .LT. 10 .AND. ABS(H) .GE. HMIN) GO TO 690
+      IDID = -7
+      IF (IRES .LT. 0) IDID = -10
+      IF (NEF .GE. 3) IDID = -9
+      GO TO 675
+C
+C
+C     THE NEWTON SCHEME CONVERGED,AND THE CAUSE
+C     OF THE FAILURE WAS THE ERROR ESTIMATE
+C     EXCEEDING THE TOLERANCE.
+660   NEF=NEF+1
+      IWM(LETF)=IWM(LETF)+1
+      IF (NEF .GT. 1) GO TO 665
+C
+C     ON FIRST ERROR TEST FAILURE, KEEP CURRENT ORDER OR LOWER
+C     ORDER BY ONE.  COMPUTE NEW STEPSIZE BASED ON DIFFERENCES
+C     OF THE SOLUTION.
+      K = KNEW
+      TEMP2 = K + 1
+      R = 0.90D0*(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2)
+      R = MAX(0.25D0,MIN(0.9D0,R))
+      H = H*R
+      IF (ABS(H) .GE. HMIN) GO TO 690
+      IDID = -6
+      GO TO 675
+C
+C     ON SECOND ERROR TEST FAILURE, USE THE CURRENT ORDER OR
+C     DECREASE ORDER BY ONE.  REDUCE THE STEPSIZE BY A FACTOR OF
+C     FOUR.
+665   IF (NEF .GT. 2) GO TO 670
+      K = KNEW
+      H = 0.25D0*H
+      IF (ABS(H) .GE. HMIN) GO TO 690
+      IDID = -6
+      GO TO 675
+C
+C     ON THIRD AND SUBSEQUENT ERROR TEST FAILURES, SET THE ORDER TO
+C     ONE AND REDUCE THE STEPSIZE BY A FACTOR OF FOUR.
+670   K = 1
+      H = 0.25D0*H
+      IF (ABS(H) .GE. HMIN) GO TO 690
+      IDID = -6
+      GO TO 675
+C
+C
+C
+C
+C     FOR ALL CRASHES, RESTORE Y TO ITS LAST VALUE,
+C     INTERPOLATE TO FIND YPRIME AT LAST X, AND RETURN
+675   CONTINUE
+      CALL DDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI)
+      RETURN
+C
+C
+C     GO BACK AND TRY THIS STEP AGAIN
+690   GO TO 200
+C
+C------END OF SUBROUTINE DDASTP------
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/dassl/ddatrp.f
@@ -0,0 +1,64 @@
+      SUBROUTINE DDATRP (X, XOUT, YOUT, YPOUT, NEQ, KOLD, PHI, PSI)
+C***BEGIN PROLOGUE  DDATRP
+C***SUBSIDIARY
+C***PURPOSE  Interpolation routine for DDASSL.
+C***LIBRARY   SLATEC (DASSL)
+C***TYPE      DOUBLE PRECISION (SDATRP-S, DDATRP-D)
+C***AUTHOR  PETZOLD, LINDA R., (LLNL)
+C***DESCRIPTION
+C-----------------------------------------------------------------------
+C     THE METHODS IN SUBROUTINE DDASTP USE POLYNOMIALS
+C     TO APPROXIMATE THE SOLUTION. DDATRP APPROXIMATES THE
+C     SOLUTION AND ITS DERIVATIVE AT TIME XOUT BY EVALUATING
+C     ONE OF THESE POLYNOMIALS,AND ITS DERIVATIVE,THERE.
+C     INFORMATION DEFINING THIS POLYNOMIAL IS PASSED FROM
+C     DDASTP, SO DDATRP CANNOT BE USED ALONE.
+C
+C     THE PARAMETERS ARE:
+C     X     THE CURRENT TIME IN THE INTEGRATION.
+C     XOUT  THE TIME AT WHICH THE SOLUTION IS DESIRED
+C     YOUT  THE INTERPOLATED APPROXIMATION TO Y AT XOUT
+C           (THIS IS OUTPUT)
+C     YPOUT THE INTERPOLATED APPROXIMATION TO YPRIME AT XOUT
+C           (THIS IS OUTPUT)
+C     NEQ   NUMBER OF EQUATIONS
+C     KOLD  ORDER USED ON LAST SUCCESSFUL STEP
+C     PHI   ARRAY OF SCALED DIVIDED DIFFERENCES OF Y
+C     PSI   ARRAY OF PAST STEPSIZE HISTORY
+C-----------------------------------------------------------------------
+C***ROUTINES CALLED  (NONE)
+C***REVISION HISTORY  (YYMMDD)
+C   830315  DATE WRITTEN
+C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
+C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
+C   901026  Added explicit declarations for all variables and minor
+C           cosmetic changes to prologue.  (FNF)
+C***END PROLOGUE  DDATRP
+C
+      INTEGER  NEQ, KOLD
+      DOUBLE PRECISION  X, XOUT, YOUT(*), YPOUT(*), PHI(NEQ,*), PSI(*)
+C
+      INTEGER  I, J, KOLDP1
+      DOUBLE PRECISION  C, D, GAMMA, TEMP1
+C
+C***FIRST EXECUTABLE STATEMENT  DDATRP
+      KOLDP1=KOLD+1
+      TEMP1=XOUT-X
+      DO 10 I=1,NEQ
+         YOUT(I)=PHI(I,1)
+10       YPOUT(I)=0.0D0
+      C=1.0D0
+      D=0.0D0
+      GAMMA=TEMP1/PSI(1)
+      DO 30 J=2,KOLDP1
+         D=D*GAMMA+C/PSI(J-1)
+         C=C*GAMMA
+         GAMMA=(TEMP1+PSI(J-1))/PSI(J)
+         DO 20 I=1,NEQ
+            YOUT(I)=YOUT(I)+C*PHI(I,J)
+20          YPOUT(I)=YPOUT(I)+D*PHI(I,J)
+30       CONTINUE
+      RETURN
+C
+C------END OF SUBROUTINE DDATRP------
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/dassl/ddawts.f
@@ -0,0 +1,42 @@
+      SUBROUTINE DDAWTS (NEQ, IWT, RTOL, ATOL, Y, WT, RPAR, IPAR)
+C***BEGIN PROLOGUE  DDAWTS
+C***SUBSIDIARY
+C***PURPOSE  Set error weight vector for DDASSL.
+C***LIBRARY   SLATEC (DASSL)
+C***TYPE      DOUBLE PRECISION (SDAWTS-S, DDAWTS-D)
+C***AUTHOR  PETZOLD, LINDA R., (LLNL)
+C***DESCRIPTION
+C-----------------------------------------------------------------------
+C     THIS SUBROUTINE SETS THE ERROR WEIGHT VECTOR
+C     WT ACCORDING TO WT(I)=RTOL(I)*ABS(Y(I))+ATOL(I),
+C     I=1,-,N.
+C     RTOL AND ATOL ARE SCALARS IF IWT = 0,
+C     AND VECTORS IF IWT = 1.
+C-----------------------------------------------------------------------
+C***ROUTINES CALLED  (NONE)
+C***REVISION HISTORY  (YYMMDD)
+C   830315  DATE WRITTEN
+C   901009  Finished conversion to SLATEC 4.0 format (F.N.Fritsch)
+C   901019  Merged changes made by C. Ulrich with SLATEC 4.0 format.
+C   901026  Added explicit declarations for all variables and minor
+C           cosmetic changes to prologue.  (FNF)
+C***END PROLOGUE  DDAWTS
+C
+      INTEGER  NEQ, IWT, IPAR(*)
+      DOUBLE PRECISION  RTOL(*), ATOL(*), Y(*), WT(*), RPAR(*)
+C
+      INTEGER  I
+      DOUBLE PRECISION  ATOLI, RTOLI
+C
+C***FIRST EXECUTABLE STATEMENT  DDAWTS
+      RTOLI=RTOL(1)
+      ATOLI=ATOL(1)
+      DO 20 I=1,NEQ
+         IF (IWT .EQ.0) GO TO 10
+           RTOLI=RTOL(I)
+           ATOLI=ATOL(I)
+10         WT(I)=RTOLI*ABS(Y(I))+ATOLI
+20         CONTINUE
+      RETURN
+C-----------END OF SUBROUTINE DDAWTS------------------------------------
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/dassl/dpotf2.f
@@ -0,0 +1,168 @@
+      SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 1.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/dassl/dpotrf.f
@@ -0,0 +1,186 @@
+      SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 1.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. 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' * 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 block version of the algorithm, calling Level 3 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
+      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
new file mode 100644
--- /dev/null
+++ b/libcruft/dassl/xerhlt.f
@@ -0,0 +1,37 @@
+      SUBROUTINE XERHLT (MESSG)
+C***BEGIN PROLOGUE  XERHLT
+C***SUBSIDIARY
+C***PURPOSE  Abort program execution and print error message.
+C***LIBRARY   SLATEC (XERROR)
+C***CATEGORY  R3C
+C***TYPE      ALL (XERHLT-A)
+C***KEYWORDS  ERROR, XERROR
+C***AUTHOR  JONES, R. E., (SNLA)
+C***DESCRIPTION
+C
+C     Abstract
+C        ***Note*** machine dependent routine
+C        XERHLT aborts the execution of the program.
+C        The error message causing the abort is given in the calling
+C        sequence, in case one needs it for printing on a dayfile,
+C        for example.
+C
+C     Description of Parameters
+C        MESSG is as in XERROR.
+C
+C***REFERENCES  JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR-
+C                 HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES,
+C                 1982.
+C***ROUTINES CALLED  (NONE)
+C***REVISION HISTORY  (YYMMDD)
+C   790801  DATE WRITTEN as XERABT
+C   861211  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900206  Routine changed from user-callable to subsidiary.  (WRB)
+C   900510  Changed calling sequence to delete length of char string
+C           Changed subroutine name from XERABT to XERHLT.  (RWC)
+C***END PROLOGUE  XERHLT
+      CHARACTER*(*) MESSG
+C***FIRST EXECUTABLE STATEMENT  XERHLT
+      CALL XSTOPX (MESSG)
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/dassl/xermsg.f
@@ -0,0 +1,308 @@
+C*DECK XERMSG
+      SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL)
+C***BEGIN PROLOGUE  XERMSG
+C***PURPOSE  Processes error messages for SLATEC and other libraries
+C***LIBRARY   SLATEC
+C***CATEGORY  R3C
+C***TYPE      ALL
+C***KEYWORDS  ERROR MESSAGE, XERROR
+C***AUTHOR  FONG, KIRBY, (NMFECC AT LLNL)
+C             Modified by
+C           FRITSCH, F. N., (LLNL)
+C***DESCRIPTION
+C
+C   XERMSG processes a diagnostic message in a manner determined by the
+C   value of LEVEL and the current value of the library error control
+C   flag, KONTRL.  See subroutine XSETF for details.
+C       (XSETF is inoperable in this version.).
+C
+C    LIBRAR   A character constant (or character variable) with the name
+C             of the library.  This will be 'SLATEC' for the SLATEC
+C             Common Math Library.  The error handling package is
+C             general enough to be used by many libraries
+C             simultaneously, so it is desirable for the routine that
+C             detects and reports an error to identify the library name
+C             as well as the routine name.
+C
+C    SUBROU   A character constant (or character variable) with the name
+C             of the routine that detected the error.  Usually it is the
+C             name of the routine that is calling XERMSG.  There are
+C             some instances where a user callable library routine calls
+C             lower level subsidiary routines where the error is
+C             detected.  In such cases it may be more informative to
+C             supply the name of the routine the user called rather than
+C             the name of the subsidiary routine that detected the
+C             error.
+C
+C    MESSG    A character constant (or character variable) with the text
+C             of the error or warning message.  In the example below,
+C             the message is a character constant that contains a
+C             generic message.
+C
+C                   CALL XERMSG ('SLATEC', 'MMPY',
+C                  *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION',
+C                  *3, 1)
+C
+C             It is possible (and is sometimes desirable) to generate a
+C             specific message--e.g., one that contains actual numeric
+C             values.  Specific numeric values can be converted into
+C             character strings using formatted WRITE statements into
+C             character variables.  This is called standard Fortran
+C             internal file I/O and is exemplified in the first three
+C             lines of the following example.  You can also catenate
+C             substrings of characters to construct the error message.
+C             Here is an example showing the use of both writing to
+C             an internal file and catenating character strings.
+C
+C                   CHARACTER*5 CHARN, CHARL
+C                   WRITE (CHARN,10) N
+C                   WRITE (CHARL,10) LDA
+C                10 FORMAT(I5)
+C                   CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN//
+C                  *   ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'//
+C                  *   CHARL, 3, 1)
+C
+C             There are two subtleties worth mentioning.  One is that
+C             the // for character catenation is used to construct the
+C             error message so that no single character constant is
+C             continued to the next line.  This avoids confusion as to
+C             whether there are trailing blanks at the end of the line.
+C             The second is that by catenating the parts of the message
+C             as an actual argument rather than encoding the entire
+C             message into one large character variable, we avoid
+C             having to know how long the message will be in order to
+C             declare an adequate length for that large character
+C             variable.  XERMSG calls XERPRN to print the message using
+C             multiple lines if necessary.  If the message is very long,
+C             XERPRN will break it into pieces of 72 characters (as
+C             requested by XERMSG) for printing on multiple lines.
+C             Also, XERMSG asks XERPRN to prefix each line with ' *  '
+C             so that the total line length could be 76 characters.
+C             Note also that XERPRN scans the error message backwards
+C             to ignore trailing blanks.  Another feature is that
+C             the substring '$$' is treated as a new line sentinel
+C             by XERPRN.  If you want to construct a multiline
+C             message without having to count out multiples of 72
+C             characters, just use '$$' as a separator.  '$$'
+C             obviously must occur within 72 characters of the
+C             start of each line to have its intended effect since
+C             XERPRN is asked to wrap around at 72 characters in
+C             addition to looking for '$$'.
+C
+C    NERR     An integer value that is chosen by the library routine's
+C             author.  It must be in the range -9999999 to 99999999 (8
+C             printable digits).  Each distinct error should have its
+C             own error number.  These error numbers should be described
+C             in the machine readable documentation for the routine.
+C             The error numbers need be unique only within each routine,
+C             so it is reasonable for each routine to start enumerating
+C             errors from 1 and proceeding to the next integer.
+C
+C    LEVEL    An integer value in the range 0 to 2 that indicates the
+C             level (severity) of the error.  Their meanings are
+C
+C            -1  A warning message.  This is used if it is not clear
+C                that there really is an error, but the user's attention
+C                may be needed.  An attempt is made to only print this
+C                message once.
+C
+C             0  A warning message.  This is used if it is not clear
+C                that there really is an error, but the user's attention
+C                may be needed.
+C
+C             1  A recoverable error.  This is used even if the error is
+C                so serious that the routine cannot return any useful
+C                answer.  If the user has told the error package to
+C                return after recoverable errors, then XERMSG will
+C                return to the Library routine which can then return to
+C                the user's routine.  The user may also permit the error
+C                package to terminate the program upon encountering a
+C                recoverable error.
+C
+C             2  A fatal error.  XERMSG will not return to its caller
+C                after it receives a fatal error.  This level should
+C                hardly ever be used; it is much better to allow the
+C                user a chance to recover.  An example of one of the few
+C                cases in which it is permissible to declare a level 2
+C                error is a reverse communication Library routine that
+C                is likely to be called repeatedly until it integrates
+C                across some interval.  If there is a serious error in
+C                the input such that another step cannot be taken and
+C                the Library routine is called again without the input
+C                error having been corrected by the caller, the Library
+C                routine will probably be called forever with improper
+C                input.  In this case, it is reasonable to declare the
+C                error to be fatal.
+C
+C    Each of the arguments to XERMSG is input; none will be modified by
+C    XERMSG.  A routine may make multiple calls to XERMSG with warning
+C    level messages; however, after a call to XERMSG with a recoverable
+C    error, the routine should return to the user.
+C
+C***REFERENCES  JONES, RONDALL E. AND KAHANER, DAVID K., "XERROR, THE
+C                 SLATEC ERROR-HANDLING PACKAGE", SOFTWARE - PRACTICE
+C                 AND EXPERIENCE, VOLUME 13, NO. 3, PP. 251-257,
+C                 MARCH, 1983.
+C***ROUTINES CALLED  XERHLT, XERPRN
+C***REVISION HISTORY  (YYMMDD)
+C   880101  DATE WRITTEN
+C   880621  REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988.
+C           THERE ARE TWO BASIC CHANGES.
+C           1.  A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO
+C               PRINT MESSAGES.  THIS ROUTINE WILL BREAK LONG MESSAGES
+C               INTO PIECES FOR PRINTING ON MULTIPLE LINES.  '$$' IS
+C               ACCEPTED AS A NEW LINE SENTINEL.  A PREFIX CAN BE
+C               ADDED TO EACH LINE TO BE PRINTED.  XERMSG USES EITHER
+C               ' ***' OR ' *  ' AND LONG MESSAGES ARE BROKEN EVERY
+C               72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE
+C               LENGTH OUTPUT CAN NOW BE AS GREAT AS 76.
+C           2.  THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE
+C               FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE
+C               OF LOWER CASE.
+C   880708  REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30.
+C           THE PRINCIPAL CHANGES ARE
+C           1.  CLARIFY COMMENTS IN THE PROLOGUES
+C           2.  RENAME XRPRNT TO XERPRN
+C           3.  REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES
+C               SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE /
+C               CHARACTER FOR NEW RECORDS.
+C   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
+C           CLEAN UP THE CODING.
+C   890721  REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN
+C           PREFIX.
+C   891013  REVISED TO CORRECT COMMENTS.
+C   891214  Prologue converted to Version 4.0 format.  (WRB)
+C   900510  Changed test on NERR to be -9999999 < NERR < 99999999, but
+C           NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3.  Added
+C           LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and
+C           XERCTL to XERCNT.  (RWC)
+C   901011  Removed error saving features to produce a simplified
+C           version for distribution with DASSL and other LLNL codes.
+C           (FNF)
+C***END PROLOGUE  XERMSG
+      CHARACTER*(*) LIBRAR, SUBROU, MESSG
+      CHARACTER*72  TEMP
+C***FIRST EXECUTABLE STATEMENT  XERMSG
+C
+C       WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN
+C          CALLING XERMSG.  THE ERROR NUMBER SHOULD BE POSITIVE,
+C          AND THE LEVEL SHOULD BE BETWEEN 0 AND 2.
+C
+      IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR.
+     *   LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN
+         CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' //
+     *      'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '//
+     *      'JOB ABORT DUE TO FATAL ERROR.', 72)
+         CALL XERHLT (' ***XERMSG -- INVALID INPUT')
+         RETURN
+      ENDIF
+C
+C       SET DEFAULT VALUES FOR CONTROL PARAMETERS.
+C
+      LKNTRL = 1
+      MKNTRL = 1
+C
+C       ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A
+C       MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS)
+C       AND SENDING IT OUT VIA XERPRN.  PRINT ONLY IF CONTROL FLAG
+C       IS NOT ZERO.
+C
+      IF (LKNTRL .NE. 0) THEN
+         TEMP(1:21) = 'MESSAGE FROM ROUTINE '
+         I = MIN(LEN(SUBROU), 16)
+         TEMP(22:21+I) = SUBROU(1:I)
+         TEMP(22+I:33+I) = ' IN LIBRARY '
+         LTEMP = 33 + I
+         I = MIN(LEN(LIBRAR), 16)
+         TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I)
+         TEMP(LTEMP+I+1:LTEMP+I+1) = '.'
+         LTEMP = LTEMP + I + 1
+         CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
+      ENDIF
+C
+C       IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE
+C       PRINTING THE MESSAGE.  THE INTRODUCTORY LINE TELLS THE CHOICE
+C       FROM EACH OF THE FOLLOWING TWO OPTIONS.
+C       1.  LEVEL OF THE MESSAGE
+C              'INFORMATIVE MESSAGE'
+C              'POTENTIALLY RECOVERABLE ERROR'
+C              'FATAL ERROR'
+C       2.  WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE
+C              'PROGRAM CONTINUES'
+C              'PROGRAM ABORTED'
+C       NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT
+C       EXCEED 74 CHARACTERS.
+C       WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED.
+C
+      IF (LKNTRL .GT. 0) THEN
+C
+C       THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL.
+C
+         IF (LEVEL .LE. 0) THEN
+            TEMP(1:20) = 'INFORMATIVE MESSAGE,'
+            LTEMP = 20
+         ELSEIF (LEVEL .EQ. 1) THEN
+            TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,'
+            LTEMP = 30
+         ELSE
+            TEMP(1:12) = 'FATAL ERROR,'
+            LTEMP = 12
+         ENDIF
+C
+C       THEN WHETHER THE PROGRAM WILL CONTINUE.
+C
+         IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR.
+     *       (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN
+            TEMP(LTEMP+1:LTEMP+17) = ' PROGRAM ABORTED.'
+            LTEMP = LTEMP + 17
+         ELSE
+            TEMP(LTEMP+1:LTEMP+19) = ' PROGRAM CONTINUES.'
+            LTEMP = LTEMP + 19
+         ENDIF
+C
+         CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
+      ENDIF
+C
+C       NOW SEND OUT THE MESSAGE.
+C
+      CALL XERPRN (' *  ', -1, MESSG, 72)
+C
+C       IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER.
+C
+      IF (LKNTRL .GT. 0) THEN
+         WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR
+         DO 10 I=16,22
+            IF (TEMP(I:I) .NE. ' ') GO TO 20
+   10    CONTINUE
+C
+   20    CALL XERPRN (' *  ', -1, TEMP(1:15) // TEMP(I:23), 72)
+      ENDIF
+C
+C       IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE.
+C
+      IF (LKNTRL .NE. 0) THEN
+         CALL XERPRN (' *  ', -1, ' ', 72)
+         CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72)
+         CALL XERPRN ('    ',  0, ' ', 72)
+      ENDIF
+C
+C       IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE
+C       CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN.
+C
+   30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN
+C
+C       THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A
+C       FATAL ERROR.  PRINT THE REASON FOR THE ABORT AND THE ERROR
+C       SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT.
+C
+      IF (LKNTRL.GT.0) THEN
+         IF (LEVEL .EQ. 1) THEN
+            CALL XERPRN
+     *         (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72)
+         ELSE
+            CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72)
+         ENDIF
+         CALL XERHLT (' ')
+      ENDIF
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/dassl/xerprn.f
@@ -0,0 +1,225 @@
+C*DECK XERPRN
+      SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP)
+C***BEGIN PROLOGUE  XERPRN
+C***SUBSIDIARY
+C***PURPOSE  This routine is called by XERMSG to print error messages
+C***LIBRARY   SLATEC
+C***CATEGORY  R3C
+C***TYPE      ALL
+C***KEYWORDS  ERROR MESSAGES, PRINTING, XERROR
+C***AUTHOR  FONG, KIRBY, (NMFECC AT LLNL)
+C***DESCRIPTION
+C
+C This routine sends one or more lines to each of the (up to five)
+C logical units to which error messages are to be sent.  This routine
+C is called several times by XERMSG, sometimes with a single line to
+C print and sometimes with a (potentially very long) message that may
+C wrap around into multiple lines.
+C
+C PREFIX  Input argument of type CHARACTER.  This argument contains
+C         characters to be put at the beginning of each line before
+C         the body of the message.  No more than 16 characters of
+C         PREFIX will be used.
+C
+C NPREF   Input argument of type INTEGER.  This argument is the number
+C         of characters to use from PREFIX.  If it is negative, the
+C         intrinsic function LEN is used to determine its length.  If
+C         it is zero, PREFIX is not used.  If it exceeds 16 or if
+C         LEN(PREFIX) exceeds 16, only the first 16 characters will be
+C         used.  If NPREF is positive and the length of PREFIX is less
+C         than NPREF, a copy of PREFIX extended with blanks to length
+C         NPREF will be used.
+C
+C MESSG   Input argument of type CHARACTER.  This is the text of a
+C         message to be printed.  If it is a long message, it will be
+C         broken into pieces for printing on multiple lines.  Each line
+C         will start with the appropriate prefix and be followed by a
+C         piece of the message.  NWRAP is the number of characters per
+C         piece; that is, after each NWRAP characters, we break and
+C         start a new line.  In addition the characters '$$' embedded
+C         in MESSG are a sentinel for a new line.  The counting of
+C         characters up to NWRAP starts over for each new line.  The
+C         value of NWRAP typically used by XERMSG is 72 since many
+C         older error messages in the SLATEC Library are laid out to
+C         rely on wrap-around every 72 characters.
+C
+C NWRAP   Input argument of type INTEGER.  This gives the maximum size
+C         piece into which to break MESSG for printing on multiple
+C         lines.  An embedded '$$' ends a line, and the count restarts
+C         at the following character.  If a line break does not occur
+C         on a blank (it would split a word) that word is moved to the
+C         next line.  Values of NWRAP less than 16 will be treated as
+C         16.  Values of NWRAP greater than 132 will be treated as 132.
+C         The actual line length will be NPREF + NWRAP after NPREF has
+C         been adjusted to fall between 0 and 16 and NWRAP has been
+C         adjusted to fall between 16 and 132.
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  I1MACH, XGETUA
+C***REVISION HISTORY  (YYMMDD)
+C   880621  DATE WRITTEN
+C   880708  REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF
+C           JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK
+C           THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE
+C           SLASH CHARACTER IN FORMAT STATEMENTS.
+C   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMMENS TO
+C           STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK
+C           LINES TO BE PRINTED.
+C   890721  REVISED TO ADD A NEW FEATURE.  A NEGATIVE VALUE OF NPREF
+C           CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH.
+C   891013  REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH.
+C   891214  Prologue converted to Version 4.0 format.  (WRB)
+C   900510  Added code to break messages between words.  (RWC)
+C***END PROLOGUE  XERPRN
+      CHARACTER*(*) PREFIX, MESSG
+      INTEGER NPREF, NWRAP
+      CHARACTER*148 CBUFF
+      INTEGER IU(5), NUNIT
+      CHARACTER*2 NEWLIN
+      PARAMETER (NEWLIN = '$$')
+C***FIRST EXECUTABLE STATEMENT  XERPRN
+      CALL XGETUA(IU,NUNIT)
+C
+C       A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD
+C       ERROR MESSAGE UNIT INSTEAD.  I1MACH(4) RETRIEVES THE STANDARD
+C       ERROR MESSAGE UNIT.
+C
+      N = I1MACH(4)
+      DO 10 I=1,NUNIT
+         IF (IU(I) .EQ. 0) IU(I) = N
+   10 CONTINUE
+C
+C       LPREF IS THE LENGTH OF THE PREFIX.  THE PREFIX IS PLACED AT THE
+C       BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING
+C       THE REST OF THIS ROUTINE.
+C
+      IF ( NPREF .LT. 0 ) THEN
+         LPREF = LEN(PREFIX)
+      ELSE
+         LPREF = NPREF
+      ENDIF
+      LPREF = MIN(16, LPREF)
+      IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX
+C
+C       LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE
+C       TIME FROM MESSG TO PRINT ON ONE LINE.
+C
+      LWRAP = MAX(16, MIN(132, NWRAP))
+C
+C       SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS.
+C
+      LENMSG = LEN(MESSG)
+      N = LENMSG
+      DO 20 I=1,N
+         IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30
+         LENMSG = LENMSG - 1
+   20 CONTINUE
+   30 CONTINUE
+C
+C       IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE.
+C
+      IF (LENMSG .EQ. 0) THEN
+         CBUFF(LPREF+1:LPREF+1) = ' '
+         DO 40 I=1,NUNIT
+            WRITE(IU(I), '(A)') CBUFF(1:LPREF+1)
+   40    CONTINUE
+         RETURN
+      ENDIF
+C
+C       SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING
+C       STARTS.  FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL.
+C       WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT.
+C       WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED.
+C
+C       WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL.  THE
+C       INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE
+C       OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH
+C       OF THE SECOND ARGUMENT.
+C
+C       THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE
+C       FOLLOWING ORDER.  WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER
+C       OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT
+C       POSITION NEXTC.
+C
+C       LPIECE .EQ. 0   THE NEW LINE SENTINEL DOES NOT OCCUR IN THE
+C                       REMAINDER OF THE CHARACTER STRING.  LPIECE
+C                       SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC,
+C                       WHICHEVER IS LESS.
+C
+C       LPIECE .EQ. 1   THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC:
+C                       NEXTC).  LPIECE IS EFFECTIVELY ZERO, AND WE
+C                       PRINT NOTHING TO AVOID PRODUCING UNNECESSARY
+C                       BLANK LINES.  THIS TAKES CARE OF THE SITUATION
+C                       WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF
+C                       EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE
+C                       SENTINEL FOLLOWED BY MORE CHARACTERS.  NEXTC
+C                       SHOULD BE INCREMENTED BY 2.
+C
+C       LPIECE .GT. LWRAP+1  REDUCE LPIECE TO LWRAP.
+C
+C       ELSE            THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1
+C                       RESET LPIECE = LPIECE-1.  NOTE THAT THIS
+C                       PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ.
+C                       LWRAP+1.  THAT IS, THE SENTINEL FALLS EXACTLY
+C                       AT THE END OF A LINE.
+C
+      NEXTC = 1
+   50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN)
+      IF (LPIECE .EQ. 0) THEN
+C
+C       THERE WAS NO NEW LINE SENTINEL FOUND.
+C
+         IDELTA = 0
+         LPIECE = MIN(LWRAP, LENMSG+1-NEXTC)
+         IF (LPIECE .LT. LENMSG+1-NEXTC) THEN
+            DO 52 I=LPIECE+1,2,-1
+               IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN
+                  LPIECE = I-1
+                  IDELTA = 1
+                  GOTO 54
+               ENDIF
+   52       CONTINUE
+         ENDIF
+   54    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
+         NEXTC = NEXTC + LPIECE + IDELTA
+      ELSEIF (LPIECE .EQ. 1) THEN
+C
+C       WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1).
+C       DON'T PRINT A BLANK LINE.
+C
+         NEXTC = NEXTC + 2
+         GO TO 50
+      ELSEIF (LPIECE .GT. LWRAP+1) THEN
+C
+C       LPIECE SHOULD BE SET DOWN TO LWRAP.
+C
+         IDELTA = 0
+         LPIECE = LWRAP
+         DO 56 I=LPIECE+1,2,-1
+            IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN
+               LPIECE = I-1
+               IDELTA = 1
+               GOTO 58
+            ENDIF
+   56    CONTINUE
+   58    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
+         NEXTC = NEXTC + LPIECE + IDELTA
+      ELSE
+C
+C       IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1.
+C       WE SHOULD DECREMENT LPIECE BY ONE.
+C
+         LPIECE = LPIECE - 1
+         CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
+         NEXTC  = NEXTC + LPIECE + 2
+      ENDIF
+C
+C       PRINT
+C
+      DO 60 I=1,NUNIT
+         WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE)
+   60 CONTINUE
+C
+      IF (NEXTC .LE. LENMSG) GO TO 50
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/dassl/xgetua.f
@@ -0,0 +1,65 @@
+C*DECK XGETUA
+      SUBROUTINE XGETUA (IUNITA, N)
+C***BEGIN PROLOGUE  XGETUA
+C***PURPOSE  Return unit number(s) to which error messages are being
+C            sent.
+C***LIBRARY   SLATEC (XERROR)
+C***CATEGORY  R3C
+C***TYPE      ALL (XGETUA-A)
+C***KEYWORDS  ERROR, XERROR
+C***AUTHOR  JONES, R. E., (SNLA)
+C             Modified by
+C           FRITSCH, F. N., (LLNL)
+C***DESCRIPTION
+C
+C     Abstract
+C        XGETUA may be called to determine the unit number or numbers
+C        to which error messages are being sent.
+C        These unit numbers may have been set by a call to XSETUN,
+C        or a call to XSETUA, or may be a default value.
+C
+C     Description of Parameters
+C      --Output--
+C        IUNIT - an array of one to five unit numbers, depending
+C                on the value of N.  A value of zero refers to the
+C                default unit, as defined by the I1MACH machine
+C                constant routine.  Only IUNIT(1),...,IUNIT(N) are
+C                defined by XGETUA.  The values of IUNIT(N+1),...,
+C                IUNIT(5) are not defined (for N .LT. 5) or altered
+C                in any way by XGETUA.
+C        N     - the number of units to which copies of the
+C                error messages are being sent.  N will be in the
+C                range from 1 to 5.
+C
+C     CAUTION:  The use of COMMON in this version is not safe for
+C               multiprocessing.
+C
+C***REFERENCES  JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR-
+C                 HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES,
+C                 1982.
+C***ROUTINES CALLED  (NONE)
+C***COMMON BLOCKS    XERUNI
+C***REVISION HISTORY  (YYMMDD)
+C   790801  DATE WRITTEN
+C   861211  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   901011  Rewritten to not use J4SAVE.  (FNF)
+C   901012  Corrected initialization problem.  (FNF)
+C***END PROLOGUE  XGETUA
+      DIMENSION IUNITA(5)
+      INTEGER  NUNIT, IUNIT(5)
+      COMMON /XERUNI/ NUNIT, IUNIT
+C***FIRST EXECUTABLE STATEMENT  XGETUA
+C       Initialize so XERMSG will use standard error unit number if
+C       block has not been set up by a CALL XSETUA.
+C       CAUTION:  This assumes uninitialized COMMON tests .LE.0 .
+      IF (NUNIT.LE.0) THEN
+         NUNIT = 1
+         IUNIT(1) = 0
+      ENDIF
+      N = NUNIT
+      DO 30 I=1,N
+         IUNITA(I) = IUNIT(I)
+   30 CONTINUE
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/dassl/xsetua.f
@@ -0,0 +1,65 @@
+C*DECK XSETUA
+      SUBROUTINE XSETUA (IUNITA, N)
+C***BEGIN PROLOGUE  XSETUA
+C***PURPOSE  Set logical unit numbers (up to 5) to which error
+C            messages are to be sent.
+C***LIBRARY   SLATEC (XERROR)
+C***CATEGORY  R3B
+C***TYPE      ALL (XSETUA-A)
+C***KEYWORDS  ERROR, XERROR
+C***AUTHOR  JONES, R. E., (SNLA)
+C             Modified by
+C           FRITSCH, F. N., (LLNL)
+C***DESCRIPTION
+C
+C     Abstract
+C        XSETUA may be called to declare a list of up to five
+C        logical units, each of which is to receive a copy of
+C        each error message processed by this package.
+C        The purpose of XSETUA is to allow simultaneous printing
+C        of each error message on, say, a main output file,
+C        an interactive terminal, and other files such as graphics
+C        communication files.
+C
+C     Description of Parameters
+C      --Input--
+C        IUNIT - an array of up to five unit numbers.
+C                Normally these numbers should all be different
+C                (but duplicates are not prohibited.)
+C        N     - the number of unit numbers provided in IUNIT
+C                must have 1 .LE. N .LE. 5.
+C
+C     CAUTION:  The use of COMMON in this version is not safe for
+C               multiprocessing.
+C
+C***REFERENCES  JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR-
+C                 HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES,
+C                 1982.
+C***ROUTINES CALLED  XERMSG
+C***COMMON BLOCKS    XERUNI
+C***REVISION HISTORY  (YYMMDD)
+C   790801  DATE WRITTEN
+C   861211  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900510  Change call to XERRWV to XERMSG.  (RWC)
+C   901011  Rewritten to not use J4SAVE.  (FNF)
+C***END PROLOGUE  XSETUA
+      DIMENSION IUNITA(5)
+      INTEGER  NUNIT, IUNIT(5)
+      COMMON /XERUNI/ NUNIT, IUNIT
+      CHARACTER *8 XERN1
+C***FIRST EXECUTABLE STATEMENT  XSETUA
+C
+      IF (N.LT.1 .OR. N.GT.5) THEN
+         WRITE (XERN1, '(I8)') N
+         CALL XERMSG ('SLATEC', 'XSETUA',
+     *      'INVALID NUMBER OF UNITS, N = ' // XERN1, 1, 2)
+         RETURN
+      ENDIF
+C
+      DO 10 I=1,N
+         IUNIT(I) = IUNITA(I)
+   10 CONTINUE
+      NUNIT = N
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/eispack/epslon.f
@@ -0,0 +1,36 @@
+      double precision function epslon (x)
+      double precision x
+c
+c     estimate unit roundoff in quantities of size x.
+c
+      double precision a,b,c,eps
+c
+c     this program should function properly on all systems
+c     satisfying the following two assumptions,
+c        1.  the base used in representing floating point
+c            numbers is not a power of three.
+c        2.  the quantity  a  in statement 10 is represented to 
+c            the accuracy used in floating point variables
+c            that are stored in memory.
+c     the statement number 10 and the go to 10 are intended to
+c     force optimizing compilers to generate code satisfying 
+c     assumption 2.
+c     under these assumptions, it should be true that,
+c            a  is not exactly equal to four-thirds,
+c            b  has a zero for its last bit or digit,
+c            c  is not exactly equal to one,
+c            eps  measures the separation of 1.0 from
+c                 the next larger floating point number.
+c     the developers of eispack would appreciate being informed
+c     about any systems where these assumptions do not hold.
+c
+c     this version dated 4/6/83.
+c
+      a = 4.0d0/3.0d0
+   10 b = a - 1.0d0
+      c = b + b + b
+      eps = dabs(c-1.0d0)
+      if (eps .eq. 0.0d0) go to 10
+      epslon = eps*dabs(x)
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/eispack/qzhes.f
@@ -0,0 +1,195 @@
+      subroutine qzhes(nm,n,a,b,matz,z)
+c
+      integer i,j,k,l,n,lb,l1,nm,nk1,nm1,nm2
+      double precision a(nm,n),b(nm,n),z(nm,n)
+      double precision r,s,t,u1,u2,v1,v2,rho
+      logical matz
+c
+c     this subroutine is the first step of the qz algorithm
+c     for solving generalized matrix eigenvalue problems,
+c     siam j. numer. anal. 10, 241-256(1973) by moler and stewart.
+c
+c     this subroutine accepts a pair of real general matrices and
+c     reduces one of them to upper hessenberg form and the other
+c     to upper triangular form using orthogonal transformations.
+c     it is usually followed by  qzit,  qzval  and, possibly,  qzvec.
+c
+c     on input
+c
+c        nm must be set to the row dimension of two-dimensional
+c          array parameters as declared in the calling program
+c          dimension statement.
+c
+c        n is the order of the matrices.
+c
+c        a contains a real general matrix.
+c
+c        b contains a real general matrix.
+c
+c        matz should be set to .true. if the right hand transformations
+c          are to be accumulated for later use in computing
+c          eigenvectors, and to .false. otherwise.
+c
+c     on output
+c
+c        a has been reduced to upper hessenberg form.  the elements
+c          below the first subdiagonal have been set to zero.
+c
+c        b has been reduced to upper triangular form.  the elements
+c          below the main diagonal have been set to zero.
+c
+c        z contains the product of the right hand transformations if
+c          matz has been set to .true.  otherwise, z is not referenced.
+c
+c     questions and comments should be directed to burton s. garbow,
+c     mathematics and computer science div, argonne national laboratory
+c
+c     this version dated august 1983.
+c
+c     ------------------------------------------------------------------
+c
+c     .......... initialize z ..........
+      if (.not. matz) go to 10
+c
+      do 3 j = 1, n
+c
+         do 2 i = 1, n
+            z(i,j) = 0.0d0
+    2    continue
+c
+         z(j,j) = 1.0d0
+    3 continue
+c     .......... reduce b to upper triangular form ..........
+   10 if (n .le. 1) go to 170
+      nm1 = n - 1
+c
+      do 100 l = 1, nm1
+         l1 = l + 1
+         s = 0.0d0
+c
+         do 20 i = l1, n
+            s = s + dabs(b(i,l))
+   20    continue
+c
+         if (s .eq. 0.0d0) go to 100
+         s = s + dabs(b(l,l))
+         r = 0.0d0
+c
+         do 25 i = l, n
+            b(i,l) = b(i,l) / s
+            r = r + b(i,l)**2
+   25    continue
+c
+         r = dsign(dsqrt(r),b(l,l))
+         b(l,l) = b(l,l) + r
+         rho = r * b(l,l)
+c
+         do 50 j = l1, n
+            t = 0.0d0
+c
+            do 30 i = l, n
+               t = t + b(i,l) * b(i,j)
+   30       continue
+c
+            t = -t / rho
+c
+            do 40 i = l, n
+               b(i,j) = b(i,j) + t * b(i,l)
+   40       continue
+c
+   50    continue
+c
+         do 80 j = 1, n
+            t = 0.0d0
+c
+            do 60 i = l, n
+               t = t + b(i,l) * a(i,j)
+   60       continue
+c
+            t = -t / rho
+c
+            do 70 i = l, n
+               a(i,j) = a(i,j) + t * b(i,l)
+   70       continue
+c
+   80    continue
+c
+         b(l,l) = -s * r
+c
+         do 90 i = l1, n
+            b(i,l) = 0.0d0
+   90    continue
+c
+  100 continue
+c     .......... reduce a to upper hessenberg form, while
+c                keeping b triangular ..........
+      if (n .eq. 2) go to 170
+      nm2 = n - 2
+c
+      do 160 k = 1, nm2
+         nk1 = nm1 - k
+c     .......... for l=n-1 step -1 until k+1 do -- ..........
+         do 150 lb = 1, nk1
+            l = n - lb
+            l1 = l + 1
+c     .......... zero a(l+1,k) ..........
+            s = dabs(a(l,k)) + dabs(a(l1,k))
+            if (s .eq. 0.0d0) go to 150
+            u1 = a(l,k) / s
+            u2 = a(l1,k) / s
+            r = dsign(dsqrt(u1*u1+u2*u2),u1)
+            v1 =  -(u1 + r) / r
+            v2 = -u2 / r
+            u2 = v2 / v1
+c
+            do 110 j = k, n
+               t = a(l,j) + u2 * a(l1,j)
+               a(l,j) = a(l,j) + t * v1
+               a(l1,j) = a(l1,j) + t * v2
+  110       continue
+c
+            a(l1,k) = 0.0d0
+c
+            do 120 j = l, n
+               t = b(l,j) + u2 * b(l1,j)
+               b(l,j) = b(l,j) + t * v1
+               b(l1,j) = b(l1,j) + t * v2
+  120       continue
+c     .......... zero b(l+1,l) ..........
+            s = dabs(b(l1,l1)) + dabs(b(l1,l))
+            if (s .eq. 0.0d0) go to 150
+            u1 = b(l1,l1) / s
+            u2 = b(l1,l) / s
+            r = dsign(dsqrt(u1*u1+u2*u2),u1)
+            v1 =  -(u1 + r) / r
+            v2 = -u2 / r
+            u2 = v2 / v1
+c
+            do 130 i = 1, l1
+               t = b(i,l1) + u2 * b(i,l)
+               b(i,l1) = b(i,l1) + t * v1
+               b(i,l) = b(i,l) + t * v2
+  130       continue
+c
+            b(l1,l) = 0.0d0
+c
+            do 140 i = 1, n
+               t = a(i,l1) + u2 * a(i,l)
+               a(i,l1) = a(i,l1) + t * v1
+               a(i,l) = a(i,l) + t * v2
+  140       continue
+c
+            if (.not. matz) go to 150
+c
+            do 145 i = 1, n
+               t = z(i,l1) + u2 * z(i,l)
+               z(i,l1) = z(i,l1) + t * v1
+               z(i,l) = z(i,l) + t * v2
+  145       continue
+c
+  150    continue
+c
+  160 continue
+c
+  170 return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/eispack/qzit.f
@@ -0,0 +1,354 @@
+      subroutine qzit(nm,n,a,b,eps1,matz,z,ierr)
+c
+      integer i,j,k,l,n,en,k1,k2,ld,ll,l1,na,nm,ish,itn,its,km1,lm1,
+     x        enm2,ierr,lor1,enorn
+      double precision a(nm,n),b(nm,n),z(nm,n)
+      double precision r,s,t,a1,a2,a3,ep,sh,u1,u2,u3,v1,v2,v3,ani,a11,
+     x       a12,a21,a22,a33,a34,a43,a44,bni,b11,b12,b22,b33,b34,
+     x       b44,epsa,epsb,eps1,anorm,bnorm,epslon
+      logical matz,notlas
+c
+c     this subroutine is the second step of the qz algorithm
+c     for solving generalized matrix eigenvalue problems,
+c     siam j. numer. anal. 10, 241-256(1973) by moler and stewart,
+c     as modified in technical note nasa tn d-7305(1973) by ward.
+c
+c     this subroutine accepts a pair of real matrices, one of them
+c     in upper hessenberg form and the other in upper triangular form.
+c     it reduces the hessenberg matrix to quasi-triangular form using
+c     orthogonal transformations while maintaining the triangular form
+c     of the other matrix.  it is usually preceded by  qzhes  and
+c     followed by  qzval  and, possibly,  qzvec.
+c
+c     on input
+c
+c        nm must be set to the row dimension of two-dimensional
+c          array parameters as declared in the calling program
+c          dimension statement.
+c
+c        n is the order of the matrices.
+c
+c        a contains a real upper hessenberg matrix.
+c
+c        b contains a real upper triangular matrix.
+c
+c        eps1 is a tolerance used to determine negligible elements.
+c          eps1 = 0.0 (or negative) may be input, in which case an
+c          element will be neglected only if it is less than roundoff
+c          error times the norm of its matrix.  if the input eps1 is
+c          positive, then an element will be considered negligible
+c          if it is less than eps1 times the norm of its matrix.  a
+c          positive value of eps1 may result in faster execution,
+c          but less accurate results.
+c
+c        matz should be set to .true. if the right hand transformations
+c          are to be accumulated for later use in computing
+c          eigenvectors, and to .false. otherwise.
+c
+c        z contains, if matz has been set to .true., the
+c          transformation matrix produced in the reduction
+c          by  qzhes, if performed, or else the identity matrix.
+c          if matz has been set to .false., z is not referenced.
+c
+c     on output
+c
+c        a has been reduced to quasi-triangular form.  the elements
+c          below the first subdiagonal are still zero and no two
+c          consecutive subdiagonal elements are nonzero.
+c
+c        b is still in upper triangular form, although its elements
+c          have been altered.  the location b(n,1) is used to store
+c          eps1 times the norm of b for later use by  qzval  and  qzvec.
+c
+c        z contains the product of the right hand transformations
+c          (for both steps) if matz has been set to .true..
+c
+c        ierr is set to
+c          zero       for normal return,
+c          j          if the limit of 30*n iterations is exhausted
+c                     while the j-th eigenvalue is being sought.
+c
+c     questions and comments should be directed to burton s. garbow,
+c     mathematics and computer science div, argonne national laboratory
+c
+c     this version dated august 1983.
+c
+c     ------------------------------------------------------------------
+c
+      ierr = 0
+c     .......... compute epsa,epsb ..........
+      anorm = 0.0d0
+      bnorm = 0.0d0
+c
+      do 30 i = 1, n
+         ani = 0.0d0
+         if (i .ne. 1) ani = dabs(a(i,i-1))
+         bni = 0.0d0
+c
+         do 20 j = i, n
+            ani = ani + dabs(a(i,j))
+            bni = bni + dabs(b(i,j))
+   20    continue
+c
+         if (ani .gt. anorm) anorm = ani
+         if (bni .gt. bnorm) bnorm = bni
+   30 continue
+c
+      if (anorm .eq. 0.0d0) anorm = 1.0d0
+      if (bnorm .eq. 0.0d0) bnorm = 1.0d0
+      ep = eps1
+      if (ep .gt. 0.0d0) go to 50
+c     .......... use roundoff level if eps1 is zero ..........
+      ep = epslon(1.0d0)
+   50 epsa = ep * anorm
+      epsb = ep * bnorm
+c     .......... reduce a to quasi-triangular form, while
+c                keeping b triangular ..........
+      lor1 = 1
+      enorn = n
+      en = n
+      itn = 30*n
+c     .......... begin qz step ..........
+   60 if (en .le. 2) go to 1001
+      if (.not. matz) enorn = en
+      its = 0
+      na = en - 1
+      enm2 = na - 1
+   70 ish = 2
+c     .......... check for convergence or reducibility.
+c                for l=en step -1 until 1 do -- ..........
+      do 80 ll = 1, en
+         lm1 = en - ll
+         l = lm1 + 1
+         if (l .eq. 1) go to 95
+         if (dabs(a(l,lm1)) .le. epsa) go to 90
+   80 continue
+c
+   90 a(l,lm1) = 0.0d0
+      if (l .lt. na) go to 95
+c     .......... 1-by-1 or 2-by-2 block isolated ..........
+      en = lm1
+      go to 60
+c     .......... check for small top of b ..........
+   95 ld = l
+  100 l1 = l + 1
+      b11 = b(l,l)
+      if (dabs(b11) .gt. epsb) go to 120
+      b(l,l) = 0.0d0
+      s = dabs(a(l,l)) + dabs(a(l1,l))
+      u1 = a(l,l) / s
+      u2 = a(l1,l) / s
+      r = dsign(dsqrt(u1*u1+u2*u2),u1)
+      v1 = -(u1 + r) / r
+      v2 = -u2 / r
+      u2 = v2 / v1
+c
+      do 110 j = l, enorn
+         t = a(l,j) + u2 * a(l1,j)
+         a(l,j) = a(l,j) + t * v1
+         a(l1,j) = a(l1,j) + t * v2
+         t = b(l,j) + u2 * b(l1,j)
+         b(l,j) = b(l,j) + t * v1
+         b(l1,j) = b(l1,j) + t * v2
+  110 continue
+c
+      if (l .ne. 1) a(l,lm1) = -a(l,lm1)
+      lm1 = l
+      l = l1
+      go to 90
+  120 a11 = a(l,l) / b11
+      a21 = a(l1,l) / b11
+      if (ish .eq. 1) go to 140
+c     .......... iteration strategy ..........
+      if (itn .eq. 0) go to 1000
+      if (its .eq. 10) go to 155
+c     .......... determine type of shift ..........
+      b22 = b(l1,l1)
+      if (dabs(b22) .lt. epsb) b22 = epsb
+      b33 = b(na,na)
+      if (dabs(b33) .lt. epsb) b33 = epsb
+      b44 = b(en,en)
+      if (dabs(b44) .lt. epsb) b44 = epsb
+      a33 = a(na,na) / b33
+      a34 = a(na,en) / b44
+      a43 = a(en,na) / b33
+      a44 = a(en,en) / b44
+      b34 = b(na,en) / b44
+      t = 0.5d0 * (a43 * b34 - a33 - a44)
+      r = t * t + a34 * a43 - a33 * a44
+      if (r .lt. 0.0d0) go to 150
+c     .......... determine single shift zeroth column of a ..........
+      ish = 1
+      r = dsqrt(r)
+      sh = -t + r
+      s = -t - r
+      if (dabs(s-a44) .lt. dabs(sh-a44)) sh = s
+c     .......... look for two consecutive small
+c                sub-diagonal elements of a.
+c                for l=en-2 step -1 until ld do -- ..........
+      do 130 ll = ld, enm2
+         l = enm2 + ld - ll
+         if (l .eq. ld) go to 140
+         lm1 = l - 1
+         l1 = l + 1
+         t = a(l,l)
+         if (dabs(b(l,l)) .gt. epsb) t = t - sh * b(l,l)
+         if (dabs(a(l,lm1)) .le. dabs(t/a(l1,l)) * epsa) go to 100
+  130 continue
+c
+  140 a1 = a11 - sh
+      a2 = a21
+      if (l .ne. ld) a(l,lm1) = -a(l,lm1)
+      go to 160
+c     .......... determine double shift zeroth column of a ..........
+  150 a12 = a(l,l1) / b22
+      a22 = a(l1,l1) / b22
+      b12 = b(l,l1) / b22
+      a1 = ((a33 - a11) * (a44 - a11) - a34 * a43 + a43 * b34 * a11)
+     x     / a21 + a12 - a11 * b12
+      a2 = (a22 - a11) - a21 * b12 - (a33 - a11) - (a44 - a11)
+     x     + a43 * b34
+      a3 = a(l1+1,l1) / b22
+      go to 160
+c     .......... ad hoc shift ..........
+  155 a1 = 0.0d0
+      a2 = 1.0d0
+      a3 = 1.1605d0
+  160 its = its + 1
+      itn = itn - 1
+      if (.not. matz) lor1 = ld
+c     .......... main loop ..........
+      do 260 k = l, na
+         notlas = k .ne. na .and. ish .eq. 2
+         k1 = k + 1
+         k2 = k + 2
+         km1 = max0(k-1,l)
+         ll = min0(en,k1+ish)
+         if (notlas) go to 190
+c     .......... zero a(k+1,k-1) ..........
+         if (k .eq. l) go to 170
+         a1 = a(k,km1)
+         a2 = a(k1,km1)
+  170    s = dabs(a1) + dabs(a2)
+         if (s .eq. 0.0d0) go to 70
+         u1 = a1 / s
+         u2 = a2 / s
+         r = dsign(dsqrt(u1*u1+u2*u2),u1)
+         v1 = -(u1 + r) / r
+         v2 = -u2 / r
+         u2 = v2 / v1
+c
+         do 180 j = km1, enorn
+            t = a(k,j) + u2 * a(k1,j)
+            a(k,j) = a(k,j) + t * v1
+            a(k1,j) = a(k1,j) + t * v2
+            t = b(k,j) + u2 * b(k1,j)
+            b(k,j) = b(k,j) + t * v1
+            b(k1,j) = b(k1,j) + t * v2
+  180    continue
+c
+         if (k .ne. l) a(k1,km1) = 0.0d0
+         go to 240
+c     .......... zero a(k+1,k-1) and a(k+2,k-1) ..........
+  190    if (k .eq. l) go to 200
+         a1 = a(k,km1)
+         a2 = a(k1,km1)
+         a3 = a(k2,km1)
+  200    s = dabs(a1) + dabs(a2) + dabs(a3)
+         if (s .eq. 0.0d0) go to 260
+         u1 = a1 / s
+         u2 = a2 / s
+         u3 = a3 / s
+         r = dsign(dsqrt(u1*u1+u2*u2+u3*u3),u1)
+         v1 = -(u1 + r) / r
+         v2 = -u2 / r
+         v3 = -u3 / r
+         u2 = v2 / v1
+         u3 = v3 / v1
+c
+         do 210 j = km1, enorn
+            t = a(k,j) + u2 * a(k1,j) + u3 * a(k2,j)
+            a(k,j) = a(k,j) + t * v1
+            a(k1,j) = a(k1,j) + t * v2
+            a(k2,j) = a(k2,j) + t * v3
+            t = b(k,j) + u2 * b(k1,j) + u3 * b(k2,j)
+            b(k,j) = b(k,j) + t * v1
+            b(k1,j) = b(k1,j) + t * v2
+            b(k2,j) = b(k2,j) + t * v3
+  210    continue
+c
+         if (k .eq. l) go to 220
+         a(k1,km1) = 0.0d0
+         a(k2,km1) = 0.0d0
+c     .......... zero b(k+2,k+1) and b(k+2,k) ..........
+  220    s = dabs(b(k2,k2)) + dabs(b(k2,k1)) + dabs(b(k2,k))
+         if (s .eq. 0.0d0) go to 240
+         u1 = b(k2,k2) / s
+         u2 = b(k2,k1) / s
+         u3 = b(k2,k) / s
+         r = dsign(dsqrt(u1*u1+u2*u2+u3*u3),u1)
+         v1 = -(u1 + r) / r
+         v2 = -u2 / r
+         v3 = -u3 / r
+         u2 = v2 / v1
+         u3 = v3 / v1
+c
+         do 230 i = lor1, ll
+            t = a(i,k2) + u2 * a(i,k1) + u3 * a(i,k)
+            a(i,k2) = a(i,k2) + t * v1
+            a(i,k1) = a(i,k1) + t * v2
+            a(i,k) = a(i,k) + t * v3
+            t = b(i,k2) + u2 * b(i,k1) + u3 * b(i,k)
+            b(i,k2) = b(i,k2) + t * v1
+            b(i,k1) = b(i,k1) + t * v2
+            b(i,k) = b(i,k) + t * v3
+  230    continue
+c
+         b(k2,k) = 0.0d0
+         b(k2,k1) = 0.0d0
+         if (.not. matz) go to 240
+c
+         do 235 i = 1, n
+            t = z(i,k2) + u2 * z(i,k1) + u3 * z(i,k)
+            z(i,k2) = z(i,k2) + t * v1
+            z(i,k1) = z(i,k1) + t * v2
+            z(i,k) = z(i,k) + t * v3
+  235    continue
+c     .......... zero b(k+1,k) ..........
+  240    s = dabs(b(k1,k1)) + dabs(b(k1,k))
+         if (s .eq. 0.0d0) go to 260
+         u1 = b(k1,k1) / s
+         u2 = b(k1,k) / s
+         r = dsign(dsqrt(u1*u1+u2*u2),u1)
+         v1 = -(u1 + r) / r
+         v2 = -u2 / r
+         u2 = v2 / v1
+c
+         do 250 i = lor1, ll
+            t = a(i,k1) + u2 * a(i,k)
+            a(i,k1) = a(i,k1) + t * v1
+            a(i,k) = a(i,k) + t * v2
+            t = b(i,k1) + u2 * b(i,k)
+            b(i,k1) = b(i,k1) + t * v1
+            b(i,k) = b(i,k) + t * v2
+  250    continue
+c
+         b(k1,k) = 0.0d0
+         if (.not. matz) go to 260
+c
+         do 255 i = 1, n
+            t = z(i,k1) + u2 * z(i,k)
+            z(i,k1) = z(i,k1) + t * v1
+            z(i,k) = z(i,k) + t * v2
+  255    continue
+c
+  260 continue
+c     .......... end qz step ..........
+      go to 70
+c     .......... set error -- all eigenvalues have not
+c                converged after 30*n iterations ..........
+ 1000 ierr = en
+c     .......... save epsb for use by qzval and qzvec ..........
+ 1001 if (n .gt. 1) b(n,1) = epsb
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/eispack/qzval.f
@@ -0,0 +1,277 @@
+      subroutine qzval(nm,n,a,b,alfr,alfi,beta,matz,z)
+c
+      integer i,j,n,en,na,nm,nn,isw
+      double precision a(nm,n),b(nm,n),alfr(n),alfi(n),beta(n),z(nm,n)
+      double precision c,d,e,r,s,t,an,a1,a2,bn,cq,cz,di,dr,ei,ti,tr,u1,
+     x       u2,v1,v2,a1i,a11,a12,a2i,a21,a22,b11,b12,b22,sqi,sqr,
+     x       ssi,ssr,szi,szr,a11i,a11r,a12i,a12r,a22i,a22r,epsb
+      logical matz
+c
+c     this subroutine is the third step of the qz algorithm
+c     for solving generalized matrix eigenvalue problems,
+c     siam j. numer. anal. 10, 241-256(1973) by moler and stewart.
+c
+c     this subroutine accepts a pair of real matrices, one of them
+c     in quasi-triangular form and the other in upper triangular form.
+c     it reduces the quasi-triangular matrix further, so that any
+c     remaining 2-by-2 blocks correspond to pairs of complex
+c     eigenvalues, and returns quantities whose ratios give the
+c     generalized eigenvalues.  it is usually preceded by  qzhes
+c     and  qzit  and may be followed by  qzvec.
+c
+c     on input
+c
+c        nm must be set to the row dimension of two-dimensional
+c          array parameters as declared in the calling program
+c          dimension statement.
+c
+c        n is the order of the matrices.
+c
+c        a contains a real upper quasi-triangular matrix.
+c
+c        b contains a real upper triangular matrix.  in addition,
+c          location b(n,1) contains the tolerance quantity (epsb)
+c          computed and saved in  qzit.
+c
+c        matz should be set to .true. if the right hand transformations
+c          are to be accumulated for later use in computing
+c          eigenvectors, and to .false. otherwise.
+c
+c        z contains, if matz has been set to .true., the
+c          transformation matrix produced in the reductions by qzhes
+c          and qzit, if performed, or else the identity matrix.
+c          if matz has been set to .false., z is not referenced.
+c
+c     on output
+c
+c        a has been reduced further to a quasi-triangular matrix
+c          in which all nonzero subdiagonal elements correspond to
+c          pairs of complex eigenvalues.
+c
+c        b is still in upper triangular form, although its elements
+c          have been altered.  b(n,1) is unaltered.
+c
+c        alfr and alfi contain the real and imaginary parts of the
+c          diagonal elements of the triangular matrix that would be
+c          obtained if a were reduced completely to triangular form
+c          by unitary transformations.  non-zero values of alfi occur
+c          in pairs, the first member positive and the second negative.
+c
+c        beta contains the diagonal elements of the corresponding b,
+c          normalized to be real and non-negative.  the generalized
+c          eigenvalues are then the ratios ((alfr+i*alfi)/beta).
+c
+c        z contains the product of the right hand transformations
+c          (for all three steps) if matz has been set to .true.
+c
+c     questions and comments should be directed to burton s. garbow,
+c     mathematics and computer science div, argonne national laboratory
+c
+c     this version dated august 1983.
+c
+c     ------------------------------------------------------------------
+c
+      epsb = b(n,1)
+      isw = 1
+c     .......... find eigenvalues of quasi-triangular matrices.
+c                for en=n step -1 until 1 do -- ..........
+      do 510 nn = 1, n
+         en = n + 1 - nn
+         na = en - 1
+         if (isw .eq. 2) go to 505
+         if (en .eq. 1) go to 410
+         if (a(en,na) .ne. 0.0d0) go to 420
+c     .......... 1-by-1 block, one real root ..........
+  410    alfr(en) = a(en,en)
+         if (b(en,en) .lt. 0.0d0) alfr(en) = -alfr(en)
+         beta(en) = dabs(b(en,en))
+         alfi(en) = 0.0d0
+         go to 510
+c     .......... 2-by-2 block ..........
+  420    if (dabs(b(na,na)) .le. epsb) go to 455
+         if (dabs(b(en,en)) .gt. epsb) go to 430
+         a1 = a(en,en)
+         a2 = a(en,na)
+         bn = 0.0d0
+         go to 435
+  430    an = dabs(a(na,na)) + dabs(a(na,en)) + dabs(a(en,na))
+     x      + dabs(a(en,en))
+         bn = dabs(b(na,na)) + dabs(b(na,en)) + dabs(b(en,en))
+         a11 = a(na,na) / an
+         a12 = a(na,en) / an
+         a21 = a(en,na) / an
+         a22 = a(en,en) / an
+         b11 = b(na,na) / bn
+         b12 = b(na,en) / bn
+         b22 = b(en,en) / bn
+         e = a11 / b11
+         ei = a22 / b22
+         s = a21 / (b11 * b22)
+         t = (a22 - e * b22) / b22
+         if (dabs(e) .le. dabs(ei)) go to 431
+         e = ei
+         t = (a11 - e * b11) / b11
+  431    c = 0.5d0 * (t - s * b12)
+         d = c * c + s * (a12 - e * b12)
+         if (d .lt. 0.0d0) go to 480
+c     .......... two real roots.
+c                zero both a(en,na) and b(en,na) ..........
+         e = e + (c + dsign(dsqrt(d),c))
+         a11 = a11 - e * b11
+         a12 = a12 - e * b12
+         a22 = a22 - e * b22
+         if (dabs(a11) + dabs(a12) .lt.
+     x       dabs(a21) + dabs(a22)) go to 432
+         a1 = a12
+         a2 = a11
+         go to 435
+  432    a1 = a22
+         a2 = a21
+c     .......... choose and apply real z ..........
+  435    s = dabs(a1) + dabs(a2)
+         u1 = a1 / s
+         u2 = a2 / s
+         r = dsign(dsqrt(u1*u1+u2*u2),u1)
+         v1 = -(u1 + r) / r
+         v2 = -u2 / r
+         u2 = v2 / v1
+c
+         do 440 i = 1, en
+            t = a(i,en) + u2 * a(i,na)
+            a(i,en) = a(i,en) + t * v1
+            a(i,na) = a(i,na) + t * v2
+            t = b(i,en) + u2 * b(i,na)
+            b(i,en) = b(i,en) + t * v1
+            b(i,na) = b(i,na) + t * v2
+  440    continue
+c
+         if (.not. matz) go to 450
+c
+         do 445 i = 1, n
+            t = z(i,en) + u2 * z(i,na)
+            z(i,en) = z(i,en) + t * v1
+            z(i,na) = z(i,na) + t * v2
+  445    continue
+c
+  450    if (bn .eq. 0.0d0) go to 475
+         if (an .lt. dabs(e) * bn) go to 455
+         a1 = b(na,na)
+         a2 = b(en,na)
+         go to 460
+  455    a1 = a(na,na)
+         a2 = a(en,na)
+c     .......... choose and apply real q ..........
+  460    s = dabs(a1) + dabs(a2)
+         if (s .eq. 0.0d0) go to 475
+         u1 = a1 / s
+         u2 = a2 / s
+         r = dsign(dsqrt(u1*u1+u2*u2),u1)
+         v1 = -(u1 + r) / r
+         v2 = -u2 / r
+         u2 = v2 / v1
+c
+         do 470 j = na, n
+            t = a(na,j) + u2 * a(en,j)
+            a(na,j) = a(na,j) + t * v1
+            a(en,j) = a(en,j) + t * v2
+            t = b(na,j) + u2 * b(en,j)
+            b(na,j) = b(na,j) + t * v1
+            b(en,j) = b(en,j) + t * v2
+  470    continue
+c
+  475    a(en,na) = 0.0d0
+         b(en,na) = 0.0d0
+         alfr(na) = a(na,na)
+         alfr(en) = a(en,en)
+         if (b(na,na) .lt. 0.0d0) alfr(na) = -alfr(na)
+         if (b(en,en) .lt. 0.0d0) alfr(en) = -alfr(en)
+         beta(na) = dabs(b(na,na))
+         beta(en) = dabs(b(en,en))
+         alfi(en) = 0.0d0
+         alfi(na) = 0.0d0
+         go to 505
+c     .......... two complex roots ..........
+  480    e = e + c
+         ei = dsqrt(-d)
+         a11r = a11 - e * b11
+         a11i = ei * b11
+         a12r = a12 - e * b12
+         a12i = ei * b12
+         a22r = a22 - e * b22
+         a22i = ei * b22
+         if (dabs(a11r) + dabs(a11i) + dabs(a12r) + dabs(a12i) .lt.
+     x       dabs(a21) + dabs(a22r) + dabs(a22i)) go to 482
+         a1 = a12r
+         a1i = a12i
+         a2 = -a11r
+         a2i = -a11i
+         go to 485
+  482    a1 = a22r
+         a1i = a22i
+         a2 = -a21
+         a2i = 0.0d0
+c     .......... choose complex z ..........
+  485    cz = dsqrt(a1*a1+a1i*a1i)
+         if (cz .eq. 0.0d0) go to 487
+         szr = (a1 * a2 + a1i * a2i) / cz
+         szi = (a1 * a2i - a1i * a2) / cz
+         r = dsqrt(cz*cz+szr*szr+szi*szi)
+         cz = cz / r
+         szr = szr / r
+         szi = szi / r
+         go to 490
+  487    szr = 1.0d0
+         szi = 0.0d0
+  490    if (an .lt. (dabs(e) + ei) * bn) go to 492
+         a1 = cz * b11 + szr * b12
+         a1i = szi * b12
+         a2 = szr * b22
+         a2i = szi * b22
+         go to 495
+  492    a1 = cz * a11 + szr * a12
+         a1i = szi * a12
+         a2 = cz * a21 + szr * a22
+         a2i = szi * a22
+c     .......... choose complex q ..........
+  495    cq = dsqrt(a1*a1+a1i*a1i)
+         if (cq .eq. 0.0d0) go to 497
+         sqr = (a1 * a2 + a1i * a2i) / cq
+         sqi = (a1 * a2i - a1i * a2) / cq
+         r = dsqrt(cq*cq+sqr*sqr+sqi*sqi)
+         cq = cq / r
+         sqr = sqr / r
+         sqi = sqi / r
+         go to 500
+  497    sqr = 1.0d0
+         sqi = 0.0d0
+c     .......... compute diagonal elements that would result
+c                if transformations were applied ..........
+  500    ssr = sqr * szr + sqi * szi
+         ssi = sqr * szi - sqi * szr
+         i = 1
+         tr = cq * cz * a11 + cq * szr * a12 + sqr * cz * a21
+     x      + ssr * a22
+         ti = cq * szi * a12 - sqi * cz * a21 + ssi * a22
+         dr = cq * cz * b11 + cq * szr * b12 + ssr * b22
+         di = cq * szi * b12 + ssi * b22
+         go to 503
+  502    i = 2
+         tr = ssr * a11 - sqr * cz * a12 - cq * szr * a21
+     x      + cq * cz * a22
+         ti = -ssi * a11 - sqi * cz * a12 + cq * szi * a21
+         dr = ssr * b11 - sqr * cz * b12 + cq * cz * b22
+         di = -ssi * b11 - sqi * cz * b12
+  503    t = ti * dr - tr * di
+         j = na
+         if (t .lt. 0.0d0) j = en
+         r = dsqrt(dr*dr+di*di)
+         beta(j) = bn * r
+         alfr(j) = an * (tr * dr + ti * di) / r
+         alfi(j) = an * t / r
+         if (i .eq. 1) go to 502
+  505    isw = 3 - isw
+  510 continue
+      b(n,1) = epsb
+c
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fftpack/cfftb.f
@@ -0,0 +1,9 @@
+      subroutine cfftb (n,c,wsave)
+      implicit double precision (a-h,o-z)
+      dimension       c(1)       ,wsave(1)
+      if (n .eq. 1) return
+      iw1 = n+n+1
+      iw2 = iw1+n+n
+      call cfftb1 (n,c,wsave,wsave(iw1),wsave(iw2))
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fftpack/cfftf.f
@@ -0,0 +1,9 @@
+      subroutine cfftf (n,c,wsave)
+      implicit double precision (a-h,o-z)
+      dimension       c(1)       ,wsave(1)
+      if (n .eq. 1) return
+      iw1 = n+n+1
+      iw2 = iw1+n+n
+      call cfftf1 (n,c,wsave,wsave(iw1),wsave(iw2))
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fftpack/cffti.f
@@ -0,0 +1,9 @@
+      subroutine cffti (n,wsave)
+      implicit double precision (a-h,o-z)
+      dimension       wsave(1)
+      if (n .eq. 1) return
+      iw1 = n+n+1
+      iw2 = iw1+n+n
+      call cffti1 (n,wsave(iw1),wsave(iw2))
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fftpack/passb.f
@@ -0,0 +1,117 @@
+      subroutine passb (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa)
+      implicit double precision (a-h,o-z)
+      dimension       ch(ido,l1,ip)          ,cc(ido,ip,l1)          ,
+     1                c1(ido,l1,ip)          ,wa(1)      ,c2(idl1,ip),
+     2                ch2(idl1,ip)
+      idot = ido/2
+      nt = ip*idl1
+      ipp2 = ip+2
+      ipph = (ip+1)/2
+      idp = ip*ido
+c
+      if (ido .lt. l1) go to 106
+      do 103 j=2,ipph
+         jc = ipp2-j
+         do 102 k=1,l1
+            do 101 i=1,ido
+               ch(i,k,j) = cc(i,j,k)+cc(i,jc,k)
+               ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k)
+  101       continue
+  102    continue
+  103 continue
+      do 105 k=1,l1
+         do 104 i=1,ido
+            ch(i,k,1) = cc(i,1,k)
+  104    continue
+  105 continue
+      go to 112
+  106 do 109 j=2,ipph
+         jc = ipp2-j
+         do 108 i=1,ido
+            do 107 k=1,l1
+               ch(i,k,j) = cc(i,j,k)+cc(i,jc,k)
+               ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k)
+  107       continue
+  108    continue
+  109 continue
+      do 111 i=1,ido
+         do 110 k=1,l1
+            ch(i,k,1) = cc(i,1,k)
+  110    continue
+  111 continue
+  112 idl = 2-ido
+      inc = 0
+      do 116 l=2,ipph
+         lc = ipp2-l
+         idl = idl+ido
+         do 113 ik=1,idl1
+            c2(ik,l) = ch2(ik,1)+wa(idl-1)*ch2(ik,2)
+            c2(ik,lc) = wa(idl)*ch2(ik,ip)
+  113    continue
+         idlj = idl
+         inc = inc+ido
+         do 115 j=3,ipph
+            jc = ipp2-j
+            idlj = idlj+inc
+            if (idlj .gt. idp) idlj = idlj-idp
+            war = wa(idlj-1)
+            wai = wa(idlj)
+            do 114 ik=1,idl1
+               c2(ik,l) = c2(ik,l)+war*ch2(ik,j)
+               c2(ik,lc) = c2(ik,lc)+wai*ch2(ik,jc)
+  114       continue
+  115    continue
+  116 continue
+      do 118 j=2,ipph
+         do 117 ik=1,idl1
+            ch2(ik,1) = ch2(ik,1)+ch2(ik,j)
+  117    continue
+  118 continue
+      do 120 j=2,ipph
+         jc = ipp2-j
+         do 119 ik=2,idl1,2
+            ch2(ik-1,j) = c2(ik-1,j)-c2(ik,jc)
+            ch2(ik-1,jc) = c2(ik-1,j)+c2(ik,jc)
+            ch2(ik,j) = c2(ik,j)+c2(ik-1,jc)
+            ch2(ik,jc) = c2(ik,j)-c2(ik-1,jc)
+  119    continue
+  120 continue
+      nac = 1
+      if (ido .eq. 2) return
+      nac = 0
+      do 121 ik=1,idl1
+         c2(ik,1) = ch2(ik,1)
+  121 continue
+      do 123 j=2,ip
+         do 122 k=1,l1
+            c1(1,k,j) = ch(1,k,j)
+            c1(2,k,j) = ch(2,k,j)
+  122    continue
+  123 continue
+      if (idot .gt. l1) go to 127
+      idij = 0
+      do 126 j=2,ip
+         idij = idij+2
+         do 125 i=4,ido,2
+            idij = idij+2
+            do 124 k=1,l1
+               c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)-wa(idij)*ch(i,k,j)
+               c1(i,k,j) = wa(idij-1)*ch(i,k,j)+wa(idij)*ch(i-1,k,j)
+  124       continue
+  125    continue
+  126 continue
+      return
+  127 idj = 2-ido
+      do 130 j=2,ip
+         idj = idj+ido
+         do 129 k=1,l1
+            idij = idj
+            do 128 i=4,ido,2
+               idij = idij+2
+               c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)-wa(idij)*ch(i,k,j)
+               c1(i,k,j) = wa(idij-1)*ch(i,k,j)+wa(idij)*ch(i-1,k,j)
+  128       continue
+  129    continue
+  130 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fftpack/passb2.f
@@ -0,0 +1,24 @@
+      subroutine passb2 (ido,l1,cc,ch,wa1)
+      implicit double precision (a-h,o-z)
+      dimension       cc(ido,2,l1)           ,ch(ido,l1,2)           ,
+     1                wa1(1)
+      if (ido .gt. 2) go to 102
+      do 101 k=1,l1
+         ch(1,k,1) = cc(1,1,k)+cc(1,2,k)
+         ch(1,k,2) = cc(1,1,k)-cc(1,2,k)
+         ch(2,k,1) = cc(2,1,k)+cc(2,2,k)
+         ch(2,k,2) = cc(2,1,k)-cc(2,2,k)
+  101 continue
+      return
+  102 do 104 k=1,l1
+         do 103 i=2,ido,2
+            ch(i-1,k,1) = cc(i-1,1,k)+cc(i-1,2,k)
+            tr2 = cc(i-1,1,k)-cc(i-1,2,k)
+            ch(i,k,1) = cc(i,1,k)+cc(i,2,k)
+            ti2 = cc(i,1,k)-cc(i,2,k)
+            ch(i,k,2) = wa1(i-1)*ti2+wa1(i)*tr2
+            ch(i-1,k,2) = wa1(i-1)*tr2-wa1(i)*ti2
+  103    continue
+  104 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fftpack/passb3.f
@@ -0,0 +1,43 @@
+      subroutine passb3 (ido,l1,cc,ch,wa1,wa2)
+      implicit double precision (a-h,o-z)
+      dimension       cc(ido,3,l1)           ,ch(ido,l1,3)           ,
+     1                wa1(1)     ,wa2(1)
+      data taur,taui /-.5,.866025403784439/
+      if (ido .ne. 2) go to 102
+      do 101 k=1,l1
+         tr2 = cc(1,2,k)+cc(1,3,k)
+         cr2 = cc(1,1,k)+taur*tr2
+         ch(1,k,1) = cc(1,1,k)+tr2
+         ti2 = cc(2,2,k)+cc(2,3,k)
+         ci2 = cc(2,1,k)+taur*ti2
+         ch(2,k,1) = cc(2,1,k)+ti2
+         cr3 = taui*(cc(1,2,k)-cc(1,3,k))
+         ci3 = taui*(cc(2,2,k)-cc(2,3,k))
+         ch(1,k,2) = cr2-ci3
+         ch(1,k,3) = cr2+ci3
+         ch(2,k,2) = ci2+cr3
+         ch(2,k,3) = ci2-cr3
+  101 continue
+      return
+  102 do 104 k=1,l1
+         do 103 i=2,ido,2
+            tr2 = cc(i-1,2,k)+cc(i-1,3,k)
+            cr2 = cc(i-1,1,k)+taur*tr2
+            ch(i-1,k,1) = cc(i-1,1,k)+tr2
+            ti2 = cc(i,2,k)+cc(i,3,k)
+            ci2 = cc(i,1,k)+taur*ti2
+            ch(i,k,1) = cc(i,1,k)+ti2
+            cr3 = taui*(cc(i-1,2,k)-cc(i-1,3,k))
+            ci3 = taui*(cc(i,2,k)-cc(i,3,k))
+            dr2 = cr2-ci3
+            dr3 = cr2+ci3
+            di2 = ci2+cr3
+            di3 = ci2-cr3
+            ch(i,k,2) = wa1(i-1)*di2+wa1(i)*dr2
+            ch(i-1,k,2) = wa1(i-1)*dr2-wa1(i)*di2
+            ch(i,k,3) = wa2(i-1)*di3+wa2(i)*dr3
+            ch(i-1,k,3) = wa2(i-1)*dr3-wa2(i)*di3
+  103    continue
+  104 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fftpack/passb4.f
@@ -0,0 +1,52 @@
+      subroutine passb4 (ido,l1,cc,ch,wa1,wa2,wa3)
+      implicit double precision (a-h,o-z)
+      dimension       cc(ido,4,l1)           ,ch(ido,l1,4)           ,
+     1                wa1(1)     ,wa2(1)     ,wa3(1)
+      if (ido .ne. 2) go to 102
+      do 101 k=1,l1
+         ti1 = cc(2,1,k)-cc(2,3,k)
+         ti2 = cc(2,1,k)+cc(2,3,k)
+         tr4 = cc(2,4,k)-cc(2,2,k)
+         ti3 = cc(2,2,k)+cc(2,4,k)
+         tr1 = cc(1,1,k)-cc(1,3,k)
+         tr2 = cc(1,1,k)+cc(1,3,k)
+         ti4 = cc(1,2,k)-cc(1,4,k)
+         tr3 = cc(1,2,k)+cc(1,4,k)
+         ch(1,k,1) = tr2+tr3
+         ch(1,k,3) = tr2-tr3
+         ch(2,k,1) = ti2+ti3
+         ch(2,k,3) = ti2-ti3
+         ch(1,k,2) = tr1+tr4
+         ch(1,k,4) = tr1-tr4
+         ch(2,k,2) = ti1+ti4
+         ch(2,k,4) = ti1-ti4
+  101 continue
+      return
+  102 do 104 k=1,l1
+         do 103 i=2,ido,2
+            ti1 = cc(i,1,k)-cc(i,3,k)
+            ti2 = cc(i,1,k)+cc(i,3,k)
+            ti3 = cc(i,2,k)+cc(i,4,k)
+            tr4 = cc(i,4,k)-cc(i,2,k)
+            tr1 = cc(i-1,1,k)-cc(i-1,3,k)
+            tr2 = cc(i-1,1,k)+cc(i-1,3,k)
+            ti4 = cc(i-1,2,k)-cc(i-1,4,k)
+            tr3 = cc(i-1,2,k)+cc(i-1,4,k)
+            ch(i-1,k,1) = tr2+tr3
+            cr3 = tr2-tr3
+            ch(i,k,1) = ti2+ti3
+            ci3 = ti2-ti3
+            cr2 = tr1+tr4
+            cr4 = tr1-tr4
+            ci2 = ti1+ti4
+            ci4 = ti1-ti4
+            ch(i-1,k,2) = wa1(i-1)*cr2-wa1(i)*ci2
+            ch(i,k,2) = wa1(i-1)*ci2+wa1(i)*cr2
+            ch(i-1,k,3) = wa2(i-1)*cr3-wa2(i)*ci3
+            ch(i,k,3) = wa2(i-1)*ci3+wa2(i)*cr3
+            ch(i-1,k,4) = wa3(i-1)*cr4-wa3(i)*ci4
+            ch(i,k,4) = wa3(i-1)*ci4+wa3(i)*cr4
+  103    continue
+  104 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fftpack/passb5.f
@@ -0,0 +1,76 @@
+      subroutine passb5 (ido,l1,cc,ch,wa1,wa2,wa3,wa4)
+      implicit double precision (a-h,o-z)
+      dimension       cc(ido,5,l1)           ,ch(ido,l1,5)           ,
+     1                wa1(1)     ,wa2(1)     ,wa3(1)     ,wa4(1)
+      data tr11,ti11,tr12,ti12 /.309016994374947,.951056516295154,
+     1-.809016994374947,.587785252292473/
+      if (ido .ne. 2) go to 102
+      do 101 k=1,l1
+         ti5 = cc(2,2,k)-cc(2,5,k)
+         ti2 = cc(2,2,k)+cc(2,5,k)
+         ti4 = cc(2,3,k)-cc(2,4,k)
+         ti3 = cc(2,3,k)+cc(2,4,k)
+         tr5 = cc(1,2,k)-cc(1,5,k)
+         tr2 = cc(1,2,k)+cc(1,5,k)
+         tr4 = cc(1,3,k)-cc(1,4,k)
+         tr3 = cc(1,3,k)+cc(1,4,k)
+         ch(1,k,1) = cc(1,1,k)+tr2+tr3
+         ch(2,k,1) = cc(2,1,k)+ti2+ti3
+         cr2 = cc(1,1,k)+tr11*tr2+tr12*tr3
+         ci2 = cc(2,1,k)+tr11*ti2+tr12*ti3
+         cr3 = cc(1,1,k)+tr12*tr2+tr11*tr3
+         ci3 = cc(2,1,k)+tr12*ti2+tr11*ti3
+         cr5 = ti11*tr5+ti12*tr4
+         ci5 = ti11*ti5+ti12*ti4
+         cr4 = ti12*tr5-ti11*tr4
+         ci4 = ti12*ti5-ti11*ti4
+         ch(1,k,2) = cr2-ci5
+         ch(1,k,5) = cr2+ci5
+         ch(2,k,2) = ci2+cr5
+         ch(2,k,3) = ci3+cr4
+         ch(1,k,3) = cr3-ci4
+         ch(1,k,4) = cr3+ci4
+         ch(2,k,4) = ci3-cr4
+         ch(2,k,5) = ci2-cr5
+  101 continue
+      return
+  102 do 104 k=1,l1
+         do 103 i=2,ido,2
+            ti5 = cc(i,2,k)-cc(i,5,k)
+            ti2 = cc(i,2,k)+cc(i,5,k)
+            ti4 = cc(i,3,k)-cc(i,4,k)
+            ti3 = cc(i,3,k)+cc(i,4,k)
+            tr5 = cc(i-1,2,k)-cc(i-1,5,k)
+            tr2 = cc(i-1,2,k)+cc(i-1,5,k)
+            tr4 = cc(i-1,3,k)-cc(i-1,4,k)
+            tr3 = cc(i-1,3,k)+cc(i-1,4,k)
+            ch(i-1,k,1) = cc(i-1,1,k)+tr2+tr3
+            ch(i,k,1) = cc(i,1,k)+ti2+ti3
+            cr2 = cc(i-1,1,k)+tr11*tr2+tr12*tr3
+            ci2 = cc(i,1,k)+tr11*ti2+tr12*ti3
+            cr3 = cc(i-1,1,k)+tr12*tr2+tr11*tr3
+            ci3 = cc(i,1,k)+tr12*ti2+tr11*ti3
+            cr5 = ti11*tr5+ti12*tr4
+            ci5 = ti11*ti5+ti12*ti4
+            cr4 = ti12*tr5-ti11*tr4
+            ci4 = ti12*ti5-ti11*ti4
+            dr3 = cr3-ci4
+            dr4 = cr3+ci4
+            di3 = ci3+cr4
+            di4 = ci3-cr4
+            dr5 = cr2+ci5
+            dr2 = cr2-ci5
+            di5 = ci2-cr5
+            di2 = ci2+cr5
+            ch(i-1,k,2) = wa1(i-1)*dr2-wa1(i)*di2
+            ch(i,k,2) = wa1(i-1)*di2+wa1(i)*dr2
+            ch(i-1,k,3) = wa2(i-1)*dr3-wa2(i)*di3
+            ch(i,k,3) = wa2(i-1)*di3+wa2(i)*dr3
+            ch(i-1,k,4) = wa3(i-1)*dr4-wa3(i)*di4
+            ch(i,k,4) = wa3(i-1)*di4+wa3(i)*dr4
+            ch(i-1,k,5) = wa4(i-1)*dr5-wa4(i)*di5
+            ch(i,k,5) = wa4(i-1)*di5+wa4(i)*dr5
+  103    continue
+  104 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fftpack/passf.f
@@ -0,0 +1,117 @@
+      subroutine passf (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa)
+      implicit double precision (a-h,o-z)
+      dimension       ch(ido,l1,ip)          ,cc(ido,ip,l1)          ,
+     1                c1(ido,l1,ip)          ,wa(1)      ,c2(idl1,ip),
+     2                ch2(idl1,ip)
+      idot = ido/2
+      nt = ip*idl1
+      ipp2 = ip+2
+      ipph = (ip+1)/2
+      idp = ip*ido
+c
+      if (ido .lt. l1) go to 106
+      do 103 j=2,ipph
+         jc = ipp2-j
+         do 102 k=1,l1
+            do 101 i=1,ido
+               ch(i,k,j) = cc(i,j,k)+cc(i,jc,k)
+               ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k)
+  101       continue
+  102    continue
+  103 continue
+      do 105 k=1,l1
+         do 104 i=1,ido
+            ch(i,k,1) = cc(i,1,k)
+  104    continue
+  105 continue
+      go to 112
+  106 do 109 j=2,ipph
+         jc = ipp2-j
+         do 108 i=1,ido
+            do 107 k=1,l1
+               ch(i,k,j) = cc(i,j,k)+cc(i,jc,k)
+               ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k)
+  107       continue
+  108    continue
+  109 continue
+      do 111 i=1,ido
+         do 110 k=1,l1
+            ch(i,k,1) = cc(i,1,k)
+  110    continue
+  111 continue
+  112 idl = 2-ido
+      inc = 0
+      do 116 l=2,ipph
+         lc = ipp2-l
+         idl = idl+ido
+         do 113 ik=1,idl1
+            c2(ik,l) = ch2(ik,1)+wa(idl-1)*ch2(ik,2)
+            c2(ik,lc) = -wa(idl)*ch2(ik,ip)
+  113    continue
+         idlj = idl
+         inc = inc+ido
+         do 115 j=3,ipph
+            jc = ipp2-j
+            idlj = idlj+inc
+            if (idlj .gt. idp) idlj = idlj-idp
+            war = wa(idlj-1)
+            wai = wa(idlj)
+            do 114 ik=1,idl1
+               c2(ik,l) = c2(ik,l)+war*ch2(ik,j)
+               c2(ik,lc) = c2(ik,lc)-wai*ch2(ik,jc)
+  114       continue
+  115    continue
+  116 continue
+      do 118 j=2,ipph
+         do 117 ik=1,idl1
+            ch2(ik,1) = ch2(ik,1)+ch2(ik,j)
+  117    continue
+  118 continue
+      do 120 j=2,ipph
+         jc = ipp2-j
+         do 119 ik=2,idl1,2
+            ch2(ik-1,j) = c2(ik-1,j)-c2(ik,jc)
+            ch2(ik-1,jc) = c2(ik-1,j)+c2(ik,jc)
+            ch2(ik,j) = c2(ik,j)+c2(ik-1,jc)
+            ch2(ik,jc) = c2(ik,j)-c2(ik-1,jc)
+  119    continue
+  120 continue
+      nac = 1
+      if (ido .eq. 2) return
+      nac = 0
+      do 121 ik=1,idl1
+         c2(ik,1) = ch2(ik,1)
+  121 continue
+      do 123 j=2,ip
+         do 122 k=1,l1
+            c1(1,k,j) = ch(1,k,j)
+            c1(2,k,j) = ch(2,k,j)
+  122    continue
+  123 continue
+      if (idot .gt. l1) go to 127
+      idij = 0
+      do 126 j=2,ip
+         idij = idij+2
+         do 125 i=4,ido,2
+            idij = idij+2
+            do 124 k=1,l1
+               c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)+wa(idij)*ch(i,k,j)
+               c1(i,k,j) = wa(idij-1)*ch(i,k,j)-wa(idij)*ch(i-1,k,j)
+  124       continue
+  125    continue
+  126 continue
+      return
+  127 idj = 2-ido
+      do 130 j=2,ip
+         idj = idj+ido
+         do 129 k=1,l1
+            idij = idj
+            do 128 i=4,ido,2
+               idij = idij+2
+               c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)+wa(idij)*ch(i,k,j)
+               c1(i,k,j) = wa(idij-1)*ch(i,k,j)-wa(idij)*ch(i-1,k,j)
+  128       continue
+  129    continue
+  130 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fftpack/passf2.f
@@ -0,0 +1,24 @@
+      subroutine passf2 (ido,l1,cc,ch,wa1)
+      implicit double precision (a-h,o-z)
+      dimension       cc(ido,2,l1)           ,ch(ido,l1,2)           ,
+     1                wa1(1)
+      if (ido .gt. 2) go to 102
+      do 101 k=1,l1
+         ch(1,k,1) = cc(1,1,k)+cc(1,2,k)
+         ch(1,k,2) = cc(1,1,k)-cc(1,2,k)
+         ch(2,k,1) = cc(2,1,k)+cc(2,2,k)
+         ch(2,k,2) = cc(2,1,k)-cc(2,2,k)
+  101 continue
+      return
+  102 do 104 k=1,l1
+         do 103 i=2,ido,2
+            ch(i-1,k,1) = cc(i-1,1,k)+cc(i-1,2,k)
+            tr2 = cc(i-1,1,k)-cc(i-1,2,k)
+            ch(i,k,1) = cc(i,1,k)+cc(i,2,k)
+            ti2 = cc(i,1,k)-cc(i,2,k)
+            ch(i,k,2) = wa1(i-1)*ti2-wa1(i)*tr2
+            ch(i-1,k,2) = wa1(i-1)*tr2+wa1(i)*ti2
+  103    continue
+  104 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fftpack/passf3.f
@@ -0,0 +1,43 @@
+      subroutine passf3 (ido,l1,cc,ch,wa1,wa2)
+      implicit double precision (a-h,o-z)
+      dimension       cc(ido,3,l1)           ,ch(ido,l1,3)           ,
+     1                wa1(1)     ,wa2(1)
+      data taur,taui /-.5,-.866025403784439/
+      if (ido .ne. 2) go to 102
+      do 101 k=1,l1
+         tr2 = cc(1,2,k)+cc(1,3,k)
+         cr2 = cc(1,1,k)+taur*tr2
+         ch(1,k,1) = cc(1,1,k)+tr2
+         ti2 = cc(2,2,k)+cc(2,3,k)
+         ci2 = cc(2,1,k)+taur*ti2
+         ch(2,k,1) = cc(2,1,k)+ti2
+         cr3 = taui*(cc(1,2,k)-cc(1,3,k))
+         ci3 = taui*(cc(2,2,k)-cc(2,3,k))
+         ch(1,k,2) = cr2-ci3
+         ch(1,k,3) = cr2+ci3
+         ch(2,k,2) = ci2+cr3
+         ch(2,k,3) = ci2-cr3
+  101 continue
+      return
+  102 do 104 k=1,l1
+         do 103 i=2,ido,2
+            tr2 = cc(i-1,2,k)+cc(i-1,3,k)
+            cr2 = cc(i-1,1,k)+taur*tr2
+            ch(i-1,k,1) = cc(i-1,1,k)+tr2
+            ti2 = cc(i,2,k)+cc(i,3,k)
+            ci2 = cc(i,1,k)+taur*ti2
+            ch(i,k,1) = cc(i,1,k)+ti2
+            cr3 = taui*(cc(i-1,2,k)-cc(i-1,3,k))
+            ci3 = taui*(cc(i,2,k)-cc(i,3,k))
+            dr2 = cr2-ci3
+            dr3 = cr2+ci3
+            di2 = ci2+cr3
+            di3 = ci2-cr3
+            ch(i,k,2) = wa1(i-1)*di2-wa1(i)*dr2
+            ch(i-1,k,2) = wa1(i-1)*dr2+wa1(i)*di2
+            ch(i,k,3) = wa2(i-1)*di3-wa2(i)*dr3
+            ch(i-1,k,3) = wa2(i-1)*dr3+wa2(i)*di3
+  103    continue
+  104 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fftpack/passf4.f
@@ -0,0 +1,52 @@
+      subroutine passf4 (ido,l1,cc,ch,wa1,wa2,wa3)
+      implicit double precision (a-h,o-z)
+      dimension       cc(ido,4,l1)           ,ch(ido,l1,4)           ,
+     1                wa1(1)     ,wa2(1)     ,wa3(1)
+      if (ido .ne. 2) go to 102
+      do 101 k=1,l1
+         ti1 = cc(2,1,k)-cc(2,3,k)
+         ti2 = cc(2,1,k)+cc(2,3,k)
+         tr4 = cc(2,2,k)-cc(2,4,k)
+         ti3 = cc(2,2,k)+cc(2,4,k)
+         tr1 = cc(1,1,k)-cc(1,3,k)
+         tr2 = cc(1,1,k)+cc(1,3,k)
+         ti4 = cc(1,4,k)-cc(1,2,k)
+         tr3 = cc(1,2,k)+cc(1,4,k)
+         ch(1,k,1) = tr2+tr3
+         ch(1,k,3) = tr2-tr3
+         ch(2,k,1) = ti2+ti3
+         ch(2,k,3) = ti2-ti3
+         ch(1,k,2) = tr1+tr4
+         ch(1,k,4) = tr1-tr4
+         ch(2,k,2) = ti1+ti4
+         ch(2,k,4) = ti1-ti4
+  101 continue
+      return
+  102 do 104 k=1,l1
+         do 103 i=2,ido,2
+            ti1 = cc(i,1,k)-cc(i,3,k)
+            ti2 = cc(i,1,k)+cc(i,3,k)
+            ti3 = cc(i,2,k)+cc(i,4,k)
+            tr4 = cc(i,2,k)-cc(i,4,k)
+            tr1 = cc(i-1,1,k)-cc(i-1,3,k)
+            tr2 = cc(i-1,1,k)+cc(i-1,3,k)
+            ti4 = cc(i-1,4,k)-cc(i-1,2,k)
+            tr3 = cc(i-1,2,k)+cc(i-1,4,k)
+            ch(i-1,k,1) = tr2+tr3
+            cr3 = tr2-tr3
+            ch(i,k,1) = ti2+ti3
+            ci3 = ti2-ti3
+            cr2 = tr1+tr4
+            cr4 = tr1-tr4
+            ci2 = ti1+ti4
+            ci4 = ti1-ti4
+            ch(i-1,k,2) = wa1(i-1)*cr2+wa1(i)*ci2
+            ch(i,k,2) = wa1(i-1)*ci2-wa1(i)*cr2
+            ch(i-1,k,3) = wa2(i-1)*cr3+wa2(i)*ci3
+            ch(i,k,3) = wa2(i-1)*ci3-wa2(i)*cr3
+            ch(i-1,k,4) = wa3(i-1)*cr4+wa3(i)*ci4
+            ch(i,k,4) = wa3(i-1)*ci4-wa3(i)*cr4
+  103    continue
+  104 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fftpack/passf5.f
@@ -0,0 +1,76 @@
+      subroutine passf5 (ido,l1,cc,ch,wa1,wa2,wa3,wa4)
+      implicit double precision (a-h,o-z)
+      dimension       cc(ido,5,l1)           ,ch(ido,l1,5)           ,
+     1                wa1(1)     ,wa2(1)     ,wa3(1)     ,wa4(1)
+      data tr11,ti11,tr12,ti12 /.309016994374947,-.951056516295154,
+     1-.809016994374947,-.587785252292473/
+      if (ido .ne. 2) go to 102
+      do 101 k=1,l1
+         ti5 = cc(2,2,k)-cc(2,5,k)
+         ti2 = cc(2,2,k)+cc(2,5,k)
+         ti4 = cc(2,3,k)-cc(2,4,k)
+         ti3 = cc(2,3,k)+cc(2,4,k)
+         tr5 = cc(1,2,k)-cc(1,5,k)
+         tr2 = cc(1,2,k)+cc(1,5,k)
+         tr4 = cc(1,3,k)-cc(1,4,k)
+         tr3 = cc(1,3,k)+cc(1,4,k)
+         ch(1,k,1) = cc(1,1,k)+tr2+tr3
+         ch(2,k,1) = cc(2,1,k)+ti2+ti3
+         cr2 = cc(1,1,k)+tr11*tr2+tr12*tr3
+         ci2 = cc(2,1,k)+tr11*ti2+tr12*ti3
+         cr3 = cc(1,1,k)+tr12*tr2+tr11*tr3
+         ci3 = cc(2,1,k)+tr12*ti2+tr11*ti3
+         cr5 = ti11*tr5+ti12*tr4
+         ci5 = ti11*ti5+ti12*ti4
+         cr4 = ti12*tr5-ti11*tr4
+         ci4 = ti12*ti5-ti11*ti4
+         ch(1,k,2) = cr2-ci5
+         ch(1,k,5) = cr2+ci5
+         ch(2,k,2) = ci2+cr5
+         ch(2,k,3) = ci3+cr4
+         ch(1,k,3) = cr3-ci4
+         ch(1,k,4) = cr3+ci4
+         ch(2,k,4) = ci3-cr4
+         ch(2,k,5) = ci2-cr5
+  101 continue
+      return
+  102 do 104 k=1,l1
+         do 103 i=2,ido,2
+            ti5 = cc(i,2,k)-cc(i,5,k)
+            ti2 = cc(i,2,k)+cc(i,5,k)
+            ti4 = cc(i,3,k)-cc(i,4,k)
+            ti3 = cc(i,3,k)+cc(i,4,k)
+            tr5 = cc(i-1,2,k)-cc(i-1,5,k)
+            tr2 = cc(i-1,2,k)+cc(i-1,5,k)
+            tr4 = cc(i-1,3,k)-cc(i-1,4,k)
+            tr3 = cc(i-1,3,k)+cc(i-1,4,k)
+            ch(i-1,k,1) = cc(i-1,1,k)+tr2+tr3
+            ch(i,k,1) = cc(i,1,k)+ti2+ti3
+            cr2 = cc(i-1,1,k)+tr11*tr2+tr12*tr3
+            ci2 = cc(i,1,k)+tr11*ti2+tr12*ti3
+            cr3 = cc(i-1,1,k)+tr12*tr2+tr11*tr3
+            ci3 = cc(i,1,k)+tr12*ti2+tr11*ti3
+            cr5 = ti11*tr5+ti12*tr4
+            ci5 = ti11*ti5+ti12*ti4
+            cr4 = ti12*tr5-ti11*tr4
+            ci4 = ti12*ti5-ti11*ti4
+            dr3 = cr3-ci4
+            dr4 = cr3+ci4
+            di3 = ci3+cr4
+            di4 = ci3-cr4
+            dr5 = cr2+ci5
+            dr2 = cr2-ci5
+            di5 = ci2-cr5
+            di2 = ci2+cr5
+            ch(i-1,k,2) = wa1(i-1)*dr2+wa1(i)*di2
+            ch(i,k,2) = wa1(i-1)*di2-wa1(i)*dr2
+            ch(i-1,k,3) = wa2(i-1)*dr3+wa2(i)*di3
+            ch(i,k,3) = wa2(i-1)*di3-wa2(i)*dr3
+            ch(i-1,k,4) = wa3(i-1)*dr4+wa3(i)*di4
+            ch(i,k,4) = wa3(i-1)*di4-wa3(i)*dr4
+            ch(i-1,k,5) = wa4(i-1)*dr5+wa4(i)*di5
+            ch(i,k,5) = wa4(i-1)*di5-wa4(i)*dr5
+  103    continue
+  104 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/check.f
@@ -0,0 +1,77 @@
+      subroutine check(nparam,nf,Linfty,nAD,nineq,nnl,neq,neqn,
+     *                 mode,modem,lstype,eps,bigbnd,bl,bu)
+c
+c     FSQP Version 3.3  : check input data
+c
+c     implicit real*8(a-h,o-z)
+      integer nparam,nf,nineq,nnl,neq,neqn,mode,modem,lstype
+      double  precision bigbnd,eps
+      double  precision bl(nparam),bu(nparam)
+      logical Linfty,nAD
+c
+      integer io,iprint,ipspan,ipyes,info,idum1,idum2,idum3
+      double  precision epsmac,dummy1,dummy2,dummy3
+      common  /fsqpp2/io,iprint,ipspan,ipyes,info,idum1,idum2,idum3,
+     *        /fsqpp3/epsmac,dummy1,dummy2,dummy3
+c
+      integer i
+      double  precision bli,bui
+c
+      if (nparam.le.0)  
+     *  call error('nparam should be positive!              ',info,io)
+      if (nf.lt.0)     
+     *  call error('nf     should not be negative!          ',info,io)
+      if (nnl.lt.0)     
+     *  call error('nineqn should not be negative!          ',info,io)
+      if (nineq.lt.nnl) 
+     *  call error('nineq  should be no smaller than nineqn!',info,io)
+      if (neqn.lt.0)  
+     *  call error('neqn   should not be negative!          ',info,io)
+      if (neq.lt.neqn)  
+     *  call error('neq    should not be smaller than neqn  ',info,io)
+      if (nparam.le.neq)  
+     *  call error('FSQPD deals with nparam larger than neq ',info,io)
+      if (iprint.lt.0.or.iprint.gt.3)     
+     *  call error('iprint is not a valid number            ',info,io)
+      if (eps.gt.epsmac) goto 10
+      call error('eps    should be bigger than epsmac!    ',info,io)
+      write(io,9902) epsmac
+ 10   if(mode.ge.200) then
+        lstype=2
+        mode=mode-100
+      else
+        lstype=1
+      endif
+      if (.not.(mode.eq.100.or.mode.eq.101.or.
+     *          mode.eq.110.or.mode.eq.111))
+     *  call error('mode   is not properly specified!       ',info,io)
+      if (info.eq.0) goto 20
+      write(io,9903)
+      goto 9000
+c
+ 20   do 30 i=1,nparam
+        bli=bl(i)
+        bui=bu(i)
+        if (bli.le.bui) goto 25
+        write(io,9901)
+        info=7
+ 25     if (info.ne.0) goto 9000
+        if (bli.lt.(-bigbnd)) bl(i)=-bigbnd
+        if (bui.gt.bigbnd)    bu(i)=bigbnd
+ 30   continue
+c
+      i=mode-100
+      if(i.lt.10) then
+        modem=0
+      else 
+        modem=1
+        i=i-10
+      endif
+      if(i.eq.0) Linfty=.false.
+      if(i.eq.1) Linfty=.true.
+c
+ 9000 return
+ 9901 format(1x,'lower bounds should be smaller than upper bounds',/)
+ 9902 format(1x,'epsmac = ',e22.14,' which is machine dependent',/)
+ 9903 format(1x,'Error: Input parameters are not consistent',/)
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/di1.f
@@ -0,0 +1,83 @@
+c
+      subroutine di1(nparam,nqpram,nob,nobL,nineqn,neq,neqn,ncnstr,
+     *               nclin,nctotl,nrowa,infoqp,mode,iw,leniw,x0,d0,
+     *               xl,xu,f,fM,gradf,grdpsf,g,gradg,cvec,a,bl,bu,
+     *               clamda,bj,hess1,x,w,lenw)
+c     implicit real*8(a-h,o-z)
+      integer nparam,nqpram,nob,nobL,nineqn,neq,neqn,ncnstr,nclin,
+     *        nctotl,nrowa,infoqp,mode,leniw,lenw,iw(leniw)
+      double  precision fM
+      double  precision x0(nparam),d0(nparam),xl(nparam),xu(nparam),
+     *        f(1),gradf(nparam,1),grdpsf(nparam),g(1),
+     *        gradg(nparam,1),cvec(1),a(nrowa,1),
+     *        bl(1),bu(1),clamda(1),bj(1),
+     *        hess1(nparam+1,nparam+1),x(1),w(lenw)
+c     double  precision x0(nparam),d0(nparam),xl(nparam),xu(nparam),
+c    *        f(nob),gradf(nparam,nob),grdpsf(nparam),g(ncnstr),
+c    *        gradg(nparam,ncnstr),cvec(nqpram),a(nrowa,nqpram),
+c    *        bl(nctotl),bu(nctotl),clamda(nctotl+nqpram),bj(nrowa),
+c    *        hess1(nparam+1,nparam+1),x(nqpram),w(lenw)
+c
+      integer io,idum1,idum2,idum3,idum4,idum5,idum6,idum7
+      double  precision epsmac,rteps,dumm1,dumm2,bigbnd,dummy
+      common  /fsqpp2/io,idum1,idum2,idum3,idum4,idum5,idum6,idum7,
+     *        /fsqpp3/epsmac,rteps,dumm1,dumm2,
+     *        /fsqpq1/bigbnd,dummy
+c
+c     bj(1) is equivalent to bl(nparam+3)
+c
+      integer i,ii,iout,j,mnn
+      double  precision x0i,eta
+c
+      iout=io
+      if(mode.eq.0) eta=0.1d0
+      if(mode.eq.1) eta=3.d0
+      do 100 i=1,nparam
+        x0i=x0(i)
+        bl(i)=xl(i)-x0i
+        bu(i)=xu(i)-x0i
+        if(mode.eq.0) cvec(i)=-eta*d0(i)
+        if(mode.eq.1) cvec(i)=0.d0
+ 100  continue
+      bl(nqpram)=-bigbnd
+      bu(nqpram)=bigbnd
+      cvec(nqpram)=1.d0
+      ii=ncnstr-nineqn
+      do 400 i=1,ncnstr
+        bj(i)=-g(ncnstr+1-i)
+        do 300 j=1,nparam
+ 300      a(i,j)=-gradg(j,ncnstr+1-i)
+        a(i,nqpram)=0.d0
+        if((i.gt.(neq-neqn).and.i.le.neq).or.i.gt.ii) a(i,nqpram)=1.d0
+ 400  continue
+      if(mode.eq.1) goto 610
+      do 600 i=1,nob
+        ii=ncnstr+i
+        bj(ii)=fM-f(i)
+        do 500 j=1,nparam
+          a(ii,j)=-gradf(j,i)+grdpsf(j)
+          if(nobL.gt.nob) a(ii+nob,j)=gradf(j,i)+grdpsf(j)
+ 500    continue
+        a(ii,nqpram)=1.d0
+        if(nobL.gt.nob) a(ii+nob,nqpram)=1.d0
+ 600  continue
+ 610  call diagnl(nqpram,eta,hess1)
+      call nullvc(nqpram,x)
+      hess1(nqpram,nqpram)=0.d0
+c
+Ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c  The following modification is done inside QP0001
+c  for the ease of interfacing with QPSOL
+c
+c     hess1(nqpram,nqpram)=qleps
+C
+      mnn=nclin+2*nqpram
+      iw(1)=1
+      call QL0001(nclin,neq-neqn,nrowa,nqpram,nparam+1,mnn,hess1,cvec,A,
+     *             bj,bL,bU,X,clamda,iout,infoqp,0,w,lenw,iw,leniw)
+C
+Ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/diagnl.f
@@ -0,0 +1,22 @@
+c=== subroutines used in FSQPD 3.3  ===============================c
+c                                                                  c
+c  diagnl  error   estlam  fool    indexs  lfuscp  matrcp  matrvc  c
+c  nullvc  resign  sbout1  sbout2  scaprd  shift   slope   small   c 
+c                                                                  c
+c==================================================================c
+c
+      subroutine diagnl(nrowa,diag,a)
+c     implicit real*8(a-h,o-z)
+      integer nrowa,i,j
+      double  precision a(nrowa,1),diag
+c     double  precision a(nrowa,nrowa),diag
+c
+c     set a=diag*I, the diagonal matrix
+c
+      do 200 i=1,nrowa
+        do 100 j=i,nrowa
+          a(i,j)=0.d0
+ 100      a(j,i)=0.d0
+ 200    a(i,i)=diag
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/dir.f
@@ -0,0 +1,417 @@
+      subroutine dir(nparam,nob,nobL,nineqn,neq,neqn,nn,ncnstr,nctotl,
+     *               nrowa,feasb,steps,epskt,epseqn,sktnom,scvneq,Ck,
+     *               d0nm,grdftd,xl,xu,indxob,indxcn,iact,iskp,iskip,
+     *               istore,iw,leniw,x,di,d,g,gradg,f,fM,fMp,psf,
+     *               gradf,grdpsf,penp,a,bl,bu,clamda,cllamd,cvec,bj,
+     *               hess,hess1,w,lenw,backup,signeq,obj,constr)
+c
+c     FSQP Version 3.3  : computation of a search direction
+c
+c     implicit real*8(a-h,o-z)
+      integer nparam,nob,nobL,nineqn,neq,neqn,nn,ncnstr,nctotl,nrowa,
+     *        iskp,leniw,lenw
+      integer indxob(1),indxcn(1),iact(1),iskip(1),
+     *        istore(1),iw(leniw)
+c     integer indxob(nob),indxcn(ncnstr),iact(nob+nineqn+neqn),iskip(1),
+c    *        istore(nineqn+nob+neqn),iw(leniw)
+      double  precision steps,epskt,epseqn,sktnom,Ck,d0nm,grdftd,
+     *        fM,fMp,psf,scvneq
+      double  precision xl(nparam),xu(nparam),x(nparam+1),di(nparam+1),
+     *        d(nparam+1),g(1),gradg(nparam,1),f(1),
+     *        gradf(nparam,1),grdpsf(nparam),penp(1),
+     *        a(nrowa,nparam+1),bl(1),bu(1),clamda(1),cllamd(1),
+     *        cvec(nparam+1),bj(nrowa),hess(nparam,nparam),
+     *        hess1(nparam+1,nparam+1),w(lenw),
+     *        backup(1),signeq(1)
+c     double  precision xl(nparam),xu(nparam),x(nparam+1),di(nparam+1),
+c    *        d(nparam+1),g(ncnstr),gradg(nparam,ncnstr),f(nob),
+c    *        gradf(nparam,nob), 
+c    *        grdpsf(nparam),penp(neqn),a(nrowa,nparam+1),bl(nctotl),
+c    *        bu(nctotl),clamda(nctotl+nparam+1),cllamd(nctotl),
+c    *        cvec(nparam+1),bj(nrowa),hess(nparam,nparam),
+c    *        hess1(nparam+1,nparam+1),w(lenw),
+c    *        backup(nob+ncnstr),signeq(neqn)
+      external obj,constr
+      logical feasb
+c
+      integer nnineq,M,ncallg,ncallf,mode,io,iprint,ipspan,ipyes,info,
+     *        ipd,iter,nstop,initvl,lstype
+      double  precision epsmac,rteps,udelta,valnom,bigbnd,tolfea,
+     *        objeps,objrep,gLgeps
+      logical dlfeas,local,update,first,lqpsl,ld0
+      common  /fsqpp1/nnineq,M,ncallg,ncallf,mode,lstype,nstop,
+     *        /fsqpp2/io,iprint,ipspan,ipyes,info,ipd,iter,initvl,
+     *        /fsqpp3/epsmac,rteps,udelta,valnom
+     *        /fsqpq1/bigbnd,tolfea,
+     *        /fsqplo/dlfeas,local,update,first,  
+     *        /fsqpqp/lqpsl,ld0
+      common  /fsqpus/objeps,objrep,gLgeps
+c
+c     bj(1) is equivalent to bl(nparam+3)
+c
+      integer i,j,k,kk,ncg,ncf,nqprm0,nclin0,nctot0,infoqp,nqprm1,ncl,
+     *        nclin1,nctot1,ncc,nff,nrowa0,nrowa1,ninq,nobb,nobbL,nncn
+      double  precision fmxl,vv,dx,dmx,dnm1,dnm,v0,v1,vk,temp1,temp2,
+     *        theta,rhol,rhog,rho,grdfd0,grdfd1,dummy,grdgd0,grdgd1,
+     *        thrshd,sign,scaprd,slope,lfuscp,dsqrt,dmin1,dmax1,dabs,
+     *        adummy(1),dnmtil
+      logical ltem1,ltem2
+c
+      ncg=0
+      ncf=0
+      iskp=0
+      ncl=nnineq-nineqn
+      local=.false.
+      update=.false.
+      lqpsl=.false.
+      thrshd=tolfea
+c
+      if(nobL.eq.1) goto 10
+        nqprm0=nparam+1
+        nclin0=ncnstr+nobL
+      goto 20
+ 10     nqprm0=nparam
+        nclin0=ncnstr
+ 20   nctot0=nqprm0+nclin0
+      vv=0.d0
+      nrowa0=max0(nclin0,1)
+      do 25 i=1,ncnstr
+        if(feasb) then
+          if(i.gt.nineqn.and.i.le.nnineq) iskip(nnineq+2-i)=i
+          iw(i)=i
+        else if(.not.feasb) then
+          if(i.le.ncl) iskip(ncl+2-i)=nineqn+i
+          if(i.le.ncl) iw(i)=nineqn+i
+          if(i.gt.ncl) iw(i)=nineqn+neqn+i
+        endif
+ 25   continue
+      do 27 i=1,nob
+ 27     iw(ncnstr+i)=i
+      ld0=.true.
+      call nullvc(nparam,cvec)
+      call dqp(nparam,nqprm0,nob,nobL,nineqn,neq,neqn,nn,ncnstr,nclin0,
+     *         nctot0,nrowa0,infoqp,iw,leniw,x,di,xl,xu,feasb,f,fM,
+     *         gradf,grdpsf,g,gradg,a,cvec,bl,bu,clamda,cllamd,bj,
+     *         hess,hess1,di,w,lenw,vv,0)
+      ld0=.false.
+      if(infoqp.eq.0) goto 30
+        info=5
+        if(.not.feasb) info=2
+        nstop=0
+        goto 9000
+c
+c    reorder indexes of constraints and objectives
+c
+ 30   if(nn.le.1) goto 45  
+      j=1
+      k=nn
+      do 40 i=nn,1,-1
+        if(lfuscp(cllamd(nqprm0+indxcn(i)),thrshd).ne.0) then
+          iact(j)=indxcn(i)
+          j=j+1
+        else
+          iact(k)=indxcn(i)
+          k=k-1
+        endif
+ 40   continue
+ 45   if(nobL.le.1) goto 60
+      j=nn+1
+      k=nn+nob
+      do 50 i=nob,1,-1
+        kk=nqprm0+ncnstr
+        ltem1=lfuscp(cllamd(kk+i),thrshd).ne.0
+        ltem2=nobL.ne.nob.and.(lfuscp(cllamd(kk+i+nob),thrshd).ne.0)
+        if(ltem1.or.ltem2) then
+          iact(j)=i
+          j=j+1
+        else
+          iact(k)=i
+          k=k-1
+        endif
+ 50   continue
+c
+ 60   vv=f(iact(nn+1))
+      d0nm=dsqrt(scaprd(nparam,di,di))
+      if(.not.first.or.nclin0.ne.0) goto 110
+        dx=dsqrt(scaprd(nparam,x,x))
+        dmx=dmax1(dx,1.d0)
+        if(d0nm.le.dmx) goto 110
+        do 100 i=1,nparam
+ 100      di(i)=di(i)*dmx/d0nm
+        d0nm=dmx
+ 110  call matrvc(nparam,nparam,nparam,nparam,hess,di,w)
+      if(nn.eq.0) grdftd=-scaprd(nparam,w,di)
+      sktnom=dsqrt(scaprd(nparam,w,w))
+      if(gLgeps.gt.0.d0.and.sktnom.le.gLgeps) goto 115
+      if(d0nm.gt.epskt) goto 120
+ 115  if(neqn.ne.0.and.scvneq.gt.epseqn) goto 120
+        nstop=0
+        if(.not.feasb) info=2
+        if(iprint.lt.3.or.ipyes.gt.0) goto 9000
+        if(nobL.eq.1) nff=1
+        if(nobL.gt.1) nff=2
+        call sbout1(io,nparam,'multipliers  for  x ',dummy,cllamd,2,2)
+        if(ncnstr.ne.0) call sbout1(io,ncnstr,'             for  g ',
+     *                              dummy,cllamd(nparam+nff),2,2)
+        if(nobL.gt.1) call sbout1(io,nob,'             for  f ',
+     *                            dummy,cllamd(nparam+nff+ncnstr),2,2)
+        goto 9000
+ 120  if(iprint.lt.3.or.ipyes.gt.0) goto 125
+        call sbout1(io,nparam,'d0                  ',dummy,di,2,2)
+        call sbout1(io,0,'d0norm              ',d0nm,adummy,1,2)
+        call sbout1(io,0,'ktnorm              ',sktnom,adummy,1,2)
+c
+c     single objective without nonlinear constraints requires
+c     no d1 and dtilde; multi-objectives without nonlinear 
+c     constraints requires no d1
+c
+ 125  call nullvc(nparam,w)
+      if(nn.ne.0) grdftd=slope(nob,nobL,neqn,nparam,feasb,f,gradf,
+     *                         grdpsf,di,w,fM,dummy,0)
+      if(nn.eq.0.and.nobL.eq.1) goto 1130 
+      if(nn.ne.0) goto 130
+        dnm=d0nm
+        rho=0.d0
+        rhog=0.d0
+        goto 310
+c
+c     compute modified first order direction d1
+c
+ 130  nqprm1=nparam+1
+      if(mode.eq.0) nclin1=ncnstr+nobL
+      if(mode.eq.1) nclin1=ncnstr
+      nctot1=nqprm1+nclin1
+      nrowa1=max0(nclin1,1)
+      ninq=nnineq
+      call di1(nparam,nqprm1,nob,nobL,nineqn,neq,neqn,ncnstr,nclin1,
+     *         nctot1,nrowa1,infoqp,mode,iw,leniw,x,di,xl,xu,f,fM,
+     *         gradf,grdpsf,g,gradg,cvec,a,bl,bu,clamda,bj,hess1,d,
+     *         w,lenw)
+      if(infoqp.eq.0) goto 140
+        info=6
+        if(.not.feasb) info=2
+        nstop=0
+        goto 9000
+ 140  dnm1=dsqrt(scaprd(nparam,d,d))
+      if(iprint.lt.3.or.ipyes.gt.0) goto 145
+        call sbout1(io,nparam,'d1                  ',dummy,d,2,2)
+        call sbout1(io,0,'d1norm              ',dnm1,adummy,1,2)
+ 145  if(mode.eq.1) goto 150
+        v0=d0nm**2.1
+        v1=dmax1(dble(0.5),dble(dnm1**2.5))
+        rho=v0/(v0+v1)
+        rhog=rho
+      goto 250
+ 150    vk=dmin1(Ck*d0nm**2,d0nm)
+        rhol=0.d0
+        do 200 i=1,nn
+          grdgd0=scaprd(nparam,gradg(1,indxcn(i)),di)
+          grdgd1=scaprd(nparam,gradg(1,indxcn(i)),d)
+          temp1=vk+g(indxcn(i))+grdgd0
+          temp2=grdgd1-grdgd0
+          if(temp1.le.0.d0) goto 200
+          if(temp2.ge.0.d0) goto 190
+          rhol=dmax1(rhol,-temp1/temp2)
+          if(rhol.lt.1.d0) goto 200
+ 190        rhol=1.0d0
+            goto 210
+ 200    continue
+ 210    theta=0.2d0
+        if(rhol.ne.0.d0) goto 220
+c
+c       to check if rhol is reset
+c
+          rhog=0.d0
+          rho=0.d0
+          dnm=d0nm
+        goto 310
+ 220    if(nobL.gt.1) goto 230
+          grdfd0=grdftd
+          grdfd1=scaprd(nparam,gradf(1,1),d)
+          grdfd1=grdfd1-scaprd(nparam,grdpsf,d)
+          temp1=grdfd1-grdfd0
+          if(temp1.le.0.d0) then
+            rhog=rhol
+          else
+            rhog=dmin1(rhol,(theta-1.d0)*grdfd0/temp1)
+          endif
+        goto 240
+ 230      rhog=slope(nob,nobL,neqn,nparam,feasb,f,gradf(1,1),grdpsf,
+     *               di,d,fM,theta,mode)
+          rhog=dmin1(rhol,rhog)
+ 240    rho=rhog
+        if (steps.eq.1.d0.and.rhol.lt.0.5d0) rho=rhol
+ 250  continue
+      do 300 i=1,nparam
+        if (rho.ne.rhog) cvec(i)=di(i)
+        di(i)=(1.d0-rho)*di(i)+rho*d(i)
+ 300  continue
+      dnm=dsqrt(scaprd(nparam,di,di))
+      if(iprint.lt.3.or.mode.eq.1.or.nn.eq.0.or.ipyes.gt.0) goto 310
+        call sbout1(io,0,'rho                 ',rho,adummy,1,2)
+        call sbout1(io,nparam,'d                   ',dummy,di,2,2)
+        call sbout1(io,0,'dnorm               ',dnm,adummy,1,2)
+ 310  continue
+ 320  do 400 i=1,nob
+ 400    bl(i)=f(i)
+      if (rho.eq.1.d0) goto 510
+      if(nn.eq.0.or.iprint.ne.3.or.mode.eq.0.or.ipyes.gt.0) goto 410
+        call sbout1(io,0,'Ck                  ',Ck,adummy,1,2)
+        call sbout1(io,0,'rhol                ',rho,adummy,1,2)
+        call sbout1(io,nparam,'dl                  ',dummy,di,2,2)
+        call sbout1(io,0,'dlnorm              ',dnm,adummy,1,2)
+ 410  if(mode.eq.0) goto 510
+        local=.true.
+        call step(nparam,nob,nobL,nineqn,neq,neqn,nn,ncnstr,ncg,ncf,
+     *            indxob,indxcn,iact,iskp,iskip,istore,feasb,grdftd,
+     *            f,fM,fMp,psf,penp,steps,scvneq,bu,x,di,d,g,w,
+     *            backup,signeq,obj,constr)
+        if(update) goto 9000
+        local=.false.
+        if(rho.eq.rhog.or.nn.eq.0) goto 510
+        do 500 i=1,nparam
+ 500      di(i)=(1-rhog)*cvec(i)+rhog*d(i)
+        dnm=dsqrt(scaprd(nparam,di,di))
+ 510  if (nn.eq.0.or.iprint.lt.3.or.mode.eq.0.or.ipyes.gt.0) goto 520
+        call sbout1(io,0,'rhog                ',rhog,adummy,1,2)
+        call sbout1(io,nparam,'dg                  ',dummy,di,2,2)
+        call sbout1(io,0,'dgnorm              ',dnm,adummy,1,2)
+ 520  if(rho.ne.0.d0) grdftd=slope(nob,nobL,neqn,nparam,feasb,bl,
+     *                             gradf,grdpsf,di,d,fM,theta,0)
+      if(mode.eq.1.and.rho.eq.rhog) goto 610
+      do 600 i=1,nparam
+ 600    bu(i)=x(i)+di(i)
+ 610  if(rho.ne.rhog) ncg=0
+      ncc=ncg+1
+      fmxl=-bigbnd
+      ninq=ncg
+      nncn=ncg
+      j=0
+c
+c     iskip(1) --- iskip(iskp) store the indexes of linear inequality
+c     constraints that are not to be used to compute d~
+c     iskip(nnineq-nineqn+1) --- iskip(nnineq-ncn+1-iskp) store those 
+c     that are to be used to compute d~
+c
+      do 700 i=ncc,ncnstr
+        kk=iact(i)
+        if(i.gt.nn) kk=indxcn(i)
+        if(kk.le.nineqn.or.kk.gt.nnineq) goto 615
+          iskip(ncl+1-j)=kk
+          j=j+1
+ 615    if(kk.gt.nnineq) goto 617
+        temp1=-0.2d0*(dnm*dsqrt(scaprd(nparam,gradg(1,kk),gradg(1,kk))))
+        temp2=cllamd(nqprm0+kk)
+        if(temp2.eq.0.d0.and.g(kk).lt.temp1) goto 620
+ 617      ninq=ninq+1
+          iw(ninq)=kk
+          if(feasb.and.kk.le.nineqn) istore(kk)=1
+          call constr(nparam,kk,bu,g(kk))
+          if(.not.feasb.or.feasb.and.kk.gt.nnineq) goto 700
+          if(kk.le.nineqn) nncn=ninq
+          fmxl=dmax1(fmxl,g(kk))
+          if(.not.feasb) goto 618
+          if(kk.le.nineqn.or.kk.gt.nnineq.and.kk.le.(nnineq+neqn))
+     *       ncallg=ncallg+1
+ 618      if(dabs(fmxl).gt.bigbnd) goto 1130
+        goto 700
+ 620      if(kk.le.nineqn) goto 700
+          iskp=iskp+1
+          iskip(iskp)=kk
+          j=j-1
+ 700  continue
+      if(neqn.ne.0) call resign(nparam,neqn,psf,grdpsf,penp,g(nnineq+1),
+     *                          gradg(1,nnineq+1),signeq,10,20)
+      ninq=ninq-neq
+      if(ncg.eq.0) goto 810
+      do 800 i=1,ncg
+        iw(i)=iact(i)
+        istore(iact(i))=1
+        fmxl=dmax1(fmxl,g(iact(i)))
+        if(dabs(fmxl).gt.bigbnd) goto 1130
+ 800  continue
+ 810  if(nobL.gt.1) goto 820
+        iw(1+ninq+neq)=1
+        nobb=nob
+        goto 1110
+ 820  if(rho.ne.rhog) ncf=0
+      nff=ncf+1
+      nobb=ncf
+      sign=1.d0
+      fmxl=-bigbnd
+      if(cllamd(nqprm0+ncnstr+iact(nn+1)).lt.0.d0) sign=-1.d0
+      do 1000 i=nff,nob
+        kk=iact(nn+i)
+        if(.not.feasb) kk=iact(i)
+        if(feasb) k=nn+1
+        if(.not.feasb) k=1
+        do 900 j=1,nparam
+ 900      w(j)=sign*gradf(j,iact(k))-gradf(j,kk)
+        temp1=dabs(f(kk)-sign*vv)
+        temp2=dnm*dsqrt(scaprd(nparam,w,w))
+        if(temp1.eq.0.d0.or.temp2.eq.0.d0) goto 910
+        temp1=temp1/temp2
+        temp2=cllamd(nqprm0+ncnstr+kk)
+        if(temp2.eq.0.d0.and.temp1.gt.0.2d0) goto 1000
+ 910    nobb=nobb+1
+        if(feasb) then
+          iw(nobb+ninq+neq)=kk
+          istore(nineqn+kk)=1
+        else
+          iw(nobb+ninq)=kk
+          istore(kk)=1
+        endif
+        if(.not.feasb) goto 920
+          call obj(nparam,kk,bu,f(kk))
+          ncallf=ncallf+1
+          if(nobL.ne.nob) fmxl=dmax1(fmxl,-f(kk))
+        goto 930
+ 920      call constr(nparam,indxob(kk),bu,f(kk))
+          ncallg=ncallg+1
+ 930    fmxl=dmax1(fmxl,f(kk))
+        if(dabs(fmxl).gt.bigbnd) goto 1130
+ 1000 continue
+      if(ncf.eq.0) goto 1110
+      do 1100 i=1,ncf
+        iw(ninq+neq+i)=iact(i+nn)
+        istore(nineqn+iact(i+nn))=1
+        fmxl=dmax1(fmxl,f(iact(i+nn)))
+        if(nobL.ne.nob) fmxl=dmax1(fmxl,-f(iact(i+nn)))
+        if(dabs(fmxl).gt.bigbnd) goto 1130
+ 1100 continue
+ 1110 call matrvc(nparam,nparam,nparam,nparam,hess,di,cvec)
+      vv=-dmin1(0.01d0*dnm,dnm**2.5)
+c
+c     compute a correction dtilde to d=(1-rho)d0+rho*d1
+c
+      if(nobL.ne.nob) nobbL=2*nobb
+      if(nobL.eq.nob) nobbL=nobb
+      if(nobbL.eq.1) goto 1115
+        nqprm0=nparam+1
+        nclin0=ninq+neq+nobbL
+      goto 1117
+ 1115   nqprm0=nparam
+        nclin0=ninq+neq
+ 1117 nctot0=nqprm0+nclin0
+      nrowa0=max0(nclin0,1)
+      i=ninq+neq
+      call dqp(nparam,nqprm0,nobb,nobbL,nncn,neq,neqn,nn,i,nclin0,
+     *         nctot0,nrowa0,infoqp,iw,leniw,x,di,xl,xu,feasb,f,fmxl,
+     *         gradf,grdpsf,g,gradg,a,cvec,bl,bu,clamda,cllamd,bj,
+     *         hess,hess1,d,w,lenw,vv,1)
+      if(infoqp.ne.0) goto 1130
+      dnmtil=dsqrt(scaprd(nparam,d,d))
+      if(dnmtil.gt.dnm) goto 1130
+      if(dnmtil.eq.0.d0) goto 1119
+        do 1118 i=1,nineqn+nob
+ 1118     istore(i)=0
+ 1119 if(iprint.lt.3.or.ipyes.gt.0) goto 9000
+        call sbout1(io,nparam,'dtilde              ',dummy,d,2,2)
+        call sbout1(io,0,'dtnorm              ',dnmtil,adummy,1,2)
+        goto 9000
+c
+ 1130 do 1200 i=1,nparam
+ 1200   d(i)=0.d0
+      dnmtil=0.d0
+ 9000 return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/dqp.f
@@ -0,0 +1,126 @@
+c
+      subroutine dqp(nparam,nqpram,nob,nobL,nineqn,neq,neqn,nn,ncnstr,
+     *               nclin,nctotl,nrowa,infoqp,iw,leniw,x0,di,xl,xu,
+     *               feasb,f,fM,gradf,grdpsf,g,gradg,a,cvec,bl,bu,
+     *               clamda,cllamd,bj,hess,hess1,x,w,lenw,vv,job)
+c     implicit double precision(a-h,o-z)
+      integer nparam,nqpram,nob,nobL,nineqn,neq,neqn,nn,ncnstr,nclin,
+     *        nctotl,nrowa,infoqp,leniw,lenw,job
+      integer iw(leniw)
+      double  precision fM,vv
+      double  precision x0(nparam),di(1),xl(nparam),xu(nparam),
+     *        f(1),gradf(nparam,1),grdpsf(nparam),g(1),
+     *        gradg(nparam,1),
+     *        a(nrowa,1),cvec(1),bl(1),bu(1),clamda(1),
+     *        cllamd(1),bj(1),hess(nparam,nparam),
+     *        hess1(nparam+1,nparam+1),x(1),w(lenw)
+c     double  precision x0(nparam),di(nqpram),xl(nparam),xu(nparam),
+c    *        f(nob),gradf(nparam,nob),grdpsf(nparam),g(ncnstr),
+c    *        gradg(nparam,ncnstr),
+c    *        a(nrowa,nqpram),cvec(nqpram),bl(nctotl),bu(nctotl),
+c    *        clamda(nctotl+nqpram),cllamd(nctotl),bj(nrowa),
+c    *        hess(nparam,nparam),hess1(nparam+1,nparam+1),
+c    *        x(nqpram),w(lenw)
+      logical feasb
+c
+      integer io,idum1,idum2,idum3,idum4,idum5,idum6,idum7
+      double  precision bigbnd,dummy,epsmac,rteps,dummy1,dummy2
+      common  /fsqpp2/io,idum1,idum2,idum3,idum4,idum5,idum6,idum7,
+     *        /fsqpp3/epsmac,rteps,dummy1,dummy2,
+     *        /fsqpq1/bigbnd,dummy
+c
+c     bj(1) is equivalent to bl(nparam+3)
+c
+c     job=0 : compute d0; job=1 : compute  d~
+c
+      integer i,ii,j,iout,mnn,nqnp
+      double  precision x0i,xdi
+c
+      iout=io
+      do 100 i=1,nparam
+        x0i=x0(i)
+        if(job.eq.1) xdi=di(i)
+        if(job.eq.0) xdi=0.d0
+        bl(i)=xl(i)-x0i-xdi
+        bu(i)=xu(i)-x0i-xdi
+        cvec(i)=cvec(i)-grdpsf(i)
+ 100  continue
+      if(nobL.eq.1) goto 110
+        bl(nqpram)=-bigbnd
+        bu(nqpram)=bigbnd
+ 110  ii=ncnstr-nn
+c
+c     constraints are assigned to a in reverse order
+c
+      do 300 i=1,ncnstr
+        x0i=vv
+        if(i.le.(neq-neqn).or.(i.gt.neq.and.i.le.(ncnstr-nineqn)))
+     *    x0i=0.d0
+        if(.not.feasb) x0i=0.d0
+        bj(i)=x0i-g(iw(ncnstr+1-i))
+        do 200 j=1,nparam
+ 200      a(i,j)=-gradg(j,iw(ncnstr+1-i))
+        if(nobL.gt.1) a(i,nqpram)=0.d0
+ 300  continue
+      if(nobL.eq.1) goto 510
+      do 500 i=1,nob
+        ii=ncnstr+i
+        bj(ii)=fM-f(iw(ii))
+        if(nobL.gt.nob) bj(ii+nob)=fM+f(iw(ii))
+        do 400 j=1,nparam
+          a(ii,j)=-gradf(j,iw(ii))
+          if(nobL.gt.nob) a(ii+nob,j)=gradf(j,iw(ii))
+ 400    continue
+        a(ii,nqpram)=1.d0
+        if(nobL.gt.nob) a(ii+nob,nqpram)=1.d0
+ 500  continue
+      cvec(nqpram)=1.d0
+      goto 610
+ 510  do 600 i=1,nparam
+ 600    cvec(i)=cvec(i)+gradf(i,1)
+ 610  call matrcp(nparam,hess,nparam+1,hess1)
+      call nullvc(nqpram,x)
+c
+Ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+C
+c  The following modification is done inside QP0001
+c  for the ease of interfacing with QPSOL
+c
+c     if(hess1(nqpram,nqpram).lt.qleps) hess1(nqpram,nqpram)=qleps
+C
+      iw(1)=1
+      mnn=nclin+2*nqpram
+      call QL0001(nclin,neq-neqn,nrowa,nqpram,nparam+1,mnn,hess1,cvec,A,
+     *            bj,bL,bU,X,clamda,iout,infoqp,0,w,lenw,iw,leniw)
+C
+Ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+C
+      if(infoqp.ne.0.or.job.eq.1) goto 9000
+      do 700 i=1,nqpram
+        ii=nclin+i
+        if(clamda(ii).eq.0.d0.and.clamda(ii+nqpram).eq.0.d0) then
+          goto 700
+        else if(clamda(ii).ne.0.d0) then
+          clamda(ii)=-clamda(ii)
+        else 
+          clamda(ii)=clamda(ii+nqpram)
+        endif
+ 700  continue
+      nqnp=nqpram+ncnstr
+      do 800 i=1,nctotl
+        if(i.le.nqpram) then
+          ii=nclin+i
+        else if(i.gt.nqpram.and.i.le.nqnp) then
+          ii=nqnp+1-i
+        else if(i.gt.nqnp) then
+          ii=i-nqpram
+        endif
+        cllamd(i)=clamda(ii)
+ 800  continue
+      if(nobL.eq.nob) goto 9000
+      do 900 i=1,nob
+        ii=i+nqpram+ncnstr
+        cllamd(ii)=cllamd(ii)-cllamd(ii+nob)
+ 900  continue
+ 9000 return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/error.f
@@ -0,0 +1,11 @@
+c
+      subroutine error(string,inform,io)
+c     implicit real*8 (a-h,o-z)
+      integer inform,io
+      character*40 string
+c
+      write(io,9900) string
+ 9900 format(1x,a40)
+      inform=7
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/estlam.f
@@ -0,0 +1,31 @@
+c
+      subroutine estlam(nparam,neq,ifail,iout,bigbnd,hess,cvec,a,b,
+     *                  gradh,psb,bl,bu,x,w,lenw,iw,leniw)
+      integer nparam,neq,ifail,iout,lenw,leniw,iw(leniw)
+      double precision bigbnd,hess(neq,1),cvec(1),a(1),b(1),
+     *                 gradh(nparam,1),psb(1),bl(1),bu(1),
+     *                 x(1),w(lenw)
+c     double precision bigbnd,hess(neq,neq),cvec(neq),a(1),b(1),
+c    *                 gradh(nparam,neq),psb(nparam),bl(1),bu(1),
+c    *                 x(neq),w(lenw)
+c
+c     compute an estimate of multipliers for updating penalty parameter
+c
+      integer i,j
+      double precision scaprd
+c
+      do 200 i=1,neq
+        bl(i)=-bigbnd
+        bu(i)=bigbnd
+        cvec(i)=scaprd(nparam,gradh(1,i),psb)
+        x(i)=0.d0
+        do 100 j=i,neq 
+          hess(i,j)=scaprd(nparam,gradh(1,i),gradh(1,j))
+ 100      hess(j,i)=hess(i,j)
+ 200  continue
+      iw(1)=1
+      call ql0001(0,0,1,neq,neq,2*neq,hess,cvec,a,b,bl,bu,x,w,
+     c            iout,ifail,0,w(2),lenw-1,iw,leniw)
+c
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/fool.f
@@ -0,0 +1,7 @@
+c
+      subroutine fool(x,y,z)
+      double precision x,y,z
+c
+      z=x*y+y
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/fsqpd.f
@@ -0,0 +1,703 @@
+c  THIS SOFTWARE MAY NOT BE COPIED TO MACHINES OUTSIDE THE SITE FOR
+c  WHICH IT HAD BEEN PROVIDED.  SEE "Conditions for External Use"
+c  BELOW FOR MORE DETAILS.  INDIVIDUALS INTERESTED IN OBTAINING
+c  THE SOFTWARE SHOULD CONTACT THE AUTHORS.
+c
+      subroutine FSQPD(nparam,nf,nineqn,nineq,neqn,neq,mode,iprint,
+     *                 miter,inform,bigbnd,eps,epseqn,udelta,bl,bu,x,
+     *                 f,g,iw,iwsize,w,nwsize,obj,constr,gradob,gradcn)
+c                                                                      
+c     implicit real*8(a-h,o-z)
+      integer nparam,nf,neqn,nineqn,nineq,neq,mode,iprint,miter,inform,
+     *        iwsize,nwsize
+      integer iw(iwsize)
+      double  precision bl(nparam),bu(nparam),x(nparam),
+     *        f(1),g(1),w(nwsize)
+c     double  precision bl(nparam),bu(nparam),x(nparam),
+c    *        f(nf),g(nineq+neq),w(nwsize)
+      double  precision bigbnd,eps,epseqn,udelta
+      external obj,constr,gradob,gradcn
+c
+c**********************************************************************c
+c                                                                      c
+c brief specification of various arrays and parameters in the calling  c
+c sequence. See manual for more detailed description.                  c
+c                                                                      c
+c nparam : number of variables                                         c
+c nf     : number of objective functions                               c
+c nineqn : number of nonlinear inequality constraints                  c
+c nineq  : number of inequality constraints                            c
+c neqn   : number of nonlinear equality constraints                    c
+c neq    : number of equality constraints                              c
+c mode   : mode=CBA specifies job options as described below:          c
+c          A = 0 : ordinary minimax problems                           c
+c            = 1 : ordinary minimax problems with each individual      c
+c                  function replaced by its absolute value, ie,        c
+c                  an L_infty problem                                  c
+c          B = 0 : monotone decrease of objective function             c
+c                  after each iteration                                c
+c            = 1 : monotone decrease of objective function after       c
+c                  at most four iterations                             c
+c          C = 1 : during line search, the function that rejected      c
+c                  the previous step size is checked first;            c
+c                  all functions of the same type ("objective" or      c
+c                  "constraints") as the latter will then be checked   c
+c                  first                                               c
+c          C = 2 : all contraints will be checked first at every trial c
+c                  point during the line search                        c
+c iprint : print level indicator with the following options            c
+c          iprint=0: no normal output except error information         c
+c                    (this option is imposed during phase 1)           c
+c          iprint=1:  a final printout at a local solution             c
+c          iprint=2:  a brief printout at the end of each iteration    c
+c          iprint=3:  detailed infomation is printed out at the end    c
+c                     of each iteration for debugging purpose          c
+c          iprint=10*N+M: N any positive integer, M=2 or 3.            c
+c                     Information corresponding to iprint=M will be    c
+c                     displayed at every 10*Nth iterations at the last c
+c                     iteration                                        c
+c miter  : maximum number of iterations allowed by the user to solve   c
+c          the problem                                                 c
+c inform : status report at the end of execution                       c
+c          inform= 0:normal termination                                c
+c          inform= 1:no feasible point found for linear constraints    c
+c          inform= 2:no feasible point found for nonlinear constraints c
+c          inform= 3:no solution has been found within miter iterations
+c          inform= 4:stepsize is smaller than machine precision before c
+c                    a successful new iterate is found                 c
+c          inform= 5:failure of the QP solver in attempting to         c
+c                    construct d0. A more robust QP solver may succeed.c
+c          inform= 6:failure of the QP solver in attempting to         c
+c                    construct d1. A more robust QP solver may succeed.c
+c          inform= 7:inconsistent input data                           c
+c bigbnd : plus infinity                                               c
+c eps    : stopping criterion that ensures at a solution, the norm of  c
+c          the Newton direction vector is smaller than eps             c
+c epseqn : tolerance of the violation of nonlinear equality constraintsc
+c          allowed by the user at an optimal solution                  c
+c udelta : perturbation size in computing gradients by finite          c
+c          difference and the true perturbation is determined by       c
+c          sign(x_i) X max{udelta, rteps X max{1, |x_i|}} for each     c
+c          component of x, where rteps is the square root of machine   c
+c          precision 
+c bl     : array of dimension nparam,containing lower bound of x       c
+c bu     : array of dimension nparam,containing upper bound of x       c
+c x      : array of dimension nparam,containing initial guess in input c
+c          and final iterate at the end of execution                   c
+c f      : array of dimension max{1,nf}, containing objective values   c
+c          at x in output                                              c
+c g      : array of dimension max{1,nineq+neq}, containing constraint  c
+c          values at x in output                                       c
+c iw     : integer working space of dimension iwsize                   c
+c iwsize : length of integer array iw                                  c
+c w      : double precision working space of dimension nwsize.         c
+c          at output, it contains lagrange multipliers                 c
+c nwsize : length of double precision array w                          c
+c obj    : subroutine that returns the value of objective functions    c
+c          one upon each call                                          c
+c constr : subroutine that returns the value of constraints            c
+c          one upon each call                                          c
+c gradob : subroutine that computes gradients of f, alternatively      c
+c          it can be replaced by grobfd that computes finite           c
+c          difference approximations                                   c
+c gradcn : subroutine that computes gradients of g, alternatively      c
+c          it can be replaced by grcnfd that computes finite           c
+c          difference approximations                                   c
+c                                                                      c
+cCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc
+c                                                                      c
+c                                                                      c
+c                        FSQP  Version 3.3                             c
+c                                                                      c
+c                  Jian L. Zhou  and  Andre L. Tits                    c
+c                   Institute for Systems Research                     c
+c                               and                                    c
+c                Electrical Engineering Department                     c
+c                     University of Maryland                           c
+c                     College Park, Md 20742                           c
+c                                                                      c
+c                           April, 1993                                c
+c                                                                      c
+c                                                                      c
+c  The purpose of FSQP is to solve general nonlinear constrained       c
+c  minimax optimization problems of the form                           c
+c                                                                      c
+c   (A=0 in mode)     minimize    max_i f_i(x)   for i=1,...,n_f       c
+c                        or                                            c
+c   (A=1 in mode)     minimize    max_j |f_i(x)|   for i=1,...,n_f     c
+c                       s.t.      bl   <= x <=  bu                     c
+c                                 g_j(x) <= 0,   for j=1,...,nineqn    c
+c                                 A_1 x - B_1 <= 0                     c
+c                                                                      c
+c                                 h_i(x)  = 0,   for i=1,...,neqn      c
+c                                 A_2 x - B_2  = 0                     c
+c                                                                      c
+c                                                                      c
+c                                                                      c
+c                  Conditions for External Use                         c
+c                  ===========================                         c
+c                                                                      c
+c   1. The FSQP routines may not be distributed to third parties.      c
+c      Interested parties should contact the authors directly.         c
+c   2. If modifications are performaed on the routines, these          c
+c      modifications will remain the sole property of the authors.     c
+c   3. Due acknowledgment must be made of the use of the FSQP routines c
+c      in research reports or publications. A copy of such reports or  c
+c      publications should be forwarded to the authors.                c
+c   4. The FSQP routines may not be used in industrial production,     c
+c      unless this has been agreed upon with the authors in writing.   c
+c                                                                      c
+c Copyright (c) 1989 --- 1993 by Jian L. Zhou and Andre L. Tits.       c
+c All Rights Reserved.                                                 c
+c                                                                      c
+c                                                                      c
+c Enquiries should be directed to:                                     c
+c                                                                      c
+c      Prof. Andre L. Tits                                             c
+c      Electrical Engineering Dept.                                    c
+c      and Institute for Systems Research                              c
+c      University of Maryland                                          c
+c      College Park, Md 20742                                          c
+c      U. S. A.                                                        c
+c                                                                      c
+c      Phone : 301-405-3669                                            c
+c      Fax   : 301-405-6707                                            c
+c      E-mail: andre@eng.umd.edu                                       c
+c                                                                      c
+c                                                                      c
+c              Enhancements in successive versions of FSQP             c
+c              ===========================================             c
+c                                                                      c
+c  Version 3.3 : April 1993                                            c
+c     1. If the user so requests (via "mode"), during the line search, c
+c        FSQP will now evaluate objectives only after having           c
+c        determined that all constraints are satisfied.  This is of    c
+c        value when some objective functions are not defined outside   c
+c        the feasible set.                                             c
+c     2. The reserved common block "fsqpst" is no longer used by FSQP. c
+c        Instead, a new reserved common block "fsqpus" is provided to  c
+c        give the users a choice of several possible stopping criteria.c
+c        (As a side-effect, the user is not allowed any more to have   c
+c        his/her own block data; see Section 4 of the manual for       c
+c        details.)                                                     c
+c     3. Some imperfections are fixed (e.g., comparision of double     c
+c        precision number to hard zero, and incorrect checking of      c
+c        value of "mode").                                             c
+c                                                                      c
+c  Version 3.2 : March 1993                                            c 
+c     1. The user is given the option to print output at every Nth     c
+c        iteration and at the end, where N is a multiple of 10.        c
+c                                                                      c
+c  Version 3.1a : January 1993                                         c 
+c     1. Bugs are fixed. This has to do with finding a feasible point  c
+c        (with the help of Yaguang Yang). There should be no effect    c
+c        if the user's problem does not contain both nonlinear and     c
+c        linear equality constraints.                                  c
+c                                                                      c
+c  Version 3.1 : November 1992                                         c 
+c     1. Possible division by zero is avoided.                         c
+c     2. Objective and constraint values values at initial feasible    c
+c        point is printed out if iprint >=1.                           c
+c     3. Estimates of Lagrange multipliers are made available on outputc
+c        even when execution is terminated abnormally in phase 2.      c
+c     4. Incorrect descriptions of nineq, neq, iwsize and nwsize in thec
+c        user's manual and in the comments in fsqpd.f are corrected.   c
+c                                                                      c
+c  Version 3.0d : October 1992                                         c 
+c     1. Some imperfections (identified by WATFOR) are cleaned up.     c
+c     2. Erroneous declaration of dummy argument in sampl*.f's         c
+c        are corrected.                                                c
+c                                                                      c
+c  Version 3.0c : September 1992                                       c 
+c     1. A bug in identifying active set of objectives fixed.          c 
+c        (Thanks go to Yaguang Yang.)                                  c
+c     2. Some imperfections (identified by WATFOR) are cleaned up.     c
+c        (Thanks go to Jaroslav Dolezal and Jiri Fidler                c
+c        at CZ Academy of Sciences.)                                   c
+c                                                                      c
+c  Version 3.0b : August 1992                                          c 
+c     1. A bug in assigning iskip(*) is fixed. This has to do with     c
+c        finding a feasible point.                                     c
+c     2. Other bugs associated with nonlinear equality constraints     c 
+c        are fixed. The effect is on nonmonotone line search.          c
+c        (Thanks go to Yaguang Yang at Institute for Systems Research  c
+c         the University of Maryland at College Park.)                 c
+c                                                                      c
+c                                                                      c
+c  Version 3.0a : June 1992                                            c 
+c     1. A bug in check.f is fixed and a typo is corrected.            c
+c     2. A bug in initpt.f is fixed.                                   c
+c     3. Printout message is adjusted for various situations.          c
+c     4. Computation of initial equality constraint violation is       c
+c        corrected.  (Thanks go to Jaroslav Dolezal and Jiri Fidler    c
+c         at CZ Academy of Sciences)                                   c
+c     5. An output error for function values is corrected.             c
+c                                                                      c
+c  Version 3.0 : June 1992                                             c
+c     1. FSQP now also handles nonlinear equality constraints.         c
+c        "Semi-feasibility" for these constraints is maintained in     c
+c        the following sense: given a scalar constraint h(x)=0,        c
+c        if h(x0)<=0 (resp. >=0), then h(xk)<=0 (resp. >=0) for all k. c
+c     2. An option is added to allow users to have their own stopping  c
+c        criterion.                                                    c
+c     3. The interface for QPSOL is no longer part of the standard     c
+c        distribution (but it is still available on request).          c
+c     4. Objective and constraints now must be provided in Fortran     c
+c        "subroutines" rather than "functions".                        c
+c     5. Concerning the default stopping criterion, the norm           c
+c        requirement on the Kuhn-Tucker vector is replaced by a norm   c
+c        requirement on Newton direction.                              c
+c     6. The meaning of "mode" is redefined to encompass several       c
+c        attributes.                                                   c
+c     7. The argument list to call FSQPD is modified.                  c
+c     8. The Hessian matrix is reset to the identity whenever          c
+c        the line search fails to complete after a specified number    c
+c        of step reductions, provided the last reset occurred at least c
+c        5*nparam iterations earlier (it used to be 1*nparam).         c
+c                                                                      c
+c  Version 2.4b : November 1991                                        c
+c     1. Bugs are fixed that affected the computation of a feasible    c
+c        point and the initialization of iskp.  (Thanks go to          c
+c        Klaus Schittkowski at U Bayreuth and John Hauser at USC.)     c
+c                                                                      c
+c  Version 2.4a : November 1991                                        c
+c     1. A bug is fixed that affected the multipliers given on output. c
+c     2. A few unused statements are commented out.                    c
+c     3. small() is modified to avoid too small a number on machines   c
+c        that use extra-length registers for internal computations     c
+c        (with the help of Roque Donizete de Oliveira at Michigan).    c
+c                                                                      c
+c  Version 2.4 : October 1991                                          c
+c     1. The Hessian matrix is reset to the identity whenever          c
+c        the line search fails to complete after a specified number    c
+c        of step reductions, provided the last reset occurred at least c
+c        nparam iterations earlier.                                    c
+c                                                                      c
+c  Version 2.3b : September 1991                                       c
+c     1. A bug is fixed in the reordering of active functions.         c
+c                                                                      c
+c  Version 2.3a : September 1991                                       c
+c     1. A bug is fixed in the reordering of active functions.         c
+c                                                                      c
+c  Version 2.3  : July 1991                                            c
+c     1. Lagrange multipliers at the solution point are provided on    c
+c        output.                                                       c
+c     2. Bugs are fixed and code is adapted to be accepted by          c
+c        some "tough" compilers (with the help of K. Schittkowski).    c
+c                                                                      c
+c  Version 2.2  : June 1991                                            c
+c     1. In computing d~, only the most "active" constraints and       c
+c        objectives are taken into account, thus reducing the          c
+c        number of function evaluations.                               c
+c     2. Refinements of nonmonotone line search are implemented        c
+c        for minimax problems without nonlinear constraints.           c
+c     3. Line search is more efficient.                                c
+c     4. A bug is fixed in the computation of d~ in mode=1*.           c
+c     5. The calling sequences of gradcn and gradob are simplified.    c
+c                                                                      c
+c  Version  2.1  : April 1991                                          c
+c     1. FSQP can use either of two quadratic programming codes:       c
+c        QPSOL or QLD.                                                 c
+c     2. Reorder constraints and objectives to enable more efficient   c
+c        line search.                                                  c
+c                                                                      c
+c  Version 2.0B : March 1991: Bugs are fixed                           c
+c  Version 2.0A : October 1990: Bugs are fixed                         c
+c  Version 2.0  : August 1990                                          c
+c     1. Extension to the solution of constrained minimax problems.    c
+c                                                                      c
+c  Version 1.0B : June 1990: Bugs are fixed                            c
+c  Version 1.0A : December  1989: Bugs are fixed                       c
+c  Version 1.0  : August 1989                                          c
+c                                                                      c
+c  References:                                                         c
+c  [1] E. Panier and A. Tits, `On Combining Feasibility, Descent and   c
+c      Superlinear Convergence In Inequality Constrained Optimization',c
+c      Mathematical Programming 59(1993), 261-276.                     c
+c  [2] J. F. Bonnans, E. Panier, A. Tits and J. Zhou, `Avoiding the    c
+c      Maratos Effect by Means of a Nonmonotone Line search: II.       c
+c      Inequality Problems - Feasible Iterates', SIAM J. Numer. Anal.  c
+c      29(1992), 1187-1202.                                            c
+c  [3] J.L. Zhou and A. Tits, `Nonmonotone Line Search for Minimax     c
+c      Problems', J. Optim. Theory Appl.76(1993), 455-476.             c
+c  [4] J.L. Zhou and A. Tits, `User's Guide for FSQP Version 3.3:      c
+c      A Fortran Code for Solving Optimization Programs, Possibly      c
+c      Minimax,with General Inequality Constraints and Linear Equality c
+c      Constraints, Generating Feasible Iterates', Institute for       c
+c      Systems Research, University of Maryland,Technical Report       c
+c      SRC-TR-92-107r3, College Park, MD 20742, 1993.                  c
+c  [5] D.Q. Mayne and E. Polak, `Feasible Directions Algorithms for    c
+c      Optimization Problems with Equality and Inequality Constraints',c
+c      Mathematical Programming 11(1976)                               c
+c                                                                      c
+cCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc
+c
+      integer i,io,ipp,iter,j,ncallg,ncallf,ncnstr,nclin,nctotl,leniw,
+     *        lenw,nwx,nwbl,nwbu,nwgrg,nwgpf,nwpenp,nwa,nwcvec,nwhess,
+     *        nwcla,nww,nrowa,modd,nppram,iwnob,iwncn,iwia,iwisp,iwist,
+     *        iwiw,nwdi,nwd,nwff,nwgrf,nwclla,nwhes1,nwsp,nwbak,nwsg,M,
+     *       maxit,nob,nobL,nnineq,info,idummy,nshift,max0,modem,lstype,
+     *       nstop,initvl,nn,nnn,nwgm,ipsp,ipspan,ipyes,iprnto,mod
+      double  precision epsmac,QLeps,small,xi,gi,gmax,dummy,big,tolfea,
+     *        rteps,epskt,upert,valnom,dsqrt,dmax1
+      logical feasbl,feasb,prnt,nspace,Linfty,nAD
+      common  /fsqpp1/nnineq,M,ncallg,ncallf,modd,lstype,nstop,
+     *        /fsqpp2/io,ipp,ipsp,ipyes,info,idummy,iter,initvl,
+     *        /fsqpp3/epsmac,rteps,upert,valnom
+     *        /fsqpq1/big,tolfea,/fsqpq2/maxit
+      common  /CMACHE/QLeps
+c
+c     compute the machine precision
+c
+      io=6
+c     iwiw=6*nparam+8*max0(1,nineq+neq)+7*max0(nf,1)+30
+c     i=nineq+neq+1
+c     nww=4*nparam**2+5*i*nparam+3*(nf+1)*nparam+26*(nparam+nf+1)
+c    *   +45*i+100
+c     if(iwsize.ge.iwiw.and.nwsize.ge.nww) goto 10
+c       if(iwsize.lt.iwiw) write(io,9906) iwiw
+c       if(nwsize.lt.nww)  write(io,9907) nww
+c       info=7
+c       goto 9000
+c
+ 10   iter=0
+      nstop=1
+      nn=nineqn+neqn
+      epsmac=small()
+      QLeps=epsmac
+      tolfea=epsmac*1.d+02
+      big=bigbnd
+      rteps=dsqrt(epsmac)
+      upert=udelta
+c
+      i=mod(iprint,10)
+      ipspan=max0(iprint-i,1)
+      iprnto=iprint
+      if(iprint.ge.10) iprint=i
+      if(iprint.lt.2) ipspan=1
+      if(ipspan.lt.10) ipyes=0
+      nob=0
+      gmax=-bigbnd
+      info=0
+      ipsp=ipspan
+      ipp=iprint
+      ncnstr=nineq+neq
+      nnineq=nineq
+c
+c     check input data 
+c
+      if(iprint.gt.0) write(io,9900)
+      call check(nparam,nf,Linfty,nAD,nineq,nineqn,neq,neqn,
+     *           mode,modem,nwa,eps,bigbnd,bl,bu)
+      if(info.eq.7) goto 9000
+      lstype=nwa
+c
+      maxit=max0(max0(miter,10*max0(nparam,ncnstr)),1000)
+      feasbl=.true.
+      feasb=.true.
+      prnt=.false.
+      nspace=.false.
+      nppram=nparam+1
+      nshift=nparam**2+nppram**2
+c
+c  check whether x is within bounds
+c
+      do 100 i=1,nparam
+        xi=x(i)
+        if(bl(i).le.xi.and.bu(i).ge.xi) goto 100
+        feasbl=.false.
+        goto 110
+ 100  continue
+ 110  nclin=ncnstr-nn
+c
+c  check whether linear constraints are feasible
+c
+      if(nclin.eq.0) goto 210
+      do 200 i=1,nclin
+        j=i+nineqn
+        if(j.le.nineq) then
+          call constr(nparam,j,x,gi)
+          if(gi.le.epsmac) goto120
+          feasbl=.false.
+        else if(j.gt.nineq) then
+          call constr(nparam,j+neqn,x,gi)
+          if(dabs(gi).le.epsmac) goto 120
+          feasbl=.false.
+        endif
+ 120    g(j)=gi
+ 200  continue
+ 210  if(feasbl) goto 240
+      if(iprint.le.0) goto 230
+        write(io,9901)
+        call sbout1(io,nparam,'x                   ',dummy,x,2,1)
+        prnt=.true.
+ 230  nctotl=nparam+nclin
+      leniw=max0(2*nparam+2*nctotl+3,2*nclin+2*nparam+6)
+      if(leniw.le.iwsize)then
+        leniw=iwsize
+      else
+        write(io,9906) leniw
+        info=7
+        nspace=.true.
+      endif
+      nwx=1
+      nwbl=nwx+nparam
+      nwbu=nwbl+nctotl+4
+      nwgrg=nwbu+nctotl+2
+      nwa=nwgrg+nclin*nparam+1
+      nwcvec=nwa+nparam*nclin+1
+      nwhess=nwcvec+nparam
+      nwcla=nwhess+nparam*nparam
+      nww=nwcla+nctotl+nparam
+      lenw=2*nparam**2+10*nparam+2*nctotl+1
+      if((nww+lenw).le.nwsize) then
+        lenw=nwsize-nww
+        if(.not.nspace) goto 235
+        write(io,9909)
+        goto 9000
+      else
+        write (io,9907) nww+lenw
+        write(io,9909)
+        info=7
+        goto 9000
+      endif
+c
+c     attempt to generate a point satisfying all linear constraints
+c 
+ 235  nrowa=max0(nclin,1)
+      call initpt(nparam,nineqn,neq,neqn,nclin,nctotl,nrowa,x,bl,bu,
+     *            iw,leniw,w(nwx),w(nwbl),w(nwbu),g(nineqn+1),w(nwgrg),
+     *            w(nwa),w(nwcvec),w(nwhess),w(nwcla),w(nwbl+nparam+3),
+     *            w(nww),lenw,constr,gradcn)
+      if(info.ne.0) goto 9000
+ 240  do 245 i=1, neq-neqn
+ 245    g(nineq+neqn+i)=g(nineq+i) 
+      if(nn.ne.0) goto 510
+      goto 605
+c
+ 290    do 300 i=1,nob
+ 300      w(i+nineqn+nshift)=w(i+nshift)
+        nob=0
+c
+ 510  continue
+      if(info.eq.-1) goto 540
+        do 520 i=1,nineqn
+          call constr(nparam,i,x,w(i+nineqn+nshift))
+          if(w(i+nineqn+nshift).gt.0.d0) feasb=.false.
+ 520    continue
+        ncallg=nineqn
+        if(feasb) goto 540
+c
+c     set indxob(i) in phase 1
+c
+        do 530 i=1,nineqn
+          nob=nob+1
+          iw(nob)=i
+          w(nob+nshift)=w(i+nineqn+nshift)
+          gmax=dmax1(gmax,w(nob+nshift))
+ 530    continue
+      goto 580
+ 540    do 550 i=1,nineqn
+          g(i)=w(i+nineqn+nshift)
+          iw(nineqn+i+1)=i
+ 550    continue
+        do 560 i=1,neq-neqn
+          g(i+nineq+neqn)=g(i+nineq)
+ 560    continue
+        do 570 i=1,neqn
+          j=i+nineq
+          call constr(nparam,j,x,g(j))
+          iw(nineqn+nineqn+i+1)=j
+ 570    continue
+        ncallg=ncallg+neqn
+ 580  continue
+c
+ 605  if(iprint.le.0.or..not.feasb.or.prnt) goto 610
+        write(io,9902)
+        call sbout1(io,nparam,'x                   ',dummy,x,2,1)
+        prnt=.true.
+ 610  if(nob.ne.0) goto 620
+      if(iprint.le.0) goto 615
+        if(info.eq.0) goto 613
+        write(io,9904) ncallg
+        if(ipp.eq.0) write(io,9910) iter
+        if(ipp.gt.0) write(io,9910) iter-1
+        if(ipp.eq.0) iter=iter+1
+ 613    if(.not.feasb.or.feasbl) goto 614
+          write(io,9903)
+          call sbout1(io,nparam,'x                   ',dummy,x,2,1)
+ 614    if(info.eq.0.and.prnt.and.feasb) goto 615
+          write(io,9903)
+          call sbout1(io,nparam,'x                   ',dummy,x,2,1)
+ 615  feasb=.true.
+      feasbl=.true.
+ 620  nspace=.false.
+      if(ipp.le.0.or.feasb.or.prnt) goto 630
+        write(io,9901)
+        call sbout1(io,nparam,'x                   ',dummy,x,2,1)
+        prnt=.true.
+ 630  if(nob.eq.0) nob=1
+c
+c     set indxcn(1)--indxcn(ncnstr)
+c
+      if(feasb) nnn=nn
+      if(.not.feasb) nnn=0
+      do 700 i=1,nnn
+ 700    iw(nob+i)=iw(nineqn+i+1)
+ 710  do 800 i=1,nineq-nineqn
+ 800    iw(nob+nnn+i)=nineqn+i
+      do 805 i=1,neq-neqn
+        if(feasb) iw(nob+nineq+neqn+i)=nineq+neqn+i
+        if(.not.feasb) iw(nineq+i)=nineq+neqn+i
+ 805  continue
+      if(.not.feasb) goto 810
+        nob=nf
+        info=0
+        ipp=iprint
+        ipsp=ipspan
+        modd=modem
+        epskt=eps
+        if(Linfty) nobL=2*nob
+        if(.not.Linfty) nobL=nob
+        if(nob.ne.0) goto 910
+        write(io,9908)
+      goto 9000
+ 810    ipp=0
+        ipsp=1
+        modd=0
+        nobL=nob
+        info=-1
+        epskt=1.d-10
+ 910  nctotl=nppram+ncnstr+nobL
+      iwnob=1
+      if(feasb) iwncn=iwnob+1
+      if(.not.feasb) iwncn=iwnob+nob
+      iwia=iwncn+ncnstr
+      iwisp=iwia+nn+nob
+      iwist=iwisp+nnineq-nineqn+1
+      iwiw=iwist+nn+nob
+      leniw=2*(ncnstr+nobL)+2*nppram+6
+c
+      if((iwiw+leniw).le.iwsize) then
+        leniw=iwsize-iwiw
+      else
+        write (io,9906) iwiw+leniw
+        info=7
+        nspace=.true.
+      endif
+      M=4
+      if(modem.eq.1.and.nn.eq.0) M=3
+      nwhess=1
+      nwhes1=nwhess+nparam**2
+      nwff=nwhes1+nppram**2
+      nwx=nwff+nob+1
+      nwdi=nwx+nppram
+      nwd=nwdi+nppram
+      nwgm=nwd+nppram
+      nwgrg=nwgm+max0(1,4*neqn)
+      nwgrf=nwgrg+ncnstr*nparam+1
+      nwgpf=nwgrf+nparam*nob+1
+      nwpenp=nwgpf+nparam
+      nwa=nwpenp+neqn+1
+      nwbl=nwa+(ncnstr+nobL)*(nppram+1)
+      nwbu=nwbl+nctotl+4
+      nwcla=nwbu+nctotl+2
+      nwclla=nwcla+nctotl+nppram
+      nwcvec=nwclla+nctotl
+      nwsp=nwcvec+nppram
+      nwbak=nwsp+M+1
+      nwsg=nwbak+nob+ncnstr+1
+      nww=nwsg+neqn+1
+      lenw=2*nppram*nppram+10*nppram+6*(ncnstr+nobL+1)
+c
+      if((nww+lenw).le.nwsize) then
+        lenw=nwsize-nww
+        if(.not.nspace) goto 920
+        write(io,9909)
+        goto 9000
+      else
+        write (io,9907) nww+lenw
+        write(io,9909)
+        info=7
+        goto 9000
+      endif
+c
+ 920  do 1000 i=nwx,nwx+nparam-1
+ 1000   w(i)=x(i-nwx+1)
+      w(nwx+nparam)=gmax
+      if(.not.feasb) goto 1150
+        do 1100 i=1,neqn
+          if(g(i+nineq).gt.0d0) w(nwsg+i-1)=-1.d0
+          if(g(i+nineq).le.0d0) w(nwsg+i-1)=1.d0
+ 1100   continue
+c
+c     either attempt to generate a point satisfying all constraints 
+c     or try to solve the original problem
+c
+ 1150 nrowa=max0(ncnstr+nobL,1)
+      call FSQPD1(miter,nparam,nob,nobL,nineqn,neq,neqn,ncnstr,nctotl,
+     *            nrowa,feasb,epskt,epseqn,bl,bu,iw(iwnob),iw(iwncn),
+     *            iw(iwia),iw(iwisp),iw(iwist),iw(iwiw),leniw,w(nwx),
+     *            w(nwdi),w(nwd),g,w(nwgm),w(nwgrg),w(nwff),w(nwgrf),
+     *            w(nwgpf),w(nwpenp),w(nwa),w(nwbl),w(nwbu),w(nwcla),
+     *            w(nwclla),w(nwcvec),w(nwbl+nparam+3),w(nwhess),
+     *            w(nwhes1),w(nwsp),w(nwbak),w(nwsg),w(nww),lenw,
+     *            obj,constr,gradob,gradcn)
+      do 1200 i=1,nparam
+ 1200   x(i)=w(nwx+i-1)
+      if(info.eq.-1) goto 290
+      if(info.eq.0.or.feasb) goto 1220
+        info=2
+        write(io,9905)
+      goto 9000
+ 1220 do 1300 i=1,nf
+ 1300   f(i)=w(nwff+i-1)
+      if(nobL.eq.1) idummy=0
+      if(nobL.gt.1) idummy=1
+      if(nf.eq.1) nob=0
+      do 1400 i=1,nparam+ncnstr+nob
+        j=i
+        if(i.gt.nparam.and.i.le.(nparam+ncnstr)) 
+     *    j=nparam+iw(iwncn+i-nparam)
+        if(i.le.nparam) then
+          w(i)=w(nwclla+j-1)
+        else if(i.gt.nparam) then
+          if(i.le.(nparam+ncnstr)) j=nparam+iw(iwncn+i-1-nparam)
+          w(i)=w(nwclla+j-1+idummy)
+        endif
+ 1400 continue
+c
+ 9000 inform=info
+      iprint=iprnto
+      return
+ 9900 format(1x,// 1x,'       FSQP Version 3.3 (Released April 1993)'
+     *   /   1x,'            Copyright (c) 1989 --- 1993         '
+     *   /   1x,'              J.L. Zhou and A.L. Tits           '
+     *   /   1x,'                All Rights Reserved             ',//)
+ 9901 format(1x,'The given initial point is infeasible for inequality',
+     *       /10x,'constraints and linear equality constraints:')
+
+ 9902 format(1x,'The given initial point is feasible for inequality',
+     *   /8x,'constraints and linear equality constraints:')
+ 9903 format(1x,'Starting from the generated point feasible for',
+     *   ' inequality',
+     *   /10x,'constraints and linear equality constraints:')
+ 9904 format(1x,'To generate a point feasible for nonlinear inequality',
+     *   /1x,'constraints and linear equality constraints,',
+     *   ' ncallg = ',i10)
+ 9905 format(1x,'Error: No feasible point is found for nonlinear',
+     *   ' inequality',
+     *    /8x,'constraints and linear equality constraints'/)
+ 9906 format(1x,'iwsize should be bigger than', i20)
+ 9907 format(1x,'nwsize should be bigger than', i20)
+ 9908 format(1x,'current feasible iterate with no objective specified'/)
+ 9909 format(1x,/)
+ 9910 format(43x,'iteration = ',i10)
+      end
+c
+      block data
+      double  precision objeps,objrep,gLgeps
+      common  /fsqpus/objeps,objrep,gLgeps
+c
+      data objeps,objrep,gLgeps/-1.d0,-1.d0,-1.d0/
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/fsqpd1.f
@@ -0,0 +1,185 @@
+      subroutine FSQPD1(miter,nparam,nob,nobL,nineqn,neq,neqn,ncnstr,
+     *                  nctotl,nrowa,feasb,epskt,epseqn,xl,xu,indxob,
+     *                  indxcn,iact,iskip,istore,iw,leniw,x,di,d,g,gm,
+     *                  gradg,f,gradf,grdpsf,penp,a,bl,bu,clamda,
+     *                  cllamd,cvec,bj,hess,hess1,span,backup,signeq,
+     *                  w,lenw,obj,constr,gradob,gradcn)
+c
+c     FSQP Version 3.3  : main routine for the optimization
+c
+c     implicit real*8(a-h,o-z)
+      integer miter,nparam,nob,nobL,nineqn,neq,neqn,ncnstr,nctotl,nrowa,
+     *        leniw,lenw
+      integer indxob(1),indxcn(1),iact(1),iskip(1),
+     *        istore(1),iw(leniw)
+c     integer indxob(nob),indxcn(ncnstr),iact(nob+nineqn+neqn),iskip(1),
+c    *        istore(nineqn+nob+neqn),iw(leniw)
+      double  precision epskt,epseqn
+      double  precision xl(nparam),xu(nparam),x(nparam+1),di(nparam+1),
+     *        d(nparam+1),g(1),gm(1),gradg(nparam,1),
+     *        f(1),gradf(nparam,1),grdpsf(nparam),penp(1),
+     *        a(nrowa,1),bl(1),bu(1),clamda(1),
+     *        cllamd(1),cvec(nparam+1),bj(1),
+     *        hess(nparam,nparam),hess1(1),span(1),
+     *        backup(1),signeq(1),w(lenw)
+c     double  precision xl(nparam),xu(nparam),x(nparam+1),di(nparam+1),
+c    *        d(nparam+1),g(ncnstr),gm(4*neqn),gradg(nparam,ncnstr),
+c    *        f(nob),gradf(nparam,nob),grdpsf(nparam),penp(neqn),
+c    *        a(nrowa,1),bl(nctotl),bu(nctotl),clamda(nctotl+nparam+1),
+c    *        cllamd(nctotl),cvec(nparam+1),bj(nrowa),
+c    *        hess(nparam,nparam),hess1(nparam+1,nparam+1),span(1),
+c    *        backup(nob+ncnstr),signeq(neqn),w(lenw)
+      external obj,constr,gradob,gradcn
+      logical feasb
+c
+      integer nnineq,M,ncallg,ncallf,mode,io,iprint,info,ipd,iter,nstop,
+     *        initvl,ipspan,ipyes,lstype
+      double  precision bigbnd,tolfea,epsmac,rteps,udelta,valnom
+      logical dlfeas,local,update,first
+      common  /fsqpp1/nnineq,M,ncallg,ncallf,mode,lstype,nstop,
+     *        /fsqpp2/io,iprint,ipspan,ipyes,info,ipd,iter,initvl,
+     *        /fsqpp3/epsmac,rteps,udelta,valnom,
+     *        /fsqpq1/bigbnd,tolfea,
+c    *        /fsqp1/rentry,
+     *        /fsqplo/dlfeas,local,update,first
+c
+c     bj(1+) is equivalent to bl(nparam+3+)
+c
+      integer i,iskp,nfs,ncf,ncg,nn,non,nstart,nrst,ncnst1,nctot1
+      double  precision Cbar,Ck,dbar,fM,fMp,steps,d0nm,dummy,
+     *        sktnom,scvneq,grdftd,dmax1,psf
+c
+      initvl=1
+      first=.true.
+      nrst=0
+      ipd=0
+      if(iter.eq.0) call diagnl(nparam,1.d0,hess)
+      if(.not.feasb) goto 5
+        first=.true.
+        if(iter.gt.0) iter=iter-1
+        if(iter.ne.0) call diagnl(nparam,1.d0,hess)
+ 5    Cbar=1.d-02
+      Ck=Cbar
+      dbar=5.0d0
+      nstart=1
+      ncallf=0
+      nstop=1
+      nfs=0
+      non=miter
+      if(mode.eq.0) goto 10
+        nfs=M
+        non=0
+ 10   if(feasb) then
+        nn=nineqn+neqn
+        ncnst1=ncnstr
+        nctot1=nctotl
+      else 
+        nn=0
+        ncnst1=ncnstr-nineqn-neqn
+        nctot1=nnineq-nineqn+neq-neqn+nparam
+        if(nob.gt.1) nctot1=nctot1+1
+      endif
+      scvneq=0.d0
+      do 100 i=1,ncnst1
+        valnom=g(indxcn(i))
+        backup(i)=valnom
+        if(feasb.and.i.gt.nineqn.and.i.le.nn) then
+          gm(i-nineqn)=valnom*signeq(i-nineqn)
+          scvneq=scvneq+dabs(valnom)
+        endif
+        if(.not.feasb.or.i.gt.nn) goto 20
+          iact(i)=indxcn(i)
+          istore(i)=0
+          if(i.gt.nineqn) penp(i-nineqn)=10.d0
+ 20     call gradcn(nparam,indxcn(i),x,gradg(1,indxcn(i)),constr)
+ 100  continue
+      call nullvc(nparam,grdpsf)
+      psf=0.d0
+      if(.not.feasb.or.neqn.eq.0) goto 110
+        call resign(nparam,neqn,psf,grdpsf,penp,g(nnineq+1),
+     *              gradg(1,nnineq+1),signeq,12,12)
+ 110  fM=-bigbnd
+      do 140 i=1,nob
+        if(.not.feasb) goto 120
+          iact(nn+i)=i
+          istore(nn+i)=0
+          call obj(nparam,i,x,f(i))
+          valnom=f(i)
+          backup(i+ncnst1)=valnom
+          call gradob(nparam,i,x,gradf(1,i),obj)
+          ncallf=ncallf+1
+          if(nobL.ne.nob) fM=dmax1(fM,-f(i))
+        goto 130
+ 120      valnom=f(i)
+          iact(i)=i
+          istore(i)=0
+          call gradcn(nparam,indxob(i),x,gradf(1,i),constr)
+ 130    fM=dmax1(fM,f(i))
+ 140  continue
+      fMp=fM-psf
+      span(1)=fM
+c
+      if(iprint.lt.3.or..not.first.or.ipyes.gt.0) goto 600
+        do 300 i=1,nob
+          if(.not.feasb) goto 250
+            if(nob.gt.1) 
+     *        call sbout2(io,nparam,i,'gradf(j,',')',gradf(1,i))
+            if(nob.eq.1) 
+     *        call sbout1(io,nparam,'gradf(j)            ',
+     *                    dummy,gradf(1,1),2,2)
+          goto 300
+ 250        call sbout2(io,nparam,indxob(i),'gradg(j,',')',gradf(1,i))
+ 300    continue
+ 310    if(ncnstr.eq.0) goto 410
+        do 400 i=1,ncnst1
+ 400      call sbout2(io,nparam,i,'gradg(j,',')',gradg(1,i))
+        if(neqn.eq.0) goto 410
+        call sbout1(io,nparam,'grdpsf(j)           ',dummy,grdpsf,2,2)
+        call sbout1(io,neqn,'P                   ',dummy,penp,2,2)
+ 410    do 500 i=1,nparam
+ 500      call sbout2(io,nparam,i,'hess (j,',')',hess(1,i))
+c
+c     main loop of the algorithm
+c
+ 600  nstop=1
+ 601  continue
+        call out(miter,nparam,nob,nineqn,nn,neqn,ncnst1,x,g,
+     *           f,fM,psf,steps,sktnom,d0nm,feasb)
+        if(nstop.ne.0) goto 810
+        if(.not.feasb) goto 801
+          do 700 i=1,ncnst1
+ 700        g(i)=backup(i)
+          do 800 i=1,nob
+ 800        f(i)=backup(i+ncnst1)
+ 801      return
+ 810    continue
+        if(ipspan.ge.10.and.iprint.ge.2.and.ipyes.eq.0) 
+     *    write(io,9900) iter
+        call dir(nparam,nob,nobL,nineqn,neq,neqn,nn,ncnst1,nctot1,nrowa,
+     *           feasb,steps,epskt,epseqn,sktnom,scvneq,Ck,d0nm,grdftd,
+     *           xl,xu,indxob,indxcn,iact,iskp,iskip,istore,iw,leniw,
+     *           x,di,d,g,gradg,f,fM,fMp,psf,gradf,grdpsf,penp,a,
+     *           bl,bu,clamda,cllamd,cvec,bj,hess,hess1,w,lenw,
+     *           backup,signeq,obj,constr)
+        if(nstop.eq.0) goto 601
+        first=.false.
+        if(update) goto 820
+        call step(nparam,nob,nobL,nineqn,neq,neqn,nn,ncnst1,ncg,ncf,
+     *            indxob,indxcn,iact,iskp,iskip,istore,feasb,grdftd,
+     *            f,fM,fMp,psf,penp,steps,scvneq,bu,x,di,d,g,w,
+     *            backup,signeq,obj,constr)
+        if(nstop.eq.0) goto 601
+ 820    call hesian(nparam,nob,nobL,nineqn,neq,neqn,nn,ncnst1,nctot1,
+     *              nfs,nstart,feasb,bigbnd,bu,x,f,fM,fMp,psf,
+     *              gradf,grdpsf,penp,g,gm,gradg,indxob,indxcn,cllamd,
+     *              bl,clamda,di,hess,d,steps,nrst,signeq,span,
+     *              obj,constr,gradob,gradcn,
+     *              hess1,cvec,bj,w,lenw,iw,leniw) 
+        if(nstop.eq.0) goto 601
+        if(mode.eq.0) goto 601
+        if(d0nm.gt.dbar) Ck=dmax1(dble(0.5*Ck),Cbar)
+        if(d0nm.le.dbar.and.dlfeas) Ck=Ck
+        if(d0nm.le.dbar.and..not.dlfeas) Ck=10.0*Ck
+      goto 601
+ 9900 format(1x,9hiteration,t22,i22)
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/grcnfd.f
@@ -0,0 +1,40 @@
+c
+      subroutine grcnfd(nparam,j,x,gradg,constr)
+c
+c     FSQP Version 3.3  : computation of gradients of constraint
+c                         functions by forward finite differences
+c
+c     implicit real*8(a-h,o-z)
+      integer nparam,j
+      double  precision x(nparam),gradg(nparam)
+      external constr
+c
+      integer io,iprint,ipspan,ipyes,info,ipd,idum,idum2
+      double  precision epsmac,rteps,udelta,gj
+      common  /fsqpp2/io,iprint,ipspan,ipyes,info,ipd,idum,idum2,
+     *        /fsqpp3/epsmac,rteps,udelta,gj
+c
+c     estimate the gradient of the ith constraint 
+c     by forward finite differences
+c
+      integer i
+      double  precision xi,delta,dmax1
+c
+      do 10 i=1,nparam
+        xi=x(i)
+        delta=dmax1(udelta,rteps*dmax1(1.d0,dabs(xi)))
+        if (xi.lt.0.d0) delta=-delta
+        if (j.ne.1.or.iprint.lt.3) goto 9
+        if (ipspan.ge.10.and.ipyes.gt.0) goto 9
+          if(i.eq.1) write(io,1001) delta
+          if(i.ne.1) write(io,1002) delta
+        ipd=1
+  9     x(i)=xi+delta
+        call constr(nparam,j,x,gradg(i))
+        gradg(i)=(gradg(i)-gj)/delta
+        x(i)=xi
+ 10   continue
+      return
+ 1001 format(1x,t17,8hdelta(i),t45,e22.14)
+ 1002 format(1x,t45,e22.14)
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/grobfd.f
@@ -0,0 +1,37 @@
+      subroutine grobfd(nparam,j,x,gradf,obj)
+c
+c     FSQP Version 3.3  : computation of gradients of objective
+c                         functions by forward finite differences
+c
+c     implicit real*8(a-h,o-z)
+      integer nparam,j
+      double  precision x(nparam),gradf(nparam)
+      external obj
+c
+      integer io,iprint,ipspan,ipyes,info,ipd,idum,idum2
+      double  precision epsmac,rteps,udelta,fj
+      common  /fsqpp2/io,iprint,ipspan,ipyes,info,ipd,idum,idum2,
+     *        /fsqpp3/epsmac,rteps,udelta,fj
+c
+c     estimates the gradient of the objective function 
+c     by forward finite differences
+c
+      integer i
+      double  precision xi,delta,dmax1
+c
+      do 10 i=1,nparam
+        xi=x(i)
+        delta=dmax1(udelta,rteps*dmax1(1.d0,dabs(xi)))
+        if (xi.lt.0.d0) delta=-delta
+        if (ipd.eq.1.or.j.ne.1.or.iprint.lt.3.or.ipyes.gt.0) goto 9
+          if(i.eq.1) write(io,1001) delta
+          if(i.ne.1) write(io,1002) delta
+  9     x(i)=xi+delta
+        call obj(nparam,j,x,gradf(i))
+        gradf(i)=(gradf(i)-fj)/delta
+        x(i)=xi
+ 10   continue
+      return
+ 1001 format(1x,t17,8hdelta(i),t45,e22.14)
+ 1002 format(1x,t45,e22.14)
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/hesian.f
@@ -0,0 +1,194 @@
+      subroutine hesian(nparam,nob,nobL,nineqn,neq,neqn,nn,ncnstr,
+     *                  nctotl,nfs,nstart,feasb,bigbnd,xnew,x,f,
+     *                  fM,fMp,psf,gradf,grdpsf,penp,g,gm,gradg,indxob,
+     *                  indxcn,cllamd,delta,eta,gamma,hess,hd,steps,
+     *                  nrst,signeq,span,obj,constr,gradob,gradcn,
+     *                  phess,psb,psmu,w,lenw,iw,leniw)
+c
+c     FSQP Version 3.3  : updating the Hessian matrix using BFGS
+c                         formula with Powell's modification
+c
+c     implicit real*8(a-h,o-z)
+      integer nparam,nob,nobL,nineqn,neq,neqn,nn,ncnstr,nctotl,nfs,
+     *        nstart,indxob(1),indxcn(1),nrst,lenw,leniw,iw(leniw)
+c    *        nstart,indxob(nob),indxcn(1),nrst,lenw,leniw,iw(leniw)
+      double  precision bigbnd,steps,psf,fM,fMp,
+     *        xnew(nparam),x(nparam),f(1),gradf(nparam,1),
+     *        grdpsf(nparam),penp(1),g(1),gm(1),
+     *        gradg(nparam,1),cllamd(1),delta(nparam),
+     *        eta(nparam),gamma(nparam),hess(nparam,nparam),hd(nparam),
+     *        signeq(1),span(1),phess(1),psb(1),psmu(1),w(lenw)
+c     double  precision bigbnd,steps,psf,fM,fMp,
+c    *        xnew(nparam),x(nparam),f(nob),gradf(nparam,nob),
+c    *        grdpsf(nparam),penp(neqn),g(ncnstr),gm(4*neqn),
+c    *        gradg(nparam,ncnstr),cllamd(nctotl),delta(nparam),
+c    *        eta(nparam),gamma(nparam),hess(nparam,nparam),hd(nparam),
+c    *        signeq(neqn),span(1),phess(neq,neq),psb(neq),
+c    *        psmu(neq),w(lenw)
+      external obj,constr,gradob,gradcn
+      logical feasb
+c
+      integer nnineq,M,ncallg,ncallf,mode,io,iprint,ipspan,ipyes,info,
+     *        ipd,iter,nstop,initvl,lstype
+      double  precision epsmac,rteps,udelta,valnom,objeps,objrep,gLgeps
+      common  /fsqpp1/nnineq,M,ncallg,ncallf,mode,lstype,nstop,
+     *        /fsqpp2/io,iprint,ipspan,ipyes,info,ipd,iter,initvl,
+     *        /fsqpp3/epsmac,rteps,udelta,valnom,
+     *        /fsqpus/objeps,objrep,gLgeps
+c
+      integer ng,i,j,ifail,indexs,np,mnm,iout
+      double  precision dhd,gammd,etad,scaprd,dummy,theta,signgj,psfnew
+      logical done
+c
+      if(feasb.and.nstop.ne.0.and.neqn.eq.0) then
+c
+c       check of gLgeps is just after computing d0!
+c
+        if(dabs(w(1)-fM).le.objeps) then
+          nstop=0
+        else if(dabs(1.d0-fM/w(1)).le.objrep) then
+          nstop=0
+        endif
+      endif
+      if(nstop.eq.0) goto 810
+c
+      ipd=0
+      done=.false.
+      psfnew=0.d0
+      call nullvc(nparam,delta)
+      call nullvc(nparam,eta)
+      if(nobL.gt.1) ng=2
+      if(nobL.eq.1) ng=1
+c
+ 100  continue
+        call nullvc(nparam,gamma)
+        if(nobL.gt.1) call matrvc(nparam,nob,nparam,nob,gradf,
+     *                     cllamd(nparam+ng+ncnstr),hd)
+        if(.not.feasb) goto 120
+        if(nineqn.eq.0) goto 110
+        call matrvc(nparam,nineqn,nparam,nineqn,gradg,cllamd(nparam+ng),
+     *              gamma)
+ 110    if(neqn.eq.0) goto 120
+        call matrvc(nparam,neqn,nparam,neqn,gradg(1,nnineq+1),
+     *              cllamd(nparam+nnineq+ng),eta)
+ 120    do 200 i=1,nparam
+          if(nobL.gt.1) then
+            if(done) psb(i)=hd(i)+cllamd(i)+gamma(i)
+            gamma(i)=gamma(i)+hd(i)-grdpsf(i)+eta(i)
+          else if(nobL.eq.1) then
+            if(done) psb(i)=gradf(i,1)+cllamd(i)+gamma(i)
+            gamma(i)=gamma(i)+gradf(i,1)-grdpsf(i)+eta(i)
+          endif
+          if(.not.done) delta(i)=gamma(i)
+ 200    continue
+        if(done) goto 410
+        if(nn.eq.0) goto 310
+        do 300 i=1,nn
+          if(feasb.and.i.gt.nineqn)     signgj=signeq(i-nineqn)
+          if(.not.feasb.or.i.le.nineqn) signgj=1.d0
+          valnom=g(indxcn(i))*signgj
+          call gradcn(nparam,indxcn(i),xnew,gradg(1,indxcn(i)),constr)
+ 300    continue
+        call resign(nparam,neqn,psf,grdpsf,penp,g(nnineq+1),
+     *              gradg(1,nnineq+1),signeq,11,11)
+ 310    do 400 i=1,nob
+          valnom=f(i)
+          if(feasb) call gradob(nparam,i,xnew,gradf(1,i),obj)
+          if(.not.feasb)
+     *      call gradcn(nparam,indxob(i),xnew,gradf(1,i),constr)
+ 400    continue
+        done=.true.
+      goto 100
+c
+ 410  if(nrst.lt.(5*nparam).or.steps.gt.0.1d0) goto 420
+        nrst=0
+        call diagnl(nparam,1.d0,hess)
+        goto 810
+ 420  nrst=nrst+1
+      do 500 i=1,nparam
+        gamma(i)=gamma(i)-delta(i)
+        delta(i)=xnew(i)-x(i)
+ 500  continue
+      call matrvc(nparam,nparam,nparam,nparam,hess,delta,hd)
+      dhd=scaprd(nparam,delta,hd)
+      gammd=scaprd(nparam,delta,gamma)
+      if(gammd.ge.0.2d0*dhd) theta=1.d0
+      if(gammd.lt.0.2d0*dhd) theta=.8d0*dhd/(dhd-gammd)
+      do 600 i=1,nparam
+ 600    eta(i)=hd(i)*(1.d0-theta)+theta*gamma(i)
+      etad=theta*gammd+(1.d0-theta)*dhd
+      do 800  i=1,nparam
+        do 700 j=i,nparam
+          hess(i,j)=hess(i,j)-hd(i)*hd(j)/dhd+eta(i)*eta(j)/etad
+ 700    hess(j,i)=hess(i,j)
+ 800  continue
+ 810  do 900 i=1,nparam
+ 900    x(i)=xnew(i)
+      if(nstop.eq.0) goto 9000
+      if(neqn.eq.0.or..not.feasb) goto 1400
+        iout=io
+        i=nnineq-nineqn
+        if(i.eq.0) goto 990
+        call matrvc(nparam,i,nparam,i,gradg(1,nineqn+1),
+     *              cllamd(nparam+ng+nineqn),gamma)
+        do 950 i=1,nparam
+ 950      psb(i)=psb(i)+gamma(i)
+ 990    call estlam(nparam,neq,ifail,iout,bigbnd,phess,delta,eta,gamma,
+     *              gradg(1,nnineq+1),psb,hd,xnew,psmu,w,lenw,iw,leniw)
+        do 1000 i=1,neqn
+          if(ifail.ne.0) then
+            penp(i)=2.d0*penp(i)
+          else if(ifail.eq.0) then
+            etad=psmu(i)+penp(i)
+            if(etad.ge.1.d0) goto 1000
+            penp(i)=dmax1(1.0d0-psmu(i),5.0d0*penp(i))
+          endif
+ 1000   continue
+        call resign(nparam,neqn,psf,grdpsf,penp,g(nnineq+1),
+     *              gradg(1,nnineq+1),signeq,20,12)
+        fMp=fM-psf
+ 1400   if(nfs.eq.0) goto 1430
+        nstart=nstart+1
+        np=indexs(nstart,nfs)
+        span(np)=fM
+        do 1410 i=1,neqn
+ 1410     gm((np-1)*neqn+i)=g(nnineq+i)
+        if(neqn.ne.0) call resign(nparam,neqn,psfnew,grdpsf,penp,
+     *                            gm(1),gradg,signeq,20,10)
+        fM=span(1)
+        fMp=span(1)-psfnew
+        mnm=min0(nstart,nfs)
+        do 1420 i=2,mnm
+          if(neqn.ne.0) call resign(nparam,neqn,psfnew,grdpsf,penp,
+     *                           gm((i-1)*neqn+1),gradg,signeq,20,10)
+          fM=dmax1(fM,span(i))
+          fMp=dmax1(fMp,span(i)-psfnew)
+ 1420   continue
+ 1430 if(iprint.lt.3.or.ipyes.gt.0) goto 9000
+        do 1700 i=1,nob
+          if(.not.feasb) goto 1600
+            if(nob.gt.1) call sbout2(io,nparam,i,'gradf(j,',')',
+     *                               gradf(1,i))
+            if(nob.eq.1) call sbout1(io,nparam,'gradf(j)            ',
+     *                               dummy,gradf(1,i),2,2)
+          goto 1700
+ 1600       call sbout2(io,nparam,indxob(i),'gradg(j,',')',
+     *                  gradf(1,i))
+ 1700   continue
+        if(ncnstr.eq.0) goto 1900
+        do 1800 i=1,ncnstr
+ 1800     call sbout2(io,nparam,i,'gradg(j,',')',
+     *                gradg(1,i))
+        if(neqn.eq.0) goto 1900
+        call sbout1(io,nparam,'grdpsf(j)           ',dummy,grdpsf,2,2)
+        call sbout1(io,neqn,'P                   ',dummy,penp,2,2)
+c       call sbout1(io,neqn,'psmu                ',dummy,psmu,2,2)
+ 1900   call sbout1(io,nparam,'multipliers  for  x ',dummy,cllamd,2,2)
+        if(ncnstr.ne.0) call sbout1(io,ncnstr,'             for  g ',
+     *                              dummy,cllamd(nparam+ng),2,2)
+        if(nobL.gt.1) call sbout1(io,nob,'             for  f ',
+     *                            dummy,cllamd(nparam+ng+ncnstr),2,2)
+        do 2000 i=1,nparam
+ 2000     call sbout2(io,nparam,i,'hess (j,',')',hess(1,i))
+ 9000 return 
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/indexs.f
@@ -0,0 +1,14 @@
+c
+      integer function indexs(i,nfs)
+c     implicit real*8(a-h,o-z)
+      integer i,nfs,mm
+c
+c     find the residue of i with respect to nfs
+c
+      mm=i
+      if(mm.le.nfs) goto 120
+ 110  mm=mm-nfs
+      if(mm.gt.nfs) goto 110
+ 120  indexs=mm
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/initpt.f
@@ -0,0 +1,74 @@
+      subroutine initpt(nparam,nnl,neq,neqn,nclin,nctotl,nrowa,x0,
+     *                  bndl,bndu,iw,leniw,x,bl,bu,g,gradg,a,cvec,hess,
+     *                  clamda,bj,w,lenw,constr,gradcn)
+c
+c     FSQP Version 3.3  : generation of a feasible point satisfying
+c                         simple bounds and linear constraints
+c
+c     implicit real*8(a-h,o-z)
+      integer nparam,nnl,neq,neqn,nclin,nctotl,nrowa,leniw,lenw
+      integer iw(leniw)
+      double  precision x0(nparam),bndl(nparam),bndu(nparam),x(nparam),
+     *        bl(1),bu(1),g(1),gradg(nparam,1),
+     *        a(nrowa,1),cvec(nparam),hess(nparam,nparam),
+     *        clamda(1),bj(1),w(lenw)
+c     double  precision x0(nparam),bndl(nparam),bndu(nparam),x(nparam),
+c    *        bl(nctotl),bu(nctotl),g(nclin),gradg(nparam,nclin),
+c    *        a(nrowa,nparam),cvec(nparam),hess(nparam,nparam),
+c    *        clamda(nctotl+nparam),bj(nclin),w(lenw)
+      external constr,gradcn
+c
+c     bj(1) is equivalent to bl(nparam+3)
+c
+      integer io,iprint,ipspan,ipyes,info,ipd,idum,idum2,maxit,
+     *        nnineq,id1,id2,id3,id4,id5,id6
+      double  precision epsmac,rteps,udelta,valnom,big,tolfea
+      common  /fsqpp1/nnineq,id1,id2,id3,id4,id5,id6
+     *        /fsqpp2/io,iprint,ipspan,ipyes,info,ipd,idum,idum2,
+     *        /fsqpp3/epsmac,rteps,udelta,valnom,
+     *        /fsqpq1/big,tolfea,/fsqpq2/maxit
+c
+      integer i,j,infoql,mnn
+      double  precision x0i
+c
+      info=1
+      do 10 i=1,nclin
+        valnom=g(i)
+        j=i+nnl
+        if(j.le.nnineq) call gradcn(nparam,j,x0,gradg(1,i),constr)
+        if(j.gt.nnineq) 
+     *    call gradcn(nparam,j+neqn,x0,gradg(1,i),constr)
+ 10   continue
+      do 20 i=1,nparam
+        x0i=x0(i)
+        bl(i)=bndl(i)-x0i
+        bu(i)=bndu(i)-x0i
+        cvec(i)=0.d0
+ 20   continue
+      do 30 i=nclin,1,-1
+ 30     bj(nclin-i+1)=-g(i)
+      do 60 i=nclin,1,-1
+        do 50 j=1,nparam
+ 50       a(nclin-i+1,j)=-gradg(j,i)
+ 60   continue
+      call diagnl(nparam,1.d0,hess)
+      call nullvc(nparam,x)
+C
+      mnn=nrowa+2*nparam
+      iw(1)=1
+      call QL0001(nclin,neq-neqn,nrowa,nparam,nparam,mnn,hess,cvec,A,
+     *            bj,bL,bU,X,clamda,io,infoql,0,w,lenw,iw,leniw)
+      if(infoql.ne.0) goto 90
+      do 70 i=1,nparam
+ 70     x0(i)=x0(i)+x(i)
+      do 80 i=1,nclin
+        j=i+nnl
+        if(j.le.nnineq) call constr(nparam,j,x0,g(i))
+        if(j.gt.nnineq) call constr(nparam,j+neqn,x0,g(i))
+ 80   continue
+      info=0
+ 90   if(info.eq.1.and.iprint.ne.0) write(io,1000)
+ 1000 format(1x,'Error: No feasible point is found for the',
+     *                 ' linear constraints',/)
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/lfuscp.f
@@ -0,0 +1,9 @@
+c
+      double precision function lfuscp(val,thrshd)
+c     implicit real*8(a-h,o-z)
+      double precision val,thrshd
+c
+      if(dabs(val).le.thrshd) lfuscp=0
+      if(dabs(val).gt.thrshd) lfuscp=1
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/matrcp.f
@@ -0,0 +1,16 @@
+c
+      subroutine matrcp(ndima,a,ndimb,b)
+c     implicit real*8(a-h,o-z)
+      integer ndima,ndimb,i,j
+      double  precision a(ndima,1),b(ndimb,1)
+c     double  precision a(ndima,ndima),b(ndimb,ndimb)
+c
+      do 100 i=1,ndima
+        do 100 j=1,ndima
+ 100      b(i,j)=a(i,j)
+      if(ndimb.le.ndima) goto 9000
+        do 200 i=1,ndimb
+          b(ndimb,i)=0.d0
+ 200      b(i,ndimb)=0.d0
+ 9000 return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/matrvc.f
@@ -0,0 +1,16 @@
+c 
+      subroutine matrvc(l,n,la,na,a,x,y)
+c     implicit real*8(a-h,o-z)
+      integer l,n,la,na,i,j
+      double  precision a(l,n),x(n),y(l),yi
+c     double  precision a(l,1),x(1),y(1),yi
+c
+c     computation of y=ax
+c
+      do 200 i=1,la
+        yi=0.d0
+        do 100 j=1,na
+ 100      yi=yi+a(i,j)*x(j)
+ 200      y(i)=yi
+      return
+      end       
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/nullvc.f
@@ -0,0 +1,12 @@
+c
+      subroutine nullvc(nparam,x)
+c     implicit real*8(a-h,o-z)
+      integer nparam,i
+      double  precision x(nparam)
+c
+c     set x=0
+c
+      do 100 i=1,nparam
+ 100    x(i)=0.d0
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/out.f
@@ -0,0 +1,113 @@
+      subroutine out(miter,nparam,nob,ncn,nn,neqn,ncnstr,x,g,f,fM,
+     *               psf,steps,sktnom,d0norm,feasb)
+c
+c     FSQP Version 3.3  : output for different value of iprint
+c
+c     implicit real*8(a-h,o-z)
+      integer miter,nparam,nob,ncn,nn,neqn,ncnstr
+      double  precision fM,steps,sktnom,d0norm,psf
+      double  precision x(nparam),g(1),f(1)
+c     double  precision x(nparam),g(ncnstr),f(nob)
+      logical feasb
+c
+      integer nnineq,M,ncallg,ncallf,mode,io,iprint,ipspan,ipyes,
+     *        info,idum1,iter,nstop,initvl,lstype
+      common  /fsqpp1/nnineq,M,ncallg,ncallf,mode,lstype,nstop,
+     *        /fsqpp2/io,iprint,ipspan,ipyes,info,idum1,iter,initvl
+c
+      integer i
+      double precision SCV,dummy,adummy(1)
+c
+      if(nstop.eq.0) ipyes=0
+      if (iter.le.miter) goto 10
+        info=3
+        nstop=0
+        goto 120
+ 10   if(iprint.eq.0.or.ipyes.gt.0) then
+        iter=iter+1
+        goto 9000
+      endif
+      if(info.gt.0) goto 120
+      if(iprint.ne.1.or.nstop.eq.0) goto 20
+        iter=iter+1
+        if(initvl.eq.0) goto 9000
+        if(feasb)
+     *    call sbout1(io,nob,'objectives          ',dummy,f,2,1)
+        if (mode.eq.1.and.iter.gt.1.and.feasb)
+     *  call sbout1(io,0,'objective max4      ',fM,adummy,1,1)
+        if(nob.gt.1) call sbout1(io,0,'objmax              ',
+     *                           fM,adummy,1,1)
+        if(ncnstr.eq.0) write(io,9909)
+        call sbout1(io,ncnstr,'constraints         ',dummy,g,2,1)
+        if(ncnstr.ne.0) write(io,9909)
+        goto 9000
+ 20   if(iprint.eq.1.and.nstop.eq.0) write(io,9900) iter
+      if(iprint.ge.2.and.nstop.eq.0.and.ipspan.ge.10) 
+     *  write(io,9900) iter
+      iter=iter+1
+      if(initvl.eq.0) 
+     *  call sbout1(io,nparam,'x                   ',dummy,x,2,1)
+      call sbout1(io,nob,'objectives          ',dummy,f,2,1)
+      if (mode.eq.1.and.iter.gt.1)
+     *  call sbout1(io,0,'objective max4      ',fM,adummy,1,1)
+      if(nob.gt.1) call sbout1(io,0,'objmax              ',
+     *                          fM,adummy,1,1)
+      if(ncnstr.eq.0) go to 110
+      call sbout1(io,ncnstr,'constraints         ',dummy,g,2,1)
+      SCV=0.d0
+      do 100 i=ncn+1,ncnstr
+        if(i.le.nnineq) SCV=SCV+dmax1(0.d0,g(i))
+        if(i.gt.nnineq) SCV=SCV+dabs(g(i))
+ 100  continue
+      if(initvl.eq.0)
+     *  call sbout1(io,0,'SCV                 ',SCV,adummy,1,1)
+ 110  continue
+      if(iter.le.1) write(io,9909)
+      if(iter.le.1.and.ipspan.lt.10) write(io,9900) iter
+      if(iter.le.1) goto 9000
+      if(iprint.ge.2.and.initvl.eq.0)
+     *  call sbout1(io,0,'step                ',steps,adummy,1,1)
+      if(initvl.eq.0.and.(nstop.eq.0.or.info.ne.0.or.iprint.eq.2)) then
+        call sbout1(io,0,'d0norm              ',d0norm,adummy,1,1)
+        call sbout1(io,0,'ktnorm              ',sktnom,adummy,1,1)
+      endif
+      if(initvl.eq.0.and.feasb) write(io,9902) ncallf
+      if(initvl.eq.0.and.(nn.ne.0.or..not.feasb)) write(io,9903) ncallg
+      if(nstop.ne.0) write(io,9909)
+      if(nstop.ne.0.and.iter.le.miter.and.ipspan.lt.10) 
+     *  write(io,9900) iter
+ 120  if(nstop.ne.0.or.iprint.eq.0) goto 9000
+      write(io,9909)
+      write(io,9901) info
+      if(info.eq.0) write(io,9904)
+      if(info.eq.0.and.sktnom.gt.0.1d0) write(io,9910)
+      if(info.eq.3) write(io,9905)
+      if(info.eq.4) write(io,9906)
+      if(info.eq.5) write(io,9907)
+      if(info.eq.6) write(io,9908)
+      write(io,9909)
+ 9000 initvl=0
+      if(ipspan.ge.10) ipyes=mod(iter,ipspan)
+      if(iter.le.miter) return
+        nstop=0
+        info=3
+        write(io,9905)
+      return
+ 9900 format(1x,9hiteration,t22,i22)
+ 9901 format(1x,6hinform,t22,i22)
+ 9902 format(1x,6hncallf,t22,i22)
+ 9903 format(1x,6hncallg,t22,i22)
+ 9904 format(1x,'Normal termination: You have obtained a solution !!')
+ 9905 format(1x,'Error : Maximum iterations have been reached ',
+     *          'before obtaining a solution !!'/)
+ 9906 format(1x,'Error : Step size has been smaller than ',
+     *          'the computed machine precision !!'/)
+ 9907 format(1x,'Error : Failure of the QP solver ',
+     *          'in constructing d0 !!',
+     *      /1x,'        A more robust QP solver may succeed.'/)
+ 9908 format(1x,'Error : Failure of the QP solver ',
+     *          'in constructing d1 !!',
+     *      /1x,'        A more robust QP solver may succeed.'/)
+ 9909 format(1x,/)
+ 9910 format(1x,'Warning: Norm of Kuhn-Tucker vector is large !!'/)
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/ql0001.f
@@ -0,0 +1,226 @@
+      SUBROUTINE QL0001(M,ME,MMAX,N,NMAX,MNN,C,D,A,B,XL,XU,
+     1           X,U,IOUT,IFAIL,IPRINT,WAR,LWAR,IWAR,LIWAR)
+c
+cCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+c
+c                     !!!! NOTICE !!!!
+c
+c 1. The routines contained in this file are due to Prof. K.Schittkowski
+c    of the University of Bayreuth, Germany (modification of routines
+c    due to Prof. MJD Powell at the University of Cambridge).  They can
+c    be freely distributed.
+c
+c 2. A minor modification was performed at the University of Maryland. 
+c    It is marked in the code by "c umd".
+c
+c                                      A.L. Tits and J.L. Zhou
+c                                      University of Maryland
+C
+C***********************************************************************
+C
+C
+C             SOLUTION OF QUADRATIC PROGRAMMING PROBLEMS
+C
+C
+C
+C   QL0001 SOLVES THE QUADRATIC PROGRAMMING PROBLEM
+C
+C   MINIMIZE        .5*X'*C*X + D'*X
+C   SUBJECT TO      A(J)*X  +  B(J)   =  0  ,  J=1,...,ME
+C                   A(J)*X  +  B(J)  >=  0  ,  J=ME+1,...,M
+C                   XL  <=  X  <=  XU
+C   
+C   HERE C MUST BE AN N BY N SYMMETRIC AND POSITIVE MATRIX, D AN N-DIMENSIONAL
+C   VECTOR, A AN M BY N MATRIX AND B AN M-DIMENSIONAL VECTOR. THE ABOVE 
+C   SITUATION IS INDICATED BY IWAR(1)=1. ALTERNATIVELY, I.E. IF IWAR(1)=0,
+C   THE OBJECTIVE FUNCTION MATRIX CAN ALSO BE PROVIDED IN FACTORIZED FORM.
+C   IN THIS CASE, C IS AN UPPER TRIANGULAR MATRIX.
+C
+C   THE SUBROUTINE REORGANIZES SOME DATA SO THAT THE PROBLEM CAN BE SOLVED
+C   BY A MODIFICATION OF AN ALGORITHM PROPOSED BY POWELL (1983).
+C
+C
+C   USAGE:
+C
+C      QL0001(M,ME,MMAX,N,NMAX,MNN,C,D,A,B,XL,XU,X,U,IOUT,IFAIL,IPRINT,
+C             WAR,LWAR,IWAR,LIWAR)
+C
+C
+C   DEFINITION OF THE PARAMETERS:
+C
+C   M :        TOTAL NUMBER OF CONSTRAINTS.
+C   ME :       NUMBER OF EQUALITY CONSTRAINTS.
+C   MMAX :     ROW DIMENSION OF A. MMAX MUST BE AT LEAST ONE AND GREATER
+C              THAN M.
+C   N :        NUMBER OF VARIABLES.
+C   NMAX :     ROW DIMENSION OF C. NMAX MUST BE GREATER OR EQUAL TO N.
+C   MNN :      MUST BE EQUAL TO M + N + N.
+C   C(NMAX,NMAX): OBJECTIVE FUNCTION MATRIX WHICH SHOULD BE SYMMETRIC AND
+C              POSITIVE DEFINITE. IF IWAR(1) = 0, C IS SUPPOSED TO BE THE
+C              CHOLESKEY-FACTOR OF ANOTHER MATRIX, I.E. C IS UPPER
+C              TRIANGULAR.
+C   D(NMAX) :  CONTAINS THE CONSTANT VECTOR OF THE OBJECTIVE FUNCTION.
+C   A(MMAX,NMAX): CONTAINS THE DATA MATRIX OF THE LINEAR CONSTRAINTS.
+C   B(MMAX) :  CONTAINS THE CONSTANT DATA OF THE LINEAR CONSTRAINTS.
+C   XL(N),XU(N): CONTAIN THE LOWER AND UPPER BOUNDS FOR THE VARIABLES.
+C   X(N) :     ON RETURN, X CONTAINS THE OPTIMAL SOLUTION VECTOR.
+C   U(MNN) :   ON RETURN, U CONTAINS THE LAGRANGE MULTIPLIERS. THE FIRST
+C              M POSITIONS ARE RESERVED FOR THE MULTIPLIERS OF THE M
+C              LINEAR CONSTRAINTS AND THE SUBSEQUENT ONES FOR THE 
+C              MULTIPLIERS OF THE LOWER AND UPPER BOUNDS. ON SUCCESSFUL
+C              TERMINATION, ALL VALUES OF U WITH RESPECT TO INEQUALITIES 
+C              AND BOUNDS SHOULD BE GREATER OR EQUAL TO ZERO.
+C   IOUT :     INTEGER INDICATING THE DESIRED OUTPUT UNIT NUMBER, I.E.
+C              ALL WRITE-STATEMENTS START WITH 'WRITE(IOUT,... '.
+C   IFAIL :    SHOWS THE TERMINATION REASON.
+C      IFAIL = 0 :   SUCCESSFUL RETURN.
+C      IFAIL = 1 :   TOO MANY ITERATIONS (MORE THAN 40*(N+M)).
+C      IFAIL = 2 :   ACCURACY INSUFFICIENT TO SATISFY CONVERGENCE
+C                    CRITERION.
+C      IFAIL = 5 :   LENGTH OF A WORKING ARRAY IS TOO SHORT.
+C      IFAIL > 10 :  THE CONSTRAINTS ARE INCONSISTENT.
+C   IPRINT :   OUTPUT CONTROL.
+C      IPRINT = 0 :  NO OUTPUT OF QL0001.
+C      IPRINT > 0 :  BRIEF OUTPUT IN ERROR CASES.
+C   WAR(LWAR) : REAL WORKING ARRAY. THE LENGTH LWAR SHOULD BE GRATER THAN
+C               NMAX*(3*NMAX+15)/2 + 2*M.
+C   IWAR(LIWAR): INTEGER WORKING ARRAY. THE LENGTH LIWAR SHOULD BE AT
+C              LEAST N.
+C              IF IWAR(1)=0 INITIALLY, THEN THE CHOLESKY DECOMPOSITION
+C              WHICH IS REQUIRED BY THE DUAL ALGORITHM TO GET THE FIRST
+C              UNCONSTRAINED MINIMUM OF THE OBJECTIVE FUNCTION, IS
+C              PERFORMED INTERNALLY. OTHERWISE, I.E. IF IWAR(1)=1, THEN
+C              IT IS ASSUMED THAT THE USER PROVIDES THE INITIAL FAC-
+C              TORIZATION BY HIMSELF AND STORES IT IN THE UPPER TRIAN-
+C              GULAR PART OF THE ARRAY C.
+C
+C   A NAMED COMMON-BLOCK  /CMACHE/EPS   MUST BE PROVIDED BY THE USER,
+C   WHERE EPS DEFINES A GUESS FOR THE UNDERLYING MACHINE PRECISION.
+C
+C
+C   AUTHOR:    K. SCHITTKOWSKI,
+C              MATHEMATISCHES INSTITUT,
+C              UNIVERSITAET BAYREUTH,
+C              8580 BAYREUTH,
+C              GERMANY, F.R.
+C
+C
+C   VERSION:   1.4  (MARCH, 1987)  
+C
+C
+C*********************************************************************
+C
+C
+      INTEGER NMAX,MMAX,N,MNN,LWAR,LIWAR
+      DIMENSION C(NMAX,NMAX),D(NMAX),A(MMAX,NMAX),B(MMAX),
+     1      XL(N),XU(N),X(N),U(MNN),WAR(LWAR),IWAR(LIWAR)
+      DOUBLE PRECISION C,D,A,B,X,XL,XU,U,WAR,DIAG,ZERO,
+     1      EPS,QPEPS,TEN
+      INTEGER M,ME,IOUT,IFAIL,IPRINT,IWAR,INW1,INW2,IN,J,LW,MN,I,         
+     1      IDIAG,INFO,NACT,MAXIT
+      LOGICAL LQL
+C
+C     INTRINSIC FUNCTIONS:  DSQRT
+C
+      COMMON /CMACHE/EPS
+C
+C     CONSTANT DATA
+C
+c#################################################################
+c
+
+      if(c(nmax,nmax).eq.0.d0) c(nmax,nmax)=eps
+c
+c umd
+c  This prevents a subsequent more major modification of the Hessian
+c  matrix in the important case when a minmax problem (yielding a 
+c  singular Hessian matrix) is being solved.
+c                                 ----UMCP, April 1991, Jian L. Zhou
+c#################################################################
+c
+      LQL=.FALSE.
+      IF (IWAR(1).EQ.1) LQL=.TRUE.
+      ZERO=0.0D+0
+      TEN=1.D+1
+      MAXIT=40*(M+N)
+      QPEPS=EPS
+      INW1=1
+      INW2=INW1+M
+C
+C     PREPARE PROBLEM DATA FOR EXECUTION
+C
+      IF (M.LE.0) GOTO 20
+      IN=INW1
+      DO 10 J=1,M
+      WAR(IN)=-B(J)
+   10 IN=IN+1
+   20 LW=NMAX*(3*NMAX+15)/2 + M
+      IF (INW2+LW-1 .GT. LWAR) GOTO 80
+      IF (LIWAR.LT.N) GOTO 81
+      IF (MNN.LT.M+N+N) GOTO 82
+      MN=M+N
+C
+C     CALL OF QL0002
+C
+      CALL QL0002(N,M,ME,MMAX,MN,MNN,NMAX,LQL,A,WAR(INW1),
+     1    D,C,XL,XU,X,NACT,IWAR,MAXIT,QPEPS,INFO,DIAG,
+     2    WAR(INW2),LW)
+C
+C     TEST OF MATRIX CORRECTIONS
+C
+      IFAIL=0
+      IF (INFO.EQ.1) GOTO 40
+      IF (INFO.EQ.2) GOTO 90
+      IDIAG=0
+      IF ((DIAG.GT.ZERO).AND.(DIAG.LT.1000.0)) IDIAG=DIAG
+      IF ((IPRINT.GT.0).AND.(IDIAG.GT.0))
+     1   WRITE(IOUT,1000) IDIAG
+      IF (INFO .LT. 0) GOTO  70
+C
+C     REORDER MULTIPLIER
+C
+      DO  50 J=1,MNN
+   50 U(J)=ZERO
+      IN=INW2-1
+      IF (NACT.EQ.0) GOTO 30
+      DO  60 I=1,NACT
+      J=IWAR(I)
+      U(J)=WAR(IN+I)
+   60 CONTINUE
+   30 CONTINUE
+      RETURN
+C
+C     ERROR MESSAGES
+C
+   70 IFAIL=-INFO+10
+      IF ((IPRINT.GT.0).AND.(NACT.GT.0))
+     1     WRITE(IOUT,1100) -INFO,(IWAR(I),I=1,NACT)
+      RETURN
+   80 IFAIL=5
+      IF (IPRINT .GT. 0) WRITE(IOUT,1200)
+      RETURN
+   81 IFAIL=5
+      IF (IPRINT .GT. 0) WRITE(IOUT,1210)
+      RETURN
+   82 IFAIL=5
+      IF (IPRINT .GT. 0) WRITE(IOUT,1220)
+      RETURN
+   40 IFAIL=1
+      IF (IPRINT.GT.0) WRITE(IOUT,1300) MAXIT
+      RETURN
+   90 IFAIL=2
+      IF (IPRINT.GT.0) WRITE(IOUT,1400) 
+      RETURN
+C
+C     FORMAT-INSTRUCTIONS
+C
+ 1000 FORMAT(/8X,28H***QL: MATRIX G WAS ENLARGED,I3,
+     1        20H-TIMES BY UNITMATRIX)
+ 1100 FORMAT(/8X,18H***QL: CONSTRAINT ,I5,
+     1        19H NOT CONSISTENT TO ,/,(10X,10I5))
+ 1200 FORMAT(/8X,21H***QL: LWAR TOO SMALL)
+ 1210 FORMAT(/8X,22H***QL: LIWAR TOO SMALL)
+ 1220 FORMAT(/8X,20H***QL: MNN TOO SMALL)
+ 1300 FORMAT(/8X,37H***QL: TOO MANY ITERATIONS (MORE THAN,I6,1H))
+ 1400 FORMAT(/8X,50H***QL: ACCURACY INSUFFICIENT TO ATTAIN CONVERGENCE) 
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/ql0002.f
@@ -0,0 +1,941 @@
+C
+      SUBROUTINE QL0002(N,M,MEQ,MMAX,MN,MNN,NMAX,LQL,A,B,GRAD,G,
+     1      XL,XU,X,NACT,IACT,MAXIT,VSMALL,INFO,DIAG,W,LW)
+C
+C**************************************************************************
+C
+C
+C   THIS SUBROUTINE SOLVES THE QUADRATIC PROGRAMMING PROBLEM 
+C
+C       MINIMIZE      GRAD'*X  +  0.5 * X*G*X
+C       SUBJECT TO    A(K)*X  =  B(K)   K=1,2,...,MEQ,
+C                     A(K)*X >=  B(K)   K=MEQ+1,...,M,
+C                     XL  <=  X  <=  XU
+C
+C   THE QUADRATIC PROGRAMMING METHOD PROCEEDS FROM AN INITIAL CHOLESKY-
+C   DECOMPOSITION OF THE OBJECTIVE FUNCTION MATRIX, TO CALCULATE THE
+C   UNIQUELY DETERMINED MINIMIZER OF THE UNCONSTRAINED PROBLEM. 
+C   SUCCESSIVELY ALL VIOLATED CONSTRAINTS ARE ADDED TO A WORKING SET 
+C   AND A MINIMIZER OF THE OBJECTIVE FUNCTION SUBJECT TO ALL CONSTRAINTS 
+C   IN THIS WORKING SET IS COMPUTED. IT IS POSSIBLE THAT CONSTRAINTS
+C   HAVE TO LEAVE THE WORKING SET.
+C
+C
+C   DESCRIPTION OF PARAMETERS:    
+C
+C     N        : IS THE NUMBER OF VARIABLES.
+C     M        : TOTAL NUMBER OF CONSTRAINTS.
+C     MEQ      : NUMBER OF EQUALITY CONTRAINTS.
+C     MMAX     : ROW DIMENSION OF A, DIMENSION OF B. MMAX MUST BE AT
+C                LEAST ONE AND GREATER OR EQUAL TO M.
+C     MN       : MUST BE EQUAL M + N.
+C     MNN      : MUST BE EQUAL M + N + N.
+C     NMAX     : ROW DIEMSION OF G. MUST BE AT LEAST N.
+C     LQL      : DETERMINES INITIAL DECOMPOSITION.
+C        LQL = .FALSE.  : THE UPPER TRIANGULAR PART OF THE MATRIX G
+C                         CONTAINS INITIALLY THE CHOLESKY-FACTOR OF A SUITABLE 
+C                         DECOMPOSITION.
+C        LQL = .TRUE.   : THE INITIAL CHOLESKY-FACTORISATION OF G IS TO BE
+C                         PERFORMED BY THE ALGORITHM.
+C     A(MMAX,NMAX) : A IS A MATRIX WHOSE COLUMNS ARE THE CONSTRAINTS NORMALS.
+C     B(MMAX)  : CONTAINS THE RIGHT HAND SIDES OF THE CONSTRAINTS.
+C     GRAD(N)  : CONTAINS THE OBJECTIVE FUNCTION VECTOR GRAD.
+C     G(NMAX,N): CONTAINS THE SYMMETRIC OBJECTIVE FUNCTION MATRIX.
+C     XL(N), XU(N): CONTAIN THE LOWER AND UPPER BOUNDS FOR X.
+C     X(N)     : VECTOR OF VARIABLES.
+C     NACT     : FINAL NUMBER OF ACTIVE CONSTRAINTS.
+C     IACT(K) (K=1,2,...,NACT): INDICES OF THE FINAL ACTIVE CONSTRAINTS.
+C     INFO     : REASON FOR THE RETURN FROM THE SUBROUTINE.
+C         INFO = 0 : CALCULATION WAS TERMINATED SUCCESSFULLY.
+C         INFO = 1 : MAXIMUM NUMBER OF ITERATIONS ATTAINED.
+C         INFO = 2 : ACCURACY IS INSUFFICIENT TO MAINTAIN INCREASING
+C                    FUNCTION VALUES.
+C         INFO < 0 : THE CONSTRAINT WITH INDEX ABS(INFO) AND THE CON-
+C                    STRAINTS WHOSE INDICES ARE IACT(K), K=1,2,...,NACT,
+C                    ARE INCONSISTENT.
+C     MAXIT    : MAXIMUM NUMBER OF ITERATIONS.
+C     VSMALL   : REQUIRED ACCURACY TO BE ACHIEVED (E.G. IN THE ORDER OF THE 
+C                MACHINE PRECISION FOR SMALL AND WELL-CONDITIONED PROBLEMS).
+C     DIAG     : ON RETURN DIAG IS EQUAL TO THE MULTIPLE OF THE UNIT MATRIX
+C                THAT WAS ADDED TO G TO ACHIEVE POSITIVE DEFINITENESS.
+C     W(LW)    : THE ELEMENTS OF W(.) ARE USED FOR WORKING SPACE. THE LENGTH
+C                OF W MUST NOT BE LESS THAN (1.5*NMAX*NMAX + 10*NMAX + M).
+C                WHEN INFO = 0 ON RETURN, THE LAGRANGE MULTIPLIERS OF THE
+C                FINAL ACTIVE CONSTRAINTS ARE HELD IN W(K), K=1,2,...,NACT.
+C   THE VALUES OF N, M, MEQ, MMAX, MN, MNN AND NMAX AND THE ELEMENTS OF
+C   A, B, GRAD AND G ARE NOT ALTERED.
+C
+C   THE FOLLOWING INTEGERS ARE USED TO PARTITION W:
+C     THE FIRST N ELEMENTS OF W HOLD LAGRANGE MULTIPLIER ESTIMATES.
+C     W(IWZ+I+(N-1)*J) HOLDS THE MATRIX ELEMENT Z(I,J).
+C     W(IWR+I+0.5*J*(J-1)) HOLDS THE UPPER TRIANGULAR MATRIX
+C       ELEMENT R(I,J). THE SUBSEQUENT N COMPONENTS OF W MAY BE
+C       TREATED AS AN EXTRA COLUMN OF R(.,.).
+C     W(IWW-N+I) (I=1,2,...,N) ARE USED FOR TEMPORARY STORAGE.
+C     W(IWW+I) (I=1,2,...,N) ARE USED FOR TEMPORARY STORAGE.
+C     W(IWD+I) (I=1,2,...,N) HOLDS G(I,I) DURING THE CALCULATION.
+C     W(IWX+I) (I=1,2,...,N) HOLDS VARIABLES THAT WILL BE USED TO
+C       TEST THAT THE ITERATIONS INCREASE THE OBJECTIVE FUNCTION.
+C     W(IWA+K) (K=1,2,...,M) USUALLY HOLDS THE RECIPROCAL OF THE
+C       LENGTH OF THE K-TH CONSTRAINT, BUT ITS SIGN INDICATES
+C       WHETHER THE CONSTRAINT IS ACTIVE.
+C
+C   
+C   AUTHOR:    K. SCHITTKOWSKI,
+C              MATHEMATISCHES INSTITUT,
+C              UNIVERSITAET BAYREUTH,
+C              8580 BAYREUTH,
+C              GERMANY, F.R.
+C
+C   AUTHOR OF ORIGINAL VERSION:
+C              M.J.D. POWELL, DAMTP,
+C              UNIVERSITY OF CAMBRIDGE, SILVER STREET
+C              CAMBRIDGE,
+C              ENGLAND
+C
+C
+C   REFERENCE: M.J.D. POWELL: ZQPCVX, A FORTRAN SUBROUTINE FOR CONVEX
+C              PROGRAMMING, REPORT DAMTP/1983/NA17, UNIVERSITY OF
+C              CAMBRIDGE, ENGLAND, 1983.
+C
+C
+C   VERSION :  2.0 (MARCH, 1987)
+C
+C
+C*************************************************************************
+C
+      INTEGER MMAX,NMAX,N,LW
+      DIMENSION A(MMAX,NMAX),B(MMAX),GRAD(N),G(NMAX,N),X(N),IACT(N),
+     1      W(LW),XL(N),XU(N)
+      INTEGER M,MEQ,MN,MNN,NACT,IACT,INFO,MAXIT
+      DOUBLE PRECISION CVMAX,DIAG,DIAGR,FDIFF,FDIFFA,GA,GB,PARINC,PARNEW       
+     1      ,RATIO,RES,STEP,SUM,SUMX,SUMY,SUMA,SUMB,SUMC,TEMP,TEMPA,
+     2       VSMALL,XMAG,XMAGR,ZERO,ONE,TWO,ONHA,VFACT
+      DOUBLE PRECISION A,B,G,GRAD,W,X,XL,XU
+C
+C   INTRINSIC FUNCTIONS:   DMAX1,DSQRT,DABS,DMIN1
+C
+      INTEGER IWZ,IWR,IWW,IWD,IWA,IFINC,KFINC,K,I,IA,ID,II,IR,IRA,
+     1     IRB,J,NM,IZ,IZA,ITERC,ITREF,JFINC,IFLAG,IWS,IS,K1,IW,KK,IP,
+     2     IPP,IL,IU,JU,KFLAG,LFLAG,JFLAG,KDROP,NU,MFLAG,KNEXT,IX,IWX,
+     3     IWY,IY,JL
+      LOGICAL LQL,LOWER
+C
+C   INITIAL ADDRESSES
+C
+      IWZ=NMAX
+      IWR=IWZ+NMAX*NMAX
+      IWW=IWR+(NMAX*(NMAX+3))/2
+      IWD=IWW+NMAX
+      IWX=IWD+NMAX
+      IWA=IWX+NMAX
+C
+C     SET SOME CONSTANTS.
+C
+      ZERO=0.D+0
+      ONE=1.D+0
+      TWO=2.D+0
+      ONHA=1.5D+0
+      VFACT=1.D+0
+C
+C     SET SOME PARAMETERS.
+C     NUMBER LESS THAN VSMALL ARE ASSUMED TO BE NEGLIGIBLE.
+C     THE MULTIPLE OF I THAT IS ADDED TO G IS AT MOST DIAGR TIMES
+C       THE LEAST MULTIPLE OF I THAT GIVES POSITIVE DEFINITENESS.
+C     X IS RE-INITIALISED IF ITS MAGNITUDE IS REDUCED BY THE
+C       FACTOR XMAGR.
+C     A CHECK IS MADE FOR AN INCREASE IN F EVERY IFINC ITERATIONS,
+C       AFTER KFINC ITERATIONS ARE COMPLETED.
+C
+      DIAGR=TWO
+      XMAGR=1.0D-2
+      IFINC=3
+      KFINC=MAX0(10,N)
+C
+C     FIND THE RECIPROCALS OF THE LENGTHS OF THE CONSTRAINT NORMALS.
+C     RETURN IF A CONSTRAINT IS INFEASIBLE DUE TO A ZERO NORMAL.
+C
+      NACT=0
+      IF (M .LE. 0) GOTO 45
+      DO 40 K=1,M
+      SUM=ZERO
+      DO 10 I=1,N
+   10 SUM=SUM+A(K,I)**2
+      IF (SUM .GT. ZERO) GOTO 20
+      IF (B(K) .EQ. ZERO) GOTO 30
+      INFO=-K
+      IF (K .LE. MEQ) GOTO 730
+      IF (B(K)) 30,30,730
+   20 SUM=ONE/DSQRT(SUM)
+   30 IA=IWA+K
+   40 W(IA)=SUM
+   45 DO 50 K=1,N
+      IA=IWA+M+K
+   50 W(IA)=ONE
+C
+C     IF NECESSARY INCREASE THE DIAGONAL ELEMENTS OF G.
+C
+      IF (.NOT. LQL) GOTO 165
+      DIAG=ZERO
+      DO 60 I=1,N
+      ID=IWD+I
+      W(ID)=G(I,I)
+      DIAG=DMAX1(DIAG,VSMALL-W(ID))
+      IF (I .EQ. N) GOTO 60
+      II=I+1
+      DO 55 J=II,N
+      GA=-DMIN1(W(ID),G(J,J))
+      GB=DABS(W(ID)-G(J,J))+DABS(G(I,J))
+      IF (GB .GT. ZERO) GA=GA+G(I,J)**2/GB
+   55 DIAG=DMAX1(DIAG,GA)
+   60 CONTINUE
+      IF (DIAG .LE. ZERO) GOTO 90
+   70 DIAG=DIAGR*DIAG
+      DO 80 I=1,N
+      ID=IWD+I
+   80 G(I,I)=DIAG+W(ID)
+C
+C     FORM THE CHOLESKY FACTORISATION OF G. THE TRANSPOSE
+C     OF THE FACTOR WILL BE PLACED IN THE R-PARTITION OF W.
+C
+   90 IR=IWR
+      DO 130 J=1,N
+      IRA=IWR
+      IRB=IR+1
+      DO 120 I=1,J
+      TEMP=G(I,J)
+      IF (I .EQ. 1) GOTO 110
+      DO 100 K=IRB,IR
+      IRA=IRA+1
+  100 TEMP=TEMP-W(K)*W(IRA)
+  110 IR=IR+1
+      IRA=IRA+1
+      IF (I .LT. J) W(IR)=TEMP/W(IRA)
+  120 CONTINUE
+      IF (TEMP .LT. VSMALL) GOTO 140
+  130 W(IR)=DSQRT(TEMP)
+      GOTO 170
+C
+C     INCREASE FURTHER THE DIAGONAL ELEMENT OF G.
+C
+  140 W(J)=ONE
+      SUMX=ONE
+      K=J
+  150 SUM=ZERO
+      IRA=IR-1
+      DO 160 I=K,J
+      SUM=SUM-W(IRA)*W(I)
+  160 IRA=IRA+I
+      IR=IR-K
+      K=K-1
+      W(K)=SUM/W(IR)
+      SUMX=SUMX+W(K)**2
+      IF (K .GE. 2) GOTO 150
+      DIAG=DIAG+VSMALL-TEMP/SUMX
+      GOTO 70
+C
+C     STORE THE CHOLESKY FACTORISATION IN THE R-PARTITION
+C     OF W.
+C
+  165 IR=IWR
+      DO 166 I=1,N
+      DO 166 J=1,I
+      IR=IR+1
+  166 W(IR)=G(J,I)
+C
+C     SET Z THE INVERSE OF THE MATRIX IN R.
+C
+  170 NM=N-1
+      DO 220 I=1,N
+      IZ=IWZ+I
+      IF (I .EQ. 1) GOTO 190
+      DO 180 J=2,I
+      W(IZ)=ZERO
+  180 IZ=IZ+N
+  190 IR=IWR+(I+I*I)/2
+      W(IZ)=ONE/W(IR)
+      IF (I .EQ. N) GOTO 220
+      IZA=IZ
+      DO 210 J=I,NM
+      IR=IR+I
+      SUM=ZERO
+      DO 200 K=IZA,IZ,N
+      SUM=SUM+W(K)*W(IR)
+  200 IR=IR+1
+      IZ=IZ+N
+  210 W(IZ)=-SUM/W(IR)
+  220 CONTINUE
+C
+C     SET THE INITIAL VALUES OF SOME VARIABLES.
+C     ITERC COUNTS THE NUMBER OF ITERATIONS.
+C     ITREF IS SET TO ONE WHEN ITERATIVE REFINEMENT IS REQUIRED.
+C     JFINC INDICATES WHEN TO TEST FOR AN INCREASE IN F.
+C
+      ITERC=1
+      ITREF=0
+      JFINC=-KFINC
+C
+C     SET X TO ZERO AND SET THE CORRESPONDING RESIDUALS OF THE
+C     KUHN-TUCKER CONDITIONS.
+C
+  230 IFLAG=1
+      IWS=IWW-N
+      DO 240 I=1,N
+      X(I)=ZERO
+      IW=IWW+I
+      W(IW)=GRAD(I)
+      IF (I .GT. NACT) GOTO 240
+      W(I)=ZERO
+      IS=IWS+I
+      K=IACT(I)
+      IF (K .LE. M) GOTO 235
+      IF (K .GT. MN) GOTO 234
+      K1=K-M
+      W(IS)=XL(K1)
+      GOTO 240
+  234 K1=K-MN
+      W(IS)=-XU(K1)
+      GOTO 240
+  235 W(IS)=B(K)
+  240 CONTINUE
+      XMAG=ZERO
+      VFACT=1.D+0
+      IF (NACT) 340,340,280
+C
+C     SET THE RESIDUALS OF THE KUHN-TUCKER CONDITIONS FOR GENERAL X.
+C
+  250 IFLAG=2
+      IWS=IWW-N
+      DO 260 I=1,N
+      IW=IWW+I
+      W(IW)=GRAD(I)
+      IF (LQL) GOTO 259
+      ID=IWD+I
+      W(ID)=ZERO
+      DO 251 J=I,N
+  251 W(ID)=W(ID)+G(I,J)*X(J)
+      DO 252 J=1,I
+      ID=IWD+J
+  252 W(IW)=W(IW)+G(J,I)*W(ID)
+      GOTO 260
+  259 DO 261 J=1,N
+  261 W(IW)=W(IW)+G(I,J)*X(J)
+  260 CONTINUE
+      IF (NACT .EQ. 0) GOTO 340
+      DO 270 K=1,NACT
+      KK=IACT(K)
+      IS=IWS+K
+      IF (KK .GT. M) GOTO 265
+      W(IS)=B(KK)
+      DO 264 I=1,N
+      IW=IWW+I
+      W(IW)=W(IW)-W(K)*A(KK,I)
+  264 W(IS)=W(IS)-X(I)*A(KK,I)
+      GOTO 270
+  265 IF (KK .GT. MN) GOTO 266
+      K1=KK-M
+      IW=IWW+K1
+      W(IW)=W(IW)-W(K)
+      W(IS)=XL(K1)-X(K1)
+      GOTO 270
+  266 K1=KK-MN
+      IW=IWW+K1
+      W(IW)=W(IW)+W(K)
+      W(IS)=-XU(K1)+X(K1)
+  270 CONTINUE
+C
+C     PRE-MULTIPLY THE VECTOR IN THE S-PARTITION OF W BY THE
+C     INVERS OF R TRANSPOSE.
+C
+  280 IR=IWR
+      IP=IWW+1
+      IPP=IWW+N
+      IL=IWS+1
+      IU=IWS+NACT
+      DO 310 I=IL,IU
+      SUM=ZERO
+      IF (I .EQ. IL) GOTO 300
+      JU=I-1
+      DO 290 J=IL,JU
+      IR=IR+1
+  290 SUM=SUM+W(IR)*W(J)
+  300 IR=IR+1
+  310 W(I)=(W(I)-SUM)/W(IR)
+C
+C     SHIFT X TO SATISFY THE ACTIVE CONSTRAINTS AND MAKE THE
+C     CORRESPONDING CHANGE TO THE GRADIENT RESIDUALS.
+C
+      DO 330 I=1,N
+      IZ=IWZ+I
+      SUM=ZERO
+      DO 320 J=IL,IU
+      SUM=SUM+W(J)*W(IZ)
+  320 IZ=IZ+N
+      X(I)=X(I)+SUM
+      IF (LQL) GOTO 329
+      ID=IWD+I
+      W(ID)=ZERO
+      DO 321 J=I,N
+  321 W(ID)=W(ID)+G(I,J)*SUM
+      IW=IWW+I
+      DO 322 J=1,I
+      ID=IWD+J
+  322 W(IW)=W(IW)+G(J,I)*W(ID)
+      GOTO 330
+  329 DO 331 J=1,N
+      IW=IWW+J
+  331 W(IW)=W(IW)+SUM*G(I,J)
+  330 CONTINUE
+C
+C     FORM THE SCALAR PRODUCT OF THE CURRENT GRADIENT RESIDUALS
+C     WITH EACH COLUMN OF Z.
+C
+  340 KFLAG=1
+      GOTO 930
+  350 IF (NACT .EQ. N) GOTO 380
+C
+C     SHIFT X SO THAT IT SATISFIES THE REMAINING KUHN-TUCKER
+C     CONDITIONS.
+C
+      IL=IWS+NACT+1
+      IZA=IWZ+NACT*N
+      DO 370 I=1,N
+      SUM=ZERO
+      IZ=IZA+I
+      DO 360 J=IL,IWW
+      SUM=SUM+W(IZ)*W(J)
+  360 IZ=IZ+N
+  370 X(I)=X(I)-SUM
+      INFO=0
+      IF (NACT .EQ. 0) GOTO 410
+C
+C     UPDATE THE LAGRANGE MULTIPLIERS.
+C
+  380 LFLAG=3
+      GOTO 740
+  390 DO 400 K=1,NACT
+      IW=IWW+K
+  400 W(K)=W(K)+W(IW)
+C
+C     REVISE THE VALUES OF XMAG.
+C     BRANCH IF ITERATIVE REFINEMENT IS REQUIRED.
+C
+  410 JFLAG=1
+      GOTO 910
+  420 IF (IFLAG .EQ. ITREF) GOTO 250
+C
+C     DELETE A CONSTRAINT IF A LAGRANGE MULTIPLIER OF AN
+C     INEQUALITY CONSTRAINT IS NEGATIVE.
+C
+      KDROP=0
+      GOTO 440
+  430 KDROP=KDROP+1
+      IF (W(KDROP) .GE. ZERO) GOTO 440
+      IF (IACT(KDROP) .LE. MEQ) GOTO 440
+      NU=NACT
+      MFLAG=1
+      GOTO 800
+  440 IF (KDROP .LT. NACT) GOTO 430
+C
+C     SEEK THE GREATEAST NORMALISED CONSTRAINT VIOLATION, DISREGARDING
+C     ANY THAT MAY BE DUE TO COMPUTER ROUNDING ERRORS.
+C
+  450 CVMAX=ZERO
+      IF (M .LE. 0) GOTO 481
+      DO 480 K=1,M
+      IA=IWA+K
+      IF (W(IA) .LE. ZERO) GOTO 480
+      SUM=-B(K)
+      DO 460 I=1,N
+  460 SUM=SUM+X(I)*A(K,I)
+      SUMX=-SUM*W(IA)
+      IF (K .LE. MEQ) SUMX=DABS(SUMX)
+      IF (SUMX .LE. CVMAX) GOTO 480
+      TEMP=DABS(B(K))
+      DO 470 I=1,N
+  470 TEMP=TEMP+DABS(X(I)*A(K,I))
+      TEMPA=TEMP+DABS(SUM)
+      IF (TEMPA .LE. TEMP) GOTO 480
+      TEMP=TEMP+ONHA*DABS(SUM)
+      IF (TEMP .LE. TEMPA) GOTO 480
+      CVMAX=SUMX
+      RES=SUM
+      KNEXT=K
+  480 CONTINUE
+  481 DO 485 K=1,N
+      LOWER=.TRUE.
+      IA=IWA+M+K
+      IF (W(IA) .LE. ZERO) GOTO 485
+      SUM=XL(K)-X(K)
+      IF (SUM) 482,485,483
+  482 SUM=X(K)-XU(K)
+      LOWER=.FALSE.
+  483 IF (SUM .LE. CVMAX) GOTO 485
+      CVMAX=SUM
+      RES=-SUM
+      KNEXT=K+M
+      IF (LOWER) GOTO 485
+      KNEXT=K+MN
+  485 CONTINUE
+C
+C     TEST FOR CONVERGENCE
+C
+      INFO=0
+      IF (CVMAX .LE. VSMALL) GOTO 700
+C
+C     RETURN IF, DUE TO ROUNDING ERRORS, THE ACTUAL CHANGE IN
+C     X MAY NOT INCREASE THE OBJECTIVE FUNCTION
+C
+      JFINC=JFINC+1
+      IF (JFINC .EQ. 0) GOTO 510
+      IF (JFINC .NE. IFINC) GOTO 530
+      FDIFF=ZERO
+      FDIFFA=ZERO
+      DO 500 I=1,N
+      SUM=TWO*GRAD(I)
+      SUMX=DABS(SUM)
+      IF (LQL) GOTO 489
+      ID=IWD+I
+      W(ID)=ZERO
+      DO 486 J=I,N
+      IX=IWX+J
+  486 W(ID)=W(ID)+G(I,J)*(W(IX)+X(J))
+      DO 487 J=1,I
+      ID=IWD+J
+      TEMP=G(J,I)*W(ID)
+      SUM=SUM+TEMP
+  487 SUMX=SUMX+DABS(TEMP)
+      GOTO 495
+  489 DO 490 J=1,N
+      IX=IWX+J
+      TEMP=G(I,J)*(W(IX)+X(J))
+      SUM=SUM+TEMP
+  490 SUMX=SUMX+DABS(TEMP)
+  495 IX=IWX+I
+      FDIFF=FDIFF+SUM*(X(I)-W(IX))
+  500 FDIFFA=FDIFFA+SUMX*DABS(X(I)-W(IX))
+      INFO=2
+      SUM=FDIFFA+FDIFF
+      IF (SUM .LE. FDIFFA) GOTO 700
+      TEMP=FDIFFA+ONHA*FDIFF
+      IF (TEMP .LE. SUM) GOTO 700
+      JFINC=0
+      INFO=0
+  510 DO 520 I=1,N
+      IX=IWX+I
+  520 W(IX)=X(I)
+C
+C     FORM THE SCALAR PRODUCT OF THE NEW CONSTRAINT NORMAL WITH EACH
+C     COLUMN OF Z. PARNEW WILL BECOME THE LAGRANGE MULTIPLIER OF
+C     THE NEW CONSTRAINT.
+C
+  530 ITERC=ITERC+1
+      IF (ITERC.LE.MAXIT) GOTO 531
+      INFO=1
+      GOTO 710
+  531 CONTINUE
+      IWS=IWR+(NACT+NACT*NACT)/2
+      IF (KNEXT .GT. M) GOTO 541
+      DO 540 I=1,N
+      IW=IWW+I
+  540 W(IW)=A(KNEXT,I)
+      GOTO 549
+  541 DO 542 I=1,N
+      IW=IWW+I
+  542 W(IW)=ZERO
+      K1=KNEXT-M
+      IF (K1 .GT. N) GOTO 545
+      IW=IWW+K1
+      W(IW)=ONE
+      IZ=IWZ+K1
+      DO 543 I=1,N
+      IS=IWS+I
+      W(IS)=W(IZ)
+  543 IZ=IZ+N
+      GOTO 550
+  545 K1=KNEXT-MN
+      IW=IWW+K1
+      W(IW)=-ONE
+      IZ=IWZ+K1
+      DO 546 I=1,N
+      IS=IWS+I
+      W(IS)=-W(IZ)
+  546 IZ=IZ+N
+      GOTO 550
+  549 KFLAG=2
+      GOTO 930
+  550 PARNEW=ZERO
+C
+C     APPLY GIVENS ROTATIONS TO MAKE THE LAST (N-NACT-2) SCALAR
+C     PRODUCTS EQUAL TO ZERO.
+C
+      IF (NACT .EQ. N) GOTO 570
+      NU=N
+      NFLAG=1
+      GOTO 860
+C
+C     BRANCH IF THERE IS NO NEED TO DELETE A CONSTRAINT.
+C
+  560 IS=IWS+NACT
+      IF (NACT .EQ. 0) GOTO 640
+      SUMA=ZERO
+      SUMB=ZERO
+      SUMC=ZERO
+      IZ=IWZ+NACT*N
+      DO 563 I=1,N
+      IZ=IZ+1
+      IW=IWW+I
+      SUMA=SUMA+W(IW)*W(IZ)
+      SUMB=SUMB+DABS(W(IW)*W(IZ))
+  563 SUMC=SUMC+W(IZ)**2
+      TEMP=SUMB+.1D+0*DABS(SUMA)
+      TEMPA=SUMB+.2D+0*DABS(SUMA)
+      IF (TEMP .LE. SUMB) GOTO 570
+      IF (TEMPA .LE. TEMP) GOTO 570
+      IF (SUMB .GT. VSMALL) GOTO 5
+      GOTO 570
+    5 SUMC=DSQRT(SUMC)
+      IA=IWA+KNEXT
+      IF (KNEXT .LE. M) SUMC=SUMC/W(IA)
+      TEMP=SUMC+.1D+0*DABS(SUMA)
+      TEMPA=SUMC+.2D+0*DABS(SUMA)
+      IF (TEMP .LE. SUMC) GOTO 567
+      IF (TEMPA .LE. TEMP) GOTO 567
+      GOTO 640
+C
+C     CALCULATE THE MULTIPLIERS FOR THE NEW CONSTRAINT NORMAL
+C     EXPRESSED IN TERMS OF THE ACTIVE CONSTRAINT NORMALS.
+C     THEN WORK OUT WHICH CONTRAINT TO DROP.
+C
+  567 LFLAG=4
+      GOTO 740
+  570 LFLAG=1
+      GOTO 740
+C
+C     COMPLETE THE TEST FOR LINEARLY DEPENDENT CONSTRAINTS.
+C
+  571 IF (KNEXT .GT. M) GOTO 574
+      DO 573 I=1,N
+      SUMA=A(KNEXT,I)
+      SUMB=DABS(SUMA)
+      IF (NACT.EQ.0) GOTO 581
+      DO 572 K=1,NACT
+      KK=IACT(K)
+      IF (KK.LE.M) GOTO 568
+      KK=KK-M
+      TEMP=ZERO
+      IF (KK.EQ.I) TEMP=W(IWW+KK)
+      KK=KK-N
+      IF (KK.EQ.I) TEMP=-W(IWW+KK)
+      GOTO 569
+  568 CONTINUE
+      IW=IWW+K
+      TEMP=W(IW)*A(KK,I)
+  569 CONTINUE
+      SUMA=SUMA-TEMP
+  572 SUMB=SUMB+DABS(TEMP)
+  581 IF (SUMA .LE. VSMALL) GOTO 573
+      TEMP=SUMB+.1D+0*DABS(SUMA)
+      TEMPA=SUMB+.2D+0*DABS(SUMA)
+      IF (TEMP .LE. SUMB) GOTO 573
+      IF (TEMPA .LE. TEMP) GOTO 573
+      GOTO 630
+  573 CONTINUE
+      LFLAG=1
+      GOTO 775
+  574 K1=KNEXT-M
+      IF (K1 .GT. N) K1=K1-N
+      DO 578 I=1,N
+      SUMA=ZERO
+      IF (I .NE. K1) GOTO 575
+      SUMA=ONE
+      IF (KNEXT .GT. MN) SUMA=-ONE
+  575 SUMB=DABS(SUMA)
+      IF (NACT.EQ.0) GOTO 582
+      DO 577 K=1,NACT
+      KK=IACT(K)
+      IF (KK .LE. M) GOTO 579
+      KK=KK-M
+      TEMP=ZERO
+      IF (KK.EQ.I) TEMP=W(IWW+KK)
+      KK=KK-N
+      IF (KK.EQ.I) TEMP=-W(IWW+KK)
+      GOTO 576
+  579 IW=IWW+K
+      TEMP=W(IW)*A(KK,I)
+  576 SUMA=SUMA-TEMP
+  577 SUMB=SUMB+DABS(TEMP)
+  582 TEMP=SUMB+.1D+0*DABS(SUMA)
+      TEMPA=SUMB+.2D+0*DABS(SUMA)
+      IF (TEMP .LE. SUMB) GOTO 578
+      IF (TEMPA .LE. TEMP) GOTO 578
+      GOTO 630
+  578 CONTINUE
+      LFLAG=1
+      GOTO 775
+C
+C     BRANCH IF THE CONTRAINTS ARE INCONSISTENT.
+C
+  580 INFO=-KNEXT
+      IF (KDROP .EQ. 0) GOTO 700
+      PARINC=RATIO
+      PARNEW=PARINC
+C
+C     REVISE THE LAGRANGE MULTIPLIERS OF THE ACTIVE CONSTRAINTS.
+C
+  590 IF (NACT.EQ.0) GOTO 601
+      DO 600 K=1,NACT
+      IW=IWW+K
+      W(K)=W(K)-PARINC*W(IW)
+      IF (IACT(K) .GT. MEQ) W(K)=DMAX1(ZERO,W(K))
+  600 CONTINUE
+  601 IF (KDROP .EQ. 0) GOTO 680
+C
+C     DELETE THE CONSTRAINT TO BE DROPPED.
+C     SHIFT THE VECTOR OF SCALAR PRODUCTS.
+C     THEN, IF APPROPRIATE, MAKE ONE MORE SCALAR PRODUCT ZERO.
+C
+      NU=NACT+1
+      MFLAG=2
+      GOTO 800
+  610 IWS=IWS-NACT-1
+      NU=MIN0(N,NU)
+      DO 620 I=1,NU
+      IS=IWS+I
+      J=IS+NACT
+  620 W(IS)=W(J+1)
+      NFLAG=2
+      GOTO 860
+C
+C     CALCULATE THE STEP TO THE VIOLATED CONSTRAINT.
+C
+  630 IS=IWS+NACT
+  640 SUMY=W(IS+1)
+      STEP=-RES/SUMY
+      PARINC=STEP/SUMY
+      IF (NACT .EQ. 0) GOTO 660
+C
+C     CALCULATE THE CHANGES TO THE LAGRANGE MULTIPLIERS, AND REDUCE
+C     THE STEP ALONG THE NEW SEARCH DIRECTION IF NECESSARY.
+C
+      LFLAG=2
+      GOTO 740
+  650 IF (KDROP .EQ. 0) GOTO 660
+      TEMP=ONE-RATIO/PARINC
+      IF (TEMP .LE. ZERO) KDROP=0
+      IF (KDROP .EQ. 0) GOTO 660
+      STEP=RATIO*SUMY
+      PARINC=RATIO
+      RES=TEMP*RES
+C
+C     UPDATE X AND THE LAGRANGE MULTIPIERS.
+C     DROP A CONSTRAINT IF THE FULL STEP IS NOT TAKEN.
+C
+  660 IWY=IWZ+NACT*N
+      DO 670 I=1,N
+      IY=IWY+I
+  670 X(I)=X(I)+STEP*W(IY)
+      PARNEW=PARNEW+PARINC
+      IF (NACT .GE. 1) GOTO 590
+C
+C     ADD THE NEW CONSTRAINT TO THE ACTIVE SET.
+C
+  680 NACT=NACT+1
+      W(NACT)=PARNEW
+      IACT(NACT)=KNEXT
+      IA=IWA+KNEXT
+      IF (KNEXT .GT. MN) IA=IA-N
+      W(IA)=-W(IA)
+C
+C     ESTIMATE THE MAGNITUDE OF X. THEN BEGIN A NEW ITERATION,
+C     RE-INITILISING X IF THIS MAGNITUDE IS SMALL.
+C
+      JFLAG=2
+      GOTO 910
+  690 IF (SUM .LT. (XMAGR*XMAG)) GOTO 230
+      IF (ITREF) 450,450,250
+C
+C     INITIATE ITERATIVE REFINEMENT IF IT HAS NOT YET BEEN USED,
+C     OR RETURN AFTER RESTORING THE DIAGONAL ELEMENTS OF G.
+C
+  700 IF (ITERC .EQ. 0) GOTO 710
+      ITREF=ITREF+1
+      JFINC=-1
+      IF (ITREF .EQ. 1) GOTO 250
+  710 IF (.NOT. LQL) RETURN
+      DO 720 I=1,N
+      ID=IWD+I
+  720 G(I,I)=W(ID)
+  730 RETURN
+C
+C
+C     THE REMAINIG INSTRUCTIONS ARE USED AS SUBROUTINES.
+C
+C
+C********************************************************************
+C
+C
+C     CALCULATE THE LAGRANGE MULTIPLIERS BY PRE-MULTIPLYING THE
+C     VECTOR IN THE S-PARTITION OF W BY THE INVERSE OF R.
+C
+  740 IR=IWR+(NACT+NACT*NACT)/2
+      I=NACT
+      SUM=ZERO
+      GOTO 770
+  750 IRA=IR-1
+      SUM=ZERO
+      IF (NACT.EQ.0) GOTO 761
+      DO 760 J=I,NACT
+      IW=IWW+J
+      SUM=SUM+W(IRA)*W(IW)
+  760 IRA=IRA+J
+  761 IR=IR-I
+      I=I-1
+  770 IW=IWW+I
+      IS=IWS+I
+      W(IW)=(W(IS)-SUM)/W(IR)
+      IF (I .GT. 1) GOTO 750
+      IF (LFLAG .EQ. 3) GOTO 390
+      IF (LFLAG .EQ. 4) GOTO 571
+C
+C     CALCULATE THE NEXT CONSTRAINT TO DROP.
+C
+  775 IP=IWW+1
+      IPP=IWW+NACT
+      KDROP=0
+      IF (NACT.EQ.0) GOTO 791
+      DO 790 K=1,NACT
+      IF (IACT(K) .LE. MEQ) GOTO 790
+      IW=IWW+K
+      IF ((RES*W(IW)) .GE. ZERO) GOTO 790
+      TEMP=W(K)/W(IW)
+      IF (KDROP .EQ. 0) GOTO 780
+      IF (DABS(TEMP) .GE. DABS(RATIO)) GOTO 790
+  780 KDROP=K
+      RATIO=TEMP
+  790 CONTINUE
+  791 GOTO (580,650), LFLAG
+C
+C
+C********************************************************************
+C
+C
+C     DROP THE CONSTRAINT IN POSITION KDROP IN THE ACTIVE SET.
+C
+  800 IA=IWA+IACT(KDROP)
+      IF (IACT(KDROP) .GT. MN) IA=IA-N
+      W(IA)=-W(IA)
+      IF (KDROP .EQ. NACT) GOTO 850
+C
+C     SET SOME INDICES AND CALCULATE THE ELEMENTS OF THE NEXT
+C     GIVENS ROTATION.
+C
+      IZ=IWZ+KDROP*N
+      IR=IWR+(KDROP+KDROP*KDROP)/2
+  810 IRA=IR
+      IR=IR+KDROP+1
+      TEMP=DMAX1(DABS(W(IR-1)),DABS(W(IR)))
+      SUM=TEMP*DSQRT((W(IR-1)/TEMP)**2+(W(IR)/TEMP)**2)
+      GA=W(IR-1)/SUM
+      GB=W(IR)/SUM
+C
+C     EXCHANGE THE COLUMNS OF R.
+C
+      DO 820 I=1,KDROP
+      IRA=IRA+1
+      J=IRA-KDROP
+      TEMP=W(IRA)
+      W(IRA)=W(J)
+  820 W(J)=TEMP
+      W(IR)=ZERO
+C
+C     APPLY THE ROTATION TO THE ROWS OF R.
+C
+      W(J)=SUM
+      KDROP=KDROP+1
+      DO 830 I=KDROP,NU
+      TEMP=GA*W(IRA)+GB*W(IRA+1)
+      W(IRA+1)=GA*W(IRA+1)-GB*W(IRA)
+      W(IRA)=TEMP
+  830 IRA=IRA+I
+C
+C     APPLY THE ROTATION TO THE COLUMNS OF Z.
+C
+      DO 840 I=1,N
+      IZ=IZ+1
+      J=IZ-N
+      TEMP=GA*W(J)+GB*W(IZ)
+      W(IZ)=GA*W(IZ)-GB*W(J)
+  840 W(J)=TEMP
+C
+C     REVISE IACT AND THE LAGRANGE MULTIPLIERS.
+C
+      IACT(KDROP-1)=IACT(KDROP)
+      W(KDROP-1)=W(KDROP)
+      IF (KDROP .LT. NACT) GOTO 810
+  850 NACT=NACT-1
+      GOTO (250,610), MFLAG
+C
+C
+C********************************************************************
+C
+C
+C     APPLY GIVENS ROTATION TO REDUCE SOME OF THE SCALAR
+C     PRODUCTS IN THE S-PARTITION OF W TO ZERO.
+C
+  860 IZ=IWZ+NU*N
+  870 IZ=IZ-N
+  880 IS=IWS+NU
+      NU=NU-1
+      IF (NU .EQ. NACT) GOTO 900
+      IF (W(IS) .EQ. ZERO) GOTO 870
+      TEMP=DMAX1(DABS(W(IS-1)),DABS(W(IS)))
+      SUM=TEMP*DSQRT((W(IS-1)/TEMP)**2+(W(IS)/TEMP)**2)
+      GA=W(IS-1)/SUM
+      GB=W(IS)/SUM
+      W(IS-1)=SUM
+      DO 890 I=1,N
+      K=IZ+N
+      TEMP=GA*W(IZ)+GB*W(K)
+      W(K)=GA*W(K)-GB*W(IZ)
+      W(IZ)=TEMP
+  890 IZ=IZ-1
+      GOTO 880
+  900 GOTO (560,630), NFLAG
+C
+C
+C********************************************************************
+C
+C
+C     CALCULATE THE MAGNITUDE OF X AN REVISE XMAG.
+C
+  910 SUM=ZERO
+      DO 920 I=1,N
+      SUM=SUM+DABS(X(I))*VFACT*(DABS(GRAD(I))+DABS(G(I,I)*X(I)))
+      IF (LQL) GOTO 920
+      IF (SUM .LT. 1.D-30) GOTO 920
+      VFACT=1.D-10*VFACT
+      SUM=1.D-10*SUM
+      XMAG=1.D-10*XMAG
+  920 CONTINUE
+  925 XMAG=DMAX1(XMAG,SUM)
+      GOTO (420,690), JFLAG
+C
+C
+C********************************************************************
+C
+C
+C     PRE-MULTIPLY THE VECTOR IN THE W-PARTITION OF W BY Z TRANSPOSE.
+C
+  930 JL=IWW+1
+      IZ=IWZ
+      DO 940 I=1,N
+      IS=IWS+I
+      W(IS)=ZERO
+      IWWN=IWW+N
+      DO 940 J=JL,IWWN
+      IZ=IZ+1
+  940 W(IS)=W(IS)+W(IZ)*W(J)
+      GOTO (350,550), KFLAG
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/resign.f
@@ -0,0 +1,31 @@
+c
+      subroutine resign(n,neqn,psf,grdpsf,penp,g,gradg,signeq,job1,job2)
+      integer i,j,job1,job2,n,neqn
+      double precision psf,grdpsf(1),penp(1),g(1),gradg(n,1),
+     *                 signeq(1)
+c     double precision psf,grdpsf(n),penp(neqn),g(neqn),gradg(n,neqn),
+c    *                 signeq(neqn)
+c
+c     job1=10: g*signeq, job1=11: gradg*signeq, job1=12: job1=10&11
+c     job1=20: do not change sign
+c     job2=10: psf,      job2=11: grdpsf,       job2=12: job2=10&11
+c     job2=20: do not compute psf or grdpsf
+c
+      if(job2.eq.10.or.job2.eq.12) psf=0.d0
+      do 100 i=1,neqn
+        if(job1.eq.10.or.job1.eq.12) g(i)=signeq(i)*g(i)
+        if(job2.eq.10.or.job2.eq.12) psf=psf+g(i)*penp(i)
+        if(job1.eq.10.or.job1.eq.20) goto 100
+          do 50 j=1,n
+            gradg(j,i)=gradg(j,i)*signeq(i)
+  50      continue
+ 100  continue
+      if(job2.eq.10.or.job2.eq.20) goto 9000
+      call nullvc(n,grdpsf)
+      do 120 i=1,n
+        do 110 j=1,neqn
+ 110      grdpsf(i)=grdpsf(i)+gradg(i,j)*penp(j)
+ 120  continue
+c
+ 9000 return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/sbout1.f
@@ -0,0 +1,23 @@
+c
+      subroutine sbout1(io,n,s1,z,z1,job,level)
+c     implicit real*8(a-h,o-z)
+      integer io,n,job,level,j
+      double precision z,z1(1)
+      character*20 s1
+c
+      if (job.eq.2) goto 10
+      if (level.eq.1)write(io,9900) s1,z
+      if (level.eq.2)write(io,9901) s1,z
+      return
+ 10   if (level.eq.1)write(io,9900) s1,z1(1)
+      if (level.eq.2)write(io,9901) s1,z1(1)
+      do 100 j=2,n
+        if (level.eq.1) write(io,9902) z1(j)
+        if (level.eq.2) write(io,9903) z1(j)
+ 100  continue
+      return
+ 9900 format(1x,a20,e22.14)
+ 9901 format(1x,t17,a20,t45,e22.14)
+ 9902 format(1x,t22,e22.14)
+ 9903 format(1x,t45,e22.14)
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/sbout2.f
@@ -0,0 +1,15 @@
+c
+      subroutine sbout2(io,n,i,s1,s2,z)
+c     implicit real*8(a-h,o-z)
+      integer io,n,i,j
+      double precision z(n)
+      character*8 s1
+      character*1 s2
+c
+      write(io,9900) s1,i,s2,z(1)
+      do 100 j=2,n
+ 100    write(io,9901) z(j)
+      return
+ 9900 format(1x,t17,a8,i5,a1,t45,e22.14)
+ 9901 format(1x,t45,e22.14)
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/scaprd.f
@@ -0,0 +1,16 @@
+c
+      double  precision function scaprd(n,x,y)
+c     implicit real*8(a-h,o-z)
+      integer n,i
+      double  precision x(1),y(1),z
+c     double  precision x(n),y(n),z
+c
+c     compute z=x'y
+c
+      z=0.d0
+      do 100 i=1,n
+        z=x(i)*y(i)+z 
+ 100  continue
+      scaprd=z
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/shift.f
@@ -0,0 +1,14 @@
+c
+      subroutine shift(n,ii,iact)
+      integer n,ii,iact(1),j,k
+c
+      if(ii.eq.iact(1)) return
+      do 200 j=1,n
+        if(ii.ne.iact(j)) goto 200
+        do 100 k=j,2,-1
+ 100      iact(k)=iact(k-1)
+        goto 210
+ 200  continue
+ 210  iact(1)=ii
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/slope.f
@@ -0,0 +1,47 @@
+c
+      double precision function slope(nob,nobL,neqn,nparam,feasb,
+     *                         f,gradf,grdpsf,x,y,fM,theta,job)
+c     implicit real*8(a-h,o-z)
+      integer nob,nobL,neqn,nparam,job,i
+      double  precision fM,theta,slope1,dmax1,dmin1,rhs,rhog,
+     *        grdftx,grdfty,diff,scaprd,grpstx,grpsty
+      double  precision f(nob),gradf(nparam,nob),grdpsf(nparam),
+     *        x(nparam),y(nparam)
+c     double  precision f(1),gradf(nparam,1),grdpsf(nparam),
+c    *        x(nparam),y(nparam)
+      logical feasb
+c
+      double  precision bigbnd,dummy
+      common  /fsqpq1/bigbnd,dummy
+c
+c     job=0 : compute the generalized gradient of the minimax
+c     job=1 : compute rhog in mode = 1
+c
+      slope=-bigbnd
+      if(neqn.eq.0.or..not.feasb) then
+        grpstx=0.d0
+        grpsty=0.d0
+      else
+        grpstx=scaprd(nparam,grdpsf,x)
+        grpsty=scaprd(nparam,grdpsf,y)
+      endif
+      do 100 i=1,nob
+        slope1=f(i)+scaprd(nparam,gradf(1,i),x)
+        slope=dmax1(slope,slope1)
+        if(nobL.ne.nob) slope=dmax1(slope,-slope1)
+ 100  continue
+      slope=slope-fM-grpstx
+      if (job.eq.0) goto 9000
+      rhs=theta*slope+fM
+      rhog=1.d0
+      do 200 i=1,nob
+        grdftx=scaprd(nparam,gradf(1,i),x)-grpstx
+        grdfty=scaprd(nparam,gradf(1,i),y)-grpsty
+        diff=grdfty-grdftx
+        if (diff.le.0.d0) goto 200
+        rhog=dmin1(rhog,(rhs-f(i)-grdftx)/diff)
+        if(nobL.ne.nob) rhog=dmin1(rhog,-(rhs+f(i)+grdftx)/diff)
+ 200  continue
+      slope=rhog
+ 9000 return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/small.f
@@ -0,0 +1,25 @@
+c
+      double precision function small()
+c     implicit real*8(a-h,o-z)
+      double precision one, two, z
+c
+      one=1.d0
+      two=2.d0
+      small=one
+10    small=small/two
+      call fool(small,one,z)
+      if(z.gt.one) goto 10
+      small=small*two*two
+c
+c The simpler sequence commented out below fails on some machines that use
+c extra-length registers for internal computation.  This was pointed out
+c to us by Roque Donizete de Oliveira (Michigan) who suggested to sequence
+c used now.
+c
+c     small=1.d0
+c100  if ((small+1.d0).eq.1.d0) goto 110
+c     small=small/2.d0
+c     goto 100
+c110  small=small*4.d0
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/fsqp/step.f
@@ -0,0 +1,217 @@
+      subroutine step(nparam,nob,nobL,nineqn,neq,neqn,nn,ncnstr,ncg,
+     *                ncf,indxob,indxcn,iact,iskp,iskip,istore,feasb,
+     *                grdftd,f,fM,fMp,psf,penp,steps,scvneq,xnew,
+     *                x,di,d,g,w,backup,signeq,obj,constr)
+c
+c     FSQP Version 3.3  : Armijo or nonmonotone line search, with
+c                         some ad hoc strategies to decrease the number
+c                         of function evaluation as much as possible
+c
+c     implicit real*8(a-h,o-z)
+      integer nparam,nob,nobL,nineqn,neq,neqn,nn,ncnstr,ncg,ncf,iskp
+      integer indxob(1),indxcn(1),iact(1),iskip(1),
+     *        istore(1)
+c     integer indxob(nob),indxcn(ncnstr),iact(nn+nob),iskip(4),
+c    *        istore(nineqn+nob)
+      double  precision grdftd,fM,fMp,steps,scvneq,psf
+      double  precision xnew(nparam),x(nparam),di(nparam),d(nparam),
+     *        f(1),penp(1),g(1),w(1),backup(1),
+     *        signeq(1)
+c     double  precision xnew(nparam),x(nparam),di(nparam),d(nparam),
+c    *        f(nob),penp(neqn),g(ncnstr),w(1),backup(nob+ncnstr),
+c    *        signeq(neqn)
+      external obj,constr
+      logical feasb
+c
+      integer nnineq,M,ncallg,ncallf,mode,io,iprint,ipspan,ipyes,info,
+     *        idum1,idum2,idum3,nstop,lstype
+      double  precision epsmac,bigbnd,tolfea,dum1,dum2,dum3
+      logical lqpsl,ldummy,dlfeas,local,update,ldumm2
+      common  /fsqpp1/nnineq,M,ncallg,ncallf,mode,lstype,nstop,
+     *        /fsqpp2/io,iprint,ipspan,ipyes,info,idum1,idum2,idum3,
+     *        /fsqpp3/epsmac,dum1,dum2,dum3,
+     *        /fsqpq1/bigbnd,tolfea,
+     *        /fsqplo/dlfeas,local,update,ldumm2,
+     *        /fsqpqp/lqpsl,ldummy
+c
+      integer i,ii,ij,itry,ikeep,j,job,nlin,mnm
+      double  precision prod1,prod,dummy,fmaxl,tolfe,dmax1,ostep,
+     *                  adummy(1),temp
+      logical ltem1,ltem2,reform,fbind,cdone,fdone,eqdone
+c
+      nlin=nnineq-nineqn
+      ii=1
+      itry=1
+      steps=1.d0
+      ostep=steps
+      fbind=.false.
+      cdone=.false.
+      fdone=.false.
+      reform=.true.
+      eqdone=.false.
+      if(local) dlfeas=.false.
+      ikeep=nlin-iskp
+      prod1=0.1d0*grdftd
+      tolfe=0.d0
+      if(lqpsl) tolfe=tolfea
+      if(iprint.ge.3.and.ipyes.eq.0)
+     *  call sbout1(io,0,'directional deriv   ',grdftd,adummy,1,2)
+c
+      w(1)=fM
+ 100  continue
+        if(iprint.ge.3.and.ipyes.eq.0) 
+     *    write(io,9901) itry
+        prod=prod1*steps
+        if(.not.feasb.or.nobL.gt.1) prod=prod+tolfe
+        do 200 i=1,nparam
+          if(local)      xnew(i)=x(i)+steps*di(i)
+          if(.not.local) xnew(i)=x(i)+steps*di(i)+d(i)*steps**2
+ 200    continue
+        if(iprint.lt.3.or.ipyes.gt.0) goto 205
+          call sbout1(io,0,'trial step          ',steps,adummy,1,2)
+          call sbout1(io,nparam,'trial point         ',
+     *                dummy,xnew,2,2)
+ 205    if(iskp.eq.0) goto 209
+          ostep=steps
+          do 207 i=ii,iskp
+            ij=iskip(i)
+            call constr(nparam,ij,xnew,g(ij))
+            if(iprint.lt.3.or.ipyes.gt.0) goto 206
+              if(i.eq.1) write(io,9900) ij,g(ij)
+              if(i.ne.1) write(io,9902) ij,g(ij)
+ 206        if(g(ij).le.tolfe) goto 207
+            ii=i
+            goto 1120
+ 207      continue
+          iskp=0
+ 209    if(nn.eq.0) goto 310
+        if(.not.local.and.fbind) goto 315
+ 210    continue
+        do 300 i=1,nn
+          ncg=i
+          ii=iact(i)
+          ij=nnineq+neqn
+          if(ii.le.nnineq.and.istore(ii).eq.1) goto 215
+          if(ii.gt.nnineq.and.ii.le.ij.and.eqdone) goto 215
+            temp=1.d0
+            if(ii.gt.nnineq.and.ii.le.ij) temp=signeq(ii-nnineq)
+            call constr(nparam,ii,xnew,g(ii))
+            g(ii)=g(ii)*temp
+            ncallg=ncallg+1
+ 215      if(iprint.lt.3.or.ipyes.gt.0) goto 220
+            if(i.eq.1.and.ikeep.eq.nlin) 
+     *        write(io,9900) ii,g(ii)
+            if(i.ne.1.or.ikeep.ne.nlin) write(io,9902) ii,g(ii)
+ 220      if(local.or.g(ii).le.tolfe) goto 230
+            call shift(nn,ii,iact)
+            goto 1110
+ 230      if(local.and.g(ii).gt.tolfe) goto 1500
+ 300    continue
+ 310    cdone=.true.
+        eqdone=.true.
+        if(local) dlfeas=.true.
+ 315    if(fdone) goto 410
+        fmaxl=-bigbnd
+        do 400 i=1,nob
+          ncf=i
+          ii=iact(nn+i)
+          if(feasb) then
+            if(eqdone.or.neqn.eq.0) goto 317
+              do 316 j=1,neqn
+ 316            call constr(nparam,nnineq+j,xnew,g(nnineq+j))
+              ncallg=ncallg+neqn
+ 317        if(neqn.eq.0) goto 318
+              if(eqdone)      job=20
+              if(.not.eqdone) job=10
+              call resign(nparam,neqn,psf,w(2),penp,
+     *                    g(nnineq+1),w(2),signeq,job,10)
+ 318        if(istore(nineqn+ii).eq.1) goto 320
+              call obj(nparam,ii,xnew,f(ii))
+              ncallf=ncallf+1
+ 320        if(i.eq.1.and.iprint.ge.3.and.ipyes.eq.0) 
+     *        write(io,9903) ii,f(ii)-psf
+            if(i.ne.1.and.iprint.ge.3.and.ipyes.eq.0) 
+     *        write(io,9902) ii,f(ii)-psf
+          else
+            if(istore(ii).eq.1) goto 325
+              call constr(nparam,indxob(ii),xnew,f(ii))
+              ncallg=ncallg+1
+ 325        if(f(ii).gt.tolfe) reform=.false.
+            if(i.eq.1.and.iprint.ge.3.and.ipyes.eq.0) 
+     *        write(io,9903) indxob(ii),f(ii)
+            if(i.ne.1.and.iprint.ge.3.and.ipyes.eq.0) 
+     *        write(io,9902) indxob(ii),f(ii)
+          endif
+          fmaxl=dmax1(fmaxl,f(ii))
+          if(nobL.ne.nob) fmaxl=dmax1(fmaxl,-f(ii))
+          if(.not.feasb.and.reform) goto 400
+          if(local) goto 340
+          if((f(ii)-psf).le.(fMp+prod)) goto 330
+            fbind=.true.
+            call shift(nob,ii,iact(nn+1))
+          goto 1110
+ 330      if(nobL.eq.nob.or.(-f(ii)-psf).le.(fMp+prod)) goto 400
+            fbind=.true.
+            call shift(nob,ii,iact(nn+1))
+          goto 1110
+ 340      ltem1=(f(ii)-psf).gt.(fMp+prod)
+          ltem2=nobL.ne.nob.and.(-f(ii)-psf).gt.(fMp+prod)
+          if(ltem1.or.ltem2) goto 1500
+ 400    continue
+        fbind=.false.
+        fdone=.true.
+        eqdone=.true.
+        if(.not.cdone) goto 210
+ 410    if(ostep.eq.steps) mnm=ikeep+neq-neqn
+        if(ostep.ne.steps) mnm=ncnstr-nn
+        do 500 i=1,mnm
+          ii=indxcn(i+nn)
+          if(ikeep.ne.nlin.and.ostep.eq.steps.and.i.le.nlin) 
+     *       ii=iskip(nlin+2-i)
+          call constr(nparam,ii,xnew,g(ii))
+ 500    continue
+        scvneq=0.d0
+        do 600 i=1,ncnstr
+          if(i.gt.nnineq.and.i.le.(nnineq+neqn)) scvneq=scvneq-g(i)
+ 600      backup(i)=g(i)
+        do 700 i=1,nob
+ 700      backup(i+ncnstr)=f(i)
+        if(feasb.or..not.reform) goto 810
+          do 800 i=1,nparam
+ 800        x(i)=xnew(i)
+          nstop=0
+          goto 1500
+ 810    if(local) ncg=ncnstr
+        if(local) update=.true.
+        fM=fmaxl
+        fMp=fmaxl-psf
+        do 1000 i=1,nn
+ 1000     iact(i)=indxcn(i)
+        do 1100 i=1,nob
+ 1100     iact(nn+i)=i
+        goto 1500
+c
+ 1110   cdone=.false.
+        fdone=.false.
+        eqdone=.false.
+        reform=.false.
+        if(lstype.eq.2) fbind=.false.
+ 1120   itry=itry+1
+        if(steps.lt.1.d0) goto 1140
+        do 1130 i=1,nob+nineqn
+ 1130     istore(i)=0
+ 1140   steps=steps*.5d0
+        if(steps.lt.epsmac) goto 1150
+      goto 100
+c
+ 1150 info=4
+      nstop=0
+ 1500 if(steps.lt.1.d0) goto 9000
+        do 1600 i=1,nob+nineqn
+ 1600     istore(i)=0
+ 9000 return
+ 9900 format(1x,t17,17htrial constraints,t37,i7,t45,e22.14)
+ 9901 format(1x,t17,12htrial number,t45,i22)
+ 9902 format(1x,t37,i7,t45,e22.14)
+ 9903 format(1x,t17,16htrial objectives,t37,i7,t45,e22.14)
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dbdsqr.f
@@ -0,0 +1,807 @@
+      SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
+     $                   LDU, C, LDC, WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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 value decomposition (SVD) of a real
+*  N-by-N (upper or lower) bidiagonal matrix B:  B = Q * S * P' (P'
+*  denotes the transpose of P), where S is a diagonal matrix with
+*  non-negative diagonal elements (the singular values of B), and Q
+*  and P are orthogonal matrices.
+*
+*  The routine computes S, and optionally computes U * Q, P' * VT,
+*  or Q' * C, for given real input matrices U, VT, and 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)
+*          On entry, the elements of E contain the
+*          offdiagonal elements of the bidiagonal matrix whose SVD
+*          is desired. On normal exit (INFO = 0), E is destroyed.
+*          If the algorithm does not converge (INFO > 0), D and E
+*          will contain the diagonal and superdiagonal elements of a
+*          bidiagonal matrix orthogonally equivalent to the one given
+*          as input. E(N) is used for workspace.
+*
+*  VT      (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
+*          On entry, an N-by-NCVT matrix VT.
+*          On exit, VT is overwritten by P' * VT.
+*          VT is 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.
+*          U is 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' * C.
+*          C is 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 only singular values wanted (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            ROTATE
+      INTEGER            I, IDIR, IROT, ISUB, ITER, IUPLO, 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, SMINLO, 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
+      IUPLO = 0
+      IF( LSAME( UPLO, 'U' ) )
+     $   IUPLO = 1
+      IF( LSAME( UPLO, 'L' ) )
+     $   IUPLO = 2
+      IF( IUPLO.EQ.0 ) 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 150
+*
+*     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
+*
+*     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( IUPLO.EQ.2 ) 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 = ABS( D( N ) )
+      DO 20 I = 1, N - 1
+         SMAX = MAX( SMAX, ABS( D( I ) ), ABS( E( I ) ) )
+   20 CONTINUE
+      SMINL = ZERO
+      IF( TOL.GE.ZERO ) THEN
+*
+*        Relative accuracy desired
+*
+         SMINOA = ABS( D( 1 ) )
+         IF( SMINOA.EQ.ZERO )
+     $      GO TO 40
+         MU = SMINOA
+         DO 30 I = 2, N
+            MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )
+            SMINOA = MIN( SMINOA, MU )
+            IF( SMINOA.EQ.ZERO )
+     $         GO TO 40
+   30    CONTINUE
+   40    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
+*
+   50 CONTINUE
+*
+*     Check for convergence or exceeding iteration count
+*
+      IF( M.LE.1 )
+     $   GO TO 150
+      IF( ITER.GT.MAXIT )
+     $   GO TO 190
+*
+*     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 60 LLL = 1, M
+         LL = M - LLL
+         IF( LL.EQ.0 )
+     $      GO TO 80
+         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 70
+         SMIN = MIN( SMIN, ABSS )
+         SMAX = MAX( SMAX, ABSS, ABSE )
+   60 CONTINUE
+   70 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 50
+      END IF
+   80 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 50
+      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 50
+         END IF
+*
+         IF( TOL.GE.ZERO ) THEN
+*
+*           If relative accuracy desired,
+*           apply convergence criterion forward
+*
+            MU = ABS( D( LL ) )
+            SMINL = MU
+            DO 90 LLL = LL, M - 1
+               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
+                  E( LLL ) = ZERO
+                  GO TO 50
+               END IF
+               SMINLO = SMINL
+               MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
+               SMINL = MIN( SMINL, MU )
+   90       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 50
+         END IF
+*
+         IF( TOL.GE.ZERO ) THEN
+*
+*           If relative accuracy desired,
+*           apply convergence criterion backward
+*
+            MU = ABS( D( M ) )
+            SMINL = MU
+            DO 100 LLL = M - 1, LL, -1
+               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
+                  E( LLL ) = ZERO
+                  GO TO 50
+               END IF
+               SMINLO = SMINL
+               MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
+               SMINL = MIN( SMINL, MU )
+  100       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
+            CALL DLARTG( D( LL )*CS, E( LL ), CS, SN, R )
+            CALL DLARTG( OLDCS*R, D( LL+1 )*SN, OLDCS, OLDSN, D( LL ) )
+            WORK( 1 ) = CS
+            WORK( 1+NM1 ) = SN
+            WORK( 1+NM12 ) = OLDCS
+            WORK( 1+NM13 ) = OLDSN
+            IROT = 1
+            DO 110 I = LL + 1, M - 1
+               CALL DLARTG( D( I )*CS, E( I ), CS, SN, R )
+               E( I-1 ) = OLDSN*R
+               CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )
+               IROT = IROT + 1
+               WORK( IROT ) = CS
+               WORK( IROT+NM1 ) = SN
+               WORK( IROT+NM12 ) = OLDCS
+               WORK( IROT+NM13 ) = OLDSN
+  110       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
+            CALL DLARTG( D( M )*CS, E( M-1 ), CS, SN, R )
+            CALL DLARTG( OLDCS*R, D( M-1 )*SN, OLDCS, OLDSN, D( M ) )
+            WORK( M-LL ) = CS
+            WORK( M-LL+NM1 ) = -SN
+            WORK( M-LL+NM12 ) = OLDCS
+            WORK( M-LL+NM13 ) = -OLDSN
+            IROT = M - LL
+            DO 120 I = M - 1, LL + 1, -1
+               CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
+               E( I ) = OLDSN*R
+               CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )
+               IROT = IROT - 1
+               WORK( IROT ) = CS
+               WORK( IROT+NM1 ) = -SN
+               WORK( IROT+NM12 ) = OLDCS
+               WORK( IROT+NM13 ) = -OLDSN
+  120       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 )
+            CALL DLARTG( F, G, COSR, SINR, R )
+            F = COSR*D( LL ) + SINR*E( LL )
+            E( LL ) = COSR*E( LL ) - SINR*D( LL )
+            G = SINR*D( LL+1 )
+            D( LL+1 ) = COSR*D( LL+1 )
+            CALL DLARTG( F, G, COSL, SINL, R )
+            D( LL ) = R
+            F = COSL*E( LL ) + SINL*D( LL+1 )
+            D( LL+1 ) = COSL*D( LL+1 ) - SINL*E( LL )
+            G = SINL*E( LL+1 )
+            E( LL+1 ) = COSL*E( LL+1 )
+            WORK( 1 ) = COSR
+            WORK( 1+NM1 ) = SINR
+            WORK( 1+NM12 ) = COSL
+            WORK( 1+NM13 ) = SINL
+            IROT = 1
+            DO 130 I = LL + 1, M - 2
+               CALL DLARTG( F, G, COSR, SINR, R )
+               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 )
+               G = SINL*E( I+1 )
+               E( I+1 ) = COSL*E( I+1 )
+               IROT = IROT + 1
+               WORK( IROT ) = COSR
+               WORK( IROT+NM1 ) = SINR
+               WORK( IROT+NM12 ) = COSL
+               WORK( IROT+NM13 ) = SINL
+  130       CONTINUE
+            CALL DLARTG( F, G, COSR, SINR, R )
+            E( M-2 ) = R
+            F = COSR*D( M-1 ) + SINR*E( M-1 )
+            E( M-1 ) = COSR*E( M-1 ) - SINR*D( M-1 )
+            G = SINR*D( M )
+            D( M ) = COSR*D( M )
+            CALL DLARTG( F, G, COSL, SINL, R )
+            D( M-1 ) = R
+            F = COSL*E( M-1 ) + SINL*D( M )
+            D( M ) = COSL*D( M ) - SINL*E( M-1 )
+            IROT = IROT + 1
+            WORK( IROT ) = COSR
+            WORK( IROT+NM1 ) = SINR
+            WORK( IROT+NM12 ) = COSL
+            WORK( IROT+NM13 ) = SINL
+            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 )
+            CALL DLARTG( F, G, COSR, SINR, R )
+            F = COSR*D( M ) + SINR*E( M-1 )
+            E( M-1 ) = COSR*E( M-1 ) - SINR*D( M )
+            G = SINR*D( M-1 )
+            D( M-1 ) = COSR*D( M-1 )
+            CALL DLARTG( F, G, COSL, SINL, R )
+            D( M ) = R
+            F = COSL*E( M-1 ) + SINL*D( M-1 )
+            D( M-1 ) = COSL*D( M-1 ) - SINL*E( M-1 )
+            G = SINL*E( M-2 )
+            E( M-2 ) = COSL*E( M-2 )
+            WORK( M-LL ) = COSR
+            WORK( M-LL+NM1 ) = -SINR
+            WORK( M-LL+NM12 ) = COSL
+            WORK( M-LL+NM13 ) = -SINL
+            IROT = M - LL
+            DO 140 I = M - 1, LL + 2, -1
+               CALL DLARTG( F, G, COSR, SINR, R )
+               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 )
+               G = SINL*E( I-2 )
+               E( I-2 ) = COSL*E( I-2 )
+               IROT = IROT - 1
+               WORK( IROT ) = COSR
+               WORK( IROT+NM1 ) = -SINR
+               WORK( IROT+NM12 ) = COSL
+               WORK( IROT+NM13 ) = -SINL
+  140       CONTINUE
+            CALL DLARTG( F, G, COSR, SINR, R )
+            E( LL+1 ) = R
+            F = COSR*D( LL+1 ) + SINR*E( LL )
+            E( LL ) = COSR*E( LL ) - SINR*D( LL+1 )
+            G = SINR*D( LL )
+            D( LL ) = COSR*D( LL )
+            CALL DLARTG( F, G, COSL, SINL, R )
+            D( LL+1 ) = R
+            F = COSL*E( LL ) + SINL*D( LL )
+            D( LL ) = COSL*D( LL ) - SINL*E( LL )
+            IROT = IROT - 1
+            WORK( IROT ) = COSR
+            WORK( IROT+NM1 ) = -SINR
+            WORK( IROT+NM12 ) = COSL
+            WORK( IROT+NM13 ) = -SINL
+            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 50
+*
+*     All singular values converged, so make them positive
+*
+  150 CONTINUE
+      DO 160 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
+  160 CONTINUE
+*
+*     Sort the singular values into decreasing order (insertion sort on
+*     singular values, but only one transposition per singular vector)
+*
+      DO 180 I = 1, N - 1
+*
+*        Scan for smallest D(I)
+*
+         ISUB = 1
+         SMIN = D( 1 )
+         DO 170 J = 2, N + 1 - I
+            IF( D( J ).LE.SMIN ) THEN
+               ISUB = J
+               SMIN = D( J )
+            END IF
+  170    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
+  180 CONTINUE
+      GO TO 210
+*
+*     Maximum number of iterations exceeded, failure to converge
+*
+  190 CONTINUE
+      INFO = 0
+      DO 200 I = 1, N - 1
+         IF( E( I ).NE.ZERO )
+     $      INFO = INFO + 1
+  200 CONTINUE
+  210 CONTINUE
+      RETURN
+*
+*     End of DBDSQR
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgebak.f
@@ -0,0 +1,189 @@
+      SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgebal.f
@@ -0,0 +1,320 @@
+      SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      DOUBLE PRECISION   SCLFAC
+      PARAMETER          ( SCLFAC = 1.0D+1 )
+      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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgebd2.f
@@ -0,0 +1,238 @@
+      SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. 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
+*
+            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
+*
+            CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAUP( I ),
+     $                  A( MIN( I+1, M ), 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgebrd.f
@@ -0,0 +1,258 @@
+      SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), D( * ), E( * ), TAUP( * ),
+     $                   TAUQ( * ), WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  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 ..
+      INTEGER            I, IINFO, J, LDWRKX, LDWRKY, MINMN, NB, NBMIN,
+     $                   NX
+      DOUBLE PRECISION   WS
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEBD2, DGEMM, DLABRD, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. 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
+      ELSE IF( LWORK.LT.MAX( 1, M, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.LT.0 ) THEN
+         CALL XERBLA( 'DGEBRD', -INFO )
+         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
+*
+*     Set the block size NB and the crossover point NX.
+*
+      NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) )
+*
+      IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN
+*
+*        Determine when to switch from blocked to unblocked code.
+*
+         NX = MAX( NB, ILAENV( 3, 'DGEBRD', ' ', M, N, -1, -1 ) )
+         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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgeesx.f
@@ -0,0 +1,492 @@
+      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 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     March 31, 1993
+*
+*     .. 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  (input) 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 (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.
+*          For good performance, LWORK must generally be larger.
+*
+*  IWORK   (workspace) INTEGER array, dimension (LIWORK)
+*          Not referenced if SENSE = 'N' or 'E'.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.
+*          LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM).
+*
+*  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, LST2SL, SCALEA, WANTSB, WANTSE,
+     $                   WANTSN, WANTST, WANTSV, WANTVS
+      INTEGER            HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL,
+     $                   IHI, ILO, INXT, IP, ITAU, IWRK, K, MAXB,
+     $                   MAXWRK, MINWRK
+      DOUBLE PRECISION   ANRM, BIGNUM, CSCALE, EPS, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD,
+     $                   DLACPY, DLASCL, DORGHR, DSWAP, DTRSEN, 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
+      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 = -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.)
+*
+      MINWRK = 1
+      IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
+         MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
+         MINWRK = MAX( 1, 3*N )
+         IF( .NOT.WANTVS ) THEN
+            MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SN', N, 1, N, -1 ), 2 )
+            K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SN', N, 1,
+     $          N, -1 ) ) )
+            HSWORK = MAX( K*( K+2 ), 2*N )
+            MAXWRK = MAX( MAXWRK, N+HSWORK, 1 )
+         ELSE
+            MAXWRK = MAX( MAXWRK, 2*N+( N-1 )*
+     $               ILAENV( 1, 'DORGHR', ' ', N, 1, N, -1 ) )
+            MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SV', N, 1, N, -1 ), 2 )
+            K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SV', N, 1,
+     $          N, -1 ) ) )
+            HSWORK = MAX( K*( K+2 ), 2*N )
+            MAXWRK = MAX( MAXWRK, N+HSWORK, 1 )
+         END IF
+         WORK( 1 ) = MAXWRK
+      END IF
+      IF( LWORK.LT.MINWRK ) THEN
+         INFO = -16
+      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
+      RETURN
+*
+*     End of DGEESX
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgeev.f
@@ -0,0 +1,402 @@
+      SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR,
+     $                  LDVR, WORK, LWORK, INFO )
+*
+*  -- LAPACK driver routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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 (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.
+*
+*  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            SCALEA, WANTVL, WANTVR
+      CHARACTER          SIDE
+      INTEGER            HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K,
+     $                   MAXB, 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, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      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.)
+*
+      MINWRK = 1
+      IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
+         MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
+         IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN
+            MINWRK = MAX( 1, 3*N )
+            MAXB = MAX( ILAENV( 8, 'DHSEQR', 'EN', N, 1, N, -1 ), 2 )
+            K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'EN', N, 1,
+     $          N, -1 ) ) )
+            HSWORK = MAX( K*( K+2 ), 2*N )
+            MAXWRK = MAX( MAXWRK, N+1, N+HSWORK )
+         ELSE
+            MINWRK = MAX( 1, 4*N )
+            MAXWRK = MAX( MAXWRK, 2*N+( N-1 )*
+     $               ILAENV( 1, 'DORGHR', ' ', N, 1, N, -1 ) )
+            MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SV', N, 1, N, -1 ), 2 )
+            K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SV', N, 1,
+     $          N, -1 ) ) )
+            HSWORK = MAX( K*( K+2 ), 2*N )
+            MAXWRK = MAX( MAXWRK, N+1, N+HSWORK )
+            MAXWRK = MAX( MAXWRK, 4*N )
+         END IF
+         WORK( 1 ) = MAXWRK
+      END IF
+      IF( LWORK.LT.MINWRK ) THEN
+         INFO = -13
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEEV ', -INFO )
+         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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgehd2.f
@@ -0,0 +1,150 @@
+      SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      INTEGER            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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgehrd.f
@@ -0,0 +1,242 @@
+      SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, ILO, INFO, LDA, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( LWORK )
+*     ..
+*
+*  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.
+*
+*  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 ..
+      INTEGER            NBMAX, LDT
+      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IB, IINFO, IWS, LDWORK, NB, NBMIN, NH, NX
+      DOUBLE PRECISION   EI
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   T( LDT, NBMAX )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEHD2, DGEMM, DLAHRD, DLARFB, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. 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
+      ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEHRD', -INFO )
+         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 30 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 DLAHRD( 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(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 )
+   30    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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgelq2.f
@@ -0,0 +1,122 @@
+      SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGELQ2 computes an LQ factorization of a real m by n matrix A:
+*  A = L * Q.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the m by n matrix A.
+*          On exit, the elements on and below the diagonal of the array
+*          contain the m by min(m,n) lower trapezoidal matrix L (L is
+*          lower triangular if m <= n); the elements above the diagonal,
+*          with the array TAU, represent the orthogonal matrix Q as a
+*          product of elementary reflectors (see Further Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (M)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(k) . . . H(2) H(1), where k = min(m,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
+*  and tau in TAU(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      DOUBLE PRECISION   AII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, DLARFG, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGELQ2', -INFO )
+         RETURN
+      END IF
+*
+      K = MIN( M, N )
+*
+      DO 10 I = 1, K
+*
+*        Generate elementary reflector H(i) to annihilate A(i,i+1:n)
+*
+         CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
+     $                TAU( I ) )
+         IF( I.LT.M ) THEN
+*
+*           Apply H(i) to A(i+1:m,i:n) from the right
+*
+            AII = A( I, I )
+            A( I, I ) = ONE
+            CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ),
+     $                  A( I+1, I ), LDA, WORK )
+            A( I, I ) = AII
+         END IF
+   10 CONTINUE
+      RETURN
+*
+*     End of DGELQ2
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgelqf.f
@@ -0,0 +1,186 @@
+      SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  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 ..
+      INTEGER            I, IB, IINFO, IWS, K, LDWORK, 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
+      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 ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGELQF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      K = MIN( M, N )
+      IF( K.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+*     Determine the block size.
+*
+      NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+      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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgelss.f
@@ -0,0 +1,603 @@
+      SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK driver routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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 (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.
+*
+*  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.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      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 )
+      MNTHR = ILAENV( 6, 'DGELSS', ' ', M, N, NRHS, -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.)
+*
+      MINWRK = 1
+      IF( INFO.EQ.0 .AND. LWORK.GE.1 ) 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
+*
+*           Compute workspace neede for DBDSQR
+*
+            BDSPAC = MAX( 1, 5*N-4 )
+            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 neede for DBDSQR
+*
+            BDSPAC = MAX( 1, 5*M-4 )
+            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 )
+         WORK( 1 ) = MAXWRK
+      END IF
+*
+      MINWRK = MAX( MINWRK, 1 )
+      IF( LWORK.LT.MINWRK )
+     $   INFO = -12
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGELSS', -INFO )
+         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, LDB,
+     $                     ZERO, WORK, N )
+               CALL DLACPY( 'G', N, BL, WORK, N, B, 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 ), N )
+               CALL DLACPY( 'G', M, BL, WORK( IWORK ), N, B, 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgeqpf.f
@@ -0,0 +1,220 @@
+      SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )
+*
+*  -- LAPACK test routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     March 31, 1993
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  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.
+*
+*  =====================================================================
+*
+*     .. 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
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEQR2, DLARF, DLARFG, DORM2R, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DNRM2
+      EXTERNAL           IDAMAX, 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 )
+*
+*     Move initial columns up front
+*
+      ITEMP = 1
+      DO 10 I = 1, N
+         IF( JPVT( I ).NE.0 ) THEN
+            IF( I.NE.ITEMP ) THEN
+               CALL DSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 )
+               JPVT( I ) = JPVT( ITEMP )
+               JPVT( ITEMP ) = I
+            ELSE
+               JPVT( I ) = I
+            END IF
+            ITEMP = ITEMP + 1
+         ELSE
+            JPVT( I ) = I
+         END IF
+   10 CONTINUE
+      ITEMP = ITEMP - 1
+*
+*     Compute the QR factorization and update remaining columns
+*
+      IF( ITEMP.GT.0 ) THEN
+         MA = MIN( ITEMP, M )
+         CALL DGEQR2( M, MA, A, LDA, TAU, WORK, INFO )
+         IF( MA.LT.N ) THEN
+            CALL DORM2R( 'Left', 'Transpose', M, N-MA, MA, A, LDA, TAU,
+     $                   A( 1, MA+1 ), LDA, WORK, INFO )
+         END IF
+      END IF
+*
+      IF( ITEMP.LT.MN ) THEN
+*
+*        Initialize partial column norms. The first n elements of
+*        work store the exact column norms.
+*
+         DO 20 I = ITEMP + 1, N
+            WORK( I ) = DNRM2( M-ITEMP, A( ITEMP+1, I ), 1 )
+            WORK( N+I ) = WORK( I )
+   20    CONTINUE
+*
+*        Compute factorization
+*
+         DO 40 I = ITEMP + 1, MN
+*
+*           Determine ith pivot column and swap if necessary
+*
+            PVT = ( I-1 ) + IDAMAX( N-I+1, WORK( I ), 1 )
+*
+            IF( PVT.NE.I ) THEN
+               CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
+               ITEMP = JPVT( PVT )
+               JPVT( PVT ) = JPVT( I )
+               JPVT( I ) = ITEMP
+               WORK( PVT ) = WORK( I )
+               WORK( N+PVT ) = WORK( N+I )
+            END IF
+*
+*           Generate elementary reflector H(i)
+*
+            IF( I.LT.M ) THEN
+               CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) )
+            ELSE
+               CALL DLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) )
+            END IF
+*
+            IF( I.LT.N ) THEN
+*
+*              Apply H(i) to A(i:m,i+1:n) from the left
+*
+               AII = A( I, I )
+               A( I, I ) = ONE
+               CALL DLARF( 'LEFT', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+     $                     A( I, I+1 ), LDA, WORK( 2*N+1 ) )
+               A( I, I ) = AII
+            END IF
+*
+*           Update partial column norms
+*
+            DO 30 J = I + 1, N
+               IF( WORK( J ).NE.ZERO ) THEN
+                  TEMP = ONE - ( ABS( A( I, J ) ) / WORK( J ) )**2
+                  TEMP = MAX( TEMP, ZERO )
+                  TEMP2 = ONE + 0.05D0*TEMP*
+     $                    ( WORK( J ) / WORK( N+J ) )**2
+                  IF( TEMP2.EQ.ONE ) 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgeqr2.f
@@ -0,0 +1,122 @@
+      SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEQR2 computes a QR factorization of a real m by n matrix A:
+*  A = Q * R.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the m by n matrix A.
+*          On exit, the elements on and above the diagonal of the array
+*          contain the min(m,n) by n upper trapezoidal matrix R (R is
+*          upper triangular if m >= n); the elements below the diagonal,
+*          with the array TAU, represent the orthogonal matrix Q as a
+*          product of elementary reflectors (see Further Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
+*  and tau in TAU(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      DOUBLE PRECISION   AII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, DLARFG, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEQR2', -INFO )
+         RETURN
+      END IF
+*
+      K = MIN( M, N )
+*
+      DO 10 I = 1, K
+*
+*        Generate elementary reflector H(i) to annihilate A(i+1:m,i)
+*
+         CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
+     $                TAU( I ) )
+         IF( I.LT.N ) THEN
+*
+*           Apply H(i) to A(i:m,i+1:n) from the left
+*
+            AII = A( I, I )
+            A( I, I ) = ONE
+            CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+     $                  A( I, I+1 ), LDA, WORK )
+            A( I, I ) = AII
+         END IF
+   10 CONTINUE
+      RETURN
+*
+*     End of DGEQR2
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgeqrf.f
@@ -0,0 +1,187 @@
+      SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  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 ..
+      INTEGER            I, IB, IINFO, IWS, K, LDWORK, 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
+      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 ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEQRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      K = MIN( M, N )
+      IF( K.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+*     Determine the block size.
+*
+      NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+      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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgesv.f
@@ -0,0 +1,108 @@
+      SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+*  -- LAPACK driver routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     March 31, 1993
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgesvd.f
@@ -0,0 +1,3408 @@
+      SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK driver routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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 (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 >= 1.
+*          LWORK >= MAX(3*MIN(M,N)+MAX(M,N),5*MIN(M,N)-4).
+*          For good performance, LWORK should generally be larger.
+*
+*  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            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 )
+      MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 )
+      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' )
+      MINWRK = 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 .AND. LWORK.GE.1 .AND. M.GT.0 .AND. N.GT.0 ) THEN
+         IF( M.GE.N ) THEN
+*
+*           Compute space needed for DBDSQR
+*
+            BDSPAC = MAX( 3*N, 5*N-4 )
+            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 )
+                  MAXWRK = MAX( MAXWRK, MINWRK )
+               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 )
+                  MAXWRK = MAX( MAXWRK, MINWRK )
+               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 )
+                  MAXWRK = MAX( MAXWRK, MINWRK )
+               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 )
+                  MAXWRK = MAX( MAXWRK, MINWRK )
+               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 )
+                  MAXWRK = MAX( MAXWRK, MINWRK )
+               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 )
+                  MAXWRK = MAX( MAXWRK, MINWRK )
+               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 )
+                  MAXWRK = MAX( MAXWRK, MINWRK )
+               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 )
+                  MAXWRK = MAX( MAXWRK, MINWRK )
+               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 )
+                  MAXWRK = MAX( MAXWRK, MINWRK )
+               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 )
+               MAXWRK = MAX( MAXWRK, MINWRK )
+            END IF
+         ELSE
+*
+*           Compute space needed for DBDSQR
+*
+            BDSPAC = MAX( 3*M, 5*M-4 )
+            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 )
+                  MAXWRK = MAX( MAXWRK, MINWRK )
+               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 )
+                  MAXWRK = MAX( MAXWRK, MINWRK )
+               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 )
+                  MAXWRK = MAX( MAXWRK, MINWRK )
+               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 )
+                  MAXWRK = MAX( MAXWRK, MINWRK )
+               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 )
+                  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, '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 )
+                  MAXWRK = MAX( MAXWRK, MINWRK )
+               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 )
+                  MAXWRK = MAX( MAXWRK, MINWRK )
+               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 )
+                  MAXWRK = MAX( MAXWRK, MINWRK )
+               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 )
+                  MAXWRK = MAX( MAXWRK, MINWRK )
+               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 )
+               MAXWRK = MAX( MAXWRK, MINWRK )
+            END IF
+         END IF
+         WORK( 1 ) = MAXWRK
+      END IF
+*
+      IF( LWORK.LT.MINWRK ) THEN
+         INFO = -13
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGESVD', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         IF( LWORK.GE.1 )
+     $      WORK( 1 ) = ONE
+         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 )
+                  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 )
+                  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 )
+                     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 )
+                     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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgetf2.f
@@ -0,0 +1,135 @@
+      SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     June 30, 1992
+*
+*     .. 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 ..
+      INTEGER            J, JP
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      EXTERNAL           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
+*
+      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 )
+     $         CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
+*
+         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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgetrf.f
@@ -0,0 +1,160 @@
+      SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     March 31, 1993
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dgetrs.f
@@ -0,0 +1,150 @@
+      SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     March 31, 1993
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dhseqr.f
@@ -0,0 +1,454 @@
+      SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z,
+     $                   LDZ, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      CHARACTER          COMPZ, JOB
+      INTEGER            IHI, ILO, INFO, LDH, LDZ, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   H( LDH, * ), WI( * ), WORK( * ), WR( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DHSEQR computes the eigenvalues of a real upper Hessenberg matrix H
+*  and, optionally, the matrices T and Z from the Schur decomposition
+*  H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur
+*  form), and Z is the orthogonal matrix of Schur vectors.
+*
+*  Optionally Z may be postmultiplied into an input orthogonal matrix Q,
+*  so that this routine can give the Schur factorization of a matrix A
+*  which has been reduced to the Hessenberg form H by the orthogonal
+*  matrix Q:  A = Q*H*Q**T = (QZ)*T*(QZ)**T.
+*
+*  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 >= 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 SGEHRD
+*          when the matrix output by DGEBAL is reduced to Hessenberg
+*          form. Otherwise ILO and IHI should be set to 1 and N
+*          respectively.
+*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+*  H       (input/output) DOUBLE PRECISION array, dimension (LDH,N)
+*          On entry, the upper Hessenberg matrix H.
+*          On exit, if JOB = 'S', 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) < 0. If JOB = 'E',
+*          the contents of H are unspecified on exit.
+*
+*  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. If two eigenvalues are computed as a complex
+*          conjugate pair, they are stored in consecutive elements of
+*          WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and
+*          WI(i+1) < 0. If JOB = 'S', the eigenvalues are stored in the
+*          same order as on the diagonal of the Schur form returned in
+*          H, 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, 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 Z contains Q*Z.
+*          Normally Q is the orthogonal matrix generated by DORGHR after
+*          the call to DGEHRD which formed the Hessenberg matrix H.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.
+*          LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  LWORK   (input) INTEGER
+*          This argument is currently redundant.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, DHSEQR failed to compute all of the
+*                eigenvalues in a total of 30*(IHI-ILO+1) iterations;
+*                elements 1:ilo-1 and i+1:n of WR and WI contain those
+*                eigenvalues which have been successfully computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+      DOUBLE PRECISION   CONST
+      PARAMETER          ( CONST = 1.5D+0 )
+      INTEGER            NSMAX, LDS
+      PARAMETER          ( NSMAX = 15, LDS = NSMAX )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            INITZ, WANTT, WANTZ
+      INTEGER            I, I1, I2, IERR, II, ITEMP, ITN, ITS, J, K, L,
+     $                   MAXB, NH, NR, NS, NV
+      DOUBLE PRECISION   ABSW, OVFL, SMLNUM, TAU, TEMP, TST1, ULP, UNFL
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   S( LDS, NSMAX ), V( NSMAX+1 ), VV( NSMAX+1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IDAMAX, ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANHS, DLAPY2
+      EXTERNAL           LSAME, IDAMAX, ILAENV, DLAMCH, DLANHS, DLAPY2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEMV, DLABAD, DLACPY, DLAHQR, DLARFG,
+     $                   DLARFX, DLASET, DSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      WANTT = LSAME( JOB, 'S' )
+      INITZ = LSAME( COMPZ, 'I' )
+      WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
+*
+      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
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DHSEQR', -INFO )
+         RETURN
+      END IF
+*
+*     Initialize Z, if necessary
+*
+      IF( INITZ )
+     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+*
+*     Store the 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
+*
+*     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
+*
+*     Set rows and columns ILO to IHI to zero below the first
+*     subdiagonal.
+*
+      DO 40 J = ILO, IHI - 2
+         DO 30 I = J + 2, N
+            H( I, J ) = ZERO
+   30    CONTINUE
+   40 CONTINUE
+      NH = IHI - ILO + 1
+*
+*     Determine the order of the multi-shift QR algorithm to be used.
+*
+      NS = ILAENV( 4, 'DHSEQR', JOB // COMPZ, N, ILO, IHI, -1 )
+      MAXB = ILAENV( 8, 'DHSEQR', JOB // COMPZ, N, ILO, IHI, -1 )
+      IF( NS.LE.2 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN
+*
+*        Use the standard double-shift algorithm
+*
+         CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
+     $                IHI, Z, LDZ, INFO )
+         RETURN
+      END IF
+      MAXB = MAX( 3, MAXB )
+      NS = MIN( NS, MAXB, NSMAX )
+*
+*     Now 2 < NS <= MAXB < NH.
+*
+*     Set machine-dependent constants for the stopping criterion.
+*     If norm(H) <= sqrt(OVFL), overflow should not occur.
+*
+      UNFL = DLAMCH( 'Safe minimum' )
+      OVFL = ONE / UNFL
+      CALL DLABAD( UNFL, OVFL )
+      ULP = DLAMCH( 'Precision' )
+      SMLNUM = UNFL*( 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
+*
+*     ITN is the total number of multiple-shift QR iterations allowed.
+*
+      ITN = 30*NH
+*
+*     The main loop begins here. I is the loop index and decreases from
+*     IHI to ILO in steps of at most MAXB. 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
+   50 CONTINUE
+      L = ILO
+      IF( I.LT.ILO )
+     $   GO TO 170
+*
+*     Perform multiple-shift QR iterations on rows and columns ILO to I
+*     until a submatrix of order at most MAXB splits off at the bottom
+*     because a subdiagonal element has become negligible.
+*
+      DO 150 ITS = 0, ITN
+*
+*        Look for a single small subdiagonal element.
+*
+         DO 60 K = I, L + 1, -1
+            TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
+            IF( TST1.EQ.ZERO )
+     $         TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK )
+            IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) )
+     $         GO TO 70
+   60    CONTINUE
+   70    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 <= MAXB has split off.
+*
+         IF( L.GE.I-MAXB+1 )
+     $      GO TO 160
+*
+*        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.20 .OR. ITS.EQ.30 ) THEN
+*
+*           Exceptional shifts.
+*
+            DO 80 II = I - NS + 1, I
+               WR( II ) = CONST*( ABS( H( II, II-1 ) )+
+     $                    ABS( H( II, II ) ) )
+               WI( II ) = ZERO
+   80       CONTINUE
+         ELSE
+*
+*           Use eigenvalues of trailing submatrix of order NS as shifts.
+*
+            CALL DLACPY( 'Full', NS, NS, H( I-NS+1, I-NS+1 ), LDH, S,
+     $                   LDS )
+            CALL DLAHQR( .FALSE., .FALSE., NS, 1, NS, S, LDS,
+     $                   WR( I-NS+1 ), WI( I-NS+1 ), 1, NS, Z, LDZ,
+     $                   IERR )
+            IF( IERR.GT.0 ) THEN
+*
+*              If DLAHQR failed to compute all NS eigenvalues, use the
+*              unconverged diagonal elements as the remaining shifts.
+*
+               DO 90 II = 1, IERR
+                  WR( I-NS+II ) = S( II, II )
+                  WI( I-NS+II ) = ZERO
+   90          CONTINUE
+            END IF
+         END IF
+*
+*        Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
+*        where G is the Hessenberg submatrix H(L:I,L:I) and w is
+*        the vector of shifts (stored in WR and WI). The result is
+*        stored in the local array V.
+*
+         V( 1 ) = ONE
+         DO 100 II = 2, NS + 1
+            V( II ) = ZERO
+  100    CONTINUE
+         NV = 1
+         DO 120 J = I - NS + 1, I
+            IF( WI( J ).GE.ZERO ) THEN
+               IF( WI( J ).EQ.ZERO ) THEN
+*
+*                 real shift
+*
+                  CALL DCOPY( NV+1, V, 1, VV, 1 )
+                  CALL DGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ),
+     $                        LDH, VV, 1, -WR( J ), V, 1 )
+                  NV = NV + 1
+               ELSE IF( WI( J ).GT.ZERO ) THEN
+*
+*                 complex conjugate pair of shifts
+*
+                  CALL DCOPY( NV+1, V, 1, VV, 1 )
+                  CALL DGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ),
+     $                        LDH, V, 1, -TWO*WR( J ), VV, 1 )
+                  ITEMP = IDAMAX( NV+1, VV, 1 )
+                  TEMP = ONE / MAX( ABS( VV( ITEMP ) ), SMLNUM )
+                  CALL DSCAL( NV+1, TEMP, VV, 1 )
+                  ABSW = DLAPY2( WR( J ), WI( J ) )
+                  TEMP = ( TEMP*ABSW )*ABSW
+                  CALL DGEMV( 'No transpose', NV+2, NV+1, ONE,
+     $                        H( L, L ), LDH, VV, 1, TEMP, V, 1 )
+                  NV = NV + 2
+               END IF
+*
+*              Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,
+*              reset it to the unit vector.
+*
+               ITEMP = IDAMAX( NV, V, 1 )
+               TEMP = ABS( V( ITEMP ) )
+               IF( TEMP.EQ.ZERO ) THEN
+                  V( 1 ) = ONE
+                  DO 110 II = 2, NV
+                     V( II ) = ZERO
+  110             CONTINUE
+               ELSE
+                  TEMP = MAX( TEMP, SMLNUM )
+                  CALL DSCAL( NV, ONE / TEMP, V, 1 )
+               END IF
+            END IF
+  120    CONTINUE
+*
+*        Multiple-shift QR step
+*
+         DO 140 K = L, 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( NS+1, I-K+1 )
+            IF( K.GT.L )
+     $         CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 )
+            CALL DLARFG( NR, V( 1 ), V( 2 ), 1, TAU )
+            IF( K.GT.L ) THEN
+               H( K, K-1 ) = V( 1 )
+               DO 130 II = K + 1, I
+                  H( II, K-1 ) = ZERO
+  130          CONTINUE
+            END IF
+            V( 1 ) = ONE
+*
+*           Apply G from the left to transform the rows of the matrix in
+*           columns K to I2.
+*
+            CALL DLARFX( 'Left', NR, I2-K+1, V, TAU, H( K, K ), LDH,
+     $                   WORK )
+*
+*           Apply G from the right to transform the columns of the
+*           matrix in rows I1 to min(K+NR,I).
+*
+            CALL DLARFX( 'Right', MIN( K+NR, I )-I1+1, NR, V, TAU,
+     $                   H( I1, K ), LDH, WORK )
+*
+            IF( WANTZ ) THEN
+*
+*              Accumulate transformations in the matrix Z
+*
+               CALL DLARFX( 'Right', NH, NR, V, TAU, Z( ILO, K ), LDZ,
+     $                      WORK )
+            END IF
+  140    CONTINUE
+*
+  150 CONTINUE
+*
+*     Failure to converge in remaining number of iterations
+*
+      INFO = I
+      RETURN
+*
+  160 CONTINUE
+*
+*     A submatrix of order <= MAXB in rows and columns L to I has split
+*     off. Use the double-shift QR algorithm to handle it.
+*
+      CALL DLAHQR( WANTT, WANTZ, N, L, I, H, LDH, WR, WI, ILO, IHI, Z,
+     $             LDZ, INFO )
+      IF( INFO.GT.0 )
+     $   RETURN
+*
+*     Decrement number of remaining iterations, and return to start of
+*     the main loop with a new value of I.
+*
+      ITN = ITN - ITS
+      I = L - 1
+      GO TO 50
+*
+  170 CONTINUE
+      RETURN
+*
+*     End of DHSEQR
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlabad.f
@@ -0,0 +1,56 @@
+      SUBROUTINE DLABAD( SMALL, LARGE )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   LARGE, SMALL
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLABAD 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 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlabrd.f
@@ -0,0 +1,291 @@
+      SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
+     $                   LDY )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. 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     (output) 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlacon.f
@@ -0,0 +1,204 @@
+      SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. 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    (output) DOUBLE PRECISION
+*         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 TRANDPOSE(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 TRANDPOSE(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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlacpy.f
@@ -0,0 +1,88 @@
+      SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dladiv.f
@@ -0,0 +1,63 @@
+      SUBROUTINE DLADIV( A, B, C, D, P, Q )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   A, B, 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlaexc.f
@@ -0,0 +1,355 @@
+      SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK,
+     $                   INFO )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlahqr.f
@@ -0,0 +1,410 @@
+      SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
+     $                   ILOZ, IHIZ, Z, LDZ, INFO )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      LOGICAL            WANTT, WANTZ
+      INTEGER            IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
+*     ..
+*     .. 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 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 WANTT is .FALSE., the contents of H are
+*          unspecified on exit.
+*
+*  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
+*          > 0: DLAHQR failed to compute all the eigenvalues ILO to IHI
+*               in a total of 30*(IHI-ILO+1) iterations; if INFO = i,
+*               elements i+1:ihi of WR and WI contain those eigenvalues
+*               which have been successfully computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      DOUBLE PRECISION   DAT1, DAT2
+      PARAMETER          ( DAT1 = 0.75D+0, DAT2 = -0.4375D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I1, I2, ITN, ITS, J, K, L, M, NH, NR, NZ
+      DOUBLE PRECISION   CS, H00, H10, H11, H12, H21, H22, H33, H33S,
+     $                   H43H34, H44, H44S, OVFL, S, SMLNUM, SN, SUM,
+     $                   T1, T2, T3, TST1, ULP, UNFL, V1, V2, V3
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   V( 3 ), WORK( 1 )
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, DLANHS
+      EXTERNAL           DLAMCH, DLANHS
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLABAD, DLANV2, DLARFG, DROT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. 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
+*
+      NH = IHI - ILO + 1
+      NZ = IHIZ - ILOZ + 1
+*
+*     Set machine-dependent constants for the stopping criterion.
+*     If norm(H) <= sqrt(OVFL), overflow should not occur.
+*
+      UNFL = DLAMCH( 'Safe minimum' )
+      OVFL = ONE / UNFL
+      CALL DLABAD( UNFL, OVFL )
+      ULP = DLAMCH( 'Precision' )
+      SMLNUM = UNFL*( 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
+*
+*     ITN is the total number of QR iterations allowed.
+*
+      ITN = 30*NH
+*
+*     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
+   10 CONTINUE
+      L = ILO
+      IF( I.LT.ILO )
+     $   GO TO 150
+*
+*     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 130 ITS = 0, ITN
+*
+*        Look for a single small subdiagonal element.
+*
+         DO 20 K = I, L + 1, -1
+            TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
+            IF( TST1.EQ.ZERO )
+     $         TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK )
+            IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) )
+     $         GO TO 30
+   20    CONTINUE
+   30    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 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 = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) )
+            H44 = DAT1*S
+            H33 = H44
+            H43H34 = DAT2*S*S
+         ELSE
+*
+*           Prepare to use Wilkinson's double shift
+*
+            H44 = H( I, I )
+            H33 = H( I-1, I-1 )
+            H43H34 = H( I, I-1 )*H( I-1, I )
+         END IF
+*
+*        Look for two consecutive small subdiagonal elements.
+*
+         DO 40 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.
+*
+            H11 = H( M, M )
+            H22 = H( M+1, M+1 )
+            H21 = H( M+1, M )
+            H12 = H( M, M+1 )
+            H44S = H44 - H11
+            H33S = H33 - H11
+            V1 = ( H33S*H44S-H43H34 ) / H21 + H12
+            V2 = H22 - H11 - H33S - H44S
+            V3 = H( M+2, M+1 )
+            S = ABS( V1 ) + ABS( V2 ) + ABS( V3 )
+            V1 = V1 / S
+            V2 = V2 / S
+            V3 = V3 / S
+            V( 1 ) = V1
+            V( 2 ) = V2
+            V( 3 ) = V3
+            IF( M.EQ.L )
+     $         GO TO 50
+            H00 = H( M-1, M-1 )
+            H10 = H( M, M-1 )
+            TST1 = ABS( V1 )*( ABS( H00 )+ABS( H11 )+ABS( H22 ) )
+            IF( ABS( H10 )*( ABS( V2 )+ABS( V3 ) ).LE.ULP*TST1 )
+     $         GO TO 50
+   40    CONTINUE
+   50    CONTINUE
+*
+*        Double-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. 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 60 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
+   60          CONTINUE
+*
+*              Apply G from the right to transform the columns of the
+*              matrix in rows I1 to min(K+3,I).
+*
+               DO 70 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
+   70          CONTINUE
+*
+               IF( WANTZ ) THEN
+*
+*                 Accumulate transformations in the matrix Z
+*
+                  DO 80 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
+   80             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 90 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
+   90          CONTINUE
+*
+*              Apply G from the right to transform the columns of the
+*              matrix in rows I1 to min(K+3,I).
+*
+               DO 100 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
+  100          CONTINUE
+*
+               IF( WANTZ ) THEN
+*
+*                 Accumulate transformations in the matrix Z
+*
+                  DO 110 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
+  110             CONTINUE
+               END IF
+            END IF
+  120    CONTINUE
+*
+  130 CONTINUE
+*
+*     Failure to converge in remaining number of iterations
+*
+      INFO = I
+      RETURN
+*
+  140 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
+*
+*     Decrement number of remaining iterations, and return to start of
+*     the main loop with new value of I.
+*
+      ITN = ITN - ITS
+      I = L - 1
+      GO TO 10
+*
+  150 CONTINUE
+      RETURN
+*
+*     End of DLAHQR
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlahrd.f
@@ -0,0 +1,206 @@
+      SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. 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 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.
+*
+*  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 (NB,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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlaln2.f
@@ -0,0 +1,508 @@
+      SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B,
+     $                   LDB, WR, WI, X, LDX, SCALE, XNORM, INFO )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      LOGICAL            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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlamc1.f
@@ -0,0 +1,187 @@
+*
+************************************************************************
+*
+      SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      LOGICAL            IEEE1, RND
+      INTEGER            BETA, T
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAMC1 determines the machine parameters given by BETA, T, RND, and
+*  IEEE1.
+*
+*  Arguments
+*  =========
+*
+*  BETA    (output) INTEGER
+*          The base of the machine.
+*
+*  T       (output) INTEGER
+*          The number of ( BETA ) digits in the mantissa.
+*
+*  RND     (output) LOGICAL
+*          Specifies whether proper rounding  ( RND = .TRUE. )  or
+*          chopping  ( RND = .FALSE. )  occurs in addition. This may not
+*          be a reliable guide to the way in which the machine performs
+*          its arithmetic.
+*
+*  IEEE1   (output) LOGICAL
+*          Specifies whether rounding appears to be done in the IEEE
+*          'round to nearest' style.
+*
+*  Further Details
+*  ===============
+*
+*  The routine is based on the routine  ENVRON  by Malcolm and
+*  incorporates suggestions by Gentleman and Marovich. See
+*
+*     Malcolm M. A. (1972) Algorithms to reveal properties of
+*        floating-point arithmetic. Comms. of the ACM, 15, 949-951.
+*
+*     Gentleman W. M. and Marovich S. B. (1974) More on algorithms
+*        that reveal properties of floating point arithmetic units.
+*        Comms. of the ACM, 17, 276-277.
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            FIRST, LIEEE1, LRND
+      INTEGER            LBETA, LT
+      DOUBLE PRECISION   A, B, C, F, ONE, QTR, SAVEC, T1, T2
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMC3
+      EXTERNAL           DLAMC3
+*     ..
+*     .. Save statement ..
+      SAVE               FIRST, LIEEE1, LBETA, LRND, LT
+*     ..
+*     .. Data statements ..
+      DATA               FIRST / .TRUE. /
+*     ..
+*     .. Executable Statements ..
+*
+      IF( FIRST ) THEN
+         FIRST = .FALSE.
+         ONE = 1
+*
+*        LBETA,  LIEEE1,  LT and  LRND  are the  local values  of  BETA,
+*        IEEE1, T and RND.
+*
+*        Throughout this routine  we use the function  DLAMC3  to ensure
+*        that relevant values are  stored and not held in registers,  or
+*        are not affected by optimizers.
+*
+*        Compute  a = 2.0**m  with the  smallest positive integer m such
+*        that
+*
+*           fl( a + 1.0 ) = a.
+*
+         A = 1
+         C = 1
+*
+*+       WHILE( C.EQ.ONE )LOOP
+   10    CONTINUE
+         IF( C.EQ.ONE ) THEN
+            A = 2*A
+            C = DLAMC3( A, ONE )
+            C = DLAMC3( C, -A )
+            GO TO 10
+         END IF
+*+       END WHILE
+*
+*        Now compute  b = 2.0**m  with the smallest positive integer m
+*        such that
+*
+*           fl( a + b ) .gt. a.
+*
+         B = 1
+         C = DLAMC3( A, B )
+*
+*+       WHILE( C.EQ.A )LOOP
+   20    CONTINUE
+         IF( C.EQ.A ) THEN
+            B = 2*B
+            C = DLAMC3( A, B )
+            GO TO 20
+         END IF
+*+       END WHILE
+*
+*        Now compute the base.  a and c  are neighbouring floating point
+*        numbers  in the  interval  ( beta**t, beta**( t + 1 ) )  and so
+*        their difference is beta. Adding 0.25 to c is to ensure that it
+*        is truncated to beta and not ( beta - 1 ).
+*
+         QTR = ONE / 4
+         SAVEC = C
+         C = DLAMC3( C, -A )
+         LBETA = C + QTR
+*
+*        Now determine whether rounding or chopping occurs,  by adding a
+*        bit  less  than  beta/2  and a  bit  more  than  beta/2  to  a.
+*
+         B = LBETA
+         F = DLAMC3( B / 2, -B / 100 )
+         C = DLAMC3( F, A )
+         IF( C.EQ.A ) THEN
+            LRND = .TRUE.
+         ELSE
+            LRND = .FALSE.
+         END IF
+         F = DLAMC3( B / 2, B / 100 )
+         C = DLAMC3( F, A )
+         IF( ( LRND ) .AND. ( C.EQ.A ) )
+     $      LRND = .FALSE.
+*
+*        Try and decide whether rounding is done in the  IEEE  'round to
+*        nearest' style. B/2 is half a unit in the last place of the two
+*        numbers A and SAVEC. Furthermore, A is even, i.e. has last  bit
+*        zero, and SAVEC is odd. Thus adding B/2 to A should not  change
+*        A, but adding B/2 to SAVEC should change SAVEC.
+*
+         T1 = DLAMC3( B / 2, A )
+         T2 = DLAMC3( B / 2, SAVEC )
+         LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
+*
+*        Now find  the  mantissa, t.  It should  be the  integer part of
+*        log to the base beta of a,  however it is safer to determine  t
+*        by powering.  So we find t as the smallest positive integer for
+*        which
+*
+*           fl( beta**t + 1.0 ) = 1.0.
+*
+         LT = 0
+         A = 1
+         C = 1
+*
+*+       WHILE( C.EQ.ONE )LOOP
+   30    CONTINUE
+         IF( C.EQ.ONE ) THEN
+            LT = LT + 1
+            A = A*LBETA
+            C = DLAMC3( A, ONE )
+            C = DLAMC3( C, -A )
+            GO TO 30
+         END IF
+*+       END WHILE
+*
+      END IF
+*
+      BETA = LBETA
+      T = LT
+      RND = LRND
+      IEEE1 = LIEEE1
+      RETURN
+*
+*     End of DLAMC1
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlamc2.f
@@ -0,0 +1,259 @@
+*
+************************************************************************
+*
+      SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      LOGICAL            RND
+      INTEGER            BETA, EMAX, EMIN, T
+      DOUBLE PRECISION   EPS, RMAX, RMIN
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAMC2 determines the machine parameters specified in its argument
+*  list.
+*
+*  Arguments
+*  =========
+*
+*  BETA    (output) INTEGER
+*          The base of the machine.
+*
+*  T       (output) INTEGER
+*          The number of ( BETA ) digits in the mantissa.
+*
+*  RND     (output) LOGICAL
+*          Specifies whether proper rounding  ( RND = .TRUE. )  or
+*          chopping  ( RND = .FALSE. )  occurs in addition. This may not
+*          be a reliable guide to the way in which the machine performs
+*          its arithmetic.
+*
+*  EPS     (output) DOUBLE PRECISION
+*          The smallest positive number such that
+*
+*             fl( 1.0 - EPS ) .LT. 1.0,
+*
+*          where fl denotes the computed value.
+*
+*  EMIN    (output) INTEGER
+*          The minimum exponent before (gradual) underflow occurs.
+*
+*  RMIN    (output) DOUBLE PRECISION
+*          The smallest normalized number for the machine, given by
+*          BASE**( EMIN - 1 ), where  BASE  is the floating point value
+*          of BETA.
+*
+*  EMAX    (output) INTEGER
+*          The maximum exponent before overflow occurs.
+*
+*  RMAX    (output) DOUBLE PRECISION
+*          The largest positive number for the machine, given by
+*          BASE**EMAX * ( 1 - EPS ), where  BASE  is the floating point
+*          value of BETA.
+*
+*  Further Details
+*  ===============
+*
+*  The computation of  EPS  is based on a routine PARANOIA by
+*  W. Kahan of the University of California at Berkeley.
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            FIRST, IEEE, IWARN, LIEEE1, LRND
+      INTEGER            GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
+     $                   NGNMIN, NGPMIN
+      DOUBLE PRECISION   A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
+     $                   SIXTH, SMALL, THIRD, TWO, ZERO
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMC3
+      EXTERNAL           DLAMC3
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAMC1, DLAMC4, DLAMC5
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Save statement ..
+      SAVE               FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,
+     $                   LRMIN, LT
+*     ..
+*     .. Data statements ..
+      DATA               FIRST / .TRUE. / , IWARN / .FALSE. /
+*     ..
+*     .. Executable Statements ..
+*
+      IF( FIRST ) THEN
+         FIRST = .FALSE.
+         ZERO = 0
+         ONE = 1
+         TWO = 2
+*
+*        LBETA, LT, LRND, LEPS, LEMIN and LRMIN  are the local values of
+*        BETA, T, RND, EPS, EMIN and RMIN.
+*
+*        Throughout this routine  we use the function  DLAMC3  to ensure
+*        that relevant values are stored  and not held in registers,  or
+*        are not affected by optimizers.
+*
+*        DLAMC1 returns the parameters  LBETA, LT, LRND and LIEEE1.
+*
+         CALL DLAMC1( LBETA, LT, LRND, LIEEE1 )
+*
+*        Start to find EPS.
+*
+         B = LBETA
+         A = B**( -LT )
+         LEPS = A
+*
+*        Try some tricks to see whether or not this is the correct  EPS.
+*
+         B = TWO / 3
+         HALF = ONE / 2
+         SIXTH = DLAMC3( B, -HALF )
+         THIRD = DLAMC3( SIXTH, SIXTH )
+         B = DLAMC3( THIRD, -HALF )
+         B = DLAMC3( B, SIXTH )
+         B = ABS( B )
+         IF( B.LT.LEPS )
+     $      B = LEPS
+*
+         LEPS = 1
+*
+*+       WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
+   10    CONTINUE
+         IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
+            LEPS = B
+            C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
+            C = DLAMC3( HALF, -C )
+            B = DLAMC3( HALF, C )
+            C = DLAMC3( HALF, -B )
+            B = DLAMC3( HALF, C )
+            GO TO 10
+         END IF
+*+       END WHILE
+*
+         IF( A.LT.LEPS )
+     $      LEPS = A
+*
+*        Computation of EPS complete.
+*
+*        Now find  EMIN.  Let A = + or - 1, and + or - (1 + BASE**(-3)).
+*        Keep dividing  A by BETA until (gradual) underflow occurs. This
+*        is detected when we cannot recover the previous A.
+*
+         RBASE = ONE / LBETA
+         SMALL = ONE
+         DO 20 I = 1, 3
+            SMALL = DLAMC3( SMALL*RBASE, ZERO )
+   20    CONTINUE
+         A = DLAMC3( ONE, SMALL )
+         CALL DLAMC4( NGPMIN, ONE, LBETA )
+         CALL DLAMC4( NGNMIN, -ONE, LBETA )
+         CALL DLAMC4( GPMIN, A, LBETA )
+         CALL DLAMC4( GNMIN, -A, LBETA )
+         IEEE = .FALSE.
+*
+         IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
+            IF( NGPMIN.EQ.GPMIN ) THEN
+               LEMIN = NGPMIN
+*            ( Non twos-complement machines, no gradual underflow;
+*              e.g.,  VAX )
+            ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
+               LEMIN = NGPMIN - 1 + LT
+               IEEE = .TRUE.
+*            ( Non twos-complement machines, with gradual underflow;
+*              e.g., IEEE standard followers )
+            ELSE
+               LEMIN = MIN( NGPMIN, GPMIN )
+*            ( A guess; no known machine )
+               IWARN = .TRUE.
+            END IF
+*
+         ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
+            IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
+               LEMIN = MAX( NGPMIN, NGNMIN )
+*            ( Twos-complement machines, no gradual underflow;
+*              e.g., CYBER 205 )
+            ELSE
+               LEMIN = MIN( NGPMIN, NGNMIN )
+*            ( A guess; no known machine )
+               IWARN = .TRUE.
+            END IF
+*
+         ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.
+     $            ( GPMIN.EQ.GNMIN ) ) THEN
+            IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
+               LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
+*            ( Twos-complement machines with gradual underflow;
+*              no known machine )
+            ELSE
+               LEMIN = MIN( NGPMIN, NGNMIN )
+*            ( A guess; no known machine )
+               IWARN = .TRUE.
+            END IF
+*
+         ELSE
+            LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
+*         ( A guess; no known machine )
+            IWARN = .TRUE.
+         END IF
+***
+* Comment out this if block if EMIN is ok
+         IF( IWARN ) THEN
+            FIRST = .TRUE.
+            WRITE( 6, FMT = 9999 )LEMIN
+         END IF
+***
+*
+*        Assume IEEE arithmetic if we found denormalised  numbers above,
+*        or if arithmetic seems to round in the  IEEE style,  determined
+*        in routine DLAMC1. A true IEEE machine should have both  things
+*        true; however, faulty machines may have one or the other.
+*
+         IEEE = IEEE .OR. LIEEE1
+*
+*        Compute  RMIN by successive division by  BETA. We could compute
+*        RMIN as BASE**( EMIN - 1 ),  but some machines underflow during
+*        this computation.
+*
+         LRMIN = 1
+         DO 30 I = 1, 1 - LEMIN
+            LRMIN = DLAMC3( LRMIN*RBASE, ZERO )
+   30    CONTINUE
+*
+*        Finally, call DLAMC5 to compute EMAX and RMAX.
+*
+         CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
+      END IF
+*
+      BETA = LBETA
+      T = LT
+      RND = LRND
+      EPS = LEPS
+      EMIN = LEMIN
+      RMIN = LRMIN
+      EMAX = LEMAX
+      RMAX = LRMAX
+*
+      RETURN
+*
+ 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
+     $      '  EMIN = ', I8, /
+     $      ' If, after inspection, the value EMIN looks',
+     $      ' acceptable please comment out ',
+     $      / ' the IF block as marked within the code of routine',
+     $      ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / )
+*
+*     End of DLAMC2
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlamc3.f
@@ -0,0 +1,38 @@
+*
+************************************************************************
+*
+      DOUBLE PRECISION FUNCTION DLAMC3( A, B )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   A, B
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAMC3  is intended to force  A  and  B  to be stored prior to doing
+*  the addition of  A  and  B ,  for use in situations where optimizers
+*  might hold one of these in a register.
+*
+*  Arguments
+*  =========
+*
+*  A, B    (input) DOUBLE PRECISION
+*          The values A and B.
+*
+* =====================================================================
+*
+*     .. Executable Statements ..
+*
+      DLAMC3 = A + B
+*
+      RETURN
+*
+*     End of DLAMC3
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlamc4.f
@@ -0,0 +1,84 @@
+*
+************************************************************************
+*
+      SUBROUTINE DLAMC4( EMIN, START, BASE )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      INTEGER            BASE, EMIN
+      DOUBLE PRECISION   START
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAMC4 is a service routine for DLAMC2.
+*
+*  Arguments
+*  =========
+*
+*  EMIN    (output) EMIN
+*          The minimum exponent before (gradual) underflow, computed by
+*          setting A = START and dividing by BASE until the previous A
+*          can not be recovered.
+*
+*  START   (input) DOUBLE PRECISION
+*          The starting point for determining EMIN.
+*
+*  BASE    (input) INTEGER
+*          The base of the machine.
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I
+      DOUBLE PRECISION   A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMC3
+      EXTERNAL           DLAMC3
+*     ..
+*     .. Executable Statements ..
+*
+      A = START
+      ONE = 1
+      RBASE = ONE / BASE
+      ZERO = 0
+      EMIN = 1
+      B1 = DLAMC3( A*RBASE, ZERO )
+      C1 = A
+      C2 = A
+      D1 = A
+      D2 = A
+*+    WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
+*    $       ( D1.EQ.A ).AND.( D2.EQ.A )      )LOOP
+   10 CONTINUE
+      IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.
+     $    ( D2.EQ.A ) ) THEN
+         EMIN = EMIN - 1
+         A = B1
+         B1 = DLAMC3( A / BASE, ZERO )
+         C1 = DLAMC3( B1*BASE, ZERO )
+         D1 = ZERO
+         DO 20 I = 1, BASE
+            D1 = D1 + B1
+   20    CONTINUE
+         B2 = DLAMC3( A*RBASE, ZERO )
+         C2 = DLAMC3( B2 / RBASE, ZERO )
+         D2 = ZERO
+         DO 30 I = 1, BASE
+            D2 = D2 + B2
+   30    CONTINUE
+         GO TO 10
+      END IF
+*+    END WHILE
+*
+      RETURN
+*
+*     End of DLAMC4
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlamc5.f
@@ -0,0 +1,162 @@
+*
+************************************************************************
+*
+      SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      LOGICAL            IEEE
+      INTEGER            BETA, EMAX, EMIN, P
+      DOUBLE PRECISION   RMAX
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAMC5 attempts to compute RMAX, the largest machine floating-point
+*  number, without overflow.  It assumes that EMAX + abs(EMIN) sum
+*  approximately to a power of 2.  It will fail on machines where this
+*  assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
+*  EMAX = 28718).  It will also fail if the value supplied for EMIN is
+*  too large (i.e. too close to zero), probably with overflow.
+*
+*  Arguments
+*  =========
+*
+*  BETA    (input) INTEGER
+*          The base of floating-point arithmetic.
+*
+*  P       (input) INTEGER
+*          The number of base BETA digits in the mantissa of a
+*          floating-point value.
+*
+*  EMIN    (input) INTEGER
+*          The minimum exponent before (gradual) underflow.
+*
+*  IEEE    (input) LOGICAL
+*          A logical flag specifying whether or not the arithmetic
+*          system is thought to comply with the IEEE standard.
+*
+*  EMAX    (output) INTEGER
+*          The largest exponent before overflow
+*
+*  RMAX    (output) DOUBLE PRECISION
+*          The largest machine floating-point number.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
+      DOUBLE PRECISION   OLDY, RECBAS, Y, Z
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMC3
+      EXTERNAL           DLAMC3
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MOD
+*     ..
+*     .. Executable Statements ..
+*
+*     First compute LEXP and UEXP, two powers of 2 that bound
+*     abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
+*     approximately to the bound that is closest to abs(EMIN).
+*     (EMAX is the exponent of the required number RMAX).
+*
+      LEXP = 1
+      EXBITS = 1
+   10 CONTINUE
+      TRY = LEXP*2
+      IF( TRY.LE.( -EMIN ) ) THEN
+         LEXP = TRY
+         EXBITS = EXBITS + 1
+         GO TO 10
+      END IF
+      IF( LEXP.EQ.-EMIN ) THEN
+         UEXP = LEXP
+      ELSE
+         UEXP = TRY
+         EXBITS = EXBITS + 1
+      END IF
+*
+*     Now -LEXP is less than or equal to EMIN, and -UEXP is greater
+*     than or equal to EMIN. EXBITS is the number of bits needed to
+*     store the exponent.
+*
+      IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
+         EXPSUM = 2*LEXP
+      ELSE
+         EXPSUM = 2*UEXP
+      END IF
+*
+*     EXPSUM is the exponent range, approximately equal to
+*     EMAX - EMIN + 1 .
+*
+      EMAX = EXPSUM + EMIN - 1
+      NBITS = 1 + EXBITS + P
+*
+*     NBITS is the total number of bits needed to store a
+*     floating-point number.
+*
+      IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
+*
+*        Either there are an odd number of bits used to store a
+*        floating-point number, which is unlikely, or some bits are
+*        not used in the representation of numbers, which is possible,
+*        (e.g. Cray machines) or the mantissa has an implicit bit,
+*        (e.g. IEEE machines, Dec Vax machines), which is perhaps the
+*        most likely. We have to assume the last alternative.
+*        If this is true, then we need to reduce EMAX by one because
+*        there must be some way of representing zero in an implicit-bit
+*        system. On machines like Cray, we are reducing EMAX by one
+*        unnecessarily.
+*
+         EMAX = EMAX - 1
+      END IF
+*
+      IF( IEEE ) THEN
+*
+*        Assume we are on an IEEE machine which reserves one exponent
+*        for infinity and NaN.
+*
+         EMAX = EMAX - 1
+      END IF
+*
+*     Now create RMAX, the largest machine number, which should
+*     be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
+*
+*     First compute 1.0 - BETA**(-P), being careful that the
+*     result is less than 1.0 .
+*
+      RECBAS = ONE / BETA
+      Z = BETA - ONE
+      Y = ZERO
+      DO 20 I = 1, P
+         Z = Z*RECBAS
+         IF( Y.LT.ONE )
+     $      OLDY = Y
+         Y = DLAMC3( Y, Z )
+   20 CONTINUE
+      IF( Y.GE.ONE )
+     $   Y = OLDY
+*
+*     Now multiply by BETA**EMAX to get RMAX.
+*
+      DO 30 I = 1, EMAX
+         Y = DLAMC3( Y*BETA, ZERO )
+   30 CONTINUE
+*
+      RMAX = Y
+      RETURN
+*
+*     End of DLAMC5
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlamch.f
@@ -0,0 +1,127 @@
+      DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      CHARACTER          CMACH
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAMCH determines double precision machine parameters.
+*
+*  Arguments
+*  =========
+*
+*  CMACH   (input) CHARACTER*1
+*          Specifies the value to be returned by DLAMCH:
+*          = 'E' or 'e',   DLAMCH := eps
+*          = 'S' or 's ,   DLAMCH := sfmin
+*          = 'B' or 'b',   DLAMCH := base
+*          = 'P' or 'p',   DLAMCH := eps*base
+*          = 'N' or 'n',   DLAMCH := t
+*          = 'R' or 'r',   DLAMCH := rnd
+*          = 'M' or 'm',   DLAMCH := emin
+*          = 'U' or 'u',   DLAMCH := rmin
+*          = 'L' or 'l',   DLAMCH := emax
+*          = 'O' or 'o',   DLAMCH := rmax
+*
+*          where
+*
+*          eps   = relative machine precision
+*          sfmin = safe minimum, such that 1/sfmin does not overflow
+*          base  = base of the machine
+*          prec  = eps*base
+*          t     = number of (base) digits in the mantissa
+*          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise
+*          emin  = minimum exponent before (gradual) underflow
+*          rmin  = underflow threshold - base**(emin-1)
+*          emax  = largest exponent before overflow
+*          rmax  = overflow threshold  - (base**emax)*(1-eps)
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            FIRST, LRND
+      INTEGER            BETA, IMAX, IMIN, IT
+      DOUBLE PRECISION   BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,
+     $                   RND, SFMIN, SMALL, T
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAMC2
+*     ..
+*     .. Save statement ..
+      SAVE               FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,
+     $                   EMAX, RMAX, PREC
+*     ..
+*     .. Data statements ..
+      DATA               FIRST / .TRUE. /
+*     ..
+*     .. Executable Statements ..
+*
+      IF( FIRST ) THEN
+         FIRST = .FALSE.
+         CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
+         BASE = BETA
+         T = IT
+         IF( LRND ) THEN
+            RND = ONE
+            EPS = ( BASE**( 1-IT ) ) / 2
+         ELSE
+            RND = ZERO
+            EPS = BASE**( 1-IT )
+         END IF
+         PREC = EPS*BASE
+         EMIN = IMIN
+         EMAX = IMAX
+         SFMIN = RMIN
+         SMALL = ONE / RMAX
+         IF( SMALL.GE.SFMIN ) THEN
+*
+*           Use SMALL plus a bit, to avoid the possibility of rounding
+*           causing overflow when computing  1/sfmin.
+*
+            SFMIN = SMALL*( ONE+EPS )
+         END IF
+      END IF
+*
+      IF( LSAME( CMACH, 'E' ) ) THEN
+         RMACH = EPS
+      ELSE IF( LSAME( CMACH, 'S' ) ) THEN
+         RMACH = SFMIN
+      ELSE IF( LSAME( CMACH, 'B' ) ) THEN
+         RMACH = BASE
+      ELSE IF( LSAME( CMACH, 'P' ) ) THEN
+         RMACH = PREC
+      ELSE IF( LSAME( CMACH, 'N' ) ) THEN
+         RMACH = T
+      ELSE IF( LSAME( CMACH, 'R' ) ) THEN
+         RMACH = RND
+      ELSE IF( LSAME( CMACH, 'M' ) ) THEN
+         RMACH = EMIN
+      ELSE IF( LSAME( CMACH, 'U' ) ) THEN
+         RMACH = RMIN
+      ELSE IF( LSAME( CMACH, 'L' ) ) THEN
+         RMACH = EMAX
+      ELSE IF( LSAME( CMACH, 'O' ) ) THEN
+         RMACH = RMAX
+      END IF
+*
+      DLAMCH = RMACH
+      RETURN
+*
+*     End of DLAMCH
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlange.f
@@ -0,0 +1,145 @@
+      DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      CHARACTER          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  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 (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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlanhs.f
@@ -0,0 +1,142 @@
+      DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      CHARACTER          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  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 (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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlanv2.f
@@ -0,0 +1,175 @@
+      SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994 
+*
+*     .. 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 both real, abs(RT1R) >= abs(RT2R); if the
+*          eigenvalues are a complex conjugate pair, RT1I > 0.
+*
+*  CS      (output) DOUBLE PRECISION
+*  SN      (output) DOUBLE PRECISION
+*          Parameters of the rotation matrix.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, HALF, ONE
+      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   AA, BB, CC, CS1, DD, P, SAB, SAC, SIGMA, SN1,
+     $                   TAU, TEMP
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAPY2
+      EXTERNAL           DLAPY2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Initialize CS and SN
+*
+      CS = ONE
+      SN = ZERO
+*
+      IF( C.EQ.ZERO ) THEN
+         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
+         GO TO 10
+      ELSE
+*
+*        Make diagonal elements equal
+*
+         TEMP = A - D
+         P = HALF*TEMP
+         SIGMA = B + C
+         TAU = DLAPY2( SIGMA, TEMP )
+         CS1 = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) )
+         SN1 = -( P / ( TAU*CS1 ) )*SIGN( ONE, SIGMA )
+*
+*        Compute [ AA  BB ] = [ A  B ] [ CS1 -SN1 ]
+*                [ CC  DD ]   [ C  D ] [ SN1  CS1 ]
+*
+         AA = A*CS1 + B*SN1
+         BB = -A*SN1 + B*CS1
+         CC = C*CS1 + D*SN1
+         DD = -C*SN1 + D*CS1
+*
+*        Compute [ A  B ] = [ CS1  SN1 ] [ AA  BB ]
+*                [ C  D ]   [-SN1  CS1 ] [ CC  DD ]
+*
+         A = AA*CS1 + CC*SN1
+         B = BB*CS1 + DD*SN1
+         C = -AA*SN1 + CC*CS1
+         D = -BB*SN1 + DD*CS1
+*
+*        Accumulate transformation
+*
+         TEMP = CS*CS1 - SN*SN1
+         SN = CS*SN1 + SN*CS1
+         CS = TEMP
+*
+         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
+*
+   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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlapy2.f
@@ -0,0 +1,54 @@
+      DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlapy3.f
@@ -0,0 +1,54 @@
+      DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   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
+         DLAPY3 = ZERO
+      ELSE
+         DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+
+     $            ( ZABS / W )**2 )
+      END IF
+      RETURN
+*
+*     End of DLAPY3
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlarf.f
@@ -0,0 +1,116 @@
+      SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE
+      INTEGER            INCV, LDC, M, N
+      DOUBLE PRECISION   TAU
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARF applies a real elementary reflector H to a real m by n matrix
+*  C, from either the left or the right. H is represented in the form
+*
+*        H = I - tau * v * v'
+*
+*  where tau is a real scalar and v is a real vector.
+*
+*  If tau = 0, then H is taken to be the unit matrix.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': form  H * C
+*          = 'R': form  C * H
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C.
+*
+*  V       (input) DOUBLE PRECISION array, dimension
+*                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'
+*                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
+*          The vector v in the representation of H. V is not used if
+*          TAU = 0.
+*
+*  INCV    (input) INTEGER
+*          The increment between elements of v. INCV <> 0.
+*
+*  TAU     (input) DOUBLE PRECISION
+*          The value tau in the representation of H.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the m by n matrix C.
+*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*          or C * H if SIDE = 'R'.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension
+*                         (N) if SIDE = 'L'
+*                      or (M) if SIDE = 'R'
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMV, DGER
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+      IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*        Form  H * C
+*
+         IF( TAU.NE.ZERO ) THEN
+*
+*           w := C' * v
+*
+            CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO,
+     $                  WORK, 1 )
+*
+*           C := C - v * w'
+*
+            CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC )
+         END IF
+      ELSE
+*
+*        Form  C * H
+*
+         IF( TAU.NE.ZERO ) THEN
+*
+*           w := C * v
+*
+            CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV,
+     $                  ZERO, WORK, 1 )
+*
+*           C := C - w * v'
+*
+            CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC )
+         END IF
+      END IF
+      RETURN
+*
+*     End of DLARF
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlarfb.f
@@ -0,0 +1,588 @@
+      SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
+     $                   T, LDT, C, LDC, WORK, LDWORK )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIRECT, SIDE, STOREV, TRANS
+      INTEGER            K, LDC, LDT, LDV, LDWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( LDC, * ), T( LDT, * ), V( LDV, * ),
+     $                   WORK( LDWORK, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARFB applies a real block reflector H or its transpose H' to a
+*  real m by n matrix C, from either the left or the right.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply H or H' from the Left
+*          = 'R': apply H or H' from the Right
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N': apply H (No transpose)
+*          = 'T': apply H' (Transpose)
+*
+*  DIRECT  (input) CHARACTER*1
+*          Indicates how H is formed from a product of elementary
+*          reflectors
+*          = 'F': H = H(1) H(2) . . . H(k) (Forward)
+*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+*  STOREV  (input) CHARACTER*1
+*          Indicates how the vectors which define the elementary
+*          reflectors are stored:
+*          = 'C': Columnwise
+*          = 'R': Rowwise
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C.
+*
+*  K       (input) INTEGER
+*          The order of the matrix T (= the number of elementary
+*          reflectors whose product defines the block reflector).
+*
+*  V       (input) DOUBLE PRECISION array, dimension
+*                                (LDV,K) if STOREV = 'C'
+*                                (LDV,M) if STOREV = 'R' and SIDE = 'L'
+*                                (LDV,N) if STOREV = 'R' and SIDE = 'R'
+*          The matrix V. See further details.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V.
+*          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
+*          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
+*          if STOREV = 'R', LDV >= K.
+*
+*  T       (input) DOUBLE PRECISION array, dimension (LDT,K)
+*          The triangular k by k matrix T in the representation of the
+*          block reflector.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= K.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the m by n matrix C.
+*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDA >= max(1,M).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)
+*
+*  LDWORK  (input) INTEGER
+*          The leading dimension of the array WORK.
+*          If SIDE = 'L', LDWORK >= max(1,N);
+*          if SIDE = 'R', LDWORK >= max(1,M).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      CHARACTER          TRANST
+      INTEGER            I, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEMM, DTRMM
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 .OR. N.LE.0 )
+     $   RETURN
+*
+      IF( LSAME( TRANS, 'N' ) ) THEN
+         TRANST = 'T'
+      ELSE
+         TRANST = 'N'
+      END IF
+*
+      IF( LSAME( STOREV, 'C' ) ) THEN
+*
+         IF( LSAME( DIRECT, 'F' ) ) THEN
+*
+*           Let  V =  ( V1 )    (first K rows)
+*                     ( V2 )
+*           where  V1  is unit lower triangular.
+*
+            IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*              Form  H * C  or  H' * C  where  C = ( C1 )
+*                                                  ( C2 )
+*
+*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
+*
+*              W := C1'
+*
+               DO 10 J = 1, K
+                  CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+   10          CONTINUE
+*
+*              W := W * V1
+*
+               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+     $                     K, ONE, V, LDV, WORK, LDWORK )
+               IF( M.GT.K ) THEN
+*
+*                 W := W + C2'*V2
+*
+                  CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
+     $                        ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
+     $                        ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V * W'
+*
+               IF( M.GT.K ) THEN
+*
+*                 C2 := C2 - V2 * W'
+*
+                  CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
+     $                        -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
+     $                        C( K+1, 1 ), LDC )
+               END IF
+*
+*              W := W * V1'
+*
+               CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
+     $                     ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W'
+*
+               DO 30 J = 1, K
+                  DO 20 I = 1, N
+                     C( J, I ) = C( J, I ) - WORK( I, J )
+   20             CONTINUE
+   30          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
+*
+*              W := C1
+*
+               DO 40 J = 1, K
+                  CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
+   40          CONTINUE
+*
+*              W := W * V1
+*
+               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+     $                     K, ONE, V, LDV, WORK, LDWORK )
+               IF( N.GT.K ) THEN
+*
+*                 W := W + C2 * V2
+*
+                  CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
+     $                        ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
+     $                        ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V'
+*
+               IF( N.GT.K ) THEN
+*
+*                 C2 := C2 - W * V2'
+*
+                  CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
+     $                        -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
+     $                        C( 1, K+1 ), LDC )
+               END IF
+*
+*              W := W * V1'
+*
+               CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
+     $                     ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 60 J = 1, K
+                  DO 50 I = 1, M
+                     C( I, J ) = C( I, J ) - WORK( I, J )
+   50             CONTINUE
+   60          CONTINUE
+            END IF
+*
+         ELSE
+*
+*           Let  V =  ( V1 )
+*                     ( V2 )    (last K rows)
+*           where  V2  is unit upper triangular.
+*
+            IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*              Form  H * C  or  H' * C  where  C = ( C1 )
+*                                                  ( C2 )
+*
+*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
+*
+*              W := C2'
+*
+               DO 70 J = 1, K
+                  CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
+   70          CONTINUE
+*
+*              W := W * V2
+*
+               CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+     $                     K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
+               IF( M.GT.K ) THEN
+*
+*                 W := W + C1'*V1
+*
+                  CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
+     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V * W'
+*
+               IF( M.GT.K ) THEN
+*
+*                 C1 := C1 - V1 * W'
+*
+                  CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
+     $                        -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
+               END IF
+*
+*              W := W * V2'
+*
+               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
+     $                     ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
+*
+*              C2 := C2 - W'
+*
+               DO 90 J = 1, K
+                  DO 80 I = 1, N
+                     C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
+   80             CONTINUE
+   90          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
+*
+*              W := C2
+*
+               DO 100 J = 1, K
+                  CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
+  100          CONTINUE
+*
+*              W := W * V2
+*
+               CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+     $                     K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
+               IF( N.GT.K ) THEN
+*
+*                 W := W + C1 * V1
+*
+                  CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
+     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V'
+*
+               IF( N.GT.K ) THEN
+*
+*                 C1 := C1 - W * V1'
+*
+                  CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
+     $                        -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
+               END IF
+*
+*              W := W * V2'
+*
+               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
+     $                     ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
+*
+*              C2 := C2 - W
+*
+               DO 120 J = 1, K
+                  DO 110 I = 1, M
+                     C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
+  110             CONTINUE
+  120          CONTINUE
+            END IF
+         END IF
+*
+      ELSE IF( LSAME( STOREV, 'R' ) ) THEN
+*
+         IF( LSAME( DIRECT, 'F' ) ) THEN
+*
+*           Let  V =  ( V1  V2 )    (V1: first K columns)
+*           where  V1  is unit upper triangular.
+*
+            IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*              Form  H * C  or  H' * C  where  C = ( C1 )
+*                                                  ( C2 )
+*
+*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
+*
+*              W := C1'
+*
+               DO 130 J = 1, K
+                  CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+  130          CONTINUE
+*
+*              W := W * V1'
+*
+               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
+     $                     ONE, V, LDV, WORK, LDWORK )
+               IF( M.GT.K ) THEN
+*
+*                 W := W + C2'*V2'
+*
+                  CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
+     $                        C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
+     $                        WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V' * W'
+*
+               IF( M.GT.K ) THEN
+*
+*                 C2 := C2 - V2' * W'
+*
+                  CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
+     $                        V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
+     $                        C( K+1, 1 ), LDC )
+               END IF
+*
+*              W := W * V1
+*
+               CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+     $                     K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W'
+*
+               DO 150 J = 1, K
+                  DO 140 I = 1, N
+                     C( J, I ) = C( J, I ) - WORK( I, J )
+  140             CONTINUE
+  150          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
+*
+*              W := C1
+*
+               DO 160 J = 1, K
+                  CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
+  160          CONTINUE
+*
+*              W := W * V1'
+*
+               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
+     $                     ONE, V, LDV, WORK, LDWORK )
+               IF( N.GT.K ) THEN
+*
+*                 W := W + C2 * V2'
+*
+                  CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
+     $                        ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
+     $                        ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V
+*
+               IF( N.GT.K ) THEN
+*
+*                 C2 := C2 - W * V2
+*
+                  CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
+     $                        -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
+     $                        C( 1, K+1 ), LDC )
+               END IF
+*
+*              W := W * V1
+*
+               CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+     $                     K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 180 J = 1, K
+                  DO 170 I = 1, M
+                     C( I, J ) = C( I, J ) - WORK( I, J )
+  170             CONTINUE
+  180          CONTINUE
+*
+            END IF
+*
+         ELSE
+*
+*           Let  V =  ( V1  V2 )    (V2: last K columns)
+*           where  V2  is unit lower triangular.
+*
+            IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*              Form  H * C  or  H' * C  where  C = ( C1 )
+*                                                  ( C2 )
+*
+*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
+*
+*              W := C2'
+*
+               DO 190 J = 1, K
+                  CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
+  190          CONTINUE
+*
+*              W := W * V2'
+*
+               CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
+     $                     ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
+               IF( M.GT.K ) THEN
+*
+*                 W := W + C1'*V1'
+*
+                  CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
+     $                        C, LDC, V, LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V' * W'
+*
+               IF( M.GT.K ) THEN
+*
+*                 C1 := C1 - V1' * W'
+*
+                  CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
+     $                        V, LDV, WORK, LDWORK, ONE, C, LDC )
+               END IF
+*
+*              W := W * V2
+*
+               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+     $                     K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
+*
+*              C2 := C2 - W'
+*
+               DO 210 J = 1, K
+                  DO 200 I = 1, N
+                     C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
+  200             CONTINUE
+  210          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
+*
+*              W := C2
+*
+               DO 220 J = 1, K
+                  CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
+  220          CONTINUE
+*
+*              W := W * V2'
+*
+               CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
+     $                     ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
+               IF( N.GT.K ) THEN
+*
+*                 W := W + C1 * V1'
+*
+                  CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
+     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V
+*
+               IF( N.GT.K ) THEN
+*
+*                 C1 := C1 - W * V1
+*
+                  CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
+     $                        -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
+               END IF
+*
+*              W := W * V2
+*
+               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+     $                     K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 240 J = 1, K
+                  DO 230 I = 1, M
+                     C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
+  230             CONTINUE
+  240          CONTINUE
+*
+            END IF
+*
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DLARFB
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlarfg.f
@@ -0,0 +1,138 @@
+      SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, N
+      DOUBLE PRECISION   ALPHA, TAU
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARFG generates a real elementary reflector H of order n, such
+*  that
+*
+*        H * ( alpha ) = ( beta ),   H' * H = I.
+*            (   x   )   (   0  )
+*
+*  where alpha and beta are scalars, and x is an (n-1)-element real
+*  vector. H is represented in the form
+*
+*        H = I - tau * ( 1 ) * ( 1 v' ) ,
+*                      ( v )
+*
+*  where tau is a real scalar and v is a real (n-1)-element
+*  vector.
+*
+*  If the elements of x are all zero, then tau = 0 and H is taken to be
+*  the unit matrix.
+*
+*  Otherwise  1 <= tau <= 2.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the elementary reflector.
+*
+*  ALPHA   (input/output) DOUBLE PRECISION
+*          On entry, the value alpha.
+*          On exit, it is overwritten with the value beta.
+*
+*  X       (input/output) DOUBLE PRECISION array, dimension
+*                         (1+(N-2)*abs(INCX))
+*          On entry, the vector x.
+*          On exit, it is overwritten with the vector v.
+*
+*  INCX    (input) INTEGER
+*          The increment between elements of X. INCX > 0.
+*
+*  TAU     (output) DOUBLE PRECISION
+*          The value tau.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J, KNT
+      DOUBLE PRECISION   BETA, RSAFMN, SAFMIN, XNORM
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, DLAPY2, DNRM2
+      EXTERNAL           DLAMCH, DLAPY2, DNRM2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SIGN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.LE.1 ) THEN
+         TAU = ZERO
+         RETURN
+      END IF
+*
+      XNORM = DNRM2( N-1, X, INCX )
+*
+      IF( XNORM.EQ.ZERO ) THEN
+*
+*        H  =  I
+*
+         TAU = ZERO
+      ELSE
+*
+*        general case
+*
+         BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
+         SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
+         IF( ABS( BETA ).LT.SAFMIN ) THEN
+*
+*           XNORM, BETA may be inaccurate; scale X and recompute them
+*
+            RSAFMN = ONE / SAFMIN
+            KNT = 0
+   10       CONTINUE
+            KNT = KNT + 1
+            CALL DSCAL( N-1, RSAFMN, X, INCX )
+            BETA = BETA*RSAFMN
+            ALPHA = ALPHA*RSAFMN
+            IF( ABS( BETA ).LT.SAFMIN )
+     $         GO TO 10
+*
+*           New BETA is at most 1, at least SAFMIN
+*
+            XNORM = DNRM2( N-1, X, INCX )
+            BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
+            TAU = ( BETA-ALPHA ) / BETA
+            CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
+*
+*           If ALPHA is subnormal, it may lose relative accuracy
+*
+            ALPHA = BETA
+            DO 20 J = 1, KNT
+               ALPHA = ALPHA*SAFMIN
+   20       CONTINUE
+         ELSE
+            TAU = ( BETA-ALPHA ) / BETA
+            CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
+            ALPHA = BETA
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DLARFG
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlarft.f
@@ -0,0 +1,218 @@
+      SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIRECT, STOREV
+      INTEGER            K, LDT, LDV, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   T( LDT, * ), TAU( * ), V( LDV, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARFT forms the triangular factor T of a real block reflector H
+*  of order n, which is defined as a product of k elementary reflectors.
+*
+*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
+*
+*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
+*
+*  If STOREV = 'C', the vector which defines the elementary reflector
+*  H(i) is stored in the i-th column of the array V, and
+*
+*     H  =  I - V * T * V'
+*
+*  If STOREV = 'R', the vector which defines the elementary reflector
+*  H(i) is stored in the i-th row of the array V, and
+*
+*     H  =  I - V' * T * V
+*
+*  Arguments
+*  =========
+*
+*  DIRECT  (input) CHARACTER*1
+*          Specifies the order in which the elementary reflectors are
+*          multiplied to form the block reflector:
+*          = 'F': H = H(1) H(2) . . . H(k) (Forward)
+*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+*  STOREV  (input) CHARACTER*1
+*          Specifies how the vectors which define the elementary
+*          reflectors are stored (see also Further Details):
+*          = 'C': columnwise
+*          = 'R': rowwise
+*
+*  N       (input) INTEGER
+*          The order of the block reflector H. N >= 0.
+*
+*  K       (input) INTEGER
+*          The order of the triangular factor T (= the number of
+*          elementary reflectors). K >= 1.
+*
+*  V       (input/output) DOUBLE PRECISION array, dimension
+*                               (LDV,K) if STOREV = 'C'
+*                               (LDV,N) if STOREV = 'R'
+*          The matrix V. See further details.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V.
+*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i).
+*
+*  T       (output) DOUBLE PRECISION array, dimension (LDT,K)
+*          The k by k triangular factor T of the block reflector.
+*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
+*          lower triangular. The rest of the array is not used.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= K.
+*
+*  Further Details
+*  ===============
+*
+*  The shape of the matrix V and the storage of the vectors which define
+*  the H(i) is best illustrated by the following example with n = 5 and
+*  k = 3. The elements equal to 1 are not stored; the corresponding
+*  array elements are modified but restored on exit. The rest of the
+*  array is not used.
+*
+*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
+*
+*               V = (  1       )                 V = (  1 v1 v1 v1 v1 )
+*                   ( v1  1    )                     (     1 v2 v2 v2 )
+*                   ( v1 v2  1 )                     (        1 v3 v3 )
+*                   ( v1 v2 v3 )
+*                   ( v1 v2 v3 )
+*
+*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
+*
+*               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )
+*                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )
+*                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )
+*                   (     1 v3 )
+*                   (        1 )
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   VII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMV, DTRMV
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( LSAME( DIRECT, 'F' ) ) THEN
+         DO 20 I = 1, K
+            IF( TAU( I ).EQ.ZERO ) THEN
+*
+*              H(i)  =  I
+*
+               DO 10 J = 1, I
+                  T( J, I ) = ZERO
+   10          CONTINUE
+            ELSE
+*
+*              general case
+*
+               VII = V( I, I )
+               V( I, I ) = ONE
+               IF( LSAME( STOREV, 'C' ) ) THEN
+*
+*                 T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i)
+*
+                  CALL DGEMV( 'Transpose', N-I+1, I-1, -TAU( I ),
+     $                        V( I, 1 ), LDV, V( I, I ), 1, ZERO,
+     $                        T( 1, I ), 1 )
+               ELSE
+*
+*                 T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)'
+*
+                  CALL DGEMV( 'No transpose', I-1, N-I+1, -TAU( I ),
+     $                        V( 1, I ), LDV, V( I, I ), LDV, ZERO,
+     $                        T( 1, I ), 1 )
+               END IF
+               V( I, I ) = VII
+*
+*              T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
+*
+               CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
+     $                     LDT, T( 1, I ), 1 )
+               T( I, I ) = TAU( I )
+            END IF
+   20    CONTINUE
+      ELSE
+         DO 40 I = K, 1, -1
+            IF( TAU( I ).EQ.ZERO ) THEN
+*
+*              H(i)  =  I
+*
+               DO 30 J = I, K
+                  T( J, I ) = ZERO
+   30          CONTINUE
+            ELSE
+*
+*              general case
+*
+               IF( I.LT.K ) THEN
+                  IF( LSAME( STOREV, 'C' ) ) THEN
+                     VII = V( N-K+I, I )
+                     V( N-K+I, I ) = ONE
+*
+*                    T(i+1:k,i) :=
+*                            - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i)
+*
+                     CALL DGEMV( 'Transpose', N-K+I, K-I, -TAU( I ),
+     $                           V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO,
+     $                           T( I+1, I ), 1 )
+                     V( N-K+I, I ) = VII
+                  ELSE
+                     VII = V( I, N-K+I )
+                     V( I, N-K+I ) = ONE
+*
+*                    T(i+1:k,i) :=
+*                            - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)'
+*
+                     CALL DGEMV( 'No transpose', K-I, N-K+I, -TAU( I ),
+     $                           V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO,
+     $                           T( I+1, I ), 1 )
+                     V( I, N-K+I ) = VII
+                  END IF
+*
+*                 T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
+*
+                  CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
+     $                        T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
+               END IF
+               T( I, I ) = TAU( I )
+            END IF
+   40    CONTINUE
+      END IF
+      RETURN
+*
+*     End of DLARFT
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlarfx.f
@@ -0,0 +1,639 @@
+      SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE
+      INTEGER            LDC, M, N
+      DOUBLE PRECISION   TAU
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARFX applies a real elementary reflector H to a real m by n
+*  matrix C, from either the left or the right. H is represented in the
+*  form
+*
+*        H = I - tau * v * v'
+*
+*  where tau is a real scalar and v is a real vector.
+*
+*  If tau = 0, then H is taken to be the unit matrix
+*
+*  This version uses inline code if H has order < 11.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': form  H * C
+*          = 'R': form  C * H
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C.
+*
+*  V       (input) DOUBLE PRECISION array, dimension (M) if SIDE = 'L'
+*                                     or (N) if SIDE = 'R'
+*          The vector v in the representation of H.
+*
+*  TAU     (input) DOUBLE PRECISION
+*          The value tau in the representation of H.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the m by n matrix C.
+*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*          or C * H if SIDE = 'R'.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDA >= (1,M).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension
+*                      (N) if SIDE = 'L'
+*                      or (M) if SIDE = 'R'
+*          WORK is not referenced if H has order < 11.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J
+      DOUBLE PRECISION   SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9,
+     $                   V1, V10, V2, V3, V4, V5, V6, V7, V8, V9
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMV, DGER
+*     ..
+*     .. Executable Statements ..
+*
+      IF( TAU.EQ.ZERO )
+     $   RETURN
+      IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*        Form  H * C, where H has order m.
+*
+         GO TO ( 10, 30, 50, 70, 90, 110, 130, 150,
+     $           170, 190 )M
+*
+*        Code for general M
+*
+*        w := C'*v
+*
+         CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, 1, ZERO, WORK,
+     $               1 )
+*
+*        C := C - tau * v * w'
+*
+         CALL DGER( M, N, -TAU, V, 1, WORK, 1, C, LDC )
+         GO TO 410
+   10    CONTINUE
+*
+*        Special code for 1 x 1 Householder
+*
+         T1 = ONE - TAU*V( 1 )*V( 1 )
+         DO 20 J = 1, N
+            C( 1, J ) = T1*C( 1, J )
+   20    CONTINUE
+         GO TO 410
+   30    CONTINUE
+*
+*        Special code for 2 x 2 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         DO 40 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+   40    CONTINUE
+         GO TO 410
+   50    CONTINUE
+*
+*        Special code for 3 x 3 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         DO 60 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+   60    CONTINUE
+         GO TO 410
+   70    CONTINUE
+*
+*        Special code for 4 x 4 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         DO 80 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+   80    CONTINUE
+         GO TO 410
+   90    CONTINUE
+*
+*        Special code for 5 x 5 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         DO 100 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+  100    CONTINUE
+         GO TO 410
+  110    CONTINUE
+*
+*        Special code for 6 x 6 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         DO 120 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+  120    CONTINUE
+         GO TO 410
+  130    CONTINUE
+*
+*        Special code for 7 x 7 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         DO 140 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+  140    CONTINUE
+         GO TO 410
+  150    CONTINUE
+*
+*        Special code for 8 x 8 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         DO 160 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+  160    CONTINUE
+         GO TO 410
+  170    CONTINUE
+*
+*        Special code for 9 x 9 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         V9 = V( 9 )
+         T9 = TAU*V9
+         DO 180 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+            C( 9, J ) = C( 9, J ) - SUM*T9
+  180    CONTINUE
+         GO TO 410
+  190    CONTINUE
+*
+*        Special code for 10 x 10 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         V9 = V( 9 )
+         T9 = TAU*V9
+         V10 = V( 10 )
+         T10 = TAU*V10
+         DO 200 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) +
+     $            V10*C( 10, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+            C( 9, J ) = C( 9, J ) - SUM*T9
+            C( 10, J ) = C( 10, J ) - SUM*T10
+  200    CONTINUE
+         GO TO 410
+      ELSE
+*
+*        Form  C * H, where H has order n.
+*
+         GO TO ( 210, 230, 250, 270, 290, 310, 330, 350,
+     $           370, 390 )N
+*
+*        Code for general N
+*
+*        w := C * v
+*
+         CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, 1, ZERO,
+     $               WORK, 1 )
+*
+*        C := C - tau * w * v'
+*
+         CALL DGER( M, N, -TAU, WORK, 1, V, 1, C, LDC )
+         GO TO 410
+  210    CONTINUE
+*
+*        Special code for 1 x 1 Householder
+*
+         T1 = ONE - TAU*V( 1 )*V( 1 )
+         DO 220 J = 1, M
+            C( J, 1 ) = T1*C( J, 1 )
+  220    CONTINUE
+         GO TO 410
+  230    CONTINUE
+*
+*        Special code for 2 x 2 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         DO 240 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+  240    CONTINUE
+         GO TO 410
+  250    CONTINUE
+*
+*        Special code for 3 x 3 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         DO 260 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+  260    CONTINUE
+         GO TO 410
+  270    CONTINUE
+*
+*        Special code for 4 x 4 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         DO 280 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+  280    CONTINUE
+         GO TO 410
+  290    CONTINUE
+*
+*        Special code for 5 x 5 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         DO 300 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+  300    CONTINUE
+         GO TO 410
+  310    CONTINUE
+*
+*        Special code for 6 x 6 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         DO 320 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+  320    CONTINUE
+         GO TO 410
+  330    CONTINUE
+*
+*        Special code for 7 x 7 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         DO 340 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+  340    CONTINUE
+         GO TO 410
+  350    CONTINUE
+*
+*        Special code for 8 x 8 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         DO 360 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 ) + V8*C( J, 8 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+            C( J, 8 ) = C( J, 8 ) - SUM*T8
+  360    CONTINUE
+         GO TO 410
+  370    CONTINUE
+*
+*        Special code for 9 x 9 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         V9 = V( 9 )
+         T9 = TAU*V9
+         DO 380 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+            C( J, 8 ) = C( J, 8 ) - SUM*T8
+            C( J, 9 ) = C( J, 9 ) - SUM*T9
+  380    CONTINUE
+         GO TO 410
+  390    CONTINUE
+*
+*        Special code for 10 x 10 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         V9 = V( 9 )
+         T9 = TAU*V9
+         V10 = V( 10 )
+         T10 = TAU*V10
+         DO 400 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) +
+     $            V10*C( J, 10 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+            C( J, 8 ) = C( J, 8 ) - SUM*T8
+            C( J, 9 ) = C( J, 9 ) - SUM*T9
+            C( J, 10 ) = C( J, 10 ) - SUM*T10
+  400    CONTINUE
+         GO TO 410
+      END IF
+  410 CONTINUE
+      RETURN
+*
+*     End of DLARFX
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlartg.f
@@ -0,0 +1,143 @@
+      SUBROUTINE DLARTG( F, G, CS, SN, R )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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.
+*
+*  =====================================================================
+*
+*     .. 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
+         FIRST = .FALSE.
+         SAFMIN = DLAMCH( 'S' )
+         EPS = DLAMCH( 'E' )
+         SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
+     $            LOG( DLAMCH( 'B' ) ) / TWO )
+         SAFMX2 = ONE / SAFMN2
+      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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlas2.f
@@ -0,0 +1,122 @@
+      SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlascl.f
@@ -0,0 +1,268 @@
+      SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. 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,M)
+*          The matrix to be multiplied by CTO/CFROM.  See TYPE for the
+*          storage type.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  INFO    (output) INTEGER
+*          0  - successful exit
+*          <0 - if INFO = -i, the i-th argument had an illegal value.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            DONE
+      INTEGER            I, ITYPE, J, K1, K2, K3, K4
+      DOUBLE PRECISION   BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+*
+      IF( LSAME( TYPE, 'G' ) ) THEN
+         ITYPE = 0
+      ELSE IF( LSAME( TYPE, 'L' ) ) THEN
+         ITYPE = 1
+      ELSE IF( LSAME( TYPE, 'U' ) ) THEN
+         ITYPE = 2
+      ELSE IF( LSAME( TYPE, 'H' ) ) THEN
+         ITYPE = 3
+      ELSE IF( LSAME( TYPE, 'B' ) ) THEN
+         ITYPE = 4
+      ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
+         ITYPE = 5
+      ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
+         ITYPE = 6
+      ELSE
+         ITYPE = -1
+      END IF
+*
+      IF( ITYPE.EQ.-1 ) THEN
+         INFO = -1
+      ELSE IF( CFROM.EQ.ZERO ) THEN
+         INFO = -4
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
+     $         ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
+         INFO = -7
+      ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -9
+      ELSE IF( ITYPE.GE.4 ) THEN
+         IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
+            INFO = -2
+         ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
+     $            ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
+     $             THEN
+            INFO = -3
+         ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
+     $            ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
+     $            ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
+            INFO = -9
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLASCL', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. M.EQ.0 )
+     $   RETURN
+*
+*     Get machine parameters
+*
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+*
+      CFROMC = CFROM
+      CTOC = CTO
+*
+   10 CONTINUE
+      CFROM1 = CFROMC*SMLNUM
+      CTO1 = CTOC / BIGNUM
+      IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
+         MUL = SMLNUM
+         DONE = .FALSE.
+         CFROMC = CFROM1
+      ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
+         MUL = BIGNUM
+         DONE = .FALSE.
+         CTOC = CTO1
+      ELSE
+         MUL = CTOC / CFROMC
+         DONE = .TRUE.
+      END IF
+*
+      IF( ITYPE.EQ.0 ) THEN
+*
+*        Full matrix
+*
+         DO 30 J = 1, N
+            DO 20 I = 1, M
+               A( I, J ) = A( I, J )*MUL
+   20       CONTINUE
+   30    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.1 ) THEN
+*
+*        Lower triangular matrix
+*
+         DO 50 J = 1, N
+            DO 40 I = J, M
+               A( I, J ) = A( I, J )*MUL
+   40       CONTINUE
+   50    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.2 ) THEN
+*
+*        Upper triangular matrix
+*
+         DO 70 J = 1, N
+            DO 60 I = 1, MIN( J, M )
+               A( I, J ) = A( I, J )*MUL
+   60       CONTINUE
+   70    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*        Upper Hessenberg matrix
+*
+         DO 90 J = 1, N
+            DO 80 I = 1, MIN( J+1, M )
+               A( I, J ) = A( I, J )*MUL
+   80       CONTINUE
+   90    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.4 ) THEN
+*
+*        Lower half of a symmetric band matrix
+*
+         K3 = KL + 1
+         K4 = N + 1
+         DO 110 J = 1, N
+            DO 100 I = 1, MIN( K3, K4-J )
+               A( I, J ) = A( I, J )*MUL
+  100       CONTINUE
+  110    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.5 ) THEN
+*
+*        Upper half of a symmetric band matrix
+*
+         K1 = KU + 2
+         K3 = KU + 1
+         DO 130 J = 1, N
+            DO 120 I = MAX( K1-J, 1 ), K3
+               A( I, J ) = A( I, J )*MUL
+  120       CONTINUE
+  130    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.6 ) THEN
+*
+*        Band matrix
+*
+         K1 = KL + KU + 2
+         K2 = KL + 1
+         K3 = 2*KL + KU + 1
+         K4 = KL + KU + 1 + M
+         DO 150 J = 1, N
+            DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
+               A( I, J ) = A( I, J )*MUL
+  140       CONTINUE
+  150    CONTINUE
+*
+      END IF
+*
+      IF( .NOT.DONE )
+     $   GO TO 10
+*
+      RETURN
+*
+*     End of DLASCL
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlaset.f
@@ -0,0 +1,115 @@
+      SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      CHARACTER          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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlasq1.f
@@ -0,0 +1,222 @@
+      SUBROUTINE DLASQ1( N, D, E, WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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, barring over/underflow or
+*     denormalization. The algorithm is described 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.
+*
+*     See also
+*     "Implementation of differential qd algorithms," by
+*     K. V. Fernando and B. N. Parlett, Technical Report,
+*     Department of Mathematics, University of California at Berkeley,
+*     1994 (Under preparation).
+*
+*     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 (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 algorithm did not converge;  i
+*                specifies how many superdiagonals did not converge.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   MEIGTH
+      PARAMETER          ( MEIGTH = -0.125D0 )
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D0 )
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D0 )
+      DOUBLE PRECISION   TEN
+      PARAMETER          ( TEN = 10.0D0 )
+      DOUBLE PRECISION   HUNDRD
+      PARAMETER          ( HUNDRD = 100.0D0 )
+      DOUBLE PRECISION   TWO56
+      PARAMETER          ( TWO56 = 256.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            RESTRT
+      INTEGER            I, IERR, J, KE, KEND, M, NY
+      DOUBLE PRECISION   DM, DX, EPS, SCL, SFMIN, SIG1, SIG2, SIGMN,
+     $                   SIGMX, SMALL2, THRESH, TOL, TOL2, TOLMUL
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLAS2, DLASCL, DLASQ2, DLASRT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, MAX, MIN, 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
+         SIGMX = MAX( SIGMX, ABS( E( I ) ) )
+   10 CONTINUE
+*
+*     Early return if sigmx is zero (matrix is already diagonal)
+*
+      IF( SIGMX.EQ.ZERO )
+     $   GO TO 70
+*
+      DO 20 I = 1, N
+         D( I ) = ABS( D( I ) )
+         SIGMX = MAX( SIGMX, D( I ) )
+   20 CONTINUE
+*
+*     Get machine parameters
+*
+      EPS = DLAMCH( 'EPSILON' )
+      SFMIN = DLAMCH( 'SAFE MINIMUM' )
+*
+*     Compute singular values to relative accuracy TOL
+*     It is assumed that tol**2 does not underflow.
+*
+      TOLMUL = MAX( TEN, MIN( HUNDRD, EPS**( -MEIGTH ) ) )
+      TOL = TOLMUL*EPS
+      TOL2 = TOL**2
+*
+      THRESH = SIGMX*SQRT( SFMIN )*TOL
+*
+*     Scale matrix so the square of the largest element is
+*     1 / ( 256 * SFMIN )
+*
+      SCL = SQRT( ONE / ( TWO56*SFMIN ) )
+      SMALL2 = ONE / ( TWO56*TOLMUL**2 )
+      CALL DCOPY( N, D, 1, WORK( 1 ), 1 )
+      CALL DCOPY( N-1, E, 1, WORK( N+1 ), 1 )
+      CALL DLASCL( 'G', 0, 0, SIGMX, SCL, N, 1, WORK( 1 ), N, IERR )
+      CALL DLASCL( 'G', 0, 0, SIGMX, SCL, N-1, 1, WORK( N+1 ), N-1,
+     $             IERR )
+*
+*     Square D and E (the input for the qd algorithm)
+*
+      DO 30 J = 1, 2*N - 1
+         WORK( J ) = WORK( J )**2
+   30 CONTINUE
+*
+*     Apply qd algorithm
+*
+      M = 0
+      E( N ) = ZERO
+      DX = WORK( 1 )
+      DM = DX
+      KE = 0
+      RESTRT = .FALSE.
+      DO 60 I = 1, N
+         IF( ABS( E( I ) ).LE.THRESH .OR. WORK( N+I ).LE.TOL2*
+     $       ( DM / DBLE( I-M ) ) ) THEN
+            NY = I - M
+            IF( NY.EQ.1 ) THEN
+               GO TO 50
+            ELSE IF( NY.EQ.2 ) THEN
+               CALL DLAS2( D( M+1 ), E( M+1 ), D( M+2 ), SIG1, SIG2 )
+               D( M+1 ) = SIG1
+               D( M+2 ) = SIG2
+            ELSE
+               KEND = KE + 1 - M
+               CALL DLASQ2( NY, D( M+1 ), E( M+1 ), WORK( M+1 ),
+     $                      WORK( M+N+1 ), EPS, TOL2, SMALL2, DM, KEND,
+     $                      INFO )
+*
+*                 Return, INFO = number of unconverged superdiagonals
+*
+               IF( INFO.NE.0 ) THEN
+                  INFO = INFO + I
+                  RETURN
+               END IF
+*
+*                 Undo scaling
+*
+               DO 40 J = M + 1, M + NY
+                  D( J ) = SQRT( D( J ) )
+   40          CONTINUE
+               CALL DLASCL( 'G', 0, 0, SCL, SIGMX, NY, 1, D( M+1 ), NY,
+     $                      IERR )
+            END IF
+   50       CONTINUE
+            M = I
+            IF( I.NE.N ) THEN
+               DX = WORK( I+1 )
+               DM = DX
+               KE = I
+               RESTRT = .TRUE.
+            END IF
+         END IF
+         IF( I.NE.N .AND. .NOT.RESTRT ) THEN
+            DX = WORK( I+1 )*( DX / ( DX+WORK( N+I ) ) )
+            IF( DM.GT.DX ) THEN
+               DM = DX
+               KE = I
+            END IF
+         END IF
+         RESTRT = .FALSE.
+   60 CONTINUE
+      KEND = KE + 1
+*
+*     Sort the singular values into decreasing order
+*
+   70 CONTINUE
+      CALL DLASRT( 'D', N, D, INFO )
+      RETURN
+*
+*     End of DLASQ1
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlasq2.f
@@ -0,0 +1,268 @@
+      SUBROUTINE DLASQ2( M, Q, E, QQ, EE, EPS, TOL2, SMALL2, SUP, KEND,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, KEND, M
+      DOUBLE PRECISION   EPS, SMALL2, SUP, TOL2
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   E( * ), EE( * ), Q( * ), QQ( * )
+*     ..
+*
+*     Purpose
+*     =======
+*
+*     DLASQ2 computes the singular values of a real N-by-N unreduced
+*     bidiagonal matrix with squared diagonal elements in Q and
+*     squared off-diagonal elements in E. The singular values are
+*     computed to relative accuracy TOL, barring over/underflow or
+*     denormalization.
+*
+*     Arguments
+*     =========
+*
+*  M       (input) INTEGER
+*          The number of rows and columns in the matrix. M >= 0.
+*
+*  Q       (output) DOUBLE PRECISION array, dimension (M)
+*          On normal exit, contains the squared singular values.
+*
+*  E       (workspace) DOUBLE PRECISION array, dimension (M)
+*
+*  QQ      (input/output) DOUBLE PRECISION array, dimension (M)
+*          On entry, QQ contains the squared diagonal elements of the
+*          bidiagonal matrix whose SVD is desired.
+*          On exit, QQ is overwritten.
+*
+*  EE      (input/output) DOUBLE PRECISION array, dimension (M)
+*          On entry, EE(1:N-1) contains the squared off-diagonal
+*          elements of the bidiagonal matrix whose SVD is desired.
+*          On exit, EE is overwritten.
+*
+*  EPS     (input) DOUBLE PRECISION
+*          Machine epsilon.
+*
+*  TOL2    (input) DOUBLE PRECISION
+*          Desired relative accuracy of computed eigenvalues
+*          as defined in DLASQ1.
+*
+*  SMALL2  (input) DOUBLE PRECISION
+*          A threshold value as defined in DLASQ1.
+*
+*  SUP     (input/output) DOUBLE PRECISION
+*          Upper bound for the smallest eigenvalue.
+*
+*  KEND    (input/output) INTEGER
+*          Index where minimum d occurs.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, the algorithm did not converge;  i
+*                specifies how many superdiagonals did not converge.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+      DOUBLE PRECISION   FOUR, HALF
+      PARAMETER          ( FOUR = 4.0D+0, HALF = 0.5D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            ICONV, IPHASE, ISP, N, OFF, OFF1
+      DOUBLE PRECISION   QEMAX, SIGMA, XINF, XX, YY
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLASQ3
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, NINT, SQRT
+*     ..
+*     .. Executable Statements ..
+      N = M
+*
+*     Set the default maximum number of iterations
+*
+      OFF = 0
+      OFF1 = OFF + 1
+      SIGMA = ZERO
+      XINF = ZERO
+      ICONV = 0
+      IPHASE = 2
+*
+*     Try deflation at the bottom
+*
+*     1x1 deflation
+*
+   10 CONTINUE
+      IF( N.LE.2 )
+     $   GO TO 20
+      IF( EE( N-1 ).LE.MAX( QQ( N ), XINF, SMALL2 )*TOL2 ) THEN
+         Q( N ) = QQ( N )
+         N = N - 1
+         IF( KEND.GT.N )
+     $      KEND = N
+         SUP = MIN( QQ( N ), QQ( N-1 ) )
+         GO TO 10
+      END IF
+*
+*     2x2 deflation
+*
+      IF( EE( N-2 ).LE.MAX( XINF, SMALL2,
+     $    ( QQ( N ) / ( QQ( N )+EE( N-1 )+QQ( N-1 ) ) )*QQ( N-1 ) )*
+     $    TOL2 ) THEN
+         QEMAX = MAX( QQ( N ), QQ( N-1 ), EE( N-1 ) )
+         IF( QEMAX.NE.ZERO ) THEN
+            IF( QEMAX.EQ.QQ( N-1 ) ) THEN
+               XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX*
+     $              SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) /
+     $              QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) )
+            ELSE IF( QEMAX.EQ.QQ( N ) ) THEN
+               XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX*
+     $              SQRT( ( ( QQ( N-1 )-QQ( N )+EE( N-1 ) ) /
+     $              QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) )
+            ELSE
+               XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX*
+     $              SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) /
+     $              QEMAX )**2+FOUR*QQ( N-1 ) / QEMAX ) )
+            END IF
+            YY = ( MAX( QQ( N ), QQ( N-1 ) ) / XX )*
+     $           MIN( QQ( N ), QQ( N-1 ) )
+         ELSE
+            XX = ZERO
+            YY = ZERO
+         END IF
+         Q( N-1 ) = XX
+         Q( N ) = YY
+         N = N - 2
+         IF( KEND.GT.N )
+     $      KEND = N
+         SUP = QQ( N )
+         GO TO 10
+      END IF
+*
+   20 CONTINUE
+      IF( N.EQ.0 ) THEN
+*
+*         The lower branch is finished
+*
+         IF( OFF.EQ.0 ) THEN
+*
+*         No upper branch; return to DLASQ1
+*
+            RETURN
+         ELSE
+*
+*         Going back to upper branch
+*
+            XINF = ZERO
+            IF( EE( OFF ).GT.ZERO ) THEN
+               ISP = NINT( EE( OFF ) )
+               IPHASE = 1
+            ELSE
+               ISP = -NINT( EE( OFF ) )
+               IPHASE = 2
+            END IF
+            SIGMA = E( OFF )
+            N = OFF - ISP + 1
+            OFF1 = ISP
+            OFF = OFF1 - 1
+            IF( N.LE.2 )
+     $         GO TO 20
+            IF( IPHASE.EQ.1 ) THEN
+               SUP = MIN( Q( N+OFF ), Q( N-1+OFF ), Q( N-2+OFF ) )
+            ELSE
+               SUP = MIN( QQ( N+OFF ), QQ( N-1+OFF ), QQ( N-2+OFF ) )
+            END IF
+            KEND = 0
+            ICONV = -3
+         END IF
+      ELSE IF( N.EQ.1 ) THEN
+*
+*     1x1 Solver
+*
+         IF( IPHASE.EQ.1 ) THEN
+            Q( OFF1 ) = Q( OFF1 ) + SIGMA
+         ELSE
+            Q( OFF1 ) = QQ( OFF1 ) + SIGMA
+         END IF
+         N = 0
+         GO TO 20
+*
+*     2x2 Solver
+*
+      ELSE IF( N.EQ.2 ) THEN
+         IF( IPHASE.EQ.2 ) THEN
+            QEMAX = MAX( QQ( N+OFF ), QQ( N-1+OFF ), EE( N-1+OFF ) )
+            IF( QEMAX.NE.ZERO ) THEN
+               IF( QEMAX.EQ.QQ( N-1+OFF ) ) THEN
+                  XX = HALF*( QQ( N+OFF )+QQ( N-1+OFF )+EE( N-1+OFF )+
+     $                 QEMAX*SQRT( ( ( QQ( N+OFF )-QQ( N-1+OFF )+EE( N-
+     $                 1+OFF ) ) / QEMAX )**2+FOUR*EE( OFF+N-1 ) /
+     $                 QEMAX ) )
+               ELSE IF( QEMAX.EQ.QQ( N+OFF ) ) THEN
+                  XX = HALF*( QQ( N+OFF )+QQ( N-1+OFF )+EE( N-1+OFF )+
+     $                 QEMAX*SQRT( ( ( QQ( N-1+OFF )-QQ( N+OFF )+EE( N-
+     $                 1+OFF ) ) / QEMAX )**2+FOUR*EE( N-1+OFF ) /
+     $                 QEMAX ) )
+               ELSE
+                  XX = HALF*( QQ( N+OFF )+QQ( N-1+OFF )+EE( N-1+OFF )+
+     $                 QEMAX*SQRT( ( ( QQ( N+OFF )-QQ( N-1+OFF )+EE( N-
+     $                 1+OFF ) ) / QEMAX )**2+FOUR*QQ( N-1+OFF ) /
+     $                 QEMAX ) )
+               END IF
+               YY = ( MAX( QQ( N+OFF ), QQ( N-1+OFF ) ) / XX )*
+     $              MIN( QQ( N+OFF ), QQ( N-1+OFF ) )
+            ELSE
+               XX = ZERO
+               YY = ZERO
+            END IF
+         ELSE
+            QEMAX = MAX( Q( N+OFF ), Q( N-1+OFF ), E( N-1+OFF ) )
+            IF( QEMAX.NE.ZERO ) THEN
+               IF( QEMAX.EQ.Q( N-1+OFF ) ) THEN
+                  XX = HALF*( Q( N+OFF )+Q( N-1+OFF )+E( N-1+OFF )+
+     $                 QEMAX*SQRT( ( ( Q( N+OFF )-Q( N-1+OFF )+E( N-1+
+     $                 OFF ) ) / QEMAX )**2+FOUR*E( N-1+OFF ) /
+     $                 QEMAX ) )
+               ELSE IF( QEMAX.EQ.Q( N+OFF ) ) THEN
+                  XX = HALF*( Q( N+OFF )+Q( N-1+OFF )+E( N-1+OFF )+
+     $                 QEMAX*SQRT( ( ( Q( N-1+OFF )-Q( N+OFF )+E( N-1+
+     $                 OFF ) ) / QEMAX )**2+FOUR*E( N-1+OFF ) /
+     $                 QEMAX ) )
+               ELSE
+                  XX = HALF*( Q( N+OFF )+Q( N-1+OFF )+E( N-1+OFF )+
+     $                 QEMAX*SQRT( ( ( Q( N+OFF )-Q( N-1+OFF )+E( N-1+
+     $                 OFF ) ) / QEMAX )**2+FOUR*Q( N-1+OFF ) /
+     $                 QEMAX ) )
+               END IF
+               YY = ( MAX( Q( N+OFF ), Q( N-1+OFF ) ) / XX )*
+     $              MIN( Q( N+OFF ), Q( N-1+OFF ) )
+            ELSE
+               XX = ZERO
+               YY = ZERO
+            END IF
+         END IF
+         Q( N-1+OFF ) = SIGMA + XX
+         Q( N+OFF ) = YY + SIGMA
+         N = 0
+         GO TO 20
+      END IF
+      CALL DLASQ3( N, Q( OFF1 ), E( OFF1 ), QQ( OFF1 ), EE( OFF1 ), SUP,
+     $             SIGMA, KEND, OFF, IPHASE, ICONV, EPS, TOL2, SMALL2 )
+      IF( SUP.LT.ZERO ) THEN
+         INFO = N + OFF
+         RETURN
+      END IF
+      OFF1 = OFF + 1
+      GO TO 20
+*
+*     End of DLASQ2
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlasq3.f
@@ -0,0 +1,820 @@
+      SUBROUTINE DLASQ3( N, Q, E, QQ, EE, SUP, SIGMA, KEND, OFF, IPHASE,
+     $                   ICONV, EPS, TOL2, SMALL2 )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            ICONV, IPHASE, KEND, N, OFF
+      DOUBLE PRECISION   EPS, SIGMA, SMALL2, SUP, TOL2
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   E( * ), EE( * ), Q( * ), QQ( * )
+*     ..
+*
+*     Purpose
+*     =======
+*
+*     DLASQ3 is the workhorse of the whole bidiagonal SVD algorithm.
+*     This can be described as the differential qd with shifts.
+*
+*     Arguments
+*     =========
+*
+*  N       (input/output) INTEGER
+*          On entry, N specifies the number of rows and columns
+*          in the matrix. N must be at least 3.
+*          On exit N is non-negative and less than the input value.
+*
+*  Q       (input/output) DOUBLE PRECISION array, dimension (N)
+*          Q array in ping (see IPHASE below)
+*
+*  E       (input/output) DOUBLE PRECISION array, dimension (N)
+*          E array in ping (see IPHASE below)
+*
+*  QQ      (input/output) DOUBLE PRECISION array, dimension (N)
+*          Q array in pong (see IPHASE below)
+*
+*  EE      (input/output) DOUBLE PRECISION array, dimension (N)
+*          E array in pong (see IPHASE below)
+*
+*  SUP     (input/output) DOUBLE PRECISION
+*          Upper bound for the smallest eigenvalue
+*
+*  SIGMA   (input/output) DOUBLE PRECISION
+*          Accumulated shift for the present submatrix
+*
+*  KEND    (input/output) INTEGER
+*          Index where minimum D(i) occurs in recurrence for
+*          splitting criterion
+*
+*  OFF     (input/output) INTEGER
+*          Offset for arrays
+*
+*  IPHASE  (input/output) INTEGER
+*          If IPHASE = 1 (ping) then data is in Q and E arrays
+*          If IPHASE = 2 (pong) then data is in QQ and EE arrays
+*
+*  ICONV   (input) INTEGER
+*          If ICONV = 0 a bottom part of a matrix (with a split)
+*          If ICONV =-3 a top part of a matrix (with a split)
+*
+*  EPS     (input) DOUBLE PRECISION
+*          Machine epsilon
+*
+*  TOL2    (input) DOUBLE PRECISION
+*          Square of the relative tolerance TOL as defined in DLASQ1
+*
+*  SMALL2  (input) DOUBLE PRECISION
+*          A threshold value as defined in DLASQ1
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+      INTEGER            NPP
+      PARAMETER          ( NPP = 32 )
+      INTEGER            IPP
+      PARAMETER          ( IPP = 5 )
+      DOUBLE PRECISION   HALF, FOUR
+      PARAMETER          ( HALF = 0.5D+0, FOUR = 4.0D+0 )
+      INTEGER            IFLMAX
+      PARAMETER          ( IFLMAX = 2 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LDEF, LSPLIT
+      INTEGER            I, IC, ICNT, IFL, IP, ISP, K1END, K2END, KE,
+     $                   KS, MAXIT, N1, N2
+      DOUBLE PRECISION   D, DM, QEMAX, T1, TAU, TOLX, TOLY, TOLZ, XX, YY
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLASQ4
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+      ICNT = 0
+      TAU = ZERO
+      DM = SUP
+      TOLX = SIGMA*TOL2
+      TOLZ = MAX( SMALL2, SIGMA )*TOL2
+*
+*     Set maximum number of iterations
+*
+      MAXIT = 100*N
+*
+*     Flipping
+*
+      IC = 2
+      IF( N.GT.3 ) THEN
+         IF( IPHASE.EQ.1 ) THEN
+            DO 10 I = 1, N - 2
+               IF( Q( I ).GT.Q( I+1 ) )
+     $            IC = IC + 1
+               IF( E( I ).GT.E( I+1 ) )
+     $            IC = IC + 1
+   10       CONTINUE
+            IF( Q( N-1 ).GT.Q( N ) )
+     $         IC = IC + 1
+            IF( IC.LT.N ) THEN
+               CALL DCOPY( N, Q, 1, QQ, -1 )
+               CALL DCOPY( N-1, E, 1, EE, -1 )
+               IF( KEND.NE.0 )
+     $            KEND = N - KEND + 1
+               IPHASE = 2
+            END IF
+         ELSE
+            DO 20 I = 1, N - 2
+               IF( QQ( I ).GT.QQ( I+1 ) )
+     $            IC = IC + 1
+               IF( EE( I ).GT.EE( I+1 ) )
+     $            IC = IC + 1
+   20       CONTINUE
+            IF( QQ( N-1 ).GT.QQ( N ) )
+     $         IC = IC + 1
+            IF( IC.LT.N ) THEN
+               CALL DCOPY( N, QQ, 1, Q, -1 )
+               CALL DCOPY( N-1, EE, 1, E, -1 )
+               IF( KEND.NE.0 )
+     $            KEND = N - KEND + 1
+               IPHASE = 1
+            END IF
+         END IF
+      END IF
+      IF( ICONV.EQ.-3 ) THEN
+         IF( IPHASE.EQ.1 ) THEN
+            GO TO 180
+         ELSE
+            GO TO 80
+         END IF
+      END IF
+      IF( IPHASE.EQ.2 )
+     $   GO TO 130
+*
+*     The ping section of the code
+*
+   30 CONTINUE
+      IFL = 0
+*
+*     Compute the shift
+*
+      IF( KEND.EQ.0 .OR. SUP.EQ.ZERO ) THEN
+         TAU = ZERO
+      ELSE IF( ICNT.GT.0 .AND. DM.LE.TOLZ ) THEN
+         TAU = ZERO
+      ELSE
+         IP = MAX( IPP, N / NPP )
+         N2 = 2*IP + 1
+         IF( N2.GE.N ) THEN
+            N1 = 1
+            N2 = N
+         ELSE IF( KEND+IP.GT.N ) THEN
+            N1 = N - 2*IP
+         ELSE IF( KEND-IP.LT.1 ) THEN
+            N1 = 1
+         ELSE
+            N1 = KEND - IP
+         END IF
+         CALL DLASQ4( N2, Q( N1 ), E( N1 ), TAU, SUP )
+      END IF
+   40 CONTINUE
+      ICNT = ICNT + 1
+      IF( ICNT.GT.MAXIT ) THEN
+         SUP = -ONE
+         RETURN
+      END IF
+      IF( TAU.EQ.ZERO ) THEN
+*
+*     dqd algorithm
+*
+         D = Q( 1 )
+         DM = D
+         KE = 0
+         DO 50 I = 1, N - 3
+            QQ( I ) = D + E( I )
+            D = ( D / QQ( I ) )*Q( I+1 )
+            IF( DM.GT.D ) THEN
+               DM = D
+               KE = I
+            END IF
+   50    CONTINUE
+         KE = KE + 1
+*
+*     Penultimate dqd step (in ping)
+*
+         K2END = KE
+         QQ( N-2 ) = D + E( N-2 )
+         D = ( D / QQ( N-2 ) )*Q( N-1 )
+         IF( DM.GT.D ) THEN
+            DM = D
+            KE = N - 1
+         END IF
+*
+*     Final dqd step (in ping)
+*
+         K1END = KE
+         QQ( N-1 ) = D + E( N-1 )
+         D = ( D / QQ( N-1 ) )*Q( N )
+         IF( DM.GT.D ) THEN
+            DM = D
+            KE = N
+         END IF
+         QQ( N ) = D
+      ELSE
+*
+*     The dqds algorithm (in ping)
+*
+         D = Q( 1 ) - TAU
+         DM = D
+         KE = 0
+         IF( D.LT.ZERO )
+     $      GO TO 120
+         DO 60 I = 1, N - 3
+            QQ( I ) = D + E( I )
+            D = ( D / QQ( I ) )*Q( I+1 ) - TAU
+            IF( DM.GT.D ) THEN
+               DM = D
+               KE = I
+               IF( D.LT.ZERO )
+     $            GO TO 120
+            END IF
+   60    CONTINUE
+         KE = KE + 1
+*
+*     Penultimate dqds step (in ping)
+*
+         K2END = KE
+         QQ( N-2 ) = D + E( N-2 )
+         D = ( D / QQ( N-2 ) )*Q( N-1 ) - TAU
+         IF( DM.GT.D ) THEN
+            DM = D
+            KE = N - 1
+            IF( D.LT.ZERO )
+     $         GO TO 120
+         END IF
+*
+*     Final dqds step (in ping)
+*
+         K1END = KE
+         QQ( N-1 ) = D + E( N-1 )
+         D = ( D / QQ( N-1 ) )*Q( N ) - TAU
+         IF( DM.GT.D ) THEN
+            DM = D
+            KE = N
+         END IF
+         QQ( N ) = D
+      END IF
+*
+*        Convergence when QQ(N) is small (in ping)
+*
+      IF( ABS( QQ( N ) ).LE.SIGMA*TOL2 ) THEN
+         QQ( N ) = ZERO
+         DM = ZERO
+         KE = N
+      END IF
+      IF( QQ( N ).LT.ZERO )
+     $   GO TO 120
+*
+*     Non-negative qd array: Update the e's
+*
+      DO 70 I = 1, N - 1
+         EE( I ) = ( E( I ) / QQ( I ) )*Q( I+1 )
+   70 CONTINUE
+*
+*     Updating sigma and iphase in ping
+*
+      SIGMA = SIGMA + TAU
+      IPHASE = 2
+   80 CONTINUE
+      TOLX = SIGMA*TOL2
+      TOLY = SIGMA*EPS
+      TOLZ = MAX( SIGMA, SMALL2 )*TOL2
+*
+*     Checking for deflation and convergence (in ping)
+*
+   90 CONTINUE
+      IF( N.LE.2 )
+     $   RETURN
+*
+*        Deflation: bottom 1x1 (in ping)
+*
+      LDEF = .FALSE.
+      IF( EE( N-1 ).LE.TOLZ ) THEN
+         LDEF = .TRUE.
+      ELSE IF( SIGMA.GT.ZERO ) THEN
+         IF( EE( N-1 ).LE.EPS*( SIGMA+QQ( N ) ) ) THEN
+            IF( EE( N-1 )*( QQ( N ) / ( QQ( N )+SIGMA ) ).LE.TOL2*
+     $          ( QQ( N )+SIGMA ) ) THEN
+               LDEF = .TRUE.
+            END IF
+         END IF
+      ELSE
+         IF( EE( N-1 ).LE.QQ( N )*TOL2 ) THEN
+            LDEF = .TRUE.
+         END IF
+      END IF
+      IF( LDEF ) THEN
+         Q( N ) = QQ( N ) + SIGMA
+         N = N - 1
+         ICONV = ICONV + 1
+         GO TO 90
+      END IF
+*
+*        Deflation: bottom 2x2 (in ping)
+*
+      LDEF = .FALSE.
+      IF( EE( N-2 ).LE.TOLZ ) THEN
+         LDEF = .TRUE.
+      ELSE IF( SIGMA.GT.ZERO ) THEN
+         T1 = SIGMA + EE( N-1 )*( SIGMA / ( SIGMA+QQ( N ) ) )
+         IF( EE( N-2 )*( T1 / ( QQ( N-1 )+T1 ) ).LE.TOLY ) THEN
+            IF( EE( N-2 )*( QQ( N-1 ) / ( QQ( N-1 )+T1 ) ).LE.TOLX )
+     $           THEN
+               LDEF = .TRUE.
+            END IF
+         END IF
+      ELSE
+         IF( EE( N-2 ).LE.( QQ( N ) / ( QQ( N )+EE( N-1 )+QQ( N-1 ) ) )*
+     $       QQ( N-1 )*TOL2 ) THEN
+            LDEF = .TRUE.
+         END IF
+      END IF
+      IF( LDEF ) THEN
+         QEMAX = MAX( QQ( N ), QQ( N-1 ), EE( N-1 ) )
+         IF( QEMAX.NE.ZERO ) THEN
+            IF( QEMAX.EQ.QQ( N-1 ) ) THEN
+               XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX*
+     $              SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) /
+     $              QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) )
+            ELSE IF( QEMAX.EQ.QQ( N ) ) THEN
+               XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX*
+     $              SQRT( ( ( QQ( N-1 )-QQ( N )+EE( N-1 ) ) /
+     $              QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) )
+            ELSE
+               XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX*
+     $              SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) /
+     $              QEMAX )**2+FOUR*QQ( N-1 ) / QEMAX ) )
+            END IF
+            YY = ( MAX( QQ( N ), QQ( N-1 ) ) / XX )*
+     $           MIN( QQ( N ), QQ( N-1 ) )
+         ELSE
+            XX = ZERO
+            YY = ZERO
+         END IF
+         Q( N-1 ) = SIGMA + XX
+         Q( N ) = YY + SIGMA
+         N = N - 2
+         ICONV = ICONV + 2
+         GO TO 90
+      END IF
+*
+*     Updating bounds before going to pong
+*
+      IF( ICONV.EQ.0 ) THEN
+         KEND = KE
+         SUP = MIN( DM, SUP-TAU )
+      ELSE IF( ICONV.GT.0 ) THEN
+         SUP = MIN( QQ( N ), QQ( N-1 ), QQ( N-2 ), QQ( 1 ), QQ( 2 ),
+     $         QQ( 3 ) )
+         IF( ICONV.EQ.1 ) THEN
+            KEND = K1END
+         ELSE IF( ICONV.EQ.2 ) THEN
+            KEND = K2END
+         ELSE
+            KEND = N
+         END IF
+         ICNT = 0
+         MAXIT = 100*N
+      END IF
+*
+*     Checking for splitting in ping
+*
+      LSPLIT = .FALSE.
+      DO 100 KS = N - 3, 3, -1
+         IF( EE( KS ).LE.TOLY ) THEN
+            IF( EE( KS )*( MIN( QQ( KS+1 ),
+     $          QQ( KS ) ) / ( MIN( QQ( KS+1 ), QQ( KS ) )+SIGMA ) ).LE.
+     $          TOLX ) THEN
+               LSPLIT = .TRUE.
+               GO TO 110
+            END IF
+         END IF
+  100 CONTINUE
+*
+      KS = 2
+      IF( EE( 2 ).LE.TOLZ ) THEN
+         LSPLIT = .TRUE.
+      ELSE IF( SIGMA.GT.ZERO ) THEN
+         T1 = SIGMA + EE( 1 )*( SIGMA / ( SIGMA+QQ( 1 ) ) )
+         IF( EE( 2 )*( T1 / ( QQ( 1 )+T1 ) ).LE.TOLY ) THEN
+            IF( EE( 2 )*( QQ( 1 ) / ( QQ( 1 )+T1 ) ).LE.TOLX ) THEN
+               LSPLIT = .TRUE.
+            END IF
+         END IF
+      ELSE
+         IF( EE( 2 ).LE.( QQ( 1 ) / ( QQ( 1 )+EE( 1 )+QQ( 2 ) ) )*
+     $       QQ( 2 )*TOL2 ) THEN
+            LSPLIT = .TRUE.
+         END IF
+      END IF
+      IF( LSPLIT )
+     $   GO TO 110
+*
+      KS = 1
+      IF( EE( 1 ).LE.TOLZ ) THEN
+         LSPLIT = .TRUE.
+      ELSE IF( SIGMA.GT.ZERO ) THEN
+         IF( EE( 1 ).LE.EPS*( SIGMA+QQ( 1 ) ) ) THEN
+            IF( EE( 1 )*( QQ( 1 ) / ( QQ( 1 )+SIGMA ) ).LE.TOL2*
+     $          ( QQ( 1 )+SIGMA ) ) THEN
+               LSPLIT = .TRUE.
+            END IF
+         END IF
+      ELSE
+         IF( EE( 1 ).LE.QQ( 1 )*TOL2 ) THEN
+            LSPLIT = .TRUE.
+         END IF
+      END IF
+*
+  110 CONTINUE
+      IF( LSPLIT ) THEN
+         SUP = MIN( QQ( N ), QQ( N-1 ), QQ( N-2 ) )
+         ISP = -( OFF+1 )
+         OFF = OFF + KS
+         N = N - KS
+         KEND = MAX( 1, KEND-KS )
+         E( KS ) = SIGMA
+         EE( KS ) = ISP
+         ICONV = 0
+         RETURN
+      END IF
+*
+*     Coincidence
+*
+      IF( TAU.EQ.ZERO .AND. DM.LE.TOLZ .AND. KEND.NE.N .AND. ICONV.EQ.
+     $    0 .AND. ICNT.GT.0 ) THEN
+         CALL DCOPY( N-KE, E( KE ), 1, QQ( KE ), 1 )
+         QQ( N ) = ZERO
+         CALL DCOPY( N-KE, Q( KE+1 ), 1, EE( KE ), 1 )
+         SUP = ZERO
+      END IF
+      ICONV = 0
+      GO TO 130
+*
+*     A new shift when the previous failed (in ping)
+*
+  120 CONTINUE
+      IFL = IFL + 1
+      SUP = TAU
+*
+*     SUP is small or
+*     Too many bad shifts (ping)
+*
+      IF( SUP.LE.TOLZ .OR. IFL.GE.IFLMAX ) THEN
+         TAU = ZERO
+         GO TO 40
+*
+*     The asymptotic shift (in ping)
+*
+      ELSE
+         TAU = MAX( TAU+D, ZERO )
+         IF( TAU.LE.TOLZ )
+     $      TAU = ZERO
+         GO TO 40
+      END IF
+*
+*     the pong section of the code
+*
+  130 CONTINUE
+      IFL = 0
+*
+*     Compute the shift (in pong)
+*
+      IF( KEND.EQ.0 .AND. SUP.EQ.ZERO ) THEN
+         TAU = ZERO
+      ELSE IF( ICNT.GT.0 .AND. DM.LE.TOLZ ) THEN
+         TAU = ZERO
+      ELSE
+         IP = MAX( IPP, N / NPP )
+         N2 = 2*IP + 1
+         IF( N2.GE.N ) THEN
+            N1 = 1
+            N2 = N
+         ELSE IF( KEND+IP.GT.N ) THEN
+            N1 = N - 2*IP
+         ELSE IF( KEND-IP.LT.1 ) THEN
+            N1 = 1
+         ELSE
+            N1 = KEND - IP
+         END IF
+         CALL DLASQ4( N2, QQ( N1 ), EE( N1 ), TAU, SUP )
+      END IF
+  140 CONTINUE
+      ICNT = ICNT + 1
+      IF( ICNT.GT.MAXIT ) THEN
+         SUP = -SUP
+         RETURN
+      END IF
+      IF( TAU.EQ.ZERO ) THEN
+*
+*     The dqd algorithm (in pong)
+*
+         D = QQ( 1 )
+         DM = D
+         KE = 0
+         DO 150 I = 1, N - 3
+            Q( I ) = D + EE( I )
+            D = ( D / Q( I ) )*QQ( I+1 )
+            IF( DM.GT.D ) THEN
+               DM = D
+               KE = I
+            END IF
+  150    CONTINUE
+         KE = KE + 1
+*
+*     Penultimate dqd step (in pong)
+*
+         K2END = KE
+         Q( N-2 ) = D + EE( N-2 )
+         D = ( D / Q( N-2 ) )*QQ( N-1 )
+         IF( DM.GT.D ) THEN
+            DM = D
+            KE = N - 1
+         END IF
+*
+*     Final dqd step (in pong)
+*
+         K1END = KE
+         Q( N-1 ) = D + EE( N-1 )
+         D = ( D / Q( N-1 ) )*QQ( N )
+         IF( DM.GT.D ) THEN
+            DM = D
+            KE = N
+         END IF
+         Q( N ) = D
+      ELSE
+*
+*     The dqds algorithm (in pong)
+*
+         D = QQ( 1 ) - TAU
+         DM = D
+         KE = 0
+         IF( D.LT.ZERO )
+     $      GO TO 220
+         DO 160 I = 1, N - 3
+            Q( I ) = D + EE( I )
+            D = ( D / Q( I ) )*QQ( I+1 ) - TAU
+            IF( DM.GT.D ) THEN
+               DM = D
+               KE = I
+               IF( D.LT.ZERO )
+     $            GO TO 220
+            END IF
+  160    CONTINUE
+         KE = KE + 1
+*
+*     Penultimate dqds step (in pong)
+*
+         K2END = KE
+         Q( N-2 ) = D + EE( N-2 )
+         D = ( D / Q( N-2 ) )*QQ( N-1 ) - TAU
+         IF( DM.GT.D ) THEN
+            DM = D
+            KE = N - 1
+            IF( D.LT.ZERO )
+     $         GO TO 220
+         END IF
+*
+*     Final dqds step (in pong)
+*
+         K1END = KE
+         Q( N-1 ) = D + EE( N-1 )
+         D = ( D / Q( N-1 ) )*QQ( N ) - TAU
+         IF( DM.GT.D ) THEN
+            DM = D
+            KE = N
+         END IF
+         Q( N ) = D
+      END IF
+*
+*        Convergence when is small (in pong)
+*
+      IF( ABS( Q( N ) ).LE.SIGMA*TOL2 ) THEN
+         Q( N ) = ZERO
+         DM = ZERO
+         KE = N
+      END IF
+      IF( Q( N ).LT.ZERO )
+     $   GO TO 220
+*
+*     Non-negative qd array: Update the e's
+*
+      DO 170 I = 1, N - 1
+         E( I ) = ( EE( I ) / Q( I ) )*QQ( I+1 )
+  170 CONTINUE
+*
+*     Updating sigma and iphase in pong
+*
+      SIGMA = SIGMA + TAU
+  180 CONTINUE
+      IPHASE = 1
+      TOLX = SIGMA*TOL2
+      TOLY = SIGMA*EPS
+*
+*     Checking for deflation and convergence (in pong)
+*
+  190 CONTINUE
+      IF( N.LE.2 )
+     $   RETURN
+*
+*        Deflation: bottom 1x1 (in pong)
+*
+      LDEF = .FALSE.
+      IF( E( N-1 ).LE.TOLZ ) THEN
+         LDEF = .TRUE.
+      ELSE IF( SIGMA.GT.ZERO ) THEN
+         IF( E( N-1 ).LE.EPS*( SIGMA+Q( N ) ) ) THEN
+            IF( E( N-1 )*( Q( N ) / ( Q( N )+SIGMA ) ).LE.TOL2*
+     $          ( Q( N )+SIGMA ) ) THEN
+               LDEF = .TRUE.
+            END IF
+         END IF
+      ELSE
+         IF( E( N-1 ).LE.Q( N )*TOL2 ) THEN
+            LDEF = .TRUE.
+         END IF
+      END IF
+      IF( LDEF ) THEN
+         Q( N ) = Q( N ) + SIGMA
+         N = N - 1
+         ICONV = ICONV + 1
+         GO TO 190
+      END IF
+*
+*        Deflation: bottom 2x2 (in pong)
+*
+      LDEF = .FALSE.
+      IF( E( N-2 ).LE.TOLZ ) THEN
+         LDEF = .TRUE.
+      ELSE IF( SIGMA.GT.ZERO ) THEN
+         T1 = SIGMA + E( N-1 )*( SIGMA / ( SIGMA+Q( N ) ) )
+         IF( E( N-2 )*( T1 / ( Q( N-1 )+T1 ) ).LE.TOLY ) THEN
+            IF( E( N-2 )*( Q( N-1 ) / ( Q( N-1 )+T1 ) ).LE.TOLX ) THEN
+               LDEF = .TRUE.
+            END IF
+         END IF
+      ELSE
+         IF( E( N-2 ).LE.( Q( N ) / ( Q( N )+EE( N-1 )+Q( N-1 ) )*Q( N-
+     $       1 ) )*TOL2 ) THEN
+            LDEF = .TRUE.
+         END IF
+      END IF
+      IF( LDEF ) THEN
+         QEMAX = MAX( Q( N ), Q( N-1 ), E( N-1 ) )
+         IF( QEMAX.NE.ZERO ) THEN
+            IF( QEMAX.EQ.Q( N-1 ) ) THEN
+               XX = HALF*( Q( N )+Q( N-1 )+E( N-1 )+QEMAX*
+     $              SQRT( ( ( Q( N )-Q( N-1 )+E( N-1 ) ) / QEMAX )**2+
+     $              FOUR*E( N-1 ) / QEMAX ) )
+            ELSE IF( QEMAX.EQ.Q( N ) ) THEN
+               XX = HALF*( Q( N )+Q( N-1 )+E( N-1 )+QEMAX*
+     $              SQRT( ( ( Q( N-1 )-Q( N )+E( N-1 ) ) / QEMAX )**2+
+     $              FOUR*E( N-1 ) / QEMAX ) )
+            ELSE
+               XX = HALF*( Q( N )+Q( N-1 )+E( N-1 )+QEMAX*
+     $              SQRT( ( ( Q( N )-Q( N-1 )+E( N-1 ) ) / QEMAX )**2+
+     $              FOUR*Q( N-1 ) / QEMAX ) )
+            END IF
+            YY = ( MAX( Q( N ), Q( N-1 ) ) / XX )*
+     $           MIN( Q( N ), Q( N-1 ) )
+         ELSE
+            XX = ZERO
+            YY = ZERO
+         END IF
+         Q( N-1 ) = SIGMA + XX
+         Q( N ) = YY + SIGMA
+         N = N - 2
+         ICONV = ICONV + 2
+         GO TO 190
+      END IF
+*
+*     Updating bounds before going to pong
+*
+      IF( ICONV.EQ.0 ) THEN
+         KEND = KE
+         SUP = MIN( DM, SUP-TAU )
+      ELSE IF( ICONV.GT.0 ) THEN
+         SUP = MIN( Q( N ), Q( N-1 ), Q( N-2 ), Q( 1 ), Q( 2 ), Q( 3 ) )
+         IF( ICONV.EQ.1 ) THEN
+            KEND = K1END
+         ELSE IF( ICONV.EQ.2 ) THEN
+            KEND = K2END
+         ELSE
+            KEND = N
+         END IF
+         ICNT = 0
+         MAXIT = 100*N
+      END IF
+*
+*     Checking for splitting in pong
+*
+      LSPLIT = .FALSE.
+      DO 200 KS = N - 3, 3, -1
+         IF( E( KS ).LE.TOLY ) THEN
+            IF( E( KS )*( MIN( Q( KS+1 ), Q( KS ) ) / ( MIN( Q( KS+1 ),
+     $          Q( KS ) )+SIGMA ) ).LE.TOLX ) THEN
+               LSPLIT = .TRUE.
+               GO TO 210
+            END IF
+         END IF
+  200 CONTINUE
+*
+      KS = 2
+      IF( E( 2 ).LE.TOLZ ) THEN
+         LSPLIT = .TRUE.
+      ELSE IF( SIGMA.GT.ZERO ) THEN
+         T1 = SIGMA + E( 1 )*( SIGMA / ( SIGMA+Q( 1 ) ) )
+         IF( E( 2 )*( T1 / ( Q( 1 )+T1 ) ).LE.TOLY ) THEN
+            IF( E( 2 )*( Q( 1 ) / ( Q( 1 )+T1 ) ).LE.TOLX ) THEN
+               LSPLIT = .TRUE.
+            END IF
+         END IF
+      ELSE
+         IF( E( 2 ).LE.( Q( 1 ) / ( Q( 1 )+E( 1 )+Q( 2 ) ) )*Q( 2 )*
+     $       TOL2 ) THEN
+            LSPLIT = .TRUE.
+         END IF
+      END IF
+      IF( LSPLIT )
+     $   GO TO 210
+*
+      KS = 1
+      IF( E( 1 ).LE.TOLZ ) THEN
+         LSPLIT = .TRUE.
+      ELSE IF( SIGMA.GT.ZERO ) THEN
+         IF( E( 1 ).LE.EPS*( SIGMA+Q( 1 ) ) ) THEN
+            IF( E( 1 )*( Q( 1 ) / ( Q( 1 )+SIGMA ) ).LE.TOL2*
+     $          ( Q( 1 )+SIGMA ) ) THEN
+               LSPLIT = .TRUE.
+            END IF
+         END IF
+      ELSE
+         IF( E( 1 ).LE.Q( 1 )*TOL2 ) THEN
+            LSPLIT = .TRUE.
+         END IF
+      END IF
+*
+  210 CONTINUE
+      IF( LSPLIT ) THEN
+         SUP = MIN( Q( N ), Q( N-1 ), Q( N-2 ) )
+         ISP = OFF + 1
+         OFF = OFF + KS
+         KEND = MAX( 1, KEND-KS )
+         N = N - KS
+         E( KS ) = SIGMA
+         EE( KS ) = ISP
+         ICONV = 0
+         RETURN
+      END IF
+*
+*     Coincidence
+*
+      IF( TAU.EQ.ZERO .AND. DM.LE.TOLZ .AND. KEND.NE.N .AND. ICONV.EQ.
+     $    0 .AND. ICNT.GT.0 ) THEN
+         CALL DCOPY( N-KE, EE( KE ), 1, Q( KE ), 1 )
+         Q( N ) = ZERO
+         CALL DCOPY( N-KE, QQ( KE+1 ), 1, E( KE ), 1 )
+         SUP = ZERO
+      END IF
+      ICONV = 0
+      GO TO 30
+*
+*     Computation of a new shift when the previous failed (in pong)
+*
+  220 CONTINUE
+      IFL = IFL + 1
+      SUP = TAU
+*
+*     SUP is small or
+*     Too many bad shifts (in pong)
+*
+      IF( SUP.LE.TOLZ .OR. IFL.GE.IFLMAX ) THEN
+         TAU = ZERO
+         GO TO 140
+*
+*     The asymptotic shift (in pong)
+*
+      ELSE
+         TAU = MAX( TAU+D, ZERO )
+         IF( TAU.LE.TOLZ )
+     $      TAU = ZERO
+         GO TO 140
+      END IF
+*
+*     End of DLASQ3
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlasq4.f
@@ -0,0 +1,103 @@
+      SUBROUTINE DLASQ4( N, Q, E, TAU, SUP )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            N
+      DOUBLE PRECISION   SUP, TAU
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   E( * ), Q( * )
+*     ..
+*
+*     Purpose
+*     =======
+*
+*     DLASQ4 estimates TAU, the smallest eigenvalue of a matrix. This
+*     routine improves the input value of SUP which is an upper bound
+*     for the smallest eigenvalue for this matrix .
+*
+*     Arguments
+*     =========
+*
+*  N       (input) INTEGER
+*          On entry, N specifies the number of rows and columns
+*          in the matrix. N must be at least 0.
+*
+*  Q       (input) DOUBLE PRECISION array, dimension (N)
+*          Q array
+*
+*  E       (input) DOUBLE PRECISION array, dimension (N)
+*          E array
+*
+*  TAU     (output) DOUBLE PRECISION
+*          Estimate of the shift
+*
+*  SUP     (input/output) DOUBLE PRECISION
+*          Upper bound for the smallest singular value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+      DOUBLE PRECISION   BIS, BIS1
+      PARAMETER          ( BIS = 0.9999D+0, BIS1 = 0.7D+0 )
+      INTEGER            IFLMAX
+      PARAMETER          ( IFLMAX = 5 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IFL
+      DOUBLE PRECISION   D, DM, XINF
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+      IFL = 1
+      SUP = MIN( SUP, Q( 1 ), Q( 2 ), Q( 3 ), Q( N ), Q( N-1 ),
+     $      Q( N-2 ) )
+      TAU = SUP*BIS
+      XINF = ZERO
+   10 CONTINUE
+      IF( IFL.EQ.IFLMAX ) THEN
+         TAU = XINF
+         RETURN
+      END IF
+      D = Q( 1 ) - TAU
+      DM = D
+      DO 20 I = 1, N - 2
+         D = ( D / ( D+E( I ) ) )*Q( I+1 ) - TAU
+         IF( DM.GT.D )
+     $      DM = D
+         IF( D.LT.ZERO ) THEN
+            SUP = TAU
+            TAU = MAX( SUP*BIS1**IFL, D+TAU )
+            IFL = IFL + 1
+            GO TO 10
+         END IF
+   20 CONTINUE
+      D = ( D / ( D+E( N-1 ) ) )*Q( N ) - TAU
+      IF( DM.GT.D )
+     $   DM = D
+      IF( D.LT.ZERO ) THEN
+         SUP = TAU
+         XINF = MAX( XINF, D+TAU )
+         IF( SUP*BIS1**IFL.LE.XINF ) THEN
+            TAU = XINF
+         ELSE
+            TAU = SUP*BIS1**IFL
+            IFL = IFL + 1
+            GO TO 10
+         END IF
+      ELSE
+         SUP = MIN( SUP, DM+TAU )
+      END IF
+      RETURN
+*
+*     End of DLASQ4
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlasr.f
@@ -0,0 +1,325 @@
+      SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIRECT, PIVOT, SIDE
+      INTEGER            LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( * ), S( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASR   performs the transformation
+*
+*     A := P*A,   when SIDE = 'L' or 'l'  (  Left-hand side )
+*
+*     A := A*P',  when SIDE = 'R' or 'r'  ( Right-hand side )
+*
+*  where A is an m by n real matrix and P is an orthogonal matrix,
+*  consisting of a sequence of plane rotations determined by the
+*  parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l'
+*  and z = n when SIDE = 'R' or 'r' ):
+*
+*  When  DIRECT = 'F' or 'f'  ( Forward sequence ) then
+*
+*     P = P( z - 1 )*...*P( 2 )*P( 1 ),
+*
+*  and when DIRECT = 'B' or 'b'  ( Backward sequence ) then
+*
+*     P = P( 1 )*P( 2 )*...*P( z - 1 ),
+*
+*  where  P( k ) is a plane rotation matrix for the following planes:
+*
+*     when  PIVOT = 'V' or 'v'  ( Variable pivot ),
+*        the plane ( k, k + 1 )
+*
+*     when  PIVOT = 'T' or 't'  ( Top pivot ),
+*        the plane ( 1, k + 1 )
+*
+*     when  PIVOT = 'B' or 'b'  ( Bottom pivot ),
+*        the plane ( k, z )
+*
+*  c( k ) and s( k )  must contain the  cosine and sine that define the
+*  matrix  P( k ).  The two by two plane rotation part of the matrix
+*  P( k ), R( k ), is assumed to be of the form
+*
+*     R( k ) = (  c( k )  s( k ) ).
+*              ( -s( k )  c( k ) )
+*
+*  This version vectorises across rows of the array A when SIDE = 'L'.
+*
+*  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'
+*
+*  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 )
+*
+*  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)
+*
+*  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, S    (input) DOUBLE PRECISION arrays, dimension
+*                  (M-1) if SIDE = 'L'
+*                  (N-1) if SIDE = 'R'
+*          c(k) and s(k) contain the cosine and sine that define the
+*          matrix P(k).  The two by two plane rotation part of the
+*          matrix P(k), R(k), is assumed to be of 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' 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlasrt.f
@@ -0,0 +1,244 @@
+      SUBROUTINE DLASRT( ID, N, D, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlassq.f
@@ -0,0 +1,89 @@
+      SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      INTEGER            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
+*          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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlasv2.f
@@ -0,0 +1,250 @@
+      SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlaswp.f
@@ -0,0 +1,98 @@
+      SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      INTEGER            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 (M*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.
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IP, IX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSWAP
+*     ..
+*     .. Executable Statements ..
+*
+*     Interchange row I with row IPIV(I) for each of rows K1 through K2.
+*
+      IF( INCX.EQ.0 )
+     $   RETURN
+      IF( INCX.GT.0 ) THEN
+         IX = K1
+      ELSE
+         IX = 1 + ( 1-K2 )*INCX
+      END IF
+      IF( INCX.EQ.1 ) THEN
+         DO 10 I = K1, K2
+            IP = IPIV( I )
+            IF( IP.NE.I )
+     $         CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
+   10    CONTINUE
+      ELSE IF( INCX.GT.1 ) THEN
+         DO 20 I = K1, K2
+            IP = IPIV( IX )
+            IF( IP.NE.I )
+     $         CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
+            IX = IX + INCX
+   20    CONTINUE
+      ELSE IF( INCX.LT.0 ) THEN
+         DO 30 I = K2, K1, -1
+            IP = IPIV( IX )
+            IF( IP.NE.I )
+     $         CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
+            IX = IX + INCX
+   30    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DLASWP
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dlasy2.f
@@ -0,0 +1,382 @@
+      SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR,
+     $                   LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      LOGICAL            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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dorg2r.f
@@ -0,0 +1,130 @@
+      SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dorgbr.f
@@ -0,0 +1,223 @@
+      SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      CHARACTER          VECT
+      INTEGER            INFO, K, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  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            WANTQ
+      INTEGER            I, IINFO, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DORGLQ, DORGQR, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      WANTQ = LSAME( VECT, 'Q' )
+      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, MIN( M, N ) ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORGBR', -INFO )
+         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
+      RETURN
+*
+*     End of DORGBR
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dorghr.f
@@ -0,0 +1,144 @@
+      SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, ILO, INFO, LDA, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  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 ..
+      INTEGER            I, IINFO, J, NH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DORGQR, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      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
+      ELSE IF( LWORK.LT.MAX( 1, IHI-ILO ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORGHR', -INFO )
+         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
+*
+      NH = IHI - ILO
+      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
+      RETURN
+*
+*     End of DORGHR
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dorgl2.f
@@ -0,0 +1,134 @@
+      SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. 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(1:i-1,i) to zero
+*
+         DO 30 L = 1, I - 1
+            A( I, L ) = ZERO
+   30    CONTINUE
+   40 CONTINUE
+      RETURN
+*
+*     End of DORGL2
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dorglq.f
@@ -0,0 +1,207 @@
+      SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  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 ..
+      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, 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
+      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 ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORGLQ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+*     Determine the block size.
+*
+      NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 )
+      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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dorgqr.f
@@ -0,0 +1,208 @@
+      SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  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 ..
+      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, 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
+      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 ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORGQR', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+*     Determine the block size.
+*
+      NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 )
+      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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dorm2r.f
@@ -0,0 +1,198 @@
+      SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dormbr.f
@@ -0,0 +1,250 @@
+      SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
+     $                   LDC, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS, VECT
+      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            APPLYQ, LEFT, NOTRAN
+      CHARACTER          TRANST
+      INTEGER            I1, I2, IINFO, MI, NI, NQ, NW
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. 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' )
+*
+*     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 ) ) THEN
+         INFO = -13
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORMBR', -INFO )
+         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
+      RETURN
+*
+*     End of DORMBR
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dorml2.f
@@ -0,0 +1,198 @@
+      SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dormlq.f
@@ -0,0 +1,254 @@
+      SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  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, NOTRAN
+      CHARACTER          TRANST
+      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
+     $                   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' )
+*
+*     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 ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORMLQ', -INFO )
+         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
+*
+*     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 ) )
+      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 ) = IWS
+      RETURN
+*
+*     End of DORMLQ
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dormqr.f
@@ -0,0 +1,247 @@
+      SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  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, NOTRAN
+      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
+     $                   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' )
+*
+*     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 ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORMQR', -INFO )
+         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
+*
+*     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 ) )
+      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 ) = IWS
+      RETURN
+*
+*     End of DORMQR
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/drscl.f
@@ -0,0 +1,115 @@
+      SUBROUTINE DRSCL( N, SA, SX, INCX )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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           DLABAD, 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dtrevc.f
@@ -0,0 +1,989 @@
+      SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
+     $                   LDVR, MM, M, WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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.
+*
+*  The right eigenvector x and the left eigenvector y of T corresponding
+*  to an eigenvalue w are defined by:
+*
+*               T*x = w*x,     y'*T = w*y'
+*
+*  where y' denotes the conjugate transpose of the vector y.
+*
+*  If all eigenvectors are requested, the routine may either return the
+*  matrices X and/or Y of right or left eigenvectors of T, or the
+*  products Q*X and/or Q*Y, where Q is an input orthogonal
+*  matrix. If T was obtained from the real-Schur factorization of an
+*  original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of
+*  right or left eigenvectors of A.
+*
+*  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.  Corresponding to each 2-by-2
+*  diagonal block is a complex conjugate pair of eigenvalues and
+*  eigenvectors; only one eigenvector of the pair is computed, namely
+*  the one corresponding to the eigenvalue with positive imaginary part.
+*
+*
+*  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,
+*                  and backtransform them using the input matrices
+*                  supplied in VR and/or VL;
+*          = 'S':  compute selected right and/or left eigenvectors,
+*                  specified by the logical array SELECT.
+*
+*  SELECT  (input/output) LOGICAL array, dimension (N)
+*          If HOWMNY = 'S', SELECT specifies the eigenvectors to be
+*          computed.
+*          If HOWMNY = 'A' or 'B', SELECT is not referenced.
+*          To select the real eigenvector corresponding to a real
+*          eigenvalue w(j), SELECT(j) must be set to .TRUE..  To select
+*          the complex eigenvector corresponding to a complex conjugate
+*          pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) 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 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.
+*          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 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.
+*          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 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, DLABAD, 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' ) .OR. LSAME( HOWMNY, 'O' )
+      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.
+*
+  210          CONTINUE
+               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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dtrexc.f
@@ -0,0 +1,346 @@
+      SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     March 31, 1993
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dtrsen.f
@@ -0,0 +1,421 @@
+      SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI,
+     $                   M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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) DOUBLE PRECISION array, dimension (LWORK)
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If JOB = 'N', LWORK >= max(1,N);
+*          if JOB = 'E', LWORK >= M*(N-M);
+*          if JOB = 'V' or 'B', LWORK >= 2*M*(N-M).
+*
+*  IWORK   (workspace) INTEGER array, dimension (LIWORK)
+*          IF JOB = 'N' or 'E', IWORK is not referenced.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.
+*          If JOB = 'N' or 'E', LIWORK >= 1;
+*          if JOB = 'V' or 'B', LIWORK >= M*(N-M).
+*
+*  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            PAIR, SWAP, WANTBH, WANTQ, WANTS, WANTSP
+      INTEGER            IERR, K, KASE, KK, KS, N1, N2, NN
+      DOUBLE PRECISION   EST, RNORM, SCALE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLANGE
+      EXTERNAL           LSAME, DLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLACON, 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
+      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( LWORK.LT.1 .OR. ( ( WANTS .AND. .NOT.WANTSP ) .AND.
+     $       LWORK.LT.NN ) .OR. ( WANTSP .AND. LWORK.LT.2*NN ) ) THEN
+            INFO = -15
+         ELSE IF( LIWORK.LT.1 .OR. ( WANTSP .AND. LIWORK.LT.NN ) ) THEN
+            INFO = -17
+         END IF
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTRSEN', -INFO )
+         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 DLACON( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE )
+         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
+      RETURN
+*
+*     End of DTRSEN
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dtrsyl.f
@@ -0,0 +1,914 @@
+      SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
+     $                   LDC, SCALE, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     March 31, 1993
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/dzsum1.f
@@ -0,0 +1,82 @@
+      DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      INTEGER            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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/ilaenv.f
@@ -0,0 +1,506 @@
+      INTEGER          FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
+     $                 N4 )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      CHARACTER*( * )    NAME, OPTS
+      INTEGER            ISPEC, N1, N2, N3, N4
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ILAENV is called from the LAPACK routines to choose problem-dependent
+*  parameters for the local environment.  See ISPEC for a description of
+*  the parameters.
+*
+*  This version provides a set of parameters which should give good,
+*  but not optimal, performance on many of the currently available
+*  computers.  Users are encouraged to modify this subroutine to set
+*  the tuning parameters for their particular machine using the option
+*  and problem size information in the arguments.
+*
+*  This routine will not function correctly if it is converted to all
+*  lower case.  Converting it to all upper case is allowed.
+*
+*  Arguments
+*  =========
+*
+*  ISPEC   (input) INTEGER
+*          Specifies the parameter to be returned as the value of
+*          ILAENV.
+*          = 1: the optimal blocksize; if this value is 1, an unblocked
+*               algorithm will give the best performance.
+*          = 2: the minimum block size for which the block routine
+*               should be used; if the usable block size is less than
+*               this value, an unblocked routine should be used.
+*          = 3: the crossover point (in a block routine, for N less
+*               than this value, an unblocked routine should be used)
+*          = 4: the number of shifts, used in the nonsymmetric
+*               eigenvalue routines
+*          = 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 and QZ methods
+*               for nonsymmetric eigenvalue problems.
+*
+*  NAME    (input) CHARACTER*(*)
+*          The name of the calling subroutine, in either upper case or
+*          lower case.
+*
+*  OPTS    (input) CHARACTER*(*)
+*          The character options to the subroutine NAME, concatenated
+*          into a single character string.  For example, UPLO = 'U',
+*          TRANS = 'T', and DIAG = 'N' for a triangular routine would
+*          be specified as OPTS = 'UTN'.
+*
+*  N1      (input) INTEGER
+*  N2      (input) INTEGER
+*  N3      (input) INTEGER
+*  N4      (input) INTEGER
+*          Problem dimensions for the subroutine NAME; these may not all
+*          be required.
+*
+* (ILAENV) (output) INTEGER
+*          >= 0: the value of the parameter specified by ISPEC
+*          < 0:  if ILAENV = -k, the k-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  The following conventions have been used when calling ILAENV from the
+*  LAPACK routines:
+*  1)  OPTS is a concatenation of all of the character options to
+*      subroutine NAME, in the same order that they appear in the
+*      argument list for NAME, even if they are not used in determining
+*      the value of the parameter specified by ISPEC.
+*  2)  The problem dimensions N1, N2, N3, N4 are specified in the order
+*      that they appear in the argument list for NAME.  N1 is used
+*      first, N2 second, and so on, and unused problem dimensions are
+*      passed a value of -1.
+*  3)  The parameter value returned by ILAENV is checked for validity in
+*      the calling subroutine.  For example, ILAENV is used to retrieve
+*      the optimal blocksize for STRTRI as follows:
+*
+*      NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
+*      IF( NB.LE.1 ) NB = MAX( 1, N )
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            CNAME, SNAME
+      CHARACTER*1        C1
+      CHARACTER*2        C2, C4
+      CHARACTER*3        C3
+      CHARACTER*6        SUBNAM
+      INTEGER            I, IC, IZ, NB, NBMIN, NX
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CHAR, ICHAR, INT, MIN, REAL
+*     ..
+*     .. Executable Statements ..
+*
+      GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC
+*
+*     Invalid value for ISPEC
+*
+      ILAENV = -1
+      RETURN
+*
+  100 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 10 I = 2, 6
+               IC = ICHAR( SUBNAM( I:I ) )
+               IF( IC.GE.97 .AND. IC.LE.122 )
+     $            SUBNAM( I:I ) = CHAR( IC-32 )
+   10       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 20 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 )
+   20       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 30 I = 2, 6
+               IC = ICHAR( SUBNAM( I:I ) )
+               IF( IC.GE.225 .AND. IC.LE.250 )
+     $            SUBNAM( I:I ) = CHAR( IC-32 )
+   30       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 ( 110, 200, 300 ) ISPEC
+*
+  110 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 = 1
+         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 = 1
+         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
+*
+  200 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
+*
+  300 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 = 1
+         END IF
+      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
+         IF( C3.EQ.'TRD' ) THEN
+            NX = 1
+         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
+*
+  400 CONTINUE
+*
+*     ISPEC = 4:  number of shifts (used by xHSEQR)
+*
+      ILAENV = 6
+      RETURN
+*
+  500 CONTINUE
+*
+*     ISPEC = 5:  minimum column dimension (not used)
+*
+      ILAENV = 2
+      RETURN
+*
+  600 CONTINUE 
+*
+*     ISPEC = 6:  crossover point for SVD (used by xGELSS and xGESVD)
+*
+      ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
+      RETURN
+*
+  700 CONTINUE
+*
+*     ISPEC = 7:  number of processors (not used)
+*
+      ILAENV = 1
+      RETURN
+*
+  800 CONTINUE
+*
+*     ISPEC = 8:  crossover point for multishift (used by xHSEQR)
+*
+      ILAENV = 50
+      RETURN
+*
+*     End of ILAENV
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/izmax1.f
@@ -0,0 +1,96 @@
+      INTEGER          FUNCTION IZMAX1( N, CX, INCX )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         CX( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  IZMAX1 finds the index of the element whose real part has maximum
+*  absolute value.
+*
+*  Based on IZAMAX from Level 1 BLAS.
+*  The change is to use the 'genuine' absolute value.
+*
+*  Contributed by Nick Higham for use with ZLACON.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of elements in the vector CX.
+*
+*  CX      (input) COMPLEX*16 array, dimension (N)
+*          The vector whose elements will be summed.
+*
+*  INCX    (input) INTEGER
+*          The spacing between successive values of CX.  INCX >= 1.
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IX
+      DOUBLE PRECISION   SMAX
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+*
+*     NEXT LINE IS THE ONLY MODIFICATION.
+      CABS1( ZDUM ) = ABS( DBLE( 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zbdsqr.f
@@ -0,0 +1,807 @@
+      SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
+     $                   LDU, C, LDC, RWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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 value decomposition (SVD) of a real
+*  N-by-N (upper or lower) bidiagonal matrix B:  B = Q * S * P' (P'
+*  denotes the transpose of P), where S is a diagonal matrix with
+*  non-negative diagonal elements (the singular values of B), and Q
+*  and P are orthogonal matrices.
+*
+*  The routine computes S, and optionally computes U * Q, P' * VT,
+*  or Q' * C, for given complex input matrices U, VT, and 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)
+*          On entry, the elements of E contain the
+*          offdiagonal elements of of the bidiagonal matrix whose SVD
+*          is desired. On normal exit (INFO = 0), E is destroyed.
+*          If the algorithm does not converge (INFO > 0), D and E
+*          will contain the diagonal and superdiagonal elements of a
+*          bidiagonal matrix orthogonally equivalent to the one given
+*          as input. E(N) is used for workspace.
+*
+*  VT      (input/output) COMPLEX*16 array, dimension (LDVT, NCVT)
+*          On entry, an N-by-NCVT matrix VT.
+*          On exit, VT is overwritten by P' * VT.
+*          VT is 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.
+*          U is 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' * C.
+*          C is 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 only singular values wanted (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            ROTATE
+      INTEGER            I, IDIR, IROT, ISUB, ITER, IUPLO, 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, SMINLO, 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
+      IUPLO = 0
+      IF( LSAME( UPLO, 'U' ) )
+     $   IUPLO = 1
+      IF( LSAME( UPLO, 'L' ) )
+     $   IUPLO = 2
+      IF( IUPLO.EQ.0 ) 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 150
+*
+*     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
+*
+*     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( IUPLO.EQ.2 ) 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 = ABS( D( N ) )
+      DO 20 I = 1, N - 1
+         SMAX = MAX( SMAX, ABS( D( I ) ), ABS( E( I ) ) )
+   20 CONTINUE
+      SMINL = ZERO
+      IF( TOL.GE.ZERO ) THEN
+*
+*        Relative accuracy desired
+*
+         SMINOA = ABS( D( 1 ) )
+         IF( SMINOA.EQ.ZERO )
+     $      GO TO 40
+         MU = SMINOA
+         DO 30 I = 2, N
+            MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )
+            SMINOA = MIN( SMINOA, MU )
+            IF( SMINOA.EQ.ZERO )
+     $         GO TO 40
+   30    CONTINUE
+   40    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
+*
+   50 CONTINUE
+*
+*     Check for convergence or exceeding iteration count
+*
+      IF( M.LE.1 )
+     $   GO TO 150
+      IF( ITER.GT.MAXIT )
+     $   GO TO 190
+*
+*     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 60 LLL = 1, M
+         LL = M - LLL
+         IF( LL.EQ.0 )
+     $      GO TO 80
+         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 70
+         SMIN = MIN( SMIN, ABSS )
+         SMAX = MAX( SMAX, ABSS, ABSE )
+   60 CONTINUE
+   70 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 50
+      END IF
+   80 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 50
+      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 50
+         END IF
+*
+         IF( TOL.GE.ZERO ) THEN
+*
+*           If relative accuracy desired,
+*           apply convergence criterion forward
+*
+            MU = ABS( D( LL ) )
+            SMINL = MU
+            DO 90 LLL = LL, M - 1
+               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
+                  E( LLL ) = ZERO
+                  GO TO 50
+               END IF
+               SMINLO = SMINL
+               MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
+               SMINL = MIN( SMINL, MU )
+   90       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 50
+         END IF
+*
+         IF( TOL.GE.ZERO ) THEN
+*
+*           If relative accuracy desired,
+*           apply convergence criterion backward
+*
+            MU = ABS( D( M ) )
+            SMINL = MU
+            DO 100 LLL = M - 1, LL, -1
+               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
+                  E( LLL ) = ZERO
+                  GO TO 50
+               END IF
+               SMINLO = SMINL
+               MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
+               SMINL = MIN( SMINL, MU )
+  100       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
+            CALL DLARTG( D( LL )*CS, E( LL ), CS, SN, R )
+            CALL DLARTG( OLDCS*R, D( LL+1 )*SN, OLDCS, OLDSN, D( LL ) )
+            RWORK( 1 ) = CS
+            RWORK( 1+NM1 ) = SN
+            RWORK( 1+NM12 ) = OLDCS
+            RWORK( 1+NM13 ) = OLDSN
+            IROT = 1
+            DO 110 I = LL + 1, M - 1
+               CALL DLARTG( D( I )*CS, E( I ), CS, SN, R )
+               E( I-1 ) = OLDSN*R
+               CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )
+               IROT = IROT + 1
+               RWORK( IROT ) = CS
+               RWORK( IROT+NM1 ) = SN
+               RWORK( IROT+NM12 ) = OLDCS
+               RWORK( IROT+NM13 ) = OLDSN
+  110       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
+            CALL DLARTG( D( M )*CS, E( M-1 ), CS, SN, R )
+            CALL DLARTG( OLDCS*R, D( M-1 )*SN, OLDCS, OLDSN, D( M ) )
+            RWORK( M-LL ) = CS
+            RWORK( M-LL+NM1 ) = -SN
+            RWORK( M-LL+NM12 ) = OLDCS
+            RWORK( M-LL+NM13 ) = -OLDSN
+            IROT = M - LL
+            DO 120 I = M - 1, LL + 1, -1
+               CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
+               E( I ) = OLDSN*R
+               CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )
+               IROT = IROT - 1
+               RWORK( IROT ) = CS
+               RWORK( IROT+NM1 ) = -SN
+               RWORK( IROT+NM12 ) = OLDCS
+               RWORK( IROT+NM13 ) = -OLDSN
+  120       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 )
+            CALL DLARTG( F, G, COSR, SINR, R )
+            F = COSR*D( LL ) + SINR*E( LL )
+            E( LL ) = COSR*E( LL ) - SINR*D( LL )
+            G = SINR*D( LL+1 )
+            D( LL+1 ) = COSR*D( LL+1 )
+            CALL DLARTG( F, G, COSL, SINL, R )
+            D( LL ) = R
+            F = COSL*E( LL ) + SINL*D( LL+1 )
+            D( LL+1 ) = COSL*D( LL+1 ) - SINL*E( LL )
+            G = SINL*E( LL+1 )
+            E( LL+1 ) = COSL*E( LL+1 )
+            RWORK( 1 ) = COSR
+            RWORK( 1+NM1 ) = SINR
+            RWORK( 1+NM12 ) = COSL
+            RWORK( 1+NM13 ) = SINL
+            IROT = 1
+            DO 130 I = LL + 1, M - 2
+               CALL DLARTG( F, G, COSR, SINR, R )
+               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 )
+               G = SINL*E( I+1 )
+               E( I+1 ) = COSL*E( I+1 )
+               IROT = IROT + 1
+               RWORK( IROT ) = COSR
+               RWORK( IROT+NM1 ) = SINR
+               RWORK( IROT+NM12 ) = COSL
+               RWORK( IROT+NM13 ) = SINL
+  130       CONTINUE
+            CALL DLARTG( F, G, COSR, SINR, R )
+            E( M-2 ) = R
+            F = COSR*D( M-1 ) + SINR*E( M-1 )
+            E( M-1 ) = COSR*E( M-1 ) - SINR*D( M-1 )
+            G = SINR*D( M )
+            D( M ) = COSR*D( M )
+            CALL DLARTG( F, G, COSL, SINL, R )
+            D( M-1 ) = R
+            F = COSL*E( M-1 ) + SINL*D( M )
+            D( M ) = COSL*D( M ) - SINL*E( M-1 )
+            IROT = IROT + 1
+            RWORK( IROT ) = COSR
+            RWORK( IROT+NM1 ) = SINR
+            RWORK( IROT+NM12 ) = COSL
+            RWORK( IROT+NM13 ) = SINL
+            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 )
+            CALL DLARTG( F, G, COSR, SINR, R )
+            F = COSR*D( M ) + SINR*E( M-1 )
+            E( M-1 ) = COSR*E( M-1 ) - SINR*D( M )
+            G = SINR*D( M-1 )
+            D( M-1 ) = COSR*D( M-1 )
+            CALL DLARTG( F, G, COSL, SINL, R )
+            D( M ) = R
+            F = COSL*E( M-1 ) + SINL*D( M-1 )
+            D( M-1 ) = COSL*D( M-1 ) - SINL*E( M-1 )
+            G = SINL*E( M-2 )
+            E( M-2 ) = COSL*E( M-2 )
+            RWORK( M-LL ) = COSR
+            RWORK( M-LL+NM1 ) = -SINR
+            RWORK( M-LL+NM12 ) = COSL
+            RWORK( M-LL+NM13 ) = -SINL
+            IROT = M - LL
+            DO 140 I = M - 1, LL + 2, -1
+               CALL DLARTG( F, G, COSR, SINR, R )
+               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 )
+               G = SINL*E( I-2 )
+               E( I-2 ) = COSL*E( I-2 )
+               IROT = IROT - 1
+               RWORK( IROT ) = COSR
+               RWORK( IROT+NM1 ) = -SINR
+               RWORK( IROT+NM12 ) = COSL
+               RWORK( IROT+NM13 ) = -SINL
+  140       CONTINUE
+            CALL DLARTG( F, G, COSR, SINR, R )
+            E( LL+1 ) = R
+            F = COSR*D( LL+1 ) + SINR*E( LL )
+            E( LL ) = COSR*E( LL ) - SINR*D( LL+1 )
+            G = SINR*D( LL )
+            D( LL ) = COSR*D( LL )
+            CALL DLARTG( F, G, COSL, SINL, R )
+            D( LL+1 ) = R
+            F = COSL*E( LL ) + SINL*D( LL )
+            D( LL ) = COSL*D( LL ) - SINL*E( LL )
+            IROT = IROT - 1
+            RWORK( IROT ) = COSR
+            RWORK( IROT+NM1 ) = -SINR
+            RWORK( IROT+NM12 ) = COSL
+            RWORK( IROT+NM13 ) = -SINL
+            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 50
+*
+*     All singular values converged, so make them positive
+*
+  150 CONTINUE
+      DO 160 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
+  160 CONTINUE
+*
+*     Sort the singular values into decreasing order (insertion sort on
+*     singular values, but only one transposition per singular vector)
+*
+      DO 180 I = 1, N - 1
+*
+*        Scan for smallest D(I)
+*
+         ISUB = 1
+         SMIN = D( 1 )
+         DO 170 J = 2, N + 1 - I
+            IF( D( J ).LE.SMIN ) THEN
+               ISUB = J
+               SMIN = D( J )
+            END IF
+  170    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
+  180 CONTINUE
+      GO TO 210
+*
+*     Maximum number of iterations exceeded, failure to converge
+*
+  190 CONTINUE
+      INFO = 0
+      DO 200 I = 1, N - 1
+         IF( E( I ).NE.ZERO )
+     $      INFO = INFO + 1
+  200 CONTINUE
+  210 CONTINUE
+      RETURN
+*
+*     End of ZBDSQR
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zdrscl.f
@@ -0,0 +1,115 @@
+      SUBROUTINE ZDRSCL( N, SA, SX, INCX )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgebak.f
@@ -0,0 +1,190 @@
+      SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgebal.f
@@ -0,0 +1,328 @@
+      SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      DOUBLE PRECISION   SCLFAC
+      PARAMETER          ( SCLFAC = 1.0D+1 )
+      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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgebd2.f
@@ -0,0 +1,249 @@
+      SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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
+*
+            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
+*
+            CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAUP( I ),
+     $                  A( MIN( I+1, M ), 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgebrd.f
@@ -0,0 +1,259 @@
+      SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E( * )
+      COMPLEX*16         A( LDA, * ), TAUP( * ), TAUQ( * ),
+     $                   WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  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 ..
+      INTEGER            I, IINFO, J, LDWRKX, LDWRKY, MINMN, NB, NBMIN,
+     $                   NX
+      DOUBLE PRECISION   WS
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEBD2, ZGEMM, ZLABRD
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. 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
+      ELSE IF( LWORK.LT.MAX( 1, M, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.LT.0 ) THEN
+         CALL XERBLA( 'ZGEBRD', -INFO )
+         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
+*
+*     Set the block size NB and the crossover point NX.
+*
+      NB = MAX( 1, ILAENV( 1, 'ZGEBRD', ' ', M, N, -1, -1 ) )
+*
+      IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN
+*
+*        Determine when to switch from blocked to unblocked code.
+*
+         NX = MAX( NB, ILAENV( 3, 'ZGEBRD', ' ', M, N, -1, -1 ) )
+         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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgeesx.f
@@ -0,0 +1,371 @@
+      SUBROUTINE ZGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W,
+     $                   VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK,
+     $                   BWORK, INFO )
+*
+*  -- LAPACK driver routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     March 31, 1993
+*
+*     .. 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  (input) 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 (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.
+*          For good performance, LWORK must generally be larger.
+*
+*  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, K, MAXB, 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, MIN, 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.)
+*
+      MINWRK = 1
+      IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
+         MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 )
+         MINWRK = MAX( 1, 2*N )
+         IF( .NOT.WANTVS ) THEN
+            MAXB = MAX( ILAENV( 8, 'ZHSEQR', 'SN', N, 1, N, -1 ), 2 )
+            K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'ZHSEQR', 'SN', N, 1,
+     $          N, -1 ) ) )
+            HSWORK = MAX( K*( K+2 ), 2*N )
+            MAXWRK = MAX( MAXWRK, HSWORK, 1 )
+         ELSE
+            MAXWRK = MAX( MAXWRK, N+( N-1 )*
+     $               ILAENV( 1, 'ZUNGHR', ' ', N, 1, N, -1 ) )
+            MAXB = MAX( ILAENV( 8, 'ZHSEQR', 'SV', N, 1, N, -1 ), 2 )
+            K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'ZHSEQR', 'SV', N, 1,
+     $          N, -1 ) ) )
+            HSWORK = MAX( K*( K+2 ), 2*N )
+            MAXWRK = MAX( MAXWRK, HSWORK, 1 )
+         END IF
+         WORK( 1 ) = MAXWRK
+      END IF
+      IF( LWORK.LT.MINWRK ) THEN
+         INFO = -15
+      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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgeev.f
@@ -0,0 +1,383 @@
+      SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR,
+     $                  WORK, LWORK, RWORK, INFO )
+*
+*  -- LAPACK driver routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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 (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.
+*
+*  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            SCALEA, WANTVL, WANTVR
+      CHARACTER          SIDE
+      INTEGER            HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU,
+     $                   IWRK, K, MAXB, 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, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      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.)
+*
+      MINWRK = 1
+      IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
+         MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 )
+         IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN
+            MINWRK = MAX( 1, 2*N )
+            MAXB = MAX( ILAENV( 8, 'ZHSEQR', 'EN', N, 1, N, -1 ), 2 )
+            K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'ZHSEQR', 'EN', N, 1,
+     $          N, -1 ) ) )
+            HSWORK = MAX( K*( K+2 ), 2*N )
+            MAXWRK = MAX( MAXWRK, HSWORK )
+         ELSE
+            MINWRK = MAX( 1, 2*N )
+            MAXWRK = MAX( MAXWRK, N+( N-1 )*
+     $               ILAENV( 1, 'ZUNGHR', ' ', N, 1, N, -1 ) )
+            MAXB = MAX( ILAENV( 8, 'ZHSEQR', 'SV', N, 1, N, -1 ), 2 )
+            K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'ZHSEQR', 'SV', N, 1,
+     $          N, -1 ) ) )
+            HSWORK = MAX( K*( K+2 ), 2*N )
+            MAXWRK = MAX( MAXWRK, HSWORK, 2*N )
+         END IF
+         WORK( 1 ) = MAXWRK
+      END IF
+      IF( LWORK.LT.MINWRK ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGEEV ', -INFO )
+         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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgehd2.f
@@ -0,0 +1,149 @@
+      SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgehrd.f
@@ -0,0 +1,244 @@
+      SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, ILO, INFO, LDA, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( LWORK )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEHRD 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 <= 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.
+*
+*  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 ..
+      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 ..
+      INTEGER            I, IB, IINFO, IWS, LDWORK, NB, NBMIN, NH, NX
+      COMPLEX*16         EI
+*     ..
+*     .. Local Arrays ..
+      COMPLEX*16         T( LDT, NBMAX )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEHD2, ZGEMM, ZLAHRD, ZLARFB
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. 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
+      ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGEHRD', -INFO )
+         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 30 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 ZLAHRD( 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(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 )
+   30    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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgelq2.f
@@ -0,0 +1,124 @@
+      SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGELQ2 computes an LQ factorization of a complex m by n matrix A:
+*  A = L * Q.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the m by n matrix A.
+*          On exit, the elements on and below the diagonal of the array
+*          contain the m by min(m,n) lower trapezoidal matrix L (L is
+*          lower triangular if m <= n); the elements above the diagonal,
+*          with the array TAU, represent the unitary matrix Q as a
+*          product of elementary reflectors (see Further Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) COMPLEX*16 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (M)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a complex scalar, and v is a complex vector with
+*  v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in
+*  A(i,i+1:n), and tau in TAU(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      COMPLEX*16         ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLACGV, ZLARF, ZLARFG
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGELQ2', -INFO )
+         RETURN
+      END IF
+*
+      K = MIN( M, N )
+*
+      DO 10 I = 1, K
+*
+*        Generate elementary reflector H(i) to annihilate A(i,i+1:n)
+*
+         CALL ZLACGV( N-I+1, A( I, I ), LDA )
+         ALPHA = A( I, I )
+         CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
+     $                TAU( I ) )
+         IF( I.LT.M ) THEN
+*
+*           Apply H(i) to A(i+1:m,i:n) from the right
+*
+            A( I, I ) = ONE
+            CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ),
+     $                  A( I+1, I ), LDA, WORK )
+         END IF
+         A( I, I ) = ALPHA
+         CALL ZLACGV( N-I+1, A( I, I ), LDA )
+   10 CONTINUE
+      RETURN
+*
+*     End of ZGELQ2
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgelqf.f
@@ -0,0 +1,186 @@
+      SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  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 ..
+      INTEGER            I, IB, IINFO, IWS, K, LDWORK, 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
+      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 ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGELQF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      K = MIN( M, N )
+      IF( K.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+*     Determine the block size.
+*
+      NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
+      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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgelss.f
@@ -0,0 +1,629 @@
+      SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
+     $                   WORK, LWORK, RWORK, INFO )
+*
+*  -- LAPACK driver routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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 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 (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.
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (5*min(M,N)-1)
+*
+*  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.0D0, ONE = 1.0D0 )
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ),
+     $                   CONE = ( 1.0D0, 0.0D0 ) )
+*     ..
+*     .. Local Scalars ..
+      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 )
+      MNTHR = ILAENV( 6, 'ZGELSS', ' ', M, N, NRHS, -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.)
+*
+      MINWRK = 1
+      IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
+         MAXWRK = 0
+         MM = M
+         IF( M.GE.N .AND. M.GE.MNTHR ) THEN
+*
+*           Path 1a - overdetermined, with many more rows than columns
+*
+*           Space needed for ZBDSQR is BDSPAC = 5*N-1
+*
+            MM = N
+            MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'ZGEQRF', ' ', M, N,
+     $               -1, -1 ) )
+            MAXWRK = MAX( MAXWRK, N+NRHS*
+     $               ILAENV( 1, 'ZUNMQR', 'LT', M, NRHS, N, -1 ) )
+         END IF
+         IF( M.GE.N ) THEN
+*
+*           Path 1 - overdetermined or exactly determined
+*
+*           Space needed for ZBDSQR is BDSPC = 7*N+12
+*
+            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
+*
+*              Space needed for ZBDSQR is BDSPAC = 5*M-1
+*
+               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', 'LT', N, NRHS, M, -1 ) )
+            ELSE
+*
+*              Path 2 - underdetermined
+*
+*              Space needed for ZBDSQR is BDSPAC = 5*M-1
+*
+               MAXWRK = 2*M + ( N+M )*ILAENV( 1, 'ZGEBRD', ' ', M, N,
+     $                  -1, -1 )
+               MAXWRK = MAX( MAXWRK, 2*M+NRHS*
+     $                  ILAENV( 1, 'ZUNMBR', 'QLT', 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
+         MINWRK = MAX( MINWRK, 1 )
+         MAXWRK = MAX( MINWRK, MAXWRK )
+         WORK( 1 ) = MAXWRK
+      END IF
+*
+      IF( LWORK.LT.MINWRK )
+     $   INFO = -12
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGELSS', -INFO )
+         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, LDB,
+     $                     CZERO, WORK, N )
+               CALL ZLACPY( 'G', N, BL, WORK, N, B, 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 ), N )
+               CALL ZLACPY( 'G', M, BL, WORK( IWORK ), N, B, 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgeqpf.f
@@ -0,0 +1,223 @@
+      SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     March 31, 1993
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  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 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) 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.
+*
+*  =====================================================================
+*
+*     .. 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
+      COMPLEX*16         AII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEQR2, ZLARF, ZLARFG, ZSWAP, ZUNM2R
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DCMPLX, DCONJG, MAX, MIN, SQRT
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DZNRM2
+      EXTERNAL           IDAMAX, 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 )
+*
+*     Move initial columns up front
+*
+      ITEMP = 1
+      DO 10 I = 1, N
+         IF( JPVT( I ).NE.0 ) THEN
+            IF( I.NE.ITEMP ) THEN
+               CALL ZSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 )
+               JPVT( I ) = JPVT( ITEMP )
+               JPVT( ITEMP ) = I
+            ELSE
+               JPVT( I ) = I
+            END IF
+            ITEMP = ITEMP + 1
+         ELSE
+            JPVT( I ) = I
+         END IF
+   10 CONTINUE
+      ITEMP = ITEMP - 1
+*
+*     Compute the QR factorization and update remaining columns
+*
+      IF( ITEMP.GT.0 ) THEN
+         MA = MIN( ITEMP, M )
+         CALL ZGEQR2( M, MA, A, LDA, TAU, WORK, INFO )
+         IF( MA.LT.N ) THEN
+            CALL ZUNM2R( 'Left', 'Conjugate transpose', M, N-MA, MA, A,
+     $                   LDA, TAU, A( 1, MA+1 ), LDA, WORK, INFO )
+         END IF
+      END IF
+*
+      IF( ITEMP.LT.MN ) THEN
+*
+*        Initialize partial column norms. The first n elements of
+*        work store the exact column norms.
+*
+         DO 20 I = ITEMP + 1, N
+            RWORK( I ) = DZNRM2( M-ITEMP, A( ITEMP+1, I ), 1 )
+            RWORK( N+I ) = RWORK( I )
+   20    CONTINUE
+*
+*        Compute factorization
+*
+         DO 40 I = ITEMP + 1, MN
+*
+*           Determine ith pivot column and swap if necessary
+*
+            PVT = ( I-1 ) + IDAMAX( N-I+1, RWORK( I ), 1 )
+*
+            IF( PVT.NE.I ) THEN
+               CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
+               ITEMP = JPVT( PVT )
+               JPVT( PVT ) = JPVT( I )
+               JPVT( I ) = ITEMP
+               RWORK( PVT ) = RWORK( I )
+               RWORK( N+PVT ) = RWORK( N+I )
+            END IF
+*
+*           Generate elementary reflector H(i)
+*
+            AII = A( I, I )
+            CALL ZLARFG( M-I+1, AII, A( MIN( I+1, M ), I ), 1,
+     $                   TAU( I ) )
+            A( I, I ) = AII
+*
+            IF( I.LT.N ) THEN
+*
+*              Apply H(i) to A(i:m,i+1:n) from the left
+*
+               AII = A( I, I )
+               A( I, I ) = DCMPLX( ONE )
+               CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
+     $                     DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
+               A( I, I ) = AII
+            END IF
+*
+*           Update partial column norms
+*
+            DO 30 J = I + 1, N
+               IF( RWORK( J ).NE.ZERO ) THEN
+                  TEMP = ONE - ( ABS( A( I, J ) ) / RWORK( J ) )**2
+                  TEMP = MAX( TEMP, ZERO )
+                  TEMP2 = ONE + 0.05D0*TEMP*
+     $                    ( RWORK( J ) / RWORK( N+J ) )**2
+                  IF( TEMP2.EQ.ONE ) 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgeqr2.f
@@ -0,0 +1,122 @@
+      SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEQR2 computes a QR factorization of a complex m by n matrix A:
+*  A = Q * R.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the m by n matrix A.
+*          On exit, the elements on and above the diagonal of the array
+*          contain the min(m,n) by n upper trapezoidal matrix R (R is
+*          upper triangular if m >= n); the elements below the diagonal,
+*          with the array TAU, represent the unitary matrix Q as a
+*          product of elementary reflectors (see Further Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) COMPLEX*16 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a complex scalar, and v is a complex vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
+*  and tau in TAU(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      COMPLEX*16         ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARF, ZLARFG
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGEQR2', -INFO )
+         RETURN
+      END IF
+*
+      K = MIN( M, N )
+*
+      DO 10 I = 1, K
+*
+*        Generate elementary reflector H(i) to annihilate A(i+1:m,i)
+*
+         CALL ZLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
+     $                TAU( I ) )
+         IF( I.LT.N ) THEN
+*
+*           Apply H(i)' to A(i:m,i+1:n) from the left
+*
+            ALPHA = A( I, I )
+            A( I, I ) = ONE
+            CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
+     $                  DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
+            A( I, I ) = ALPHA
+         END IF
+   10 CONTINUE
+      RETURN
+*
+*     End of ZGEQR2
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgeqrf.f
@@ -0,0 +1,187 @@
+      SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  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 ..
+      INTEGER            I, IB, IINFO, IWS, K, LDWORK, 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
+      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 ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGEQRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      K = MIN( M, N )
+      IF( K.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+*     Determine the block size.
+*
+      NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
+      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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgesv.f
@@ -0,0 +1,108 @@
+      SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+*  -- LAPACK driver routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     March 31, 1993
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgesvd.f
@@ -0,0 +1,3610 @@
+      SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
+     $                   WORK, LWORK, RWORK, INFO )
+*
+*  -- LAPACK driver routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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 (LWORK)
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= 1.
+*          LWORK >=  2*MIN(M,N)+MAX(M,N).
+*          For good performance, LWORK should generally be larger.
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension
+*                                  (max(3*min(M,N),5*min(M,N)-4))
+*          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            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 )
+      MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 )
+      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' )
+      MINWRK = 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 .AND. LWORK.GE.1 .AND. M.GT.0 .AND. N.GT.0 ) THEN
+         IF( M.GE.N ) THEN
+*
+*           Space needed for ZBDSQR is BDSPAC = MAX( 3*N, 5*N-4 )
+*
+            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
+                  MAXWRK = MAX( MINWRK, MAXWRK )
+               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
+                  MAXWRK = MAX( MINWRK, MAXWRK )
+               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
+                  MAXWRK = MAX( MINWRK, MAXWRK )
+               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
+                  MAXWRK = MAX( MINWRK, MAXWRK )
+               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
+                  MAXWRK = MAX( MINWRK, MAXWRK )
+               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
+                  MAXWRK = MAX( MINWRK, MAXWRK )
+               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
+                  MAXWRK = MAX( MINWRK, MAXWRK )
+               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
+                  MAXWRK = MAX( MINWRK, MAXWRK )
+               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
+                  MAXWRK = MAX( MINWRK, MAXWRK )
+               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
+               MAXWRK = MAX( MINWRK, MAXWRK )
+            END IF
+         ELSE
+*
+*           Space needed for ZBDSQR is BDSPAC = MAX( 3*M, 5*M-4 )
+*
+            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
+                  MAXWRK = MAX( MINWRK, MAXWRK )
+               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
+                  MAXWRK = MAX( MINWRK, MAXWRK )
+               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
+                  MAXWRK = MAX( MINWRK, MAXWRK )
+               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
+                  MAXWRK = MAX( MINWRK, MAXWRK )
+               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
+                  MAXWRK = MAX( MINWRK, MAXWRK )
+               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
+                  MAXWRK = MAX( MINWRK, MAXWRK )
+               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
+                  MAXWRK = MAX( MINWRK, MAXWRK )
+               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
+                  MAXWRK = MAX( MINWRK, MAXWRK )
+               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
+                  MAXWRK = MAX( MINWRK, MAXWRK )
+               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
+               MAXWRK = MAX( MINWRK, MAXWRK )
+            END IF
+         END IF
+         WORK( 1 ) = MAXWRK
+      END IF
+*
+      IF( LWORK.LT.MINWRK ) THEN
+         INFO = -13
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGESVD', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         IF( LWORK.GE.1 )
+     $      WORK( 1 ) = ONE
+         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 )
+                  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 )
+                  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 )
+                     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 )
+                     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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgetf2.f
@@ -0,0 +1,136 @@
+      SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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 ..
+      INTEGER            J, JP
+*     ..
+*     .. External Functions ..
+      INTEGER            IZAMAX
+      EXTERNAL           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
+*
+      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 )
+     $         CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
+*
+         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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgetrf.f
@@ -0,0 +1,160 @@
+      SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zgetrs.f
@@ -0,0 +1,150 @@
+      SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zhseqr.f
@@ -0,0 +1,461 @@
+      SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      CHARACTER          COMPZ, JOB
+      INTEGER            IHI, ILO, INFO, LDH, LDZ, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHSEQR computes the eigenvalues of a complex upper 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)*T*(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 >= 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 CGEHRD
+*          when the matrix output by ZGEBAL is reduced to Hessenberg
+*          form. Otherwise ILO and IHI should be set to 1 and N
+*          respectively.
+*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+*  H       (input/output) COMPLEX*16 array, dimension (LDH,N)
+*          On entry, the upper Hessenberg matrix H.
+*          On exit, if JOB = 'S', H contains the upper triangular matrix
+*          T from the Schur decomposition (the Schur form). If
+*          JOB = 'E', the contents of H are unspecified on exit.
+*
+*  LDH     (input) INTEGER
+*          The leading dimension of the array H. LDH >= 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, 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 Z contains Q*Z.
+*          Normally Q is the unitary matrix generated by ZUNGHR after
+*          the call to ZGEHRD which formed the Hessenberg matrix H.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.
+*          LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise.
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (N)
+*
+*  LWORK   (input) INTEGER
+*          This argument is currently redundant.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, ZHSEQR failed to compute all the
+*                eigenvalues in a total of 30*(IHI-ILO+1) iterations;
+*                elements 1:ilo-1 and i+1:n of W contain those
+*                eigenvalues which have been successfully computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
+      DOUBLE PRECISION   RZERO, RONE, CONST
+      PARAMETER          ( RZERO = 0.0D+0, RONE = 1.0D+0,
+     $                   CONST = 1.5D+0 )
+      INTEGER            NSMAX, LDS
+      PARAMETER          ( NSMAX = 15, LDS = NSMAX )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            INITZ, WANTT, WANTZ
+      INTEGER            I, I1, I2, IERR, II, ITEMP, ITN, ITS, J, K, L,
+     $                   MAXB, NH, NR, NS, NV
+      DOUBLE PRECISION   OVFL, RTEMP, SMLNUM, TST1, ULP, UNFL
+      COMPLEX*16         CDUM, TAU, TEMP
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   RWORK( 1 )
+      COMPLEX*16         S( LDS, NSMAX ), V( NSMAX+1 ), VV( NSMAX+1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV, IZAMAX
+      DOUBLE PRECISION   DLAMCH, DLAPY2, ZLANHS
+      EXTERNAL           LSAME, ILAENV, IZAMAX, DLAMCH, DLAPY2, ZLANHS
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLACPY,
+     $                   ZLAHQR, ZLARFG, ZLARFX, ZLASET, ZSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      WANTT = LSAME( JOB, 'S' )
+      INITZ = LSAME( COMPZ, 'I' )
+      WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
+*
+      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
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHSEQR', -INFO )
+         RETURN
+      END IF
+*
+*     Initialize Z, if necessary
+*
+      IF( INITZ )
+     $   CALL ZLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+*
+*     Store the eigenvalues isolated by ZGEBAL.
+*
+      DO 10 I = 1, ILO - 1
+         W( I ) = H( I, I )
+   10 CONTINUE
+      DO 20 I = IHI + 1, N
+         W( I ) = H( I, I )
+   20 CONTINUE
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 )
+     $   RETURN
+      IF( ILO.EQ.IHI ) THEN
+         W( ILO ) = H( ILO, ILO )
+         RETURN
+      END IF
+*
+*     Set rows and columns ILO to IHI to zero below the first
+*     subdiagonal.
+*
+      DO 40 J = ILO, IHI - 2
+         DO 30 I = J + 2, N
+            H( I, J ) = ZERO
+   30    CONTINUE
+   40 CONTINUE
+      NH = IHI - ILO + 1
+*
+*     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 re-set inside the main loop.
+*
+      IF( WANTT ) THEN
+         I1 = 1
+         I2 = N
+      ELSE
+         I1 = ILO
+         I2 = IHI
+      END IF
+*
+*     Ensure that the subdiagonal elements are real.
+*
+      DO 50 I = ILO + 1, IHI
+         TEMP = H( I, I-1 )
+         IF( DIMAG( TEMP ).NE.RZERO ) THEN
+            RTEMP = DLAPY2( DBLE( TEMP ), DIMAG( 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( I.LT.IHI )
+     $         H( I+1, I ) = TEMP*H( I+1, I )
+            IF( WANTZ )
+     $         CALL ZSCAL( NH, TEMP, Z( ILO, I ), 1 )
+         END IF
+   50 CONTINUE
+*
+*     Determine the order of the multi-shift QR algorithm to be used.
+*
+      NS = ILAENV( 4, 'ZHSEQR', JOB // COMPZ, N, ILO, IHI, -1 )
+      MAXB = ILAENV( 8, 'ZHSEQR', JOB // COMPZ, N, ILO, IHI, -1 )
+      IF( NS.LE.1 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN
+*
+*        Use the standard double-shift algorithm
+*
+         CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, Z,
+     $                LDZ, INFO )
+         RETURN
+      END IF
+      MAXB = MAX( 2, MAXB )
+      NS = MIN( NS, MAXB, NSMAX )
+*
+*     Now 1 < NS <= MAXB < NH.
+*
+*     Set machine-dependent constants for the stopping criterion.
+*     If norm(H) <= sqrt(OVFL), overflow should not occur.
+*
+      UNFL = DLAMCH( 'Safe minimum' )
+      OVFL = RONE / UNFL
+      CALL DLABAD( UNFL, OVFL )
+      ULP = DLAMCH( 'Precision' )
+      SMLNUM = UNFL*( NH / ULP )
+*
+*     ITN is the total number of multiple-shift QR iterations allowed.
+*
+      ITN = 30*NH
+*
+*     The main loop begins here. I is the loop index and decreases from
+*     IHI to ILO in steps of at most MAXB. 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
+   60 CONTINUE
+      IF( I.LT.ILO )
+     $   GO TO 180
+*
+*     Perform multiple-shift QR iterations on rows and columns ILO to I
+*     until a submatrix of order at most MAXB splits off at the bottom
+*     because a subdiagonal element has become negligible.
+*
+      L = ILO
+      DO 160 ITS = 0, ITN
+*
+*        Look for a single small subdiagonal element.
+*
+         DO 70 K = I, L + 1, -1
+            TST1 = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) )
+            IF( TST1.EQ.RZERO )
+     $         TST1 = ZLANHS( '1', I-L+1, H( L, L ), LDH, RWORK )
+            IF( ABS( DBLE( H( K, K-1 ) ) ).LE.MAX( ULP*TST1, SMLNUM ) )
+     $         GO TO 80
+   70    CONTINUE
+   80    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 <= MAXB has split off.
+*
+         IF( L.GE.I-MAXB+1 )
+     $      GO TO 170
+*
+*        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.20 .OR. ITS.EQ.30 ) THEN
+*
+*           Exceptional shifts.
+*
+            DO 90 II = I - NS + 1, I
+               W( II ) = CONST*( ABS( DBLE( H( II, II-1 ) ) )+
+     $                   ABS( DBLE( H( II, II ) ) ) )
+   90       CONTINUE
+         ELSE
+*
+*           Use eigenvalues of trailing submatrix of order NS as shifts.
+*
+            CALL ZLACPY( 'Full', NS, NS, H( I-NS+1, I-NS+1 ), LDH, S,
+     $                   LDS )
+            CALL ZLAHQR( .FALSE., .FALSE., NS, 1, NS, S, LDS,
+     $                   W( I-NS+1 ), 1, NS, Z, LDZ, IERR )
+            IF( IERR.GT.0 ) THEN
+*
+*              If ZLAHQR failed to compute all NS eigenvalues, use the
+*              unconverged diagonal elements as the remaining shifts.
+*
+               DO 100 II = 1, IERR
+                  W( I-NS+II ) = S( II, II )
+  100          CONTINUE
+            END IF
+         END IF
+*
+*        Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
+*        where G is the Hessenberg submatrix H(L:I,L:I) and w is
+*        the vector of shifts (stored in W). The result is
+*        stored in the local array V.
+*
+         V( 1 ) = ONE
+         DO 110 II = 2, NS + 1
+            V( II ) = ZERO
+  110    CONTINUE
+         NV = 1
+         DO 130 J = I - NS + 1, I
+            CALL ZCOPY( NV+1, V, 1, VV, 1 )
+            CALL ZGEMV( 'No transpose', NV+1, NV, ONE, H( L, L ), LDH,
+     $                  VV, 1, -W( J ), V, 1 )
+            NV = NV + 1
+*
+*           Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,
+*           reset it to the unit vector.
+*
+            ITEMP = IZAMAX( NV, V, 1 )
+            RTEMP = CABS1( V( ITEMP ) )
+            IF( RTEMP.EQ.RZERO ) THEN
+               V( 1 ) = ONE
+               DO 120 II = 2, NV
+                  V( II ) = ZERO
+  120          CONTINUE
+            ELSE
+               RTEMP = MAX( RTEMP, SMLNUM )
+               CALL ZDSCAL( NV, RONE / RTEMP, V, 1 )
+            END IF
+  130    CONTINUE
+*
+*        Multiple-shift QR step
+*
+         DO 150 K = L, 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( NS+1, I-K+1 )
+            IF( K.GT.L )
+     $         CALL ZCOPY( NR, H( K, K-1 ), 1, V, 1 )
+            CALL ZLARFG( NR, V( 1 ), V( 2 ), 1, TAU )
+            IF( K.GT.L ) THEN
+               H( K, K-1 ) = V( 1 )
+               DO 140 II = K + 1, I
+                  H( II, K-1 ) = ZERO
+  140          CONTINUE
+            END IF
+            V( 1 ) = ONE
+*
+*           Apply G' from the left to transform the rows of the matrix
+*           in columns K to I2.
+*
+            CALL ZLARFX( 'Left', NR, I2-K+1, V, DCONJG( TAU ),
+     $                   H( K, K ), LDH, WORK )
+*
+*           Apply G from the right to transform the columns of the
+*           matrix in rows I1 to min(K+NR,I).
+*
+            CALL ZLARFX( 'Right', MIN( K+NR, I )-I1+1, NR, V, TAU,
+     $                   H( I1, K ), LDH, WORK )
+*
+            IF( WANTZ ) THEN
+*
+*              Accumulate transformations in the matrix Z
+*
+               CALL ZLARFX( 'Right', NH, NR, V, TAU, Z( ILO, K ), LDZ,
+     $                      WORK )
+            END IF
+  150    CONTINUE
+*
+*        Ensure that H(I,I-1) is real.
+*
+         TEMP = H( I, I-1 )
+         IF( DIMAG( TEMP ).NE.RZERO ) THEN
+            RTEMP = DLAPY2( DBLE( TEMP ), DIMAG( 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( NH, TEMP, Z( ILO, I ), 1 )
+            END IF
+         END IF
+*
+  160 CONTINUE
+*
+*     Failure to converge in remaining number of iterations
+*
+      INFO = I
+      RETURN
+*
+  170 CONTINUE
+*
+*     A submatrix of order <= MAXB in rows and columns L to I has split
+*     off. Use the double-shift QR algorithm to handle it.
+*
+      CALL ZLAHQR( WANTT, WANTZ, N, L, I, H, LDH, W, ILO, IHI, Z, LDZ,
+     $             INFO )
+      IF( INFO.GT.0 )
+     $   RETURN
+*
+*     Decrement number of remaining iterations, and return to start of
+*     the main loop with a new value of I.
+*
+      ITN = ITN - ITS
+      I = L - 1
+      GO TO 60
+*
+  180 CONTINUE
+      RETURN
+*
+*     End of ZHSEQR
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlabrd.f
@@ -0,0 +1,329 @@
+      SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
+     $                   LDY )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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     (output) 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlacgv.f
@@ -0,0 +1,61 @@
+      SUBROUTINE ZLACGV( N, X, INCX )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      INTEGER            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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlacon.f
@@ -0,0 +1,205 @@
+      SUBROUTINE ZLACON( N, V, X, EST, KASE )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      INTEGER            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    (output) DOUBLE PRECISION
+*         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.
+*
+*  =====================================================================
+*
+*     .. 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   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
+*     ..
+*     .. 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
+         IF( ABS( X( I ) ).GT.SAFMIN ) THEN
+            X( I ) = X( I ) / DCMPLX( ABS( X( I ) ) )
+         ELSE
+            X( I ) = CONE
+         END IF
+   30 CONTINUE
+      KASE = 2
+      JUMP = 2
+      RETURN
+*
+*     ................ ENTRY   (JUMP = 2)
+*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY ZTRANS(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
+         IF( ABS( X( I ) ).GT.SAFMIN ) THEN
+            X( I ) = X( I ) / DCMPLX( ABS( X( I ) ) )
+         ELSE
+            X( I ) = CONE
+         END IF
+   80 CONTINUE
+      KASE = 2
+      JUMP = 4
+      RETURN
+*
+*     ................ ENTRY   (JUMP = 4)
+*     X HAS BEEN OVERWRITTEN BY ZTRANS(A)*X.
+*
+   90 CONTINUE
+      JLAST = J
+      J = IZMAX1( N, X, 1 )
+      IF( ( DBLE( X( JLAST ) ).NE.ABS( DBLE( 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlacpy.f
@@ -0,0 +1,91 @@
+      SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zladiv.f
@@ -0,0 +1,47 @@
+      DOUBLE COMPLEX   FUNCTION ZLADIV( X, Y )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlahqr.f
@@ -0,0 +1,380 @@
+      SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
+     $                   IHIZ, Z, LDZ, INFO )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      LOGICAL            WANTT, WANTZ
+      INTEGER            IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         H( LDH, * ), W( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAHQR is an auxiliary routine called by ZHSEQR to update the
+*  eigenvalues and Schur decomposition already computed by ZHSEQR, 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 WANTT is .TRUE., H is upper triangular in rows
+*          and columns ILO:IHI, with any 2-by-2 diagonal blocks in
+*          standard form. If WANTT is .FALSE., the contents of H are
+*          unspecified on exit.
+*
+*  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 ZHSEQR, 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
+*          > 0: if INFO = i, ZLAHQR failed to compute all the
+*               eigenvalues ILO to IHI in a total of 30*(IHI-ILO+1)
+*               iterations; elements i+1:ihi of W contain those
+*               eigenvalues which have been successfully computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
+      DOUBLE PRECISION   RZERO, RONE, HALF
+      PARAMETER          ( RZERO = 0.0D+0, RONE = 1.0D+0,
+     $                   HALF = 0.5D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, I1, I2, ITN, ITS, J, K, L, M, NH, NZ
+      DOUBLE PRECISION   H10, H21, OVFL, RTEMP, S, SMLNUM, T2, TST1,
+     $                   ULP, UNFL
+      COMPLEX*16         CDUM, H11, H11S, H22, SUM, T, T1, TEMP, U, V2,
+     $                   X, Y
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   RWORK( 1 )
+      COMPLEX*16         V( 2 )
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, DLAPY2, ZLANHS
+      COMPLEX*16         ZLADIV
+      EXTERNAL           DLAMCH, DLAPY2, ZLANHS, ZLADIV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, ZCOPY, ZLARFG, ZSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. 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
+*
+      NH = IHI - ILO + 1
+      NZ = IHIZ - ILOZ + 1
+*
+*     Set machine-dependent constants for the stopping criterion.
+*     If norm(H) <= sqrt(OVFL), overflow should not occur.
+*
+      UNFL = DLAMCH( 'Safe minimum' )
+      OVFL = RONE / UNFL
+      CALL DLABAD( UNFL, OVFL )
+      ULP = DLAMCH( 'Precision' )
+      SMLNUM = UNFL*( 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
+*
+*     ITN is the total number of QR iterations allowed.
+*
+      ITN = 30*NH
+*
+*     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
+   10 CONTINUE
+      IF( I.LT.ILO )
+     $   GO TO 130
+*
+*     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 110 ITS = 0, ITN
+*
+*        Look for a single small subdiagonal element.
+*
+         DO 20 K = I, L + 1, -1
+            TST1 = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) )
+            IF( TST1.EQ.RZERO )
+     $         TST1 = ZLANHS( '1', I-L+1, H( L, L ), LDH, RWORK )
+            IF( ABS( DBLE( H( K, K-1 ) ) ).LE.MAX( ULP*TST1, SMLNUM ) )
+     $         GO TO 30
+   20    CONTINUE
+   30    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 120
+*
+*        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.
+*
+            T = ABS( DBLE( H( I, I-1 ) ) ) +
+     $          ABS( DBLE( H( I-1, I-2 ) ) )
+         ELSE
+*
+*           Wilkinson's shift.
+*
+            T = H( I, I )
+            U = H( I-1, I )*DBLE( H( I, I-1 ) )
+            IF( U.NE.ZERO ) THEN
+               X = HALF*( H( I-1, I-1 )-T )
+               Y = SQRT( X*X+U )
+               IF( DBLE( X )*DBLE( Y )+DIMAG( X )*DIMAG( Y ).LT.RZERO )
+     $            Y = -Y
+               T = T - ZLADIV( U, ( X+Y ) )
+            END IF
+         END IF
+*
+*        Look for two consecutive small subdiagonal elements.
+*
+         DO 40 M = I - 1, L, -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
+            IF( M.EQ.L )
+     $         GO TO 50
+            H10 = H( M, M-1 )
+            TST1 = CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) )
+            IF( ABS( H10*H21 ).LE.ULP*TST1 )
+     $         GO TO 50
+   40    CONTINUE
+   50    CONTINUE
+*
+*        Single-shift QR step
+*
+         DO 100 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 60 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
+   60       CONTINUE
+*
+*           Apply G from the right to transform the columns of the
+*           matrix in rows I1 to min(K+2,I).
+*
+            DO 70 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 )
+   70       CONTINUE
+*
+            IF( WANTZ ) THEN
+*
+*              Accumulate transformations in the matrix Z
+*
+               DO 80 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 )
+   80          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 / DLAPY2( DBLE( TEMP ), DIMAG( 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 90 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
+   90          CONTINUE
+            END IF
+  100    CONTINUE
+*
+*        Ensure that H(I,I-1) is real.
+*
+         TEMP = H( I, I-1 )
+         IF( DIMAG( TEMP ).NE.RZERO ) THEN
+            RTEMP = DLAPY2( DBLE( TEMP ), DIMAG( 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
+*
+  110 CONTINUE
+*
+*     Failure to converge in remaining number of iterations
+*
+      INFO = I
+      RETURN
+*
+  120 CONTINUE
+*
+*     H(I,I-1) is negligible: one eigenvalue has converged.
+*
+      W( I ) = H( I, I )
+*
+*     Decrement number of remaining iterations, and return to start of
+*     the main loop with new value of I.
+*
+      ITN = ITN - ITS
+      I = L - 1
+      GO TO 10
+*
+  130 CONTINUE
+      RETURN
+*
+*     End of ZLAHQR
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlahrd.f
@@ -0,0 +1,212 @@
+      SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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 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.
+*
+*  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 (NB,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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlange.f
@@ -0,0 +1,146 @@
+      DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      CHARACTER          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  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 (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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlanhs.f
@@ -0,0 +1,143 @@
+      DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      CHARACTER          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  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 (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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlarf.f
@@ -0,0 +1,121 @@
+      SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE
+      INTEGER            INCV, LDC, M, N
+      COMPLEX*16         TAU
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         C( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARF applies a complex elementary reflector H to a complex M-by-N
+*  matrix C, from either the left or the right. H is represented in the
+*  form
+*
+*        H = I - tau * v * v'
+*
+*  where tau is a complex scalar and v is a complex vector.
+*
+*  If tau = 0, then H is taken to be the unit matrix.
+*
+*  To apply H' (the conjugate transpose of H), supply conjg(tau) instead
+*  tau.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': form  H * C
+*          = 'R': form  C * H
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C.
+*
+*  V       (input) COMPLEX*16 array, dimension
+*                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'
+*                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
+*          The vector v in the representation of H. V is not used if
+*          TAU = 0.
+*
+*  INCV    (input) INTEGER
+*          The increment between elements of v. INCV <> 0.
+*
+*  TAU     (input) COMPLEX*16
+*          The value tau in the representation of H.
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*          or C * H if SIDE = 'R'.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension
+*                         (N) if SIDE = 'L'
+*                      or (M) if SIDE = 'R'
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
+     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZGEMV, ZGERC
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+      IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*        Form  H * C
+*
+         IF( TAU.NE.ZERO ) THEN
+*
+*           w := C' * v
+*
+            CALL ZGEMV( 'Conjugate transpose', M, N, ONE, C, LDC, V,
+     $                  INCV, ZERO, WORK, 1 )
+*
+*           C := C - v * w'
+*
+            CALL ZGERC( M, N, -TAU, V, INCV, WORK, 1, C, LDC )
+         END IF
+      ELSE
+*
+*        Form  C * H
+*
+         IF( TAU.NE.ZERO ) THEN
+*
+*           w := C * v
+*
+            CALL ZGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV,
+     $                  ZERO, WORK, 1 )
+*
+*           C := C - w * v'
+*
+            CALL ZGERC( M, N, -TAU, WORK, 1, V, INCV, C, LDC )
+         END IF
+      END IF
+      RETURN
+*
+*     End of ZLARF
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlarfb.f
@@ -0,0 +1,609 @@
+      SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
+     $                   T, LDT, C, LDC, WORK, LDWORK )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIRECT, SIDE, STOREV, TRANS
+      INTEGER            K, LDC, LDT, LDV, LDWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         C( LDC, * ), T( LDT, * ), V( LDV, * ),
+     $                   WORK( LDWORK, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARFB applies a complex block reflector H or its transpose H' to a
+*  complex M-by-N matrix C, from either the left or the right.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply H or H' from the Left
+*          = 'R': apply H or H' from the Right
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N': apply H (No transpose)
+*          = 'C': apply H' (Conjugate transpose)
+*
+*  DIRECT  (input) CHARACTER*1
+*          Indicates how H is formed from a product of elementary
+*          reflectors
+*          = 'F': H = H(1) H(2) . . . H(k) (Forward)
+*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+*  STOREV  (input) CHARACTER*1
+*          Indicates how the vectors which define the elementary
+*          reflectors are stored:
+*          = 'C': Columnwise
+*          = 'R': Rowwise
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C.
+*
+*  K       (input) INTEGER
+*          The order of the matrix T (= the number of elementary
+*          reflectors whose product defines the block reflector).
+*
+*  V       (input) COMPLEX*16 array, dimension
+*                                (LDV,K) if STOREV = 'C'
+*                                (LDV,M) if STOREV = 'R' and SIDE = 'L'
+*                                (LDV,N) if STOREV = 'R' and SIDE = 'R'
+*          The matrix V. See further details.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V.
+*          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
+*          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
+*          if STOREV = 'R', LDV >= K.
+*
+*  T       (input) COMPLEX*16 array, dimension (LDT,K)
+*          The triangular K-by-K matrix T in the representation of the
+*          block reflector.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= K.
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (LDWORK,K)
+*
+*  LDWORK  (input) INTEGER
+*          The leading dimension of the array WORK.
+*          If SIDE = 'L', LDWORK >= max(1,N);
+*          if SIDE = 'R', LDWORK >= max(1,M).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      CHARACTER          TRANST
+      INTEGER            I, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZCOPY, ZGEMM, ZLACGV, ZTRMM
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 .OR. N.LE.0 )
+     $   RETURN
+*
+      IF( LSAME( TRANS, 'N' ) ) THEN
+         TRANST = 'C'
+      ELSE
+         TRANST = 'N'
+      END IF
+*
+      IF( LSAME( STOREV, 'C' ) ) THEN
+*
+         IF( LSAME( DIRECT, 'F' ) ) THEN
+*
+*           Let  V =  ( V1 )    (first K rows)
+*                     ( V2 )
+*           where  V1  is unit lower triangular.
+*
+            IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*              Form  H * C  or  H' * C  where  C = ( C1 )
+*                                                  ( C2 )
+*
+*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
+*
+*              W := C1'
+*
+               DO 10 J = 1, K
+                  CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+                  CALL ZLACGV( N, WORK( 1, J ), 1 )
+   10          CONTINUE
+*
+*              W := W * V1
+*
+               CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+     $                     K, ONE, V, LDV, WORK, LDWORK )
+               IF( M.GT.K ) THEN
+*
+*                 W := W + C2'*V2
+*
+                  CALL ZGEMM( 'Conjugate transpose', 'No transpose', N,
+     $                        K, M-K, ONE, C( K+1, 1 ), LDC,
+     $                        V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V * W'
+*
+               IF( M.GT.K ) THEN
+*
+*                 C2 := C2 - V2 * W'
+*
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose',
+     $                        M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK,
+     $                        LDWORK, ONE, C( K+1, 1 ), LDC )
+               END IF
+*
+*              W := W * V1'
+*
+               CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
+     $                     'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W'
+*
+               DO 30 J = 1, K
+                  DO 20 I = 1, N
+                     C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
+   20             CONTINUE
+   30          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
+*
+*              W := C1
+*
+               DO 40 J = 1, K
+                  CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
+   40          CONTINUE
+*
+*              W := W * V1
+*
+               CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+     $                     K, ONE, V, LDV, WORK, LDWORK )
+               IF( N.GT.K ) THEN
+*
+*                 W := W + C2 * V2
+*
+                  CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K,
+     $                        ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
+     $                        ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V'
+*
+               IF( N.GT.K ) THEN
+*
+*                 C2 := C2 - W * V2'
+*
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
+     $                        N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ),
+     $                        LDV, ONE, C( 1, K+1 ), LDC )
+               END IF
+*
+*              W := W * V1'
+*
+               CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
+     $                     'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 60 J = 1, K
+                  DO 50 I = 1, M
+                     C( I, J ) = C( I, J ) - WORK( I, J )
+   50             CONTINUE
+   60          CONTINUE
+            END IF
+*
+         ELSE
+*
+*           Let  V =  ( V1 )
+*                     ( V2 )    (last K rows)
+*           where  V2  is unit upper triangular.
+*
+            IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*              Form  H * C  or  H' * C  where  C = ( C1 )
+*                                                  ( C2 )
+*
+*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
+*
+*              W := C2'
+*
+               DO 70 J = 1, K
+                  CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
+                  CALL ZLACGV( N, WORK( 1, J ), 1 )
+   70          CONTINUE
+*
+*              W := W * V2
+*
+               CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+     $                     K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
+               IF( M.GT.K ) THEN
+*
+*                 W := W + C1'*V1
+*
+                  CALL ZGEMM( 'Conjugate transpose', 'No transpose', N,
+     $                        K, M-K, ONE, C, LDC, V, LDV, ONE, WORK,
+     $                        LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V * W'
+*
+               IF( M.GT.K ) THEN
+*
+*                 C1 := C1 - V1 * W'
+*
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose',
+     $                        M-K, N, K, -ONE, V, LDV, WORK, LDWORK,
+     $                        ONE, C, LDC )
+               END IF
+*
+*              W := W * V2'
+*
+               CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
+     $                     'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK,
+     $                     LDWORK )
+*
+*              C2 := C2 - W'
+*
+               DO 90 J = 1, K
+                  DO 80 I = 1, N
+                     C( M-K+J, I ) = C( M-K+J, I ) -
+     $                               DCONJG( WORK( I, J ) )
+   80             CONTINUE
+   90          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
+*
+*              W := C2
+*
+               DO 100 J = 1, K
+                  CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
+  100          CONTINUE
+*
+*              W := W * V2
+*
+               CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+     $                     K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
+               IF( N.GT.K ) THEN
+*
+*                 W := W + C1 * V1
+*
+                  CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K,
+     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V'
+*
+               IF( N.GT.K ) THEN
+*
+*                 C1 := C1 - W * V1'
+*
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
+     $                        N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE,
+     $                        C, LDC )
+               END IF
+*
+*              W := W * V2'
+*
+               CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
+     $                     'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK,
+     $                     LDWORK )
+*
+*              C2 := C2 - W
+*
+               DO 120 J = 1, K
+                  DO 110 I = 1, M
+                     C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
+  110             CONTINUE
+  120          CONTINUE
+            END IF
+         END IF
+*
+      ELSE IF( LSAME( STOREV, 'R' ) ) THEN
+*
+         IF( LSAME( DIRECT, 'F' ) ) THEN
+*
+*           Let  V =  ( V1  V2 )    (V1: first K columns)
+*           where  V1  is unit upper triangular.
+*
+            IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*              Form  H * C  or  H' * C  where  C = ( C1 )
+*                                                  ( C2 )
+*
+*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
+*
+*              W := C1'
+*
+               DO 130 J = 1, K
+                  CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+                  CALL ZLACGV( N, WORK( 1, J ), 1 )
+  130          CONTINUE
+*
+*              W := W * V1'
+*
+               CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
+     $                     'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
+               IF( M.GT.K ) THEN
+*
+*                 W := W + C2'*V2'
+*
+                  CALL ZGEMM( 'Conjugate transpose',
+     $                        'Conjugate transpose', N, K, M-K, ONE,
+     $                        C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
+     $                        WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V' * W'
+*
+               IF( M.GT.K ) THEN
+*
+*                 C2 := C2 - V2' * W'
+*
+                  CALL ZGEMM( 'Conjugate transpose',
+     $                        'Conjugate transpose', M-K, N, K, -ONE,
+     $                        V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
+     $                        C( K+1, 1 ), LDC )
+               END IF
+*
+*              W := W * V1
+*
+               CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+     $                     K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W'
+*
+               DO 150 J = 1, K
+                  DO 140 I = 1, N
+                     C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
+  140             CONTINUE
+  150          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
+*
+*              W := C1
+*
+               DO 160 J = 1, K
+                  CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
+  160          CONTINUE
+*
+*              W := W * V1'
+*
+               CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
+     $                     'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
+               IF( N.GT.K ) THEN
+*
+*                 W := W + C2 * V2'
+*
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
+     $                        K, N-K, ONE, C( 1, K+1 ), LDC,
+     $                        V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V
+*
+               IF( N.GT.K ) THEN
+*
+*                 C2 := C2 - W * V2
+*
+                  CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K,
+     $                        -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
+     $                        C( 1, K+1 ), LDC )
+               END IF
+*
+*              W := W * V1
+*
+               CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+     $                     K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 180 J = 1, K
+                  DO 170 I = 1, M
+                     C( I, J ) = C( I, J ) - WORK( I, J )
+  170             CONTINUE
+  180          CONTINUE
+*
+            END IF
+*
+         ELSE
+*
+*           Let  V =  ( V1  V2 )    (V2: last K columns)
+*           where  V2  is unit lower triangular.
+*
+            IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*              Form  H * C  or  H' * C  where  C = ( C1 )
+*                                                  ( C2 )
+*
+*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
+*
+*              W := C2'
+*
+               DO 190 J = 1, K
+                  CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
+                  CALL ZLACGV( N, WORK( 1, J ), 1 )
+  190          CONTINUE
+*
+*              W := W * V2'
+*
+               CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
+     $                     'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK,
+     $                     LDWORK )
+               IF( M.GT.K ) THEN
+*
+*                 W := W + C1'*V1'
+*
+                  CALL ZGEMM( 'Conjugate transpose',
+     $                        'Conjugate transpose', N, K, M-K, ONE, C,
+     $                        LDC, V, LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V' * W'
+*
+               IF( M.GT.K ) THEN
+*
+*                 C1 := C1 - V1' * W'
+*
+                  CALL ZGEMM( 'Conjugate transpose',
+     $                        'Conjugate transpose', M-K, N, K, -ONE, V,
+     $                        LDV, WORK, LDWORK, ONE, C, LDC )
+               END IF
+*
+*              W := W * V2
+*
+               CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+     $                     K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
+*
+*              C2 := C2 - W'
+*
+               DO 210 J = 1, K
+                  DO 200 I = 1, N
+                     C( M-K+J, I ) = C( M-K+J, I ) -
+     $                               DCONJG( WORK( I, J ) )
+  200             CONTINUE
+  210          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
+*
+*              W := C2
+*
+               DO 220 J = 1, K
+                  CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
+  220          CONTINUE
+*
+*              W := W * V2'
+*
+               CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
+     $                     'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK,
+     $                     LDWORK )
+               IF( N.GT.K ) THEN
+*
+*                 W := W + C1 * V1'
+*
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
+     $                        K, N-K, ONE, C, LDC, V, LDV, ONE, WORK,
+     $                        LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V
+*
+               IF( N.GT.K ) THEN
+*
+*                 C1 := C1 - W * V1
+*
+                  CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K,
+     $                        -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
+               END IF
+*
+*              W := W * V2
+*
+               CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+     $                     K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 240 J = 1, K
+                  DO 230 I = 1, M
+                     C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
+  230             CONTINUE
+  240          CONTINUE
+*
+            END IF
+*
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZLARFB
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlarfg.f
@@ -0,0 +1,146 @@
+      SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, N
+      COMPLEX*16         ALPHA, TAU
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARFG generates a complex elementary reflector H of order n, such
+*  that
+*
+*        H' * ( alpha ) = ( beta ),   H' * H = I.
+*             (   x   )   (   0  )
+*
+*  where alpha and beta are scalars, with beta real, and x is an
+*  (n-1)-element complex vector. H is represented in the form
+*
+*        H = I - tau * ( 1 ) * ( 1 v' ) ,
+*                      ( v )
+*
+*  where tau is a complex scalar and v is a complex (n-1)-element
+*  vector. Note that H is not hermitian.
+*
+*  If the elements of x are all zero and alpha is real, then tau = 0
+*  and H is taken to be the unit matrix.
+*
+*  Otherwise  1 <= real(tau) <= 2  and  abs(tau-1) <= 1 .
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the elementary reflector.
+*
+*  ALPHA   (input/output) COMPLEX*16
+*          On entry, the value alpha.
+*          On exit, it is overwritten with the value beta.
+*
+*  X       (input/output) COMPLEX*16 array, dimension
+*                         (1+(N-2)*abs(INCX))
+*          On entry, the vector x.
+*          On exit, it is overwritten with the vector v.
+*
+*  INCX    (input) INTEGER
+*          The increment between elements of X. INCX > 0.
+*
+*  TAU     (output) COMPLEX*16
+*          The value tau.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J, KNT
+      DOUBLE PRECISION   ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, DLAPY3, DZNRM2
+      COMPLEX*16         ZLADIV
+      EXTERNAL           DLAMCH, DLAPY3, DZNRM2, ZLADIV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, SIGN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZDSCAL, ZSCAL
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.LE.0 ) THEN
+         TAU = ZERO
+         RETURN
+      END IF
+*
+      XNORM = DZNRM2( N-1, X, INCX )
+      ALPHR = DBLE( ALPHA )
+      ALPHI = DIMAG( ALPHA )
+*
+      IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
+*
+*        H  =  I
+*
+         TAU = ZERO
+      ELSE
+*
+*        general case
+*
+         BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
+         SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
+         RSAFMN = ONE / SAFMIN
+*
+         IF( ABS( BETA ).LT.SAFMIN ) THEN
+*
+*           XNORM, BETA may be inaccurate; scale X and recompute them
+*
+            KNT = 0
+   10       CONTINUE
+            KNT = KNT + 1
+            CALL ZDSCAL( N-1, RSAFMN, X, INCX )
+            BETA = BETA*RSAFMN
+            ALPHI = ALPHI*RSAFMN
+            ALPHR = ALPHR*RSAFMN
+            IF( ABS( BETA ).LT.SAFMIN )
+     $         GO TO 10
+*
+*           New BETA is at most 1, at least SAFMIN
+*
+            XNORM = DZNRM2( N-1, X, INCX )
+            ALPHA = DCMPLX( ALPHR, ALPHI )
+            BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
+            TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
+            ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
+            CALL ZSCAL( N-1, ALPHA, X, INCX )
+*
+*           If ALPHA is subnormal, it may lose relative accuracy
+*
+            ALPHA = BETA
+            DO 20 J = 1, KNT
+               ALPHA = ALPHA*SAFMIN
+   20       CONTINUE
+         ELSE
+            TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
+            ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
+            CALL ZSCAL( N-1, ALPHA, X, INCX )
+            ALPHA = BETA
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZLARFG
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlarft.f
@@ -0,0 +1,225 @@
+      SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIRECT, STOREV
+      INTEGER            K, LDT, LDV, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         T( LDT, * ), TAU( * ), V( LDV, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARFT forms the triangular factor T of a complex block reflector H
+*  of order n, which is defined as a product of k elementary reflectors.
+*
+*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
+*
+*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
+*
+*  If STOREV = 'C', the vector which defines the elementary reflector
+*  H(i) is stored in the i-th column of the array V, and
+*
+*     H  =  I - V * T * V'
+*
+*  If STOREV = 'R', the vector which defines the elementary reflector
+*  H(i) is stored in the i-th row of the array V, and
+*
+*     H  =  I - V' * T * V
+*
+*  Arguments
+*  =========
+*
+*  DIRECT  (input) CHARACTER*1
+*          Specifies the order in which the elementary reflectors are
+*          multiplied to form the block reflector:
+*          = 'F': H = H(1) H(2) . . . H(k) (Forward)
+*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+*  STOREV  (input) CHARACTER*1
+*          Specifies how the vectors which define the elementary
+*          reflectors are stored (see also Further Details):
+*          = 'C': columnwise
+*          = 'R': rowwise
+*
+*  N       (input) INTEGER
+*          The order of the block reflector H. N >= 0.
+*
+*  K       (input) INTEGER
+*          The order of the triangular factor T (= the number of
+*          elementary reflectors). K >= 1.
+*
+*  V       (input/output) COMPLEX*16 array, dimension
+*                               (LDV,K) if STOREV = 'C'
+*                               (LDV,N) if STOREV = 'R'
+*          The matrix V. See further details.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V.
+*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
+*
+*  TAU     (input) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i).
+*
+*  T       (output) COMPLEX*16 array, dimension (LDT,K)
+*          The k by k triangular factor T of the block reflector.
+*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
+*          lower triangular. The rest of the array is not used.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= K.
+*
+*  Further Details
+*  ===============
+*
+*  The shape of the matrix V and the storage of the vectors which define
+*  the H(i) is best illustrated by the following example with n = 5 and
+*  k = 3. The elements equal to 1 are not stored; the corresponding
+*  array elements are modified but restored on exit. The rest of the
+*  array is not used.
+*
+*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
+*
+*               V = (  1       )                 V = (  1 v1 v1 v1 v1 )
+*                   ( v1  1    )                     (     1 v2 v2 v2 )
+*                   ( v1 v2  1 )                     (        1 v3 v3 )
+*                   ( v1 v2 v3 )
+*                   ( v1 v2 v3 )
+*
+*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
+*
+*               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )
+*                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )
+*                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )
+*                   (     1 v3 )
+*                   (        1 )
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
+     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      COMPLEX*16         VII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZGEMV, ZLACGV, ZTRMV
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( LSAME( DIRECT, 'F' ) ) THEN
+         DO 20 I = 1, K
+            IF( TAU( I ).EQ.ZERO ) THEN
+*
+*              H(i)  =  I
+*
+               DO 10 J = 1, I
+                  T( J, I ) = ZERO
+   10          CONTINUE
+            ELSE
+*
+*              general case
+*
+               VII = V( I, I )
+               V( I, I ) = ONE
+               IF( LSAME( STOREV, 'C' ) ) THEN
+*
+*                 T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i)
+*
+                  CALL ZGEMV( 'Conjugate transpose', N-I+1, I-1,
+     $                        -TAU( I ), V( I, 1 ), LDV, V( I, I ), 1,
+     $                        ZERO, T( 1, I ), 1 )
+               ELSE
+*
+*                 T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)'
+*
+                  IF( I.LT.N )
+     $               CALL ZLACGV( N-I, V( I, I+1 ), LDV )
+                  CALL ZGEMV( 'No transpose', I-1, N-I+1, -TAU( I ),
+     $                        V( 1, I ), LDV, V( I, I ), LDV, ZERO,
+     $                        T( 1, I ), 1 )
+                  IF( I.LT.N )
+     $               CALL ZLACGV( N-I, V( I, I+1 ), LDV )
+               END IF
+               V( I, I ) = VII
+*
+*              T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
+*
+               CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
+     $                     LDT, T( 1, I ), 1 )
+               T( I, I ) = TAU( I )
+            END IF
+   20    CONTINUE
+      ELSE
+         DO 40 I = K, 1, -1
+            IF( TAU( I ).EQ.ZERO ) THEN
+*
+*              H(i)  =  I
+*
+               DO 30 J = I, K
+                  T( J, I ) = ZERO
+   30          CONTINUE
+            ELSE
+*
+*              general case
+*
+               IF( I.LT.K ) THEN
+                  IF( LSAME( STOREV, 'C' ) ) THEN
+                     VII = V( N-K+I, I )
+                     V( N-K+I, I ) = ONE
+*
+*                    T(i+1:k,i) :=
+*                            - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i)
+*
+                     CALL ZGEMV( 'Conjugate transpose', N-K+I, K-I,
+     $                           -TAU( I ), V( 1, I+1 ), LDV, V( 1, I ),
+     $                           1, ZERO, T( I+1, I ), 1 )
+                     V( N-K+I, I ) = VII
+                  ELSE
+                     VII = V( I, N-K+I )
+                     V( I, N-K+I ) = ONE
+*
+*                    T(i+1:k,i) :=
+*                            - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)'
+*
+                     CALL ZLACGV( N-K+I-1, V( I, 1 ), LDV )
+                     CALL ZGEMV( 'No transpose', K-I, N-K+I, -TAU( I ),
+     $                           V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO,
+     $                           T( I+1, I ), 1 )
+                     CALL ZLACGV( N-K+I-1, V( I, 1 ), LDV )
+                     V( I, N-K+I ) = VII
+                  END IF
+*
+*                 T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
+*
+                  CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
+     $                        T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
+               END IF
+               T( I, I ) = TAU( I )
+            END IF
+   40    CONTINUE
+      END IF
+      RETURN
+*
+*     End of ZLARFT
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlarfx.f
@@ -0,0 +1,642 @@
+      SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE
+      INTEGER            LDC, M, N
+      COMPLEX*16         TAU
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         C( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARFX applies a complex elementary reflector H to a complex m by n
+*  matrix C, from either the left or the right. H is represented in the
+*  form
+*
+*        H = I - tau * v * v'
+*
+*  where tau is a complex scalar and v is a complex vector.
+*
+*  If tau = 0, then H is taken to be the unit matrix
+*
+*  This version uses inline code if H has order < 11.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': form  H * C
+*          = 'R': form  C * H
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C.
+*
+*  V       (input) COMPLEX*16 array, dimension (M) if SIDE = 'L'
+*                                        or (N) if SIDE = 'R'
+*          The vector v in the representation of H.
+*
+*  TAU     (input) COMPLEX*16
+*          The value tau in the representation of H.
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
+*          On entry, the m by n matrix C.
+*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*          or C * H if SIDE = 'R'.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDA >= max(1,M).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (N) if SIDE = 'L'
+*                                            or (M) if SIDE = 'R'
+*          WORK is not referenced if H has order < 11.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J
+      COMPLEX*16         SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9,
+     $                   V1, V10, V2, V3, V4, V5, V6, V7, V8, V9
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZGEMV, ZGERC
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG
+*     ..
+*     .. Executable Statements ..
+*
+      IF( TAU.EQ.ZERO )
+     $   RETURN
+      IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*        Form  H * C, where H has order m.
+*
+         GO TO ( 10, 30, 50, 70, 90, 110, 130, 150,
+     $           170, 190 )M
+*
+*        Code for general M
+*
+*        w := C'*v
+*
+         CALL ZGEMV( 'Conjugate transpose', M, N, ONE, C, LDC, V, 1,
+     $               ZERO, WORK, 1 )
+*
+*        C := C - tau * v * w'
+*
+         CALL ZGERC( M, N, -TAU, V, 1, WORK, 1, C, LDC )
+         GO TO 410
+   10    CONTINUE
+*
+*        Special code for 1 x 1 Householder
+*
+         T1 = ONE - TAU*V( 1 )*DCONJG( V( 1 ) )
+         DO 20 J = 1, N
+            C( 1, J ) = T1*C( 1, J )
+   20    CONTINUE
+         GO TO 410
+   30    CONTINUE
+*
+*        Special code for 2 x 2 Householder
+*
+         V1 = DCONJG( V( 1 ) )
+         T1 = TAU*DCONJG( V1 )
+         V2 = DCONJG( V( 2 ) )
+         T2 = TAU*DCONJG( V2 )
+         DO 40 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+   40    CONTINUE
+         GO TO 410
+   50    CONTINUE
+*
+*        Special code for 3 x 3 Householder
+*
+         V1 = DCONJG( V( 1 ) )
+         T1 = TAU*DCONJG( V1 )
+         V2 = DCONJG( V( 2 ) )
+         T2 = TAU*DCONJG( V2 )
+         V3 = DCONJG( V( 3 ) )
+         T3 = TAU*DCONJG( V3 )
+         DO 60 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+   60    CONTINUE
+         GO TO 410
+   70    CONTINUE
+*
+*        Special code for 4 x 4 Householder
+*
+         V1 = DCONJG( V( 1 ) )
+         T1 = TAU*DCONJG( V1 )
+         V2 = DCONJG( V( 2 ) )
+         T2 = TAU*DCONJG( V2 )
+         V3 = DCONJG( V( 3 ) )
+         T3 = TAU*DCONJG( V3 )
+         V4 = DCONJG( V( 4 ) )
+         T4 = TAU*DCONJG( V4 )
+         DO 80 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+   80    CONTINUE
+         GO TO 410
+   90    CONTINUE
+*
+*        Special code for 5 x 5 Householder
+*
+         V1 = DCONJG( V( 1 ) )
+         T1 = TAU*DCONJG( V1 )
+         V2 = DCONJG( V( 2 ) )
+         T2 = TAU*DCONJG( V2 )
+         V3 = DCONJG( V( 3 ) )
+         T3 = TAU*DCONJG( V3 )
+         V4 = DCONJG( V( 4 ) )
+         T4 = TAU*DCONJG( V4 )
+         V5 = DCONJG( V( 5 ) )
+         T5 = TAU*DCONJG( V5 )
+         DO 100 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+  100    CONTINUE
+         GO TO 410
+  110    CONTINUE
+*
+*        Special code for 6 x 6 Householder
+*
+         V1 = DCONJG( V( 1 ) )
+         T1 = TAU*DCONJG( V1 )
+         V2 = DCONJG( V( 2 ) )
+         T2 = TAU*DCONJG( V2 )
+         V3 = DCONJG( V( 3 ) )
+         T3 = TAU*DCONJG( V3 )
+         V4 = DCONJG( V( 4 ) )
+         T4 = TAU*DCONJG( V4 )
+         V5 = DCONJG( V( 5 ) )
+         T5 = TAU*DCONJG( V5 )
+         V6 = DCONJG( V( 6 ) )
+         T6 = TAU*DCONJG( V6 )
+         DO 120 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+  120    CONTINUE
+         GO TO 410
+  130    CONTINUE
+*
+*        Special code for 7 x 7 Householder
+*
+         V1 = DCONJG( V( 1 ) )
+         T1 = TAU*DCONJG( V1 )
+         V2 = DCONJG( V( 2 ) )
+         T2 = TAU*DCONJG( V2 )
+         V3 = DCONJG( V( 3 ) )
+         T3 = TAU*DCONJG( V3 )
+         V4 = DCONJG( V( 4 ) )
+         T4 = TAU*DCONJG( V4 )
+         V5 = DCONJG( V( 5 ) )
+         T5 = TAU*DCONJG( V5 )
+         V6 = DCONJG( V( 6 ) )
+         T6 = TAU*DCONJG( V6 )
+         V7 = DCONJG( V( 7 ) )
+         T7 = TAU*DCONJG( V7 )
+         DO 140 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+  140    CONTINUE
+         GO TO 410
+  150    CONTINUE
+*
+*        Special code for 8 x 8 Householder
+*
+         V1 = DCONJG( V( 1 ) )
+         T1 = TAU*DCONJG( V1 )
+         V2 = DCONJG( V( 2 ) )
+         T2 = TAU*DCONJG( V2 )
+         V3 = DCONJG( V( 3 ) )
+         T3 = TAU*DCONJG( V3 )
+         V4 = DCONJG( V( 4 ) )
+         T4 = TAU*DCONJG( V4 )
+         V5 = DCONJG( V( 5 ) )
+         T5 = TAU*DCONJG( V5 )
+         V6 = DCONJG( V( 6 ) )
+         T6 = TAU*DCONJG( V6 )
+         V7 = DCONJG( V( 7 ) )
+         T7 = TAU*DCONJG( V7 )
+         V8 = DCONJG( V( 8 ) )
+         T8 = TAU*DCONJG( V8 )
+         DO 160 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+  160    CONTINUE
+         GO TO 410
+  170    CONTINUE
+*
+*        Special code for 9 x 9 Householder
+*
+         V1 = DCONJG( V( 1 ) )
+         T1 = TAU*DCONJG( V1 )
+         V2 = DCONJG( V( 2 ) )
+         T2 = TAU*DCONJG( V2 )
+         V3 = DCONJG( V( 3 ) )
+         T3 = TAU*DCONJG( V3 )
+         V4 = DCONJG( V( 4 ) )
+         T4 = TAU*DCONJG( V4 )
+         V5 = DCONJG( V( 5 ) )
+         T5 = TAU*DCONJG( V5 )
+         V6 = DCONJG( V( 6 ) )
+         T6 = TAU*DCONJG( V6 )
+         V7 = DCONJG( V( 7 ) )
+         T7 = TAU*DCONJG( V7 )
+         V8 = DCONJG( V( 8 ) )
+         T8 = TAU*DCONJG( V8 )
+         V9 = DCONJG( V( 9 ) )
+         T9 = TAU*DCONJG( V9 )
+         DO 180 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+            C( 9, J ) = C( 9, J ) - SUM*T9
+  180    CONTINUE
+         GO TO 410
+  190    CONTINUE
+*
+*        Special code for 10 x 10 Householder
+*
+         V1 = DCONJG( V( 1 ) )
+         T1 = TAU*DCONJG( V1 )
+         V2 = DCONJG( V( 2 ) )
+         T2 = TAU*DCONJG( V2 )
+         V3 = DCONJG( V( 3 ) )
+         T3 = TAU*DCONJG( V3 )
+         V4 = DCONJG( V( 4 ) )
+         T4 = TAU*DCONJG( V4 )
+         V5 = DCONJG( V( 5 ) )
+         T5 = TAU*DCONJG( V5 )
+         V6 = DCONJG( V( 6 ) )
+         T6 = TAU*DCONJG( V6 )
+         V7 = DCONJG( V( 7 ) )
+         T7 = TAU*DCONJG( V7 )
+         V8 = DCONJG( V( 8 ) )
+         T8 = TAU*DCONJG( V8 )
+         V9 = DCONJG( V( 9 ) )
+         T9 = TAU*DCONJG( V9 )
+         V10 = DCONJG( V( 10 ) )
+         T10 = TAU*DCONJG( V10 )
+         DO 200 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) +
+     $            V10*C( 10, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+            C( 9, J ) = C( 9, J ) - SUM*T9
+            C( 10, J ) = C( 10, J ) - SUM*T10
+  200    CONTINUE
+         GO TO 410
+      ELSE
+*
+*        Form  C * H, where H has order n.
+*
+         GO TO ( 210, 230, 250, 270, 290, 310, 330, 350,
+     $           370, 390 )N
+*
+*        Code for general N
+*
+*        w := C * v
+*
+         CALL ZGEMV( 'No transpose', M, N, ONE, C, LDC, V, 1, ZERO,
+     $               WORK, 1 )
+*
+*        C := C - tau * w * v'
+*
+         CALL ZGERC( M, N, -TAU, WORK, 1, V, 1, C, LDC )
+         GO TO 410
+  210    CONTINUE
+*
+*        Special code for 1 x 1 Householder
+*
+         T1 = ONE - TAU*V( 1 )*DCONJG( V( 1 ) )
+         DO 220 J = 1, M
+            C( J, 1 ) = T1*C( J, 1 )
+  220    CONTINUE
+         GO TO 410
+  230    CONTINUE
+*
+*        Special code for 2 x 2 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*DCONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*DCONJG( V2 )
+         DO 240 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+  240    CONTINUE
+         GO TO 410
+  250    CONTINUE
+*
+*        Special code for 3 x 3 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*DCONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*DCONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*DCONJG( V3 )
+         DO 260 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+  260    CONTINUE
+         GO TO 410
+  270    CONTINUE
+*
+*        Special code for 4 x 4 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*DCONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*DCONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*DCONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*DCONJG( V4 )
+         DO 280 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+  280    CONTINUE
+         GO TO 410
+  290    CONTINUE
+*
+*        Special code for 5 x 5 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*DCONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*DCONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*DCONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*DCONJG( V4 )
+         V5 = V( 5 )
+         T5 = TAU*DCONJG( V5 )
+         DO 300 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+  300    CONTINUE
+         GO TO 410
+  310    CONTINUE
+*
+*        Special code for 6 x 6 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*DCONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*DCONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*DCONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*DCONJG( V4 )
+         V5 = V( 5 )
+         T5 = TAU*DCONJG( V5 )
+         V6 = V( 6 )
+         T6 = TAU*DCONJG( V6 )
+         DO 320 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+  320    CONTINUE
+         GO TO 410
+  330    CONTINUE
+*
+*        Special code for 7 x 7 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*DCONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*DCONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*DCONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*DCONJG( V4 )
+         V5 = V( 5 )
+         T5 = TAU*DCONJG( V5 )
+         V6 = V( 6 )
+         T6 = TAU*DCONJG( V6 )
+         V7 = V( 7 )
+         T7 = TAU*DCONJG( V7 )
+         DO 340 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+  340    CONTINUE
+         GO TO 410
+  350    CONTINUE
+*
+*        Special code for 8 x 8 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*DCONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*DCONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*DCONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*DCONJG( V4 )
+         V5 = V( 5 )
+         T5 = TAU*DCONJG( V5 )
+         V6 = V( 6 )
+         T6 = TAU*DCONJG( V6 )
+         V7 = V( 7 )
+         T7 = TAU*DCONJG( V7 )
+         V8 = V( 8 )
+         T8 = TAU*DCONJG( V8 )
+         DO 360 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 ) + V8*C( J, 8 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+            C( J, 8 ) = C( J, 8 ) - SUM*T8
+  360    CONTINUE
+         GO TO 410
+  370    CONTINUE
+*
+*        Special code for 9 x 9 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*DCONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*DCONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*DCONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*DCONJG( V4 )
+         V5 = V( 5 )
+         T5 = TAU*DCONJG( V5 )
+         V6 = V( 6 )
+         T6 = TAU*DCONJG( V6 )
+         V7 = V( 7 )
+         T7 = TAU*DCONJG( V7 )
+         V8 = V( 8 )
+         T8 = TAU*DCONJG( V8 )
+         V9 = V( 9 )
+         T9 = TAU*DCONJG( V9 )
+         DO 380 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+            C( J, 8 ) = C( J, 8 ) - SUM*T8
+            C( J, 9 ) = C( J, 9 ) - SUM*T9
+  380    CONTINUE
+         GO TO 410
+  390    CONTINUE
+*
+*        Special code for 10 x 10 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*DCONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*DCONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*DCONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*DCONJG( V4 )
+         V5 = V( 5 )
+         T5 = TAU*DCONJG( V5 )
+         V6 = V( 6 )
+         T6 = TAU*DCONJG( V6 )
+         V7 = V( 7 )
+         T7 = TAU*DCONJG( V7 )
+         V8 = V( 8 )
+         T8 = TAU*DCONJG( V8 )
+         V9 = V( 9 )
+         T9 = TAU*DCONJG( V9 )
+         V10 = V( 10 )
+         T10 = TAU*DCONJG( V10 )
+         DO 400 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) +
+     $            V10*C( J, 10 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+            C( J, 8 ) = C( J, 8 ) - SUM*T8
+            C( J, 9 ) = C( J, 9 ) - SUM*T9
+            C( J, 10 ) = C( J, 10 ) - SUM*T10
+  400    CONTINUE
+         GO TO 410
+      END IF
+  410 CONTINUE
+      RETURN
+*
+*     End of ZLARFX
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlartg.f
@@ -0,0 +1,117 @@
+      SUBROUTINE ZLARTG( F, G, CS, SN, R )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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 and (G .ne. 0), then CS=0 and SN=1 without doing any
+*        floating point operations.
+*
+*  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.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+      COMPLEX*16         CZERO
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   D, DI, F1, F2, FA, G1, G2, GA
+      COMPLEX*16         FS, GS, SS, T
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCONJG, DIMAG, SQRT
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   ABS1, ABSSQ
+*     ..
+*     .. Statement Function definitions ..
+      ABS1( T ) = ABS( DBLE( T ) ) + ABS( DIMAG( T ) )
+      ABSSQ( T ) = DBLE( T )**2 + DIMAG( T )**2
+*     ..
+*     .. Executable Statements ..
+*
+*     [ 25 or 38 ops for main paths ]
+*
+      IF( G.EQ.CZERO ) THEN
+         CS = ONE
+         SN = ZERO
+         R = F
+      ELSE IF( F.EQ.CZERO ) THEN
+         CS = ZERO
+*
+         SN = DCONJG( G ) / ABS( G )
+         R = ABS( G )
+*
+*         SN = ONE
+*         R = G
+*
+      ELSE
+         F1 = ABS1( F )
+         G1 = ABS1( G )
+         IF( F1.GE.G1 ) THEN
+            GS = G / F1
+            G2 = ABSSQ( GS )
+            FS = F / F1
+            F2 = ABSSQ( FS )
+            D = SQRT( ONE+G2 / F2 )
+            CS = ONE / D
+            SN = DCONJG( GS )*FS*( CS / F2 )
+            R = F*D
+         ELSE
+            FS = F / G1
+            F2 = ABSSQ( FS )
+            FA = SQRT( F2 )
+            GS = G / G1
+            G2 = ABSSQ( GS )
+            GA = SQRT( G2 )
+            D = SQRT( ONE+F2 / G2 )
+            DI = ONE / D
+            CS = ( FA / GA )*DI
+            SS = ( DCONJG( GS )*FS ) / ( FA*GA )
+            SN = SS*DI
+            R = G*SS*D
+         END IF
+      END IF
+      RETURN
+*
+*     End of ZLARTG
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlascl.f
@@ -0,0 +1,268 @@
+      SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     February 29, 1992
+*
+*     .. 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,M)
+*          The matrix to be multiplied by CTO/CFROM.  See TYPE for the
+*          storage type.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  INFO    (output) INTEGER
+*          0  - successful exit
+*          <0 - if INFO = -i, the i-th argument had an illegal value.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            DONE
+      INTEGER            I, ITYPE, J, K1, K2, K3, K4
+      DOUBLE PRECISION   BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+*
+      IF( LSAME( TYPE, 'G' ) ) THEN
+         ITYPE = 0
+      ELSE IF( LSAME( TYPE, 'L' ) ) THEN
+         ITYPE = 1
+      ELSE IF( LSAME( TYPE, 'U' ) ) THEN
+         ITYPE = 2
+      ELSE IF( LSAME( TYPE, 'H' ) ) THEN
+         ITYPE = 3
+      ELSE IF( LSAME( TYPE, 'B' ) ) THEN
+         ITYPE = 4
+      ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
+         ITYPE = 5
+      ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
+         ITYPE = 6
+      ELSE
+         ITYPE = -1
+      END IF
+*
+      IF( ITYPE.EQ.-1 ) THEN
+         INFO = -1
+      ELSE IF( CFROM.EQ.ZERO ) THEN
+         INFO = -4
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
+     $         ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
+         INFO = -7
+      ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -9
+      ELSE IF( ITYPE.GE.4 ) THEN
+         IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
+            INFO = -2
+         ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
+     $            ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
+     $             THEN
+            INFO = -3
+         ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
+     $            ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
+     $            ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
+            INFO = -9
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZLASCL', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. M.EQ.0 )
+     $   RETURN
+*
+*     Get machine parameters
+*
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+*
+      CFROMC = CFROM
+      CTOC = CTO
+*
+   10 CONTINUE
+      CFROM1 = CFROMC*SMLNUM
+      CTO1 = CTOC / BIGNUM
+      IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
+         MUL = SMLNUM
+         DONE = .FALSE.
+         CFROMC = CFROM1
+      ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
+         MUL = BIGNUM
+         DONE = .FALSE.
+         CTOC = CTO1
+      ELSE
+         MUL = CTOC / CFROMC
+         DONE = .TRUE.
+      END IF
+*
+      IF( ITYPE.EQ.0 ) THEN
+*
+*        Full matrix
+*
+         DO 30 J = 1, N
+            DO 20 I = 1, M
+               A( I, J ) = A( I, J )*MUL
+   20       CONTINUE
+   30    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.1 ) THEN
+*
+*        Lower triangular matrix
+*
+         DO 50 J = 1, N
+            DO 40 I = J, M
+               A( I, J ) = A( I, J )*MUL
+   40       CONTINUE
+   50    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.2 ) THEN
+*
+*        Upper triangular matrix
+*
+         DO 70 J = 1, N
+            DO 60 I = 1, MIN( J, M )
+               A( I, J ) = A( I, J )*MUL
+   60       CONTINUE
+   70    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*        Upper Hessenberg matrix
+*
+         DO 90 J = 1, N
+            DO 80 I = 1, MIN( J+1, M )
+               A( I, J ) = A( I, J )*MUL
+   80       CONTINUE
+   90    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.4 ) THEN
+*
+*        Lower half of a symmetric band matrix
+*
+         K3 = KL + 1
+         K4 = N + 1
+         DO 110 J = 1, N
+            DO 100 I = 1, MIN( K3, K4-J )
+               A( I, J ) = A( I, J )*MUL
+  100       CONTINUE
+  110    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.5 ) THEN
+*
+*        Upper half of a symmetric band matrix
+*
+         K1 = KU + 2
+         K3 = KU + 1
+         DO 130 J = 1, N
+            DO 120 I = MAX( K1-J, 1 ), K3
+               A( I, J ) = A( I, J )*MUL
+  120       CONTINUE
+  130    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.6 ) THEN
+*
+*        Band matrix
+*
+         K1 = KL + KU + 2
+         K2 = KL + 1
+         K3 = 2*KL + KU + 1
+         K4 = KL + KU + 1 + M
+         DO 150 J = 1, N
+            DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
+               A( I, J ) = A( I, J )*MUL
+  140       CONTINUE
+  150    CONTINUE
+*
+      END IF
+*
+      IF( .NOT.DONE )
+     $   GO TO 10
+*
+      RETURN
+*
+*     End of ZLASCL
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlaset.f
@@ -0,0 +1,115 @@
+      SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      CHARACTER          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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlasr.f
@@ -0,0 +1,325 @@
+      SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIRECT, PIVOT, SIDE
+      INTEGER            LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( * ), S( * )
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLASR   performs the transformation
+*
+*     A := P*A,   when SIDE = 'L' or 'l'  (  Left-hand side )
+*
+*     A := A*P',  when SIDE = 'R' or 'r'  ( Right-hand side )
+*
+*  where A is an m by n complex matrix and P is an orthogonal matrix,
+*  consisting of a sequence of plane rotations determined by the
+*  parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l'
+*  and z = n when SIDE = 'R' or 'r' ):
+*
+*  When  DIRECT = 'F' or 'f'  ( Forward sequence ) then
+*
+*     P = P( z - 1 )*...*P( 2 )*P( 1 ),
+*
+*  and when DIRECT = 'B' or 'b'  ( Backward sequence ) then
+*
+*     P = P( 1 )*P( 2 )*...*P( z - 1 ),
+*
+*  where  P( k ) is a plane rotation matrix for the following planes:
+*
+*     when  PIVOT = 'V' or 'v'  ( Variable pivot ),
+*        the plane ( k, k + 1 )
+*
+*     when  PIVOT = 'T' or 't'  ( Top pivot ),
+*        the plane ( 1, k + 1 )
+*
+*     when  PIVOT = 'B' or 'b'  ( Bottom pivot ),
+*        the plane ( k, z )
+*
+*  c( k ) and s( k )  must contain the  cosine and sine that define the
+*  matrix  P( k ).  The two by two plane rotation part of the matrix
+*  P( k ), R( k ), is assumed to be of the form
+*
+*     R( k ) = (  c( k )  s( k ) ).
+*              ( -s( k )  c( k ) )
+*
+*  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'
+*
+*  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 )
+*
+*  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)
+*
+*  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, S    (input) DOUBLE PRECISION arrays, dimension
+*                  (M-1) if SIDE = 'L'
+*                  (N-1) if SIDE = 'R'
+*          c(k) and s(k) contain the cosine and sine that define the
+*          matrix P(k).  The two by two plane rotation part of the
+*          matrix P(k), R(k), is assumed to be of 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' 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlassq.f
@@ -0,0 +1,102 @@
+      SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      INTEGER            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) DOUBLE PRECISION
+*          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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlaswp.f
@@ -0,0 +1,98 @@
+      SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      INTEGER            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 (M*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.
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IP, IX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZSWAP
+*     ..
+*     .. Executable Statements ..
+*
+*     Interchange row I with row IPIV(I) for each of rows K1 through K2.
+*
+      IF( INCX.EQ.0 )
+     $   RETURN
+      IF( INCX.GT.0 ) THEN
+         IX = K1
+      ELSE
+         IX = 1 + ( 1-K2 )*INCX
+      END IF
+      IF( INCX.EQ.1 ) THEN
+         DO 10 I = K1, K2
+            IP = IPIV( I )
+            IF( IP.NE.I )
+     $         CALL ZSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
+   10    CONTINUE
+      ELSE IF( INCX.GT.1 ) THEN
+         DO 20 I = K1, K2
+            IP = IPIV( IX )
+            IF( IP.NE.I )
+     $         CALL ZSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
+            IX = IX + INCX
+   20    CONTINUE
+      ELSE IF( INCX.LT.0 ) THEN
+         DO 30 I = K2, K1, -1
+            IP = IPIV( IX )
+            IF( IP.NE.I )
+     $         CALL ZSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
+            IX = IX + INCX
+   30    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZLASWP
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zlatrs.f
@@ -0,0 +1,880 @@
+      SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
+     $                   CNORM, INFO )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     June 30, 1992
+*
+*     .. 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           DLABAD, 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zpotf2.f
@@ -0,0 +1,175 @@
+      SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zpotrf.f
@@ -0,0 +1,187 @@
+      SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zrot.f
@@ -0,0 +1,92 @@
+      SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S )
+*
+*  -- LAPACK auxiliary routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      INTEGER            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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/ztrevc.f
@@ -0,0 +1,384 @@
+      SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
+     $                   LDVR, MM, M, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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.
+*
+*  The right eigenvector x and the left eigenvector y of T corresponding
+*  to an eigenvalue w are defined by:
+*
+*               T*x = w*x,     y'*T = w*y'
+*
+*  where y' denotes the conjugate transpose of the vector y.
+*
+*  If all eigenvectors are requested, the routine may either return the
+*  matrices X and/or Y of right or left eigenvectors of T, or the
+*  products Q*X and/or Q*Y, where Q is an input unitary
+*  matrix. If T was obtained from the Schur factorization of an
+*  original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of
+*  right or 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,
+*                  and backtransform them using the input matrices
+*                  supplied 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 HOWMNY = 'A' or 'B', SELECT is not referenced.
+*          To select the eigenvector corresponding to 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)
+*          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.
+*          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 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.
+*          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 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           DLABAD, 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' ) .OR. LSAME( HOWMNY, 'O' )
+      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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/ztrexc.f
@@ -0,0 +1,163 @@
+      SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     March 31, 1993
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/ztrsen.f
@@ -0,0 +1,333 @@
+      SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S,
+     $                   SEP, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     March 31, 1993
+*
+*     .. 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
+*          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) COMPLEX*16 array, dimension (LWORK)
+*          If JOB = 'N', WORK is not referenced.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If JOB = 'N', LWORK >= 1;
+*          if JOB = 'E', LWORK = M*(N-M);
+*          if JOB = 'V' or 'B', LWORK >= 2*M*(N-M).
+*
+*  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            WANTBH, WANTQ, WANTS, WANTSP
+      INTEGER            IERR, K, KASE, KS, N1, N2, NN
+      DOUBLE PRECISION   EST, RNORM, SCALE
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   RWORK( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   ZLANGE
+      EXTERNAL           LSAME, ZLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLACON, 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
+      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.1 .OR. ( ( WANTS .AND. .NOT.WANTSP ) .AND.
+     $         LWORK.LT.NN ) .OR. ( WANTSP .AND. LWORK.LT.2*NN ) ) THEN
+         INFO = -14
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTRSEN', -INFO )
+         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 ZLACON( NN, WORK( NN+1 ), WORK, EST, KASE )
+         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
+      RETURN
+*
+*     End of ZTRSEN
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/ztrsyl.f
@@ -0,0 +1,368 @@
+      SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
+     $                   LDC, SCALE, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     March 31, 1993
+*
+*     .. 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
+      EXTERNAL           LSAME, DLAMCH, ZLANGE, ZDOTC, ZDOTU
+*     ..
+*     .. 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, '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( '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 = ( 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 = ( 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 = ( 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 = ( 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zung2r.f
@@ -0,0 +1,131 @@
+      SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zungbr.f
@@ -0,0 +1,224 @@
+      SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      CHARACTER          VECT
+      INTEGER            INFO, K, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  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            WANTQ
+      INTEGER            I, IINFO, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZUNGLQ, ZUNGQR
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      WANTQ = LSAME( VECT, 'Q' )
+      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, MIN( M, N ) ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNGBR', -INFO )
+         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
+      RETURN
+*
+*     End of ZUNGBR
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zunghr.f
@@ -0,0 +1,145 @@
+      SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, ILO, INFO, LDA, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  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 ..
+      INTEGER            I, IINFO, J, NH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZUNGQR
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      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
+      ELSE IF( LWORK.LT.MAX( 1, IHI-ILO ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNGHR', -INFO )
+         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
+*
+      NH = IHI - ILO
+      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
+      RETURN
+*
+*     End of ZUNGHR
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zungl2.f
@@ -0,0 +1,137 @@
+      SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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(1:i-1,i) to zero
+*
+         DO 30 L = 1, I - 1
+            A( I, L ) = ZERO
+   30    CONTINUE
+   40 CONTINUE
+      RETURN
+*
+*     End of ZUNGL2
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zunglq.f
@@ -0,0 +1,207 @@
+      SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  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 ..
+      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, 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
+      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 ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNGLQ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+*     Determine the block size.
+*
+      NB = ILAENV( 1, 'ZUNGLQ', ' ', M, N, K, -1 )
+      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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zungqr.f
@@ -0,0 +1,208 @@
+      SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  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 ..
+      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, 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
+      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 ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNGQR', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+*     Determine the block size.
+*
+      NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 )
+      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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zunm2r.f
@@ -0,0 +1,202 @@
+      SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zunmbr.f
@@ -0,0 +1,250 @@
+      SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
+     $                   LDC, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS, VECT
+      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            APPLYQ, LEFT, NOTRAN
+      CHARACTER          TRANST
+      INTEGER            I1, I2, IINFO, MI, NI, NQ, NW
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. 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' )
+*
+*     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, '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 ) ) THEN
+         INFO = -13
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNMBR', -INFO )
+         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 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
+      RETURN
+*
+*     End of ZUNMBR
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zunml2.f
@@ -0,0 +1,206 @@
+      SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. 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
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zunmlq.f
@@ -0,0 +1,254 @@
+      SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  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, NOTRAN
+      CHARACTER          TRANST
+      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
+     $                   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' )
+*
+*     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 ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNMLQ', -INFO )
+         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
+*
+*     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 ) )
+      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 ) = IWS
+      RETURN
+*
+*     End of ZUNMLQ
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/lapack/zunmqr.f
@@ -0,0 +1,247 @@
+      SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 2.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ),
+     $                   WORK( LWORK )
+*     ..
+*
+*  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 (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.
+*
+*  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, NOTRAN
+      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
+     $                   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' )
+*
+*     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 ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNMQR', -INFO )
+         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
+*
+*     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 ) )
+      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 ) = IWS
+      RETURN
+*
+*     End of ZUNMQR
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/linpack/dgbfa.f
@@ -0,0 +1,174 @@
+      SUBROUTINE DGBFA(ABD,LDA,N,ML,MU,IPVT,INFO)
+      INTEGER LDA,N,ML,MU,IPVT(1),INFO
+      DOUBLE PRECISION ABD(LDA,1)
+C
+C     DGBFA FACTORS A DOUBLE PRECISION BAND MATRIX BY ELIMINATION.
+C
+C     DGBFA IS USUALLY CALLED BY DGBCO, BUT IT CAN BE CALLED
+C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
+C
+C     ON ENTRY
+C
+C        ABD     DOUBLE PRECISION(LDA, N)
+C                CONTAINS THE MATRIX IN BAND STORAGE.  THE COLUMNS
+C                OF THE MATRIX ARE STORED IN THE COLUMNS OF  ABD  AND
+C                THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS
+C                ML+1 THROUGH 2*ML+MU+1 OF  ABD .
+C                SEE THE COMMENTS BELOW FOR DETAILS.
+C
+C        LDA     INTEGER
+C                THE LEADING DIMENSION OF THE ARRAY  ABD .
+C                LDA MUST BE .GE. 2*ML + MU + 1 .
+C
+C        N       INTEGER
+C                THE ORDER OF THE ORIGINAL MATRIX.
+C
+C        ML      INTEGER
+C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
+C                0 .LE. ML .LT. N .
+C
+C        MU      INTEGER
+C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
+C                0 .LE. MU .LT. N .
+C                MORE EFFICIENT IF  ML .LE. MU .
+C     ON RETURN
+C
+C        ABD     AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND
+C                THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
+C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
+C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
+C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
+C
+C        IPVT    INTEGER(N)
+C                AN INTEGER VECTOR OF PIVOT INDICES.
+C
+C        INFO    INTEGER
+C                = 0  NORMAL VALUE.
+C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
+C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
+C                     INDICATE THAT DGBSL WILL DIVIDE BY ZERO IF
+C                     CALLED.  USE  RCOND  IN DGBCO FOR A RELIABLE
+C                     INDICATION OF SINGULARITY.
+C
+C     BAND STORAGE
+C
+C           IF  A  IS A BAND MATRIX, THE FOLLOWING PROGRAM SEGMENT
+C           WILL SET UP THE INPUT.
+C
+C                   ML = (BAND WIDTH BELOW THE DIAGONAL)
+C                   MU = (BAND WIDTH ABOVE THE DIAGONAL)
+C                   M = ML + MU + 1
+C                   DO 20 J = 1, N
+C                      I1 = MAX0(1, J-MU)
+C                      I2 = MIN0(N, J+ML)
+C                      DO 10 I = I1, I2
+C                         K = I - J + M
+C                         ABD(K,J) = A(I,J)
+C                10    CONTINUE
+C                20 CONTINUE
+C
+C           THIS USES ROWS  ML+1  THROUGH  2*ML+MU+1  OF  ABD .
+C           IN ADDITION, THE FIRST  ML  ROWS IN  ABD  ARE USED FOR
+C           ELEMENTS GENERATED DURING THE TRIANGULARIZATION.
+C           THE TOTAL NUMBER OF ROWS NEEDED IN  ABD  IS  2*ML+MU+1 .
+C           THE  ML+MU BY ML+MU  UPPER LEFT TRIANGLE AND THE
+C           ML BY ML  LOWER RIGHT TRIANGLE ARE NOT REFERENCED.
+C
+C     LINPACK. THIS VERSION DATED 08/14/78 .
+C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
+C
+C     SUBROUTINES AND FUNCTIONS
+C
+C     BLAS DAXPY,DSCAL,IDAMAX
+C     FORTRAN MAX0,MIN0
+C
+C     INTERNAL VARIABLES
+C
+      DOUBLE PRECISION T
+      INTEGER I,IDAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1
+C
+C
+      M = ML + MU + 1
+      INFO = 0
+C
+C     ZERO INITIAL FILL-IN COLUMNS
+C
+      J0 = MU + 2
+      J1 = MIN0(N,M) - 1
+      IF (J1 .LT. J0) GO TO 30
+      DO 20 JZ = J0, J1
+         I0 = M + 1 - JZ
+         DO 10 I = I0, ML
+            ABD(I,JZ) = 0.0D0
+   10    CONTINUE
+   20 CONTINUE
+   30 CONTINUE
+      JZ = J1
+      JU = 0
+C
+C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
+C
+      NM1 = N - 1
+      IF (NM1 .LT. 1) GO TO 130
+      DO 120 K = 1, NM1
+         KP1 = K + 1
+C
+C        ZERO NEXT FILL-IN COLUMN
+C
+         JZ = JZ + 1
+         IF (JZ .GT. N) GO TO 50
+         IF (ML .LT. 1) GO TO 50
+            DO 40 I = 1, ML
+               ABD(I,JZ) = 0.0D0
+   40       CONTINUE
+   50    CONTINUE
+C
+C        FIND L = PIVOT INDEX
+C
+         LM = MIN0(ML,N-K)
+         L = IDAMAX(LM+1,ABD(M,K),1) + M - 1
+         IPVT(K) = L + K - M
+C
+C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
+C
+         IF (ABD(L,K) .EQ. 0.0D0) GO TO 100
+C
+C           INTERCHANGE IF NECESSARY
+C
+            IF (L .EQ. M) GO TO 60
+               T = ABD(L,K)
+               ABD(L,K) = ABD(M,K)
+               ABD(M,K) = T
+   60       CONTINUE
+C
+C           COMPUTE MULTIPLIERS
+C
+            T = -1.0D0/ABD(M,K)
+            CALL DSCAL(LM,T,ABD(M+1,K),1)
+C
+C           ROW ELIMINATION WITH COLUMN INDEXING
+C
+            JU = MIN0(MAX0(JU,MU+IPVT(K)),N)
+            MM = M
+            IF (JU .LT. KP1) GO TO 90
+            DO 80 J = KP1, JU
+               L = L - 1
+               MM = MM - 1
+               T = ABD(L,J)
+               IF (L .EQ. MM) GO TO 70
+                  ABD(L,J) = ABD(MM,J)
+                  ABD(MM,J) = T
+   70          CONTINUE
+               CALL DAXPY(LM,T,ABD(M+1,K),1,ABD(MM+1,J),1)
+   80       CONTINUE
+   90       CONTINUE
+         GO TO 110
+  100    CONTINUE
+            INFO = K
+  110    CONTINUE
+  120 CONTINUE
+  130 CONTINUE
+      IPVT(N) = N
+      IF (ABD(M,N) .EQ. 0.0D0) INFO = N
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/linpack/dgbsl.f
@@ -0,0 +1,135 @@
+      SUBROUTINE DGBSL(ABD,LDA,N,ML,MU,IPVT,B,JOB)
+      INTEGER LDA,N,ML,MU,IPVT(1),JOB
+      DOUBLE PRECISION ABD(LDA,1),B(1)
+C
+C     DGBSL SOLVES THE DOUBLE PRECISION BAND SYSTEM
+C     A * X = B  OR  TRANS(A) * X = B
+C     USING THE FACTORS COMPUTED BY DGBCO OR DGBFA.
+C
+C     ON ENTRY
+C
+C        ABD     DOUBLE PRECISION(LDA, N)
+C                THE OUTPUT FROM DGBCO OR DGBFA.
+C
+C        LDA     INTEGER
+C                THE LEADING DIMENSION OF THE ARRAY  ABD .
+C
+C        N       INTEGER
+C                THE ORDER OF THE ORIGINAL MATRIX.
+C
+C        ML      INTEGER
+C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
+C
+C        MU      INTEGER
+C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
+C
+C        IPVT    INTEGER(N)
+C                THE PIVOT VECTOR FROM DGBCO OR DGBFA.
+C
+C        B       DOUBLE PRECISION(N)
+C                THE RIGHT HAND SIDE VECTOR.
+C
+C        JOB     INTEGER
+C                = 0         TO SOLVE  A*X = B ,
+C                = NONZERO   TO SOLVE  TRANS(A)*X = B , WHERE
+C                            TRANS(A)  IS THE TRANSPOSE.
+C
+C     ON RETURN
+C
+C        B       THE SOLUTION VECTOR  X .
+C
+C     ERROR CONDITION
+C
+C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
+C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
+C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
+C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
+C        CALLED CORRECTLY AND IF DGBCO HAS SET RCOND .GT. 0.0
+C        OR DGBFA HAS SET INFO .EQ. 0 .
+C
+C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
+C     WITH  P  COLUMNS
+C           CALL DGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z)
+C           IF (RCOND IS TOO SMALL) GO TO ...
+C           DO 10 J = 1, P
+C              CALL DGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0)
+C        10 CONTINUE
+C
+C     LINPACK. THIS VERSION DATED 08/14/78 .
+C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
+C
+C     SUBROUTINES AND FUNCTIONS
+C
+C     BLAS DAXPY,DDOT
+C     FORTRAN MIN0
+C
+C     INTERNAL VARIABLES
+C
+      DOUBLE PRECISION DDOT,T
+      INTEGER K,KB,L,LA,LB,LM,M,NM1
+C
+      M = MU + ML + 1
+      NM1 = N - 1
+      IF (JOB .NE. 0) GO TO 50
+C
+C        JOB = 0 , SOLVE  A * X = B
+C        FIRST SOLVE L*Y = B
+C
+         IF (ML .EQ. 0) GO TO 30
+         IF (NM1 .LT. 1) GO TO 30
+            DO 20 K = 1, NM1
+               LM = MIN0(ML,N-K)
+               L = IPVT(K)
+               T = B(L)
+               IF (L .EQ. K) GO TO 10
+                  B(L) = B(K)
+                  B(K) = T
+   10          CONTINUE
+               CALL DAXPY(LM,T,ABD(M+1,K),1,B(K+1),1)
+   20       CONTINUE
+   30    CONTINUE
+C
+C        NOW SOLVE  U*X = Y
+C
+         DO 40 KB = 1, N
+            K = N + 1 - KB
+            B(K) = B(K)/ABD(M,K)
+            LM = MIN0(K,M) - 1
+            LA = M - LM
+            LB = K - LM
+            T = -B(K)
+            CALL DAXPY(LM,T,ABD(LA,K),1,B(LB),1)
+   40    CONTINUE
+      GO TO 100
+   50 CONTINUE
+C
+C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
+C        FIRST SOLVE  TRANS(U)*Y = B
+C
+         DO 60 K = 1, N
+            LM = MIN0(K,M) - 1
+            LA = M - LM
+            LB = K - LM
+            T = DDOT(LM,ABD(LA,K),1,B(LB),1)
+            B(K) = (B(K) - T)/ABD(M,K)
+   60    CONTINUE
+C
+C        NOW SOLVE TRANS(L)*X = Y
+C
+         IF (ML .EQ. 0) GO TO 90
+         IF (NM1 .LT. 1) GO TO 90
+            DO 80 KB = 1, NM1
+               K = N - KB
+               LM = MIN0(ML,N-K)
+               B(K) = B(K) + DDOT(LM,ABD(M+1,K),1,B(K+1),1)
+               L = IPVT(K)
+               IF (L .EQ. K) GO TO 70
+                  T = B(L)
+                  B(L) = B(K)
+                  B(K) = T
+   70          CONTINUE
+   80       CONTINUE
+   90    CONTINUE
+  100 CONTINUE
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/linpack/dgeco.f
@@ -0,0 +1,193 @@
+      SUBROUTINE DGECO(A,LDA,N,IPVT,RCOND,Z)
+      INTEGER LDA,N,IPVT(1)
+      DOUBLE PRECISION A(LDA,1),Z(1)
+      DOUBLE PRECISION RCOND
+C
+C     DGECO FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION
+C     AND ESTIMATES THE CONDITION OF THE MATRIX.
+C
+C     IF  RCOND  IS NOT NEEDED, DGEFA IS SLIGHTLY FASTER.
+C     TO SOLVE  A*X = B , FOLLOW DGECO BY DGESL.
+C     TO COMPUTE  INVERSE(A)*C , FOLLOW DGECO BY DGESL.
+C     TO COMPUTE  DETERMINANT(A) , FOLLOW DGECO BY DGEDI.
+C     TO COMPUTE  INVERSE(A) , FOLLOW DGECO BY DGEDI.
+C
+C     ON ENTRY
+C
+C        A       DOUBLE PRECISION(LDA, N)
+C                THE MATRIX TO BE FACTORED.
+C
+C        LDA     INTEGER
+C                THE LEADING DIMENSION OF THE ARRAY  A .
+C
+C        N       INTEGER
+C                THE ORDER OF THE MATRIX  A .
+C
+C     ON RETURN
+C
+C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
+C                WHICH WERE USED TO OBTAIN IT.
+C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
+C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
+C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
+C
+C        IPVT    INTEGER(N)
+C                AN INTEGER VECTOR OF PIVOT INDICES.
+C
+C        RCOND   DOUBLE PRECISION
+C                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  A .
+C                FOR THE SYSTEM  A*X = B , RELATIVE PERTURBATIONS
+C                IN  A  AND  B  OF SIZE  EPSILON  MAY CAUSE
+C                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND .
+C                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION
+C                           1.0 + RCOND .EQ. 1.0
+C                IS TRUE, THEN  A  MAY BE SINGULAR TO WORKING
+C                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF
+C                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
+C                UNDERFLOWS.
+C
+C        Z       DOUBLE PRECISION(N)
+C                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
+C                IF  A  IS CLOSE TO A SINGULAR MATRIX, THEN  Z  IS
+C                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
+C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
+C
+C     LINPACK. THIS VERSION DATED 08/14/78 .
+C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
+C
+C     SUBROUTINES AND FUNCTIONS
+C
+C     LINPACK DGEFA
+C     BLAS DAXPY,DDOT,DSCAL,DASUM
+C     FORTRAN DABS,DMAX1,DSIGN
+C
+C     INTERNAL VARIABLES
+C
+      DOUBLE PRECISION DDOT,EK,T,WK,WKM
+      DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM
+      INTEGER INFO,J,K,KB,KP1,L
+C
+C
+C     COMPUTE 1-NORM OF A
+C
+      ANORM = 0.0D0
+      DO 10 J = 1, N
+         ANORM = DMAX1(ANORM,DASUM(N,A(1,J),1))
+   10 CONTINUE
+C
+C     FACTOR
+C
+      CALL DGEFA(A,LDA,N,IPVT,INFO)
+C
+C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
+C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  TRANS(A)*Y = E .
+C     TRANS(A)  IS THE TRANSPOSE OF A .  THE COMPONENTS OF  E  ARE
+C     CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W  WHERE
+C     TRANS(U)*W = E .  THE VECTORS ARE FREQUENTLY RESCALED TO AVOID
+C     OVERFLOW.
+C
+C     SOLVE TRANS(U)*W = E
+C
+      EK = 1.0D0
+      DO 20 J = 1, N
+         Z(J) = 0.0D0
+   20 CONTINUE
+      DO 100 K = 1, N
+         IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K))
+         IF (DABS(EK-Z(K)) .LE. DABS(A(K,K))) GO TO 30
+            S = DABS(A(K,K))/DABS(EK-Z(K))
+            CALL DSCAL(N,S,Z,1)
+            EK = S*EK
+   30    CONTINUE
+         WK = EK - Z(K)
+         WKM = -EK - Z(K)
+         S = DABS(WK)
+         SM = DABS(WKM)
+         IF (A(K,K) .EQ. 0.0D0) GO TO 40
+            WK = WK/A(K,K)
+            WKM = WKM/A(K,K)
+         GO TO 50
+   40    CONTINUE
+            WK = 1.0D0
+            WKM = 1.0D0
+   50    CONTINUE
+         KP1 = K + 1
+         IF (KP1 .GT. N) GO TO 90
+            DO 60 J = KP1, N
+               SM = SM + DABS(Z(J)+WKM*A(K,J))
+               Z(J) = Z(J) + WK*A(K,J)
+               S = S + DABS(Z(J))
+   60       CONTINUE
+            IF (S .GE. SM) GO TO 80
+               T = WKM - WK
+               WK = WKM
+               DO 70 J = KP1, N
+                  Z(J) = Z(J) + T*A(K,J)
+   70          CONTINUE
+   80       CONTINUE
+   90    CONTINUE
+         Z(K) = WK
+  100 CONTINUE
+      S = 1.0D0/DASUM(N,Z,1)
+      CALL DSCAL(N,S,Z,1)
+C
+C     SOLVE TRANS(L)*Y = W
+C
+      DO 120 KB = 1, N
+         K = N + 1 - KB
+         IF (K .LT. N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1)
+         IF (DABS(Z(K)) .LE. 1.0D0) GO TO 110
+            S = 1.0D0/DABS(Z(K))
+            CALL DSCAL(N,S,Z,1)
+  110    CONTINUE
+         L = IPVT(K)
+         T = Z(L)
+         Z(L) = Z(K)
+         Z(K) = T
+  120 CONTINUE
+      S = 1.0D0/DASUM(N,Z,1)
+      CALL DSCAL(N,S,Z,1)
+C
+      YNORM = 1.0D0
+C
+C     SOLVE L*V = Y
+C
+      DO 140 K = 1, N
+         L = IPVT(K)
+         T = Z(L)
+         Z(L) = Z(K)
+         Z(K) = T
+         IF (K .LT. N) CALL DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1)
+         IF (DABS(Z(K)) .LE. 1.0D0) GO TO 130
+            S = 1.0D0/DABS(Z(K))
+            CALL DSCAL(N,S,Z,1)
+            YNORM = S*YNORM
+  130    CONTINUE
+  140 CONTINUE
+      S = 1.0D0/DASUM(N,Z,1)
+      CALL DSCAL(N,S,Z,1)
+      YNORM = S*YNORM
+C
+C     SOLVE  U*Z = V
+C
+      DO 160 KB = 1, N
+         K = N + 1 - KB
+         IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 150
+            S = DABS(A(K,K))/DABS(Z(K))
+            CALL DSCAL(N,S,Z,1)
+            YNORM = S*YNORM
+  150    CONTINUE
+         IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K)
+         IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0
+         T = -Z(K)
+         CALL DAXPY(K-1,T,A(1,K),1,Z(1),1)
+  160 CONTINUE
+C     MAKE ZNORM = 1.0
+      S = 1.0D0/DASUM(N,Z,1)
+      CALL DSCAL(N,S,Z,1)
+      YNORM = S*YNORM
+C
+      IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM
+      IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/linpack/dgedi.f
@@ -0,0 +1,128 @@
+      SUBROUTINE DGEDI(A,LDA,N,IPVT,DET,WORK,JOB)
+      INTEGER LDA,N,IPVT(1),JOB
+      DOUBLE PRECISION A(LDA,1),DET(2),WORK(1)
+C
+C     DGEDI COMPUTES THE DETERMINANT AND INVERSE OF A MATRIX
+C     USING THE FACTORS COMPUTED BY DGECO OR DGEFA.
+C
+C     ON ENTRY
+C
+C        A       DOUBLE PRECISION(LDA, N)
+C                THE OUTPUT FROM DGECO OR DGEFA.
+C
+C        LDA     INTEGER
+C                THE LEADING DIMENSION OF THE ARRAY  A .
+C
+C        N       INTEGER
+C                THE ORDER OF THE MATRIX  A .
+C
+C        IPVT    INTEGER(N)
+C                THE PIVOT VECTOR FROM DGECO OR DGEFA.
+C
+C        WORK    DOUBLE PRECISION(N)
+C                WORK VECTOR.  CONTENTS DESTROYED.
+C
+C        JOB     INTEGER
+C                = 11   BOTH DETERMINANT AND INVERSE.
+C                = 01   INVERSE ONLY.
+C                = 10   DETERMINANT ONLY.
+C
+C     ON RETURN
+C
+C        A       INVERSE OF ORIGINAL MATRIX IF REQUESTED.
+C                OTHERWISE UNCHANGED.
+C
+C        DET     DOUBLE PRECISION(2)
+C                DETERMINANT OF ORIGINAL MATRIX IF REQUESTED.
+C                OTHERWISE NOT REFERENCED.
+C                DETERMINANT = DET(1) * 10.0**DET(2)
+C                WITH  1.0 .LE. DABS(DET(1)) .LT. 10.0
+C                OR  DET(1) .EQ. 0.0 .
+C
+C     ERROR CONDITION
+C
+C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS
+C        A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED.
+C        IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY
+C        AND IF DGECO HAS SET RCOND .GT. 0.0 OR DGEFA HAS SET
+C        INFO .EQ. 0 .
+C
+C     LINPACK. THIS VERSION DATED 08/14/78 .
+C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
+C
+C     SUBROUTINES AND FUNCTIONS
+C
+C     BLAS DAXPY,DSCAL,DSWAP
+C     FORTRAN DABS,MOD
+C
+C     INTERNAL VARIABLES
+C
+      DOUBLE PRECISION T
+      DOUBLE PRECISION TEN
+      INTEGER I,J,K,KB,KP1,L,NM1
+C
+C
+C     COMPUTE DETERMINANT
+C
+      IF (JOB/10 .EQ. 0) GO TO 70
+         DET(1) = 1.0D0
+         DET(2) = 0.0D0
+         TEN = 10.0D0
+         DO 50 I = 1, N
+            IF (IPVT(I) .NE. I) DET(1) = -DET(1)
+            DET(1) = A(I,I)*DET(1)
+C        ...EXIT
+            IF (DET(1) .EQ. 0.0D0) GO TO 60
+   10       IF (DABS(DET(1)) .GE. 1.0D0) GO TO 20
+               DET(1) = TEN*DET(1)
+               DET(2) = DET(2) - 1.0D0
+            GO TO 10
+   20       CONTINUE
+   30       IF (DABS(DET(1)) .LT. TEN) GO TO 40
+               DET(1) = DET(1)/TEN
+               DET(2) = DET(2) + 1.0D0
+            GO TO 30
+   40       CONTINUE
+   50    CONTINUE
+   60    CONTINUE
+   70 CONTINUE
+C
+C     COMPUTE INVERSE(U)
+C
+      IF (MOD(JOB,10) .EQ. 0) GO TO 150
+         DO 100 K = 1, N
+            A(K,K) = 1.0D0/A(K,K)
+            T = -A(K,K)
+            CALL DSCAL(K-1,T,A(1,K),1)
+            KP1 = K + 1
+            IF (N .LT. KP1) GO TO 90
+            DO 80 J = KP1, N
+               T = A(K,J)
+               A(K,J) = 0.0D0
+               CALL DAXPY(K,T,A(1,K),1,A(1,J),1)
+   80       CONTINUE
+   90       CONTINUE
+  100    CONTINUE
+C
+C        FORM INVERSE(U)*INVERSE(L)
+C
+         NM1 = N - 1
+         IF (NM1 .LT. 1) GO TO 140
+         DO 130 KB = 1, NM1
+            K = N - KB
+            KP1 = K + 1
+            DO 110 I = KP1, N
+               WORK(I) = A(I,K)
+               A(I,K) = 0.0D0
+  110       CONTINUE
+            DO 120 J = KP1, N
+               T = WORK(J)
+               CALL DAXPY(N,T,A(1,J),1,A(1,K),1)
+  120       CONTINUE
+            L = IPVT(K)
+            IF (L .NE. K) CALL DSWAP(N,A(1,K),1,A(1,L),1)
+  130    CONTINUE
+  140    CONTINUE
+  150 CONTINUE
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/linpack/dgefa.f
@@ -0,0 +1,103 @@
+      SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO)
+      INTEGER LDA,N,IPVT(1),INFO
+      DOUBLE PRECISION A(LDA,1)
+C
+C     DGEFA FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION.
+C
+C     DGEFA IS USUALLY CALLED BY DGECO, BUT IT CAN BE CALLED
+C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
+C     (TIME FOR DGECO) = (1 + 9/N)*(TIME FOR DGEFA) .
+C
+C     ON ENTRY
+C
+C        A       DOUBLE PRECISION(LDA, N)
+C                THE MATRIX TO BE FACTORED.
+C
+C        LDA     INTEGER
+C                THE LEADING DIMENSION OF THE ARRAY  A .
+C
+C        N       INTEGER
+C                THE ORDER OF THE MATRIX  A .
+C
+C     ON RETURN
+C
+C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
+C                WHICH WERE USED TO OBTAIN IT.
+C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
+C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
+C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
+C
+C        IPVT    INTEGER(N)
+C                AN INTEGER VECTOR OF PIVOT INDICES.
+C
+C        INFO    INTEGER
+C                = 0  NORMAL VALUE.
+C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
+C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
+C                     INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO
+C                     IF CALLED.  USE  RCOND  IN DGECO FOR A RELIABLE
+C                     INDICATION OF SINGULARITY.
+C
+C     LINPACK. THIS VERSION DATED 08/14/78 .
+C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
+C
+C     SUBROUTINES AND FUNCTIONS
+C
+C     BLAS DAXPY,DSCAL,IDAMAX
+C
+C     INTERNAL VARIABLES
+C
+      DOUBLE PRECISION T
+      INTEGER IDAMAX,J,K,KP1,L,NM1
+C
+C
+C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
+C
+      INFO = 0
+      NM1 = N - 1
+      IF (NM1 .LT. 1) GO TO 70
+      DO 60 K = 1, NM1
+         KP1 = K + 1
+C
+C        FIND L = PIVOT INDEX
+C
+         L = IDAMAX(N-K+1,A(K,K),1) + K - 1
+         IPVT(K) = L
+C
+C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
+C
+         IF (A(L,K) .EQ. 0.0D0) GO TO 40
+C
+C           INTERCHANGE IF NECESSARY
+C
+            IF (L .EQ. K) GO TO 10
+               T = A(L,K)
+               A(L,K) = A(K,K)
+               A(K,K) = T
+   10       CONTINUE
+C
+C           COMPUTE MULTIPLIERS
+C
+            T = -1.0D0/A(K,K)
+            CALL DSCAL(N-K,T,A(K+1,K),1)
+C
+C           ROW ELIMINATION WITH COLUMN INDEXING
+C
+            DO 30 J = KP1, N
+               T = A(L,J)
+               IF (L .EQ. K) GO TO 20
+                  A(L,J) = A(K,J)
+                  A(K,J) = T
+   20          CONTINUE
+               CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
+   30       CONTINUE
+         GO TO 50
+   40    CONTINUE
+            INFO = K
+   50    CONTINUE
+   60 CONTINUE
+   70 CONTINUE
+      IPVT(N) = N
+      IF (A(N,N) .EQ. 0.0D0) INFO = N
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/linpack/dgesl.f
@@ -0,0 +1,117 @@
+      SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB)
+      INTEGER LDA,N,IPVT(1),JOB
+      DOUBLE PRECISION A(LDA,1),B(1)
+C
+C     DGESL SOLVES THE DOUBLE PRECISION SYSTEM
+C     A * X = B  OR  TRANS(A) * X = B
+C     USING THE FACTORS COMPUTED BY DGECO OR DGEFA.
+C
+C     ON ENTRY
+C
+C        A       DOUBLE PRECISION(LDA, N)
+C                THE OUTPUT FROM DGECO OR DGEFA.
+C
+C        LDA     INTEGER
+C                THE LEADING DIMENSION OF THE ARRAY  A .
+C
+C        N       INTEGER
+C                THE ORDER OF THE MATRIX  A .
+C
+C        IPVT    INTEGER(N)
+C                THE PIVOT VECTOR FROM DGECO OR DGEFA.
+C
+C        B       DOUBLE PRECISION(N)
+C                THE RIGHT HAND SIDE VECTOR.
+C
+C        JOB     INTEGER
+C                = 0         TO SOLVE  A*X = B ,
+C                = NONZERO   TO SOLVE  TRANS(A)*X = B  WHERE
+C                            TRANS(A)  IS THE TRANSPOSE.
+C
+C     ON RETURN
+C
+C        B       THE SOLUTION VECTOR  X .
+C
+C     ERROR CONDITION
+C
+C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
+C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
+C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
+C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
+C        CALLED CORRECTLY AND IF DGECO HAS SET RCOND .GT. 0.0
+C        OR DGEFA HAS SET INFO .EQ. 0 .
+C
+C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
+C     WITH  P  COLUMNS
+C           CALL DGECO(A,LDA,N,IPVT,RCOND,Z)
+C           IF (RCOND IS TOO SMALL) GO TO ...
+C           DO 10 J = 1, P
+C              CALL DGESL(A,LDA,N,IPVT,C(1,J),0)
+C        10 CONTINUE
+C
+C     LINPACK. THIS VERSION DATED 08/14/78 .
+C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
+C
+C     SUBROUTINES AND FUNCTIONS
+C
+C     BLAS DAXPY,DDOT
+C
+C     INTERNAL VARIABLES
+C
+      DOUBLE PRECISION DDOT,T
+      INTEGER K,KB,L,NM1
+C
+      NM1 = N - 1
+      IF (JOB .NE. 0) GO TO 50
+C
+C        JOB = 0 , SOLVE  A * X = B
+C        FIRST SOLVE  L*Y = B
+C
+         IF (NM1 .LT. 1) GO TO 30
+         DO 20 K = 1, NM1
+            L = IPVT(K)
+            T = B(L)
+            IF (L .EQ. K) GO TO 10
+               B(L) = B(K)
+               B(K) = T
+   10       CONTINUE
+            CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1)
+   20    CONTINUE
+   30    CONTINUE
+C
+C        NOW SOLVE  U*X = Y
+C
+         DO 40 KB = 1, N
+            K = N + 1 - KB
+            B(K) = B(K)/A(K,K)
+            T = -B(K)
+            CALL DAXPY(K-1,T,A(1,K),1,B(1),1)
+   40    CONTINUE
+      GO TO 100
+   50 CONTINUE
+C
+C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
+C        FIRST SOLVE  TRANS(U)*Y = B
+C
+         DO 60 K = 1, N
+            T = DDOT(K-1,A(1,K),1,B(1),1)
+            B(K) = (B(K) - T)/A(K,K)
+   60    CONTINUE
+C
+C        NOW SOLVE TRANS(L)*X = Y
+C
+         IF (NM1 .LT. 1) GO TO 90
+         DO 80 KB = 1, NM1
+            K = N - KB
+            B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1)
+            L = IPVT(K)
+            IF (L .EQ. K) GO TO 70
+               T = B(L)
+               B(L) = B(K)
+               B(K) = T
+   70       CONTINUE
+   80    CONTINUE
+   90    CONTINUE
+  100 CONTINUE
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/linpack/spofa.f
@@ -0,0 +1,71 @@
+      SUBROUTINE SPOFA(A,LDA,N,INFO)
+      INTEGER LDA,N,INFO
+      REAL A(LDA,1)
+C
+C     SPOFA FACTORS A REAL SYMMETRIC POSITIVE DEFINITE MATRIX.
+C
+C     SPOFA IS USUALLY CALLED BY SPOCO, BUT IT CAN BE CALLED
+C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
+C     (TIME FOR SPOCO) = (1 + 18/N)*(TIME FOR SPOFA) .
+C
+C     ON ENTRY
+C
+C        A       REAL(LDA, N)
+C                THE SYMMETRIC MATRIX TO BE FACTORED.  ONLY THE
+C                DIAGONAL AND UPPER TRIANGLE ARE USED.
+C
+C        LDA     INTEGER
+C                THE LEADING DIMENSION OF THE ARRAY  A .
+C
+C        N       INTEGER
+C                THE ORDER OF THE MATRIX  A .
+C
+C     ON RETURN
+C
+C        A       AN UPPER TRIANGULAR MATRIX  R  SO THAT  A = TRANS(R)*R
+C                WHERE  TRANS(R)  IS THE TRANSPOSE.
+C                THE STRICT LOWER TRIANGLE IS UNALTERED.
+C                IF  INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE.
+C
+C        INFO    INTEGER
+C                = 0  FOR NORMAL RETURN.
+C                = K  SIGNALS AN ERROR CONDITION.  THE LEADING MINOR
+C                     OF ORDER  K  IS NOT POSITIVE DEFINITE.
+C
+C     LINPACK.  THIS VERSION DATED 08/14/78 .
+C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
+C
+C     SUBROUTINES AND FUNCTIONS
+C
+C     BLAS SDOT
+C     FORTRAN SQRT
+C
+C     INTERNAL VARIABLES
+C
+      REAL SDOT,T
+      REAL S
+      INTEGER J,JM1,K
+C     BEGIN BLOCK WITH ...EXITS TO 40
+C
+C
+         DO 30 J = 1, N
+            INFO = J
+            S = 0.0E0
+            JM1 = J - 1
+            IF (JM1 .LT. 1) GO TO 20
+            DO 10 K = 1, JM1
+               T = A(K,J) - SDOT(K-1,A(1,K),1,A(1,J),1)
+               T = T/A(K,K)
+               A(K,J) = T
+               S = S + T*T
+   10       CONTINUE
+   20       CONTINUE
+            S = A(J,J) - S
+C     ......EXIT
+            IF (S .LE. 0.0E0) GO TO 40
+            A(J,J) = SQRT(S)
+   30    CONTINUE
+         INFO = 0
+   40 CONTINUE
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/linpack/zgeco.f
@@ -0,0 +1,201 @@
+      subroutine zgeco(a,lda,n,ipvt,rcond,z)
+      integer lda,n,ipvt(1)
+      complex*16 a(lda,1),z(1)
+      double precision rcond
+c
+c     zgeco factors a complex*16 matrix by gaussian elimination
+c     and estimates the condition of the matrix.
+c
+c     if  rcond  is not needed, zgefa is slightly faster.
+c     to solve  a*x = b , follow zgeco by zgesl.
+c     to compute  inverse(a)*c , follow zgeco by zgesl.
+c     to compute  determinant(a) , follow zgeco by zgedi.
+c     to compute  inverse(a) , follow zgeco by zgedi.
+c
+c     on entry
+c
+c        a       complex*16(lda, n)
+c                the matrix to be factored.
+c
+c        lda     integer
+c                the leading dimension of the array  a .
+c
+c        n       integer
+c                the order of the matrix  a .
+c
+c     on return
+c
+c        a       an upper triangular matrix and the multipliers
+c                which were used to obtain it.
+c                the factorization can be written  a = l*u  where
+c                l  is a product of permutation and unit lower
+c                triangular matrices and  u  is upper triangular.
+c
+c        ipvt    integer(n)
+c                an integer vector of pivot indices.
+c
+c        rcond   double precision
+c                an estimate of the reciprocal condition of  a .
+c                for the system  a*x = b , relative perturbations
+c                in  a  and  b  of size  epsilon  may cause
+c                relative perturbations in  x  of size  epsilon/rcond .
+c                if  rcond  is so small that the logical expression
+c                           1.0 + rcond .eq. 1.0
+c                is true, then  a  may be singular to working
+c                precision.  in particular,  rcond  is zero  if
+c                exact singularity is detected or the estimate
+c                underflows.
+c
+c        z       complex*16(n)
+c                a work vector whose contents are usually unimportant.
+c                if  a  is close to a singular matrix, then  z  is
+c                an approximate null vector in the sense that
+c                norm(a*z) = rcond*norm(a)*norm(z) .
+c
+c     linpack. this version dated 08/14/78 .
+c     cleve moler, university of new mexico, argonne national lab.
+c
+c     subroutines and functions
+c
+c     linpack zgefa
+c     blas zaxpy,zdotc,zdscal,dzasum
+c     fortran dabs,dmax1,dcmplx,dconjg
+c
+c     internal variables
+c
+      complex*16 zdotc,ek,t,wk,wkm
+      double precision anorm,s,dzasum,sm,ynorm
+      integer info,j,k,kb,kp1,l
+c
+      complex*16 zdum,zdum1,zdum2,csign1
+      double precision cabs1
+      double precision dreal,dimag
+      complex*16 zdumr,zdumi
+      dreal(zdumr) = zdumr
+      dimag(zdumi) = (0.0d0,-1.0d0)*zdumi
+      cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum))
+      csign1(zdum1,zdum2) = cabs1(zdum1)*(zdum2/cabs1(zdum2))
+c
+c     compute 1-norm of a
+c
+      anorm = 0.0d0
+      do 10 j = 1, n
+         anorm = dmax1(anorm,dzasum(n,a(1,j),1))
+   10 continue
+c
+c     factor
+c
+      call zgefa(a,lda,n,ipvt,info)
+c
+c     rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) .
+c     estimate = norm(z)/norm(y) where  a*z = y  and  ctrans(a)*y = e .
+c     ctrans(a)  is the conjugate transpose of a .
+c     the components of  e  are chosen to cause maximum local
+c     growth in the elements of w  where  ctrans(u)*w = e .
+c     the vectors are frequently rescaled to avoid overflow.
+c
+c     solve ctrans(u)*w = e
+c
+      ek = (1.0d0,0.0d0)
+      do 20 j = 1, n
+         z(j) = (0.0d0,0.0d0)
+   20 continue
+      do 100 k = 1, n
+         if (cabs1(z(k)) .ne. 0.0d0) ek = csign1(ek,-z(k))
+         if (cabs1(ek-z(k)) .le. cabs1(a(k,k))) go to 30
+            s = cabs1(a(k,k))/cabs1(ek-z(k))
+            call zdscal(n,s,z,1)
+            ek = dcmplx(s,0.0d0)*ek
+   30    continue
+         wk = ek - z(k)
+         wkm = -ek - z(k)
+         s = cabs1(wk)
+         sm = cabs1(wkm)
+         if (cabs1(a(k,k)) .eq. 0.0d0) go to 40
+            wk = wk/dconjg(a(k,k))
+            wkm = wkm/dconjg(a(k,k))
+         go to 50
+   40    continue
+            wk = (1.0d0,0.0d0)
+            wkm = (1.0d0,0.0d0)
+   50    continue
+         kp1 = k + 1
+         if (kp1 .gt. n) go to 90
+            do 60 j = kp1, n
+               sm = sm + cabs1(z(j)+wkm*dconjg(a(k,j)))
+               z(j) = z(j) + wk*dconjg(a(k,j))
+               s = s + cabs1(z(j))
+   60       continue
+            if (s .ge. sm) go to 80
+               t = wkm - wk
+               wk = wkm
+               do 70 j = kp1, n
+                  z(j) = z(j) + t*dconjg(a(k,j))
+   70          continue
+   80       continue
+   90    continue
+         z(k) = wk
+  100 continue
+      s = 1.0d0/dzasum(n,z,1)
+      call zdscal(n,s,z,1)
+c
+c     solve ctrans(l)*y = w
+c
+      do 120 kb = 1, n
+         k = n + 1 - kb
+         if (k .lt. n) z(k) = z(k) + zdotc(n-k,a(k+1,k),1,z(k+1),1)
+         if (cabs1(z(k)) .le. 1.0d0) go to 110
+            s = 1.0d0/cabs1(z(k))
+            call zdscal(n,s,z,1)
+  110    continue
+         l = ipvt(k)
+         t = z(l)
+         z(l) = z(k)
+         z(k) = t
+  120 continue
+      s = 1.0d0/dzasum(n,z,1)
+      call zdscal(n,s,z,1)
+c
+      ynorm = 1.0d0
+c
+c     solve l*v = y
+c
+      do 140 k = 1, n
+         l = ipvt(k)
+         t = z(l)
+         z(l) = z(k)
+         z(k) = t
+         if (k .lt. n) call zaxpy(n-k,t,a(k+1,k),1,z(k+1),1)
+         if (cabs1(z(k)) .le. 1.0d0) go to 130
+            s = 1.0d0/cabs1(z(k))
+            call zdscal(n,s,z,1)
+            ynorm = s*ynorm
+  130    continue
+  140 continue
+      s = 1.0d0/dzasum(n,z,1)
+      call zdscal(n,s,z,1)
+      ynorm = s*ynorm
+c
+c     solve  u*z = v
+c
+      do 160 kb = 1, n
+         k = n + 1 - kb
+         if (cabs1(z(k)) .le. cabs1(a(k,k))) go to 150
+            s = cabs1(a(k,k))/cabs1(z(k))
+            call zdscal(n,s,z,1)
+            ynorm = s*ynorm
+  150    continue
+         if (cabs1(a(k,k)) .ne. 0.0d0) z(k) = z(k)/a(k,k)
+         if (cabs1(a(k,k)) .eq. 0.0d0) z(k) = (1.0d0,0.0d0)
+         t = -z(k)
+         call zaxpy(k-1,t,a(1,k),1,z(1),1)
+  160 continue
+c     make znorm = 1.0
+      s = 1.0d0/dzasum(n,z,1)
+      call zdscal(n,s,z,1)
+      ynorm = s*ynorm
+c
+      if (anorm .ne. 0.0d0) rcond = ynorm/anorm
+      if (anorm .eq. 0.0d0) rcond = 0.0d0
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/linpack/zgedi.f
@@ -0,0 +1,135 @@
+      subroutine zgedi(a,lda,n,ipvt,det,work,job)
+      integer lda,n,ipvt(1),job
+      complex*16 a(lda,1),det(2),work(1)
+c
+c     zgedi computes the determinant and inverse of a matrix
+c     using the factors computed by zgeco or zgefa.
+c
+c     on entry
+c
+c        a       complex*16(lda, n)
+c                the output from zgeco or zgefa.
+c
+c        lda     integer
+c                the leading dimension of the array  a .
+c
+c        n       integer
+c                the order of the matrix  a .
+c
+c        ipvt    integer(n)
+c                the pivot vector from zgeco or zgefa.
+c
+c        work    complex*16(n)
+c                work vector.  contents destroyed.
+c
+c        job     integer
+c                = 11   both determinant and inverse.
+c                = 01   inverse only.
+c                = 10   determinant only.
+c
+c     on return
+c
+c        a       inverse of original matrix if requested.
+c                otherwise unchanged.
+c
+c        det     complex*16(2)
+c                determinant of original matrix if requested.
+c                otherwise not referenced.
+c                determinant = det(1) * 10.0**det(2)
+c                with  1.0 .le. cabs1(det(1)) .lt. 10.0
+c                or  det(1) .eq. 0.0 .
+c
+c     error condition
+c
+c        a division by zero will occur if the input factor contains
+c        a zero on the diagonal and the inverse is requested.
+c        it will not occur if the subroutines are called correctly
+c        and if zgeco has set rcond .gt. 0.0 or zgefa has set
+c        info .eq. 0 .
+c
+c     linpack. this version dated 08/14/78 .
+c     cleve moler, university of new mexico, argonne national lab.
+c
+c     subroutines and functions
+c
+c     blas zaxpy,zscal,zswap
+c     fortran dabs,dcmplx,mod
+c
+c     internal variables
+c
+      complex*16 t
+      double precision ten
+      integer i,j,k,kb,kp1,l,nm1
+c
+      complex*16 zdum
+      double precision cabs1
+      double precision dreal,dimag
+      complex*16 zdumr,zdumi
+      dreal(zdumr) = zdumr
+      dimag(zdumi) = (0.0d0,-1.0d0)*zdumi
+      cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum))
+c
+c     compute determinant
+c
+      if (job/10 .eq. 0) go to 70
+         det(1) = (1.0d0,0.0d0)
+         det(2) = (0.0d0,0.0d0)
+         ten = 10.0d0
+         do 50 i = 1, n
+            if (ipvt(i) .ne. i) det(1) = -det(1)
+            det(1) = a(i,i)*det(1)
+c        ...exit
+            if (cabs1(det(1)) .eq. 0.0d0) go to 60
+   10       if (cabs1(det(1)) .ge. 1.0d0) go to 20
+               det(1) = dcmplx(ten,0.0d0)*det(1)
+               det(2) = det(2) - (1.0d0,0.0d0)
+            go to 10
+   20       continue
+   30       if (cabs1(det(1)) .lt. ten) go to 40
+               det(1) = det(1)/dcmplx(ten,0.0d0)
+               det(2) = det(2) + (1.0d0,0.0d0)
+            go to 30
+   40       continue
+   50    continue
+   60    continue
+   70 continue
+c
+c     compute inverse(u)
+c
+      if (mod(job,10) .eq. 0) go to 150
+         do 100 k = 1, n
+            a(k,k) = (1.0d0,0.0d0)/a(k,k)
+            t = -a(k,k)
+            call zscal(k-1,t,a(1,k),1)
+            kp1 = k + 1
+            if (n .lt. kp1) go to 90
+            do 80 j = kp1, n
+               t = a(k,j)
+               a(k,j) = (0.0d0,0.0d0)
+               call zaxpy(k,t,a(1,k),1,a(1,j),1)
+   80       continue
+   90       continue
+  100    continue
+c
+c        form inverse(u)*inverse(l)
+c
+         nm1 = n - 1
+         if (nm1 .lt. 1) go to 140
+         do 130 kb = 1, nm1
+            k = n - kb
+            kp1 = k + 1
+            do 110 i = kp1, n
+               work(i) = a(i,k)
+               a(i,k) = (0.0d0,0.0d0)
+  110       continue
+            do 120 j = kp1, n
+               t = work(j)
+               call zaxpy(n,t,a(1,j),1,a(1,k),1)
+  120       continue
+            l = ipvt(k)
+            if (l .ne. k) call zswap(n,a(1,k),1,a(1,l),1)
+  130    continue
+  140    continue
+  150 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/linpack/zgefa.f
@@ -0,0 +1,111 @@
+      subroutine zgefa(a,lda,n,ipvt,info)
+      integer lda,n,ipvt(1),info
+      complex*16 a(lda,1)
+c
+c     zgefa factors a complex*16 matrix by gaussian elimination.
+c
+c     zgefa is usually called by zgeco, but it can be called
+c     directly with a saving in time if  rcond  is not needed.
+c     (time for zgeco) = (1 + 9/n)*(time for zgefa) .
+c
+c     on entry
+c
+c        a       complex*16(lda, n)
+c                the matrix to be factored.
+c
+c        lda     integer
+c                the leading dimension of the array  a .
+c
+c        n       integer
+c                the order of the matrix  a .
+c
+c     on return
+c
+c        a       an upper triangular matrix and the multipliers
+c                which were used to obtain it.
+c                the factorization can be written  a = l*u  where
+c                l  is a product of permutation and unit lower
+c                triangular matrices and  u  is upper triangular.
+c
+c        ipvt    integer(n)
+c                an integer vector of pivot indices.
+c
+c        info    integer
+c                = 0  normal value.
+c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
+c                     condition for this subroutine, but it does
+c                     indicate that zgesl or zgedi will divide by zero
+c                     if called.  use  rcond  in zgeco for a reliable
+c                     indication of singularity.
+c
+c     linpack. this version dated 08/14/78 .
+c     cleve moler, university of new mexico, argonne national lab.
+c
+c     subroutines and functions
+c
+c     blas zaxpy,zscal,izamax
+c     fortran dabs
+c
+c     internal variables
+c
+      complex*16 t
+      integer izamax,j,k,kp1,l,nm1
+c
+      complex*16 zdum
+      double precision cabs1
+      double precision dreal,dimag
+      complex*16 zdumr,zdumi
+      dreal(zdumr) = zdumr
+      dimag(zdumi) = (0.0d0,-1.0d0)*zdumi
+      cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum))
+c
+c     gaussian elimination with partial pivoting
+c
+      info = 0
+      nm1 = n - 1
+      if (nm1 .lt. 1) go to 70
+      do 60 k = 1, nm1
+         kp1 = k + 1
+c
+c        find l = pivot index
+c
+         l = izamax(n-k+1,a(k,k),1) + k - 1
+         ipvt(k) = l
+c
+c        zero pivot implies this column already triangularized
+c
+         if (cabs1(a(l,k)) .eq. 0.0d0) go to 40
+c
+c           interchange if necessary
+c
+            if (l .eq. k) go to 10
+               t = a(l,k)
+               a(l,k) = a(k,k)
+               a(k,k) = t
+   10       continue
+c
+c           compute multipliers
+c
+            t = -(1.0d0,0.0d0)/a(k,k)
+            call zscal(n-k,t,a(k+1,k),1)
+c
+c           row elimination with column indexing
+c
+            do 30 j = kp1, n
+               t = a(l,j)
+               if (l .eq. k) go to 20
+                  a(l,j) = a(k,j)
+                  a(k,j) = t
+   20          continue
+               call zaxpy(n-k,t,a(k+1,k),1,a(k+1,j),1)
+   30       continue
+         go to 50
+   40    continue
+            info = k
+   50    continue
+   60 continue
+   70 continue
+      ipvt(n) = n
+      if (cabs1(a(n,n)) .eq. 0.0d0) info = n
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/linpack/zgesl.f
@@ -0,0 +1,122 @@
+      subroutine zgesl(a,lda,n,ipvt,b,job)
+      integer lda,n,ipvt(1),job
+      complex*16 a(lda,1),b(1)
+c
+c     zgesl solves the complex*16 system
+c     a * x = b  or  ctrans(a) * x = b
+c     using the factors computed by zgeco or zgefa.
+c
+c     on entry
+c
+c        a       complex*16(lda, n)
+c                the output from zgeco or zgefa.
+c
+c        lda     integer
+c                the leading dimension of the array  a .
+c
+c        n       integer
+c                the order of the matrix  a .
+c
+c        ipvt    integer(n)
+c                the pivot vector from zgeco or zgefa.
+c
+c        b       complex*16(n)
+c                the right hand side vector.
+c
+c        job     integer
+c                = 0         to solve  a*x = b ,
+c                = nonzero   to solve  ctrans(a)*x = b  where
+c                            ctrans(a)  is the conjugate transpose.
+c
+c     on return
+c
+c        b       the solution vector  x .
+c
+c     error condition
+c
+c        a division by zero will occur if the input factor contains a
+c        zero on the diagonal.  technically this indicates singularity
+c        but it is often caused by improper arguments or improper
+c        setting of lda .  it will not occur if the subroutines are
+c        called correctly and if zgeco has set rcond .gt. 0.0
+c        or zgefa has set info .eq. 0 .
+c
+c     to compute  inverse(a) * c  where  c  is a matrix
+c     with  p  columns
+c           call zgeco(a,lda,n,ipvt,rcond,z)
+c           if (rcond is too small) go to ...
+c           do 10 j = 1, p
+c              call zgesl(a,lda,n,ipvt,c(1,j),0)
+c        10 continue
+c
+c     linpack. this version dated 08/14/78 .
+c     cleve moler, university of new mexico, argonne national lab.
+c
+c     subroutines and functions
+c
+c     blas zaxpy,zdotc
+c     fortran dconjg
+c
+c     internal variables
+c
+      complex*16 zdotc,t
+      integer k,kb,l,nm1
+c     double precision dreal,dimag
+c     complex*16 zdumr,zdumi
+c     dreal(zdumr) = zdumr
+c     dimag(zdumi) = (0.0d0,-1.0d0)*zdumi
+c
+      nm1 = n - 1
+      if (job .ne. 0) go to 50
+c
+c        job = 0 , solve  a * x = b
+c        first solve  l*y = b
+c
+         if (nm1 .lt. 1) go to 30
+         do 20 k = 1, nm1
+            l = ipvt(k)
+            t = b(l)
+            if (l .eq. k) go to 10
+               b(l) = b(k)
+               b(k) = t
+   10       continue
+            call zaxpy(n-k,t,a(k+1,k),1,b(k+1),1)
+   20    continue
+   30    continue
+c
+c        now solve  u*x = y
+c
+         do 40 kb = 1, n
+            k = n + 1 - kb
+            b(k) = b(k)/a(k,k)
+            t = -b(k)
+            call zaxpy(k-1,t,a(1,k),1,b(1),1)
+   40    continue
+      go to 100
+   50 continue
+c
+c        job = nonzero, solve  ctrans(a) * x = b
+c        first solve  ctrans(u)*y = b
+c
+         do 60 k = 1, n
+            t = zdotc(k-1,a(1,k),1,b(1),1)
+            b(k) = (b(k) - t)/dconjg(a(k,k))
+   60    continue
+c
+c        now solve ctrans(l)*x = y
+c
+         if (nm1 .lt. 1) go to 90
+         do 80 kb = 1, nm1
+            k = n - kb
+            b(k) = b(k) + zdotc(n-k,a(k+1,k),1,b(k+1),1)
+            l = ipvt(k)
+            if (l .eq. k) go to 70
+               t = b(l)
+               b(l) = b(k)
+               b(k) = t
+   70       continue
+   80    continue
+   90    continue
+  100 continue
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/minpack/dogleg.f
@@ -0,0 +1,177 @@
+      SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2)
+      INTEGER N,LR
+      DOUBLE PRECISION DELTA
+      DOUBLE PRECISION R(LR),DIAG(N),QTB(N),X(N),WA1(N),WA2(N)
+C     **********
+C
+C     SUBROUTINE DOGLEG
+C
+C     GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL
+C     MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, THE
+C     PROBLEM IS TO DETERMINE THE CONVEX COMBINATION X OF THE
+C     GAUSS-NEWTON AND SCALED GRADIENT DIRECTIONS THAT MINIMIZES
+C     (A*X - B) IN THE LEAST SQUARES SENSE, SUBJECT TO THE
+C     RESTRICTION THAT THE EUCLIDEAN NORM OF D*X BE AT MOST DELTA.
+C
+C     THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM
+C     IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE
+C     QR FACTORIZATION OF A. THAT IS, IF A = Q*R, WHERE Q HAS
+C     ORTHOGONAL COLUMNS AND R IS AN UPPER TRIANGULAR MATRIX,
+C     THEN DOGLEG EXPECTS THE FULL UPPER TRIANGLE OF R AND
+C     THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B.
+C
+C     THE SUBROUTINE STATEMENT IS
+C
+C       SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2)
+C
+C     WHERE
+C
+C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R.
+C
+C       R IS AN INPUT ARRAY OF LENGTH LR WHICH MUST CONTAIN THE UPPER
+C         TRIANGULAR MATRIX R STORED BY ROWS.
+C
+C       LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
+C         (N*(N+1))/2.
+C
+C       DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
+C         DIAGONAL ELEMENTS OF THE MATRIX D.
+C
+C       QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST
+C         N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B.
+C
+C       DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER
+C         BOUND ON THE EUCLIDEAN NORM OF D*X.
+C
+C       X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE DESIRED
+C         CONVEX COMBINATION OF THE GAUSS-NEWTON DIRECTION AND THE
+C         SCALED GRADIENT DIRECTION.
+C
+C       WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N.
+C
+C     SUBPROGRAMS CALLED
+C
+C       MINPACK-SUPPLIED ... DPMPAR,ENORM
+C
+C       FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT
+C
+C     MINPACK. VERSION OF JULY 1978.
+C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
+C
+C     **********
+      INTEGER I,J,JJ,JP1,K,L
+      DOUBLE PRECISION ALPHA,BNORM,EPSMCH,GNORM,ONE,QNORM,SGNORM,SUM,
+     *                 TEMP,ZERO
+      DOUBLE PRECISION DPMPAR,ENORM
+      DATA ONE,ZERO /1.0D0,0.0D0/
+C
+C     EPSMCH IS THE MACHINE PRECISION.
+C
+      EPSMCH = DPMPAR(1)
+C
+C     FIRST, CALCULATE THE GAUSS-NEWTON DIRECTION.
+C
+      JJ = (N*(N + 1))/2 + 1
+      DO 50 K = 1, N
+         J = N - K + 1
+         JP1 = J + 1
+         JJ = JJ - K
+         L = JJ + 1
+         SUM = ZERO
+         IF (N .LT. JP1) GO TO 20
+         DO 10 I = JP1, N
+            SUM = SUM + R(L)*X(I)
+            L = L + 1
+   10       CONTINUE
+   20    CONTINUE
+         TEMP = R(JJ)
+         IF (TEMP .NE. ZERO) GO TO 40
+         L = J
+         DO 30 I = 1, J
+            TEMP = DMAX1(TEMP,DABS(R(L)))
+            L = L + N - I
+   30       CONTINUE
+         TEMP = EPSMCH*TEMP
+         IF (TEMP .EQ. ZERO) TEMP = EPSMCH
+   40    CONTINUE
+         X(J) = (QTB(J) - SUM)/TEMP
+   50    CONTINUE
+C
+C     TEST WHETHER THE GAUSS-NEWTON DIRECTION IS ACCEPTABLE.
+C
+      DO 60 J = 1, N
+         WA1(J) = ZERO
+         WA2(J) = DIAG(J)*X(J)
+   60    CONTINUE
+      QNORM = ENORM(N,WA2)
+      IF (QNORM .LE. DELTA) GO TO 140
+C
+C     THE GAUSS-NEWTON DIRECTION IS NOT ACCEPTABLE.
+C     NEXT, CALCULATE THE SCALED GRADIENT DIRECTION.
+C
+      L = 1
+      DO 80 J = 1, N
+         TEMP = QTB(J)
+         DO 70 I = J, N
+            WA1(I) = WA1(I) + R(L)*TEMP
+            L = L + 1
+   70       CONTINUE
+         WA1(J) = WA1(J)/DIAG(J)
+   80    CONTINUE
+C
+C     CALCULATE THE NORM OF THE SCALED GRADIENT DIRECTION,
+C     NORMALIZE, AND RESCALE THE GRADIENT.
+C
+      GNORM = ENORM(N,WA1)
+      SGNORM = ZERO
+      ALPHA = DELTA/QNORM
+      IF (GNORM .EQ. ZERO) GO TO 120
+      DO 90 J = 1, N
+         WA1(J) = (WA1(J)/GNORM)/DIAG(J)
+   90    CONTINUE
+C
+C     CALCULATE THE POINT ALONG THE SCALED GRADIENT
+C     AT WHICH THE QUADRATIC IS MINIMIZED.
+C
+      L = 1
+      DO 110 J = 1, N
+         SUM = ZERO
+         DO 100 I = J, N
+            SUM = SUM + R(L)*WA1(I)
+            L = L + 1
+  100       CONTINUE
+         WA2(J) = SUM
+  110    CONTINUE
+      TEMP = ENORM(N,WA2)
+      SGNORM = (GNORM/TEMP)/TEMP
+C
+C     TEST WHETHER THE SCALED GRADIENT DIRECTION IS ACCEPTABLE.
+C
+      ALPHA = ZERO
+      IF (SGNORM .GE. DELTA) GO TO 120
+C
+C     THE SCALED GRADIENT DIRECTION IS NOT ACCEPTABLE.
+C     FINALLY, CALCULATE THE POINT ALONG THE DOGLEG
+C     AT WHICH THE QUADRATIC IS MINIMIZED.
+C
+      BNORM = ENORM(N,QTB)
+      TEMP = (BNORM/GNORM)*(BNORM/QNORM)*(SGNORM/DELTA)
+      TEMP = TEMP - (DELTA/QNORM)*(SGNORM/DELTA)**2
+     *       + DSQRT((TEMP-(DELTA/QNORM))**2
+     *               +(ONE-(DELTA/QNORM)**2)*(ONE-(SGNORM/DELTA)**2))
+      ALPHA = ((DELTA/QNORM)*(ONE - (SGNORM/DELTA)**2))/TEMP
+  120 CONTINUE
+C
+C     FORM APPROPRIATE CONVEX COMBINATION OF THE GAUSS-NEWTON
+C     DIRECTION AND THE SCALED GRADIENT DIRECTION.
+C
+      TEMP = (ONE - ALPHA)*DMIN1(SGNORM,DELTA)
+      DO 130 J = 1, N
+         X(J) = TEMP*WA1(J) + ALPHA*X(J)
+  130    CONTINUE
+  140 CONTINUE
+      RETURN
+C
+C     LAST CARD OF SUBROUTINE DOGLEG.
+C
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/minpack/dpmpar.f
@@ -0,0 +1,52 @@
+      DOUBLE PRECISION FUNCTION DPMPAR(I)
+      INTEGER I
+C     **********
+C
+C     FUNCTION DPMPAR
+C
+C     THIS FUNCTION PROVIDES DOUBLE PRECISION MACHINE PARAMETERS
+C     WHEN THE APPROPRIATE SET OF DATA STATEMENTS IS ACTIVATED (BY
+C     REMOVING THE C FROM COLUMN 1) AND ALL OTHER DATA STATEMENTS ARE
+C     RENDERED INACTIVE. MOST OF THE PARAMETER VALUES WERE OBTAINED
+C     FROM THE CORRESPONDING BELL LABORATORIES PORT LIBRARY FUNCTION.
+C
+C     THE FUNCTION STATEMENT IS
+C
+C       DOUBLE PRECISION FUNCTION DPMPAR(I)
+C
+C     WHERE
+C
+C       I IS AN INTEGER INPUT VARIABLE SET TO 1, 2, OR 3 WHICH
+C         SELECTS THE DESIRED MACHINE PARAMETER. IF THE MACHINE HAS
+C         T BASE B DIGITS AND ITS SMALLEST AND LARGEST EXPONENTS ARE
+C         EMIN AND EMAX, RESPECTIVELY, THEN THESE PARAMETERS ARE
+C
+C         DPMPAR(1) = B**(1 - T), THE MACHINE PRECISION,
+C
+C         DPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE,
+C
+C         DPMPAR(3) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
+C
+C     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1983.
+C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
+C
+C     Modified Mon Aug 28 14:46:17 CDT 1989 by John W. Eaton
+C     (chpf127@emx.utexas.edu) to use D1MACH
+C
+C     **********
+C
+      DOUBLE PRECISION  D1MACH
+C
+      IF ( I .EQ. 1 ) THEN
+        DPMPAR = D1MACH(4)
+      ELSEIF ( I . EQ. 2 ) THEN
+        DPMPAR = D1MACH(1)
+      ELSEIF ( I .EQ. 3 ) THEN
+        DPMPAR = D1MACH(2)
+      ENDIF
+C
+      RETURN
+C
+C     LAST CARD OF FUNCTION DPMPAR.
+C
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/minpack/enorm.f
@@ -0,0 +1,108 @@
+      DOUBLE PRECISION FUNCTION ENORM(N,X)
+      INTEGER N
+      DOUBLE PRECISION X(N)
+C     **********
+C
+C     FUNCTION ENORM
+C
+C     GIVEN AN N-VECTOR X, THIS FUNCTION CALCULATES THE
+C     EUCLIDEAN NORM OF X.
+C
+C     THE EUCLIDEAN NORM IS COMPUTED BY ACCUMULATING THE SUM OF
+C     SQUARES IN THREE DIFFERENT SUMS. THE SUMS OF SQUARES FOR THE
+C     SMALL AND LARGE COMPONENTS ARE SCALED SO THAT NO OVERFLOWS
+C     OCCUR. NON-DESTRUCTIVE UNDERFLOWS ARE PERMITTED. UNDERFLOWS
+C     AND OVERFLOWS DO NOT OCCUR IN THE COMPUTATION OF THE UNSCALED
+C     SUM OF SQUARES FOR THE INTERMEDIATE COMPONENTS.
+C     THE DEFINITIONS OF SMALL, INTERMEDIATE AND LARGE COMPONENTS
+C     DEPEND ON TWO CONSTANTS, RDWARF AND RGIANT. THE MAIN
+C     RESTRICTIONS ON THESE CONSTANTS ARE THAT RDWARF**2 NOT
+C     UNDERFLOW AND RGIANT**2 NOT OVERFLOW. THE CONSTANTS
+C     GIVEN HERE ARE SUITABLE FOR EVERY KNOWN COMPUTER.
+C
+C     THE FUNCTION STATEMENT IS
+C
+C       DOUBLE PRECISION FUNCTION ENORM(N,X)
+C
+C     WHERE
+C
+C       N IS A POSITIVE INTEGER INPUT VARIABLE.
+C
+C       X IS AN INPUT ARRAY OF LENGTH N.
+C
+C     SUBPROGRAMS CALLED
+C
+C       FORTRAN-SUPPLIED ... DABS,DSQRT
+C
+C     MINPACK. VERSION OF OCTOBER 1979.
+C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
+C
+C     **********
+      INTEGER I
+      DOUBLE PRECISION AGIANT,FLOATN,ONE,RDWARF,RGIANT,S1,S2,S3,XABS,
+     *                 X1MAX,X3MAX,ZERO
+      DATA ONE,ZERO,RDWARF,RGIANT /1.0D0,0.0D0,3.834D-20,1.304D19/
+      S1 = ZERO
+      S2 = ZERO
+      S3 = ZERO
+      X1MAX = ZERO
+      X3MAX = ZERO
+      FLOATN = N
+      AGIANT = RGIANT/FLOATN
+      DO 90 I = 1, N
+         XABS = DABS(X(I))
+         IF (XABS .GT. RDWARF .AND. XABS .LT. AGIANT) GO TO 70
+            IF (XABS .LE. RDWARF) GO TO 30
+C
+C              SUM FOR LARGE COMPONENTS.
+C
+               IF (XABS .LE. X1MAX) GO TO 10
+                  S1 = ONE + S1*(X1MAX/XABS)**2
+                  X1MAX = XABS
+                  GO TO 20
+   10          CONTINUE
+                  S1 = S1 + (XABS/X1MAX)**2
+   20          CONTINUE
+               GO TO 60
+   30       CONTINUE
+C
+C              SUM FOR SMALL COMPONENTS.
+C
+               IF (XABS .LE. X3MAX) GO TO 40
+                  S3 = ONE + S3*(X3MAX/XABS)**2
+                  X3MAX = XABS
+                  GO TO 50
+   40          CONTINUE
+                  IF (XABS .NE. ZERO) S3 = S3 + (XABS/X3MAX)**2
+   50          CONTINUE
+   60       CONTINUE
+            GO TO 80
+   70    CONTINUE
+C
+C           SUM FOR INTERMEDIATE COMPONENTS.
+C
+            S2 = S2 + XABS**2
+   80    CONTINUE
+   90    CONTINUE
+C
+C     CALCULATION OF NORM.
+C
+      IF (S1 .EQ. ZERO) GO TO 100
+         ENORM = X1MAX*DSQRT(S1+(S2/X1MAX)/X1MAX)
+         GO TO 130
+  100 CONTINUE
+         IF (S2 .EQ. ZERO) GO TO 110
+            IF (S2 .GE. X3MAX)
+     *         ENORM = DSQRT(S2*(ONE+(X3MAX/S2)*(X3MAX*S3)))
+            IF (S2 .LT. X3MAX)
+     *         ENORM = DSQRT(X3MAX*((S2/X3MAX)+(X3MAX*S3)))
+            GO TO 120
+  110    CONTINUE
+            ENORM = X3MAX*DSQRT(S3)
+  120    CONTINUE
+  130 CONTINUE
+      RETURN
+C
+C     LAST CARD OF FUNCTION ENORM.
+C
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/minpack/fdjac1.f
@@ -0,0 +1,151 @@
+      SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,
+     *                  WA1,WA2)
+      INTEGER N,LDFJAC,IFLAG,ML,MU
+      DOUBLE PRECISION EPSFCN
+      DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N),WA1(N),WA2(N)
+      EXTERNAL FCN
+C     **********
+C
+C     SUBROUTINE FDJAC1
+C
+C     THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION
+C     TO THE N BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED
+C     PROBLEM OF N FUNCTIONS IN N VARIABLES. IF THE JACOBIAN HAS
+C     A BANDED FORM, THEN FUNCTION EVALUATIONS ARE SAVED BY ONLY
+C     APPROXIMATING THE NONZERO TERMS.
+C
+C     THE SUBROUTINE STATEMENT IS
+C
+C       SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,
+C                         WA1,WA2)
+C
+C     WHERE
+C
+C       FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH
+C         CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED
+C         IN AN EXTERNAL STATEMENT IN THE USER CALLING
+C         PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
+C
+C         SUBROUTINE FCN(N,X,FVEC,IFLAG)
+C         INTEGER N,IFLAG
+C         DOUBLE PRECISION X(N),FVEC(N)
+C         ----------
+C         CALCULATE THE FUNCTIONS AT X AND
+C         RETURN THIS VECTOR IN FVEC.
+C         ----------
+C         RETURN
+C         END
+C
+C         THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS
+C         THE USER WANTS TO TERMINATE EXECUTION OF FDJAC1.
+C         IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
+C
+C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C         OF FUNCTIONS AND VARIABLES.
+C
+C       X IS AN INPUT ARRAY OF LENGTH N.
+C
+C       FVEC IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
+C         FUNCTIONS EVALUATED AT X.
+C
+C       FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE
+C         APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X.
+C
+C       LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
+C         WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
+C
+C       IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE
+C         THE EXECUTION OF FDJAC1. SEE DESCRIPTION OF FCN.
+C
+C       ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES
+C         THE NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE
+C         JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET
+C         ML TO AT LEAST N - 1.
+C
+C       EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE
+C         STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS
+C         APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE
+C         FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS
+C         THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE
+C         ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE
+C         PRECISION.
+C
+C       MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES
+C         THE NUMBER OF SUPERDIAGONALS WITHIN THE BAND OF THE
+C         JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET
+C         MU TO AT LEAST N - 1.
+C
+C       WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. IF ML + MU + 1 IS AT
+C         LEAST N, THEN THE JACOBIAN IS CONSIDERED DENSE, AND WA2 IS
+C         NOT REFERENCED.
+C
+C     SUBPROGRAMS CALLED
+C
+C       MINPACK-SUPPLIED ... DPMPAR
+C
+C       FORTRAN-SUPPLIED ... DABS,DMAX1,DSQRT
+C
+C     MINPACK. VERSION OF JUNE 1979.
+C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
+C
+C     **********
+      INTEGER I,J,K,MSUM
+      DOUBLE PRECISION EPS,EPSMCH,H,TEMP,ZERO
+      DOUBLE PRECISION DPMPAR
+      DATA ZERO /0.0D0/
+C
+C     EPSMCH IS THE MACHINE PRECISION.
+C
+      EPSMCH = DPMPAR(1)
+C
+      EPS = DSQRT(DMAX1(EPSFCN,EPSMCH))
+      MSUM = ML + MU + 1
+      IF (MSUM .LT. N) GO TO 40
+C
+C        COMPUTATION OF DENSE APPROXIMATE JACOBIAN.
+C
+         DO 20 J = 1, N
+            TEMP = X(J)
+            H = EPS*DABS(TEMP)
+            IF (H .EQ. ZERO) H = EPS
+            X(J) = TEMP + H
+            CALL FCN(N,X,WA1,IFLAG)
+            IF (IFLAG .LT. 0) GO TO 30
+            X(J) = TEMP
+            DO 10 I = 1, N
+               FJAC(I,J) = (WA1(I) - FVEC(I))/H
+   10          CONTINUE
+   20       CONTINUE
+   30    CONTINUE
+         GO TO 110
+   40 CONTINUE
+C
+C        COMPUTATION OF BANDED APPROXIMATE JACOBIAN.
+C
+         DO 90 K = 1, MSUM
+            DO 60 J = K, N, MSUM
+               WA2(J) = X(J)
+               H = EPS*DABS(WA2(J))
+               IF (H .EQ. ZERO) H = EPS
+               X(J) = WA2(J) + H
+   60          CONTINUE
+            CALL FCN(N,X,WA1,IFLAG)
+            IF (IFLAG .LT. 0) GO TO 100
+            DO 80 J = K, N, MSUM
+               X(J) = WA2(J)
+               H = EPS*DABS(WA2(J))
+               IF (H .EQ. ZERO) H = EPS
+               DO 70 I = 1, N
+                  FJAC(I,J) = ZERO
+                  IF (I .GE. J - MU .AND. I .LE. J + ML)
+     *               FJAC(I,J) = (WA1(I) - FVEC(I))/H
+   70             CONTINUE
+   80          CONTINUE
+   90       CONTINUE
+  100    CONTINUE
+  110 CONTINUE
+      RETURN
+C
+C     LAST CARD OF SUBROUTINE FDJAC1.
+C
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/minpack/hybrd.f
@@ -0,0 +1,459 @@
+      SUBROUTINE HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,DIAG,
+     *                 MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC,R,LR,
+     *                 QTF,WA1,WA2,WA3,WA4)
+      INTEGER N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR
+      DOUBLE PRECISION XTOL,EPSFCN,FACTOR
+      DOUBLE PRECISION X(N),FVEC(N),DIAG(N),FJAC(LDFJAC,N),R(LR),
+     *                 QTF(N),WA1(N),WA2(N),WA3(N),WA4(N)
+      EXTERNAL FCN
+C     **********
+C
+C     SUBROUTINE HYBRD
+C
+C     THE PURPOSE OF HYBRD IS TO FIND A ZERO OF A SYSTEM OF
+C     N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION
+C     OF THE POWELL HYBRID METHOD. THE USER MUST PROVIDE A
+C     SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS
+C     THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION.
+C
+C     THE SUBROUTINE STATEMENT IS
+C
+C       SUBROUTINE HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,
+C                        DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,
+C                        LDFJAC,R,LR,QTF,WA1,WA2,WA3,WA4)
+C
+C     WHERE
+C
+C       FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH
+C         CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED
+C         IN AN EXTERNAL STATEMENT IN THE USER CALLING
+C         PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
+C
+C         SUBROUTINE FCN(N,X,FVEC,IFLAG)
+C         INTEGER N,IFLAG
+C         DOUBLE PRECISION X(N),FVEC(N)
+C         ----------
+C         CALCULATE THE FUNCTIONS AT X AND
+C         RETURN THIS VECTOR IN FVEC.
+C         ---------
+C         RETURN
+C         END
+C
+C         THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS
+C         THE USER WANTS TO TERMINATE EXECUTION OF HYBRD.
+C         IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
+C
+C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C         OF FUNCTIONS AND VARIABLES.
+C
+C       X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
+C         AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
+C         CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
+C
+C       FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
+C         THE FUNCTIONS EVALUATED AT THE OUTPUT X.
+C
+C       XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
+C         OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE
+C         ITERATES IS AT MOST XTOL.
+C
+C       MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION
+C         OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST MAXFEV
+C         BY THE END OF AN ITERATION.
+C
+C       ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES
+C         THE NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE
+C         JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET
+C         ML TO AT LEAST N - 1.
+C
+C       MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES
+C         THE NUMBER OF SUPERDIAGONALS WITHIN THE BAND OF THE
+C         JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET
+C         MU TO AT LEAST N - 1.
+C
+C       EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE
+C         STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS
+C         APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE
+C         FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS
+C         THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE
+C         ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE
+C         PRECISION.
+C
+C       DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE
+C         BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG
+C         MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS IMPLICIT
+C         (MULTIPLICATIVE) SCALE FACTORS FOR THE VARIABLES.
+C
+C       MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE
+C         VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2,
+C         THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER
+C         VALUES OF MODE ARE EQUIVALENT TO MODE = 1.
+C
+C       FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE
+C         INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF
+C         FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE
+C         TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE
+C         INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE.
+C
+C       NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED
+C         PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE,
+C         FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST
+C         ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND
+C         IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE
+C         FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS
+C         OF FCN WITH IFLAG = 0 ARE MADE.
+C
+C       INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
+C         TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
+C         VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
+C         INFO IS SET AS FOLLOWS.
+C
+C         INFO = 0   IMPROPER INPUT PARAMETERS.
+C
+C         INFO = 1   RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES
+C                    IS AT MOST TOL.
+C
+C         INFO = 2   NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED
+C                    MAXFEV.
+C
+C         INFO = 3   XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
+C                    THE APPROXIMATE SOLUTION X IS POSSIBLE.
+C
+C         INFO = 4   ITERATION IS NOT MAKING GOOD PROGRESS, AS
+C                    MEASURED BY THE IMPROVEMENT FROM THE LAST
+C                    FIVE JACOBIAN EVALUATIONS.
+C
+C         INFO = 5   ITERATION IS NOT MAKING GOOD PROGRESS, AS
+C                    MEASURED BY THE IMPROVEMENT FROM THE LAST
+C                    TEN ITERATIONS.
+C
+C       NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
+C         CALLS TO FCN.
+C
+C       FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE
+C         ORTHOGONAL MATRIX Q PRODUCED BY THE QR FACTORIZATION
+C         OF THE FINAL APPROXIMATE JACOBIAN.
+C
+C       LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
+C         WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
+C
+C       R IS AN OUTPUT ARRAY OF LENGTH LR WHICH CONTAINS THE
+C         UPPER TRIANGULAR MATRIX PRODUCED BY THE QR FACTORIZATION
+C         OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE.
+C
+C       LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
+C         (N*(N+1))/2.
+C
+C       QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
+C         THE VECTOR (Q TRANSPOSE)*FVEC.
+C
+C       WA1, WA2, WA3, AND WA4 ARE WORK ARRAYS OF LENGTH N.
+C
+C     SUBPROGRAMS CALLED
+C
+C       USER-SUPPLIED ...... FCN
+C
+C       MINPACK-SUPPLIED ... DOGLEG,DPMPAR,ENORM,FDJAC1,
+C                            QFORM,QRFAC,R1MPYQ,R1UPDT
+C
+C       FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,MIN0,MOD
+C
+C     MINPACK. VERSION OF SEPTEMBER 1979.
+C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
+C
+C     **********
+      INTEGER I,IFLAG,ITER,J,JM1,L,MSUM,NCFAIL,NCSUC,NSLOW1,NSLOW2
+      INTEGER IWA(1)
+      LOGICAL JEVAL,SING
+      DOUBLE PRECISION ACTRED,DELTA,EPSMCH,FNORM,FNORM1,ONE,PNORM,
+     *                 PRERED,P1,P5,P001,P0001,RATIO,SUM,TEMP,XNORM,
+     *                 ZERO
+      DOUBLE PRECISION DPMPAR,ENORM
+      DATA ONE,P1,P5,P001,P0001,ZERO
+     *     /1.0D0,1.0D-1,5.0D-1,1.0D-3,1.0D-4,0.0D0/
+C
+C     EPSMCH IS THE MACHINE PRECISION.
+C
+      EPSMCH = DPMPAR(1)
+C
+      INFO = 0
+      IFLAG = 0
+      NFEV = 0
+C
+C     CHECK THE INPUT PARAMETERS FOR ERRORS.
+C
+      IF (N .LE. 0 .OR. XTOL .LT. ZERO .OR. MAXFEV .LE. 0
+     *    .OR. ML .LT. 0 .OR. MU .LT. 0 .OR. FACTOR .LE. ZERO
+     *    .OR. LDFJAC .LT. N .OR. LR .LT. (N*(N + 1))/2) GO TO 300
+      IF (MODE .NE. 2) GO TO 20
+      DO 10 J = 1, N
+         IF (DIAG(J) .LE. ZERO) GO TO 300
+   10    CONTINUE
+   20 CONTINUE
+C
+C     EVALUATE THE FUNCTION AT THE STARTING POINT
+C     AND CALCULATE ITS NORM.
+C
+      IFLAG = 1
+      CALL FCN(N,X,FVEC,IFLAG)
+      NFEV = 1
+      IF (IFLAG .LT. 0) GO TO 300
+      FNORM = ENORM(N,FVEC)
+C
+C     DETERMINE THE NUMBER OF CALLS TO FCN NEEDED TO COMPUTE
+C     THE JACOBIAN MATRIX.
+C
+      MSUM = MIN0(ML+MU+1,N)
+C
+C     INITIALIZE ITERATION COUNTER AND MONITORS.
+C
+      ITER = 1
+      NCSUC = 0
+      NCFAIL = 0
+      NSLOW1 = 0
+      NSLOW2 = 0
+C
+C     BEGINNING OF THE OUTER LOOP.
+C
+   30 CONTINUE
+         JEVAL = .TRUE.
+C
+C        CALCULATE THE JACOBIAN MATRIX.
+C
+         IFLAG = 2
+         CALL FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,WA1,
+     *               WA2)
+         NFEV = NFEV + MSUM
+         IF (IFLAG .LT. 0) GO TO 300
+C
+C        COMPUTE THE QR FACTORIZATION OF THE JACOBIAN.
+C
+         CALL QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3)
+C
+C        ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING
+C        TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN.
+C
+         IF (ITER .NE. 1) GO TO 70
+         IF (MODE .EQ. 2) GO TO 50
+         DO 40 J = 1, N
+            DIAG(J) = WA2(J)
+            IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE
+   40       CONTINUE
+   50    CONTINUE
+C
+C        ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X
+C        AND INITIALIZE THE STEP BOUND DELTA.
+C
+         DO 60 J = 1, N
+            WA3(J) = DIAG(J)*X(J)
+   60       CONTINUE
+         XNORM = ENORM(N,WA3)
+         DELTA = FACTOR*XNORM
+         IF (DELTA .EQ. ZERO) DELTA = FACTOR
+   70    CONTINUE
+C
+C        FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF.
+C
+         DO 80 I = 1, N
+            QTF(I) = FVEC(I)
+   80       CONTINUE
+         DO 120 J = 1, N
+            IF (FJAC(J,J) .EQ. ZERO) GO TO 110
+            SUM = ZERO
+            DO 90 I = J, N
+               SUM = SUM + FJAC(I,J)*QTF(I)
+   90          CONTINUE
+            TEMP = -SUM/FJAC(J,J)
+            DO 100 I = J, N
+               QTF(I) = QTF(I) + FJAC(I,J)*TEMP
+  100          CONTINUE
+  110       CONTINUE
+  120       CONTINUE
+C
+C        COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R.
+C
+         SING = .FALSE.
+         DO 150 J = 1, N
+            L = J
+            JM1 = J - 1
+            IF (JM1 .LT. 1) GO TO 140
+            DO 130 I = 1, JM1
+               R(L) = FJAC(I,J)
+               L = L + N - I
+  130          CONTINUE
+  140       CONTINUE
+            R(L) = WA1(J)
+            IF (WA1(J) .EQ. ZERO) SING = .TRUE.
+  150       CONTINUE
+C
+C        ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC.
+C
+         CALL QFORM(N,N,FJAC,LDFJAC,WA1)
+C
+C        RESCALE IF NECESSARY.
+C
+         IF (MODE .EQ. 2) GO TO 170
+         DO 160 J = 1, N
+            DIAG(J) = DMAX1(DIAG(J),WA2(J))
+  160       CONTINUE
+  170    CONTINUE
+C
+C        BEGINNING OF THE INNER LOOP.
+C
+  180    CONTINUE
+C
+C           IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
+C
+            IF (NPRINT .LE. 0) GO TO 190
+            IFLAG = 0
+            IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(N,X,FVEC,IFLAG)
+            IF (IFLAG .LT. 0) GO TO 300
+  190       CONTINUE
+C
+C           DETERMINE THE DIRECTION P.
+C
+            CALL DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3)
+C
+C           STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P.
+C
+            DO 200 J = 1, N
+               WA1(J) = -WA1(J)
+               WA2(J) = X(J) + WA1(J)
+               WA3(J) = DIAG(J)*WA1(J)
+  200          CONTINUE
+            PNORM = ENORM(N,WA3)
+C
+C           ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND.
+C
+            IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM)
+C
+C           EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM.
+C
+            IFLAG = 1
+            CALL FCN(N,WA2,WA4,IFLAG)
+            NFEV = NFEV + 1
+            IF (IFLAG .LT. 0) GO TO 300
+            FNORM1 = ENORM(N,WA4)
+C
+C           COMPUTE THE SCALED ACTUAL REDUCTION.
+C
+            ACTRED = -ONE
+            IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2
+C
+C           COMPUTE THE SCALED PREDICTED REDUCTION.
+C
+            L = 1
+            DO 220 I = 1, N
+               SUM = ZERO
+               DO 210 J = I, N
+                  SUM = SUM + R(L)*WA1(J)
+                  L = L + 1
+  210             CONTINUE
+               WA3(I) = QTF(I) + SUM
+  220          CONTINUE
+            TEMP = ENORM(N,WA3)
+            PRERED = ZERO
+            IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2
+C
+C           COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED
+C           REDUCTION.
+C
+            RATIO = ZERO
+            IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED
+C
+C           UPDATE THE STEP BOUND.
+C
+            IF (RATIO .GE. P1) GO TO 230
+               NCSUC = 0
+               NCFAIL = NCFAIL + 1
+               DELTA = P5*DELTA
+               GO TO 240
+  230       CONTINUE
+               NCFAIL = 0
+               NCSUC = NCSUC + 1
+               IF (RATIO .GE. P5 .OR. NCSUC .GT. 1)
+     *            DELTA = DMAX1(DELTA,PNORM/P5)
+               IF (DABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5
+  240       CONTINUE
+C
+C           TEST FOR SUCCESSFUL ITERATION.
+C
+            IF (RATIO .LT. P0001) GO TO 260
+C
+C           SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS.
+C
+            DO 250 J = 1, N
+               X(J) = WA2(J)
+               WA2(J) = DIAG(J)*X(J)
+               FVEC(J) = WA4(J)
+  250          CONTINUE
+            XNORM = ENORM(N,WA2)
+            FNORM = FNORM1
+            ITER = ITER + 1
+  260       CONTINUE
+C
+C           DETERMINE THE PROGRESS OF THE ITERATION.
+C
+            NSLOW1 = NSLOW1 + 1
+            IF (ACTRED .GE. P001) NSLOW1 = 0
+            IF (JEVAL) NSLOW2 = NSLOW2 + 1
+            IF (ACTRED .GE. P1) NSLOW2 = 0
+C
+C           TEST FOR CONVERGENCE.
+C
+            IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1
+            IF (INFO .NE. 0) GO TO 300
+C
+C           TESTS FOR TERMINATION AND STRINGENT TOLERANCES.
+C
+            IF (NFEV .GE. MAXFEV) INFO = 2
+            IF (P1*DMAX1(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3
+            IF (NSLOW2 .EQ. 5) INFO = 4
+            IF (NSLOW1 .EQ. 10) INFO = 5
+            IF (INFO .NE. 0) GO TO 300
+C
+C           CRITERION FOR RECALCULATING JACOBIAN APPROXIMATION
+C           BY FORWARD DIFFERENCES.
+C
+            IF (NCFAIL .EQ. 2) GO TO 290
+C
+C           CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN
+C           AND UPDATE QTF IF NECESSARY.
+C
+            DO 280 J = 1, N
+               SUM = ZERO
+               DO 270 I = 1, N
+                  SUM = SUM + FJAC(I,J)*WA4(I)
+  270             CONTINUE
+               WA2(J) = (SUM - WA3(J))/PNORM
+               WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM)
+               IF (RATIO .GE. P0001) QTF(J) = SUM
+  280          CONTINUE
+C
+C           COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN.
+C
+            CALL R1UPDT(N,N,R,LR,WA1,WA2,WA3,SING)
+            CALL R1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3)
+            CALL R1MPYQ(1,N,QTF,1,WA2,WA3)
+C
+C           END OF THE INNER LOOP.
+C
+            JEVAL = .FALSE.
+            GO TO 180
+  290    CONTINUE
+C
+C        END OF THE OUTER LOOP.
+C
+         GO TO 30
+  300 CONTINUE
+C
+C     TERMINATION, EITHER NORMAL OR USER IMPOSED.
+C
+      IF (IFLAG .LT. 0) INFO = IFLAG
+      IFLAG = 0
+      IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,IFLAG)
+      RETURN
+C
+C     LAST CARD OF SUBROUTINE HYBRD.
+C
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/minpack/hybrd1.f
@@ -0,0 +1,123 @@
+      SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA)
+      INTEGER N,INFO,LWA
+      DOUBLE PRECISION TOL
+      DOUBLE PRECISION X(N),FVEC(N),WA(LWA)
+      EXTERNAL FCN
+C     **********
+C
+C     SUBROUTINE HYBRD1
+C
+C     THE PURPOSE OF HYBRD1 IS TO FIND A ZERO OF A SYSTEM OF
+C     N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION
+C     OF THE POWELL HYBRID METHOD. THIS IS DONE BY USING THE
+C     MORE GENERAL NONLINEAR EQUATION SOLVER HYBRD. THE USER
+C     MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE FUNCTIONS.
+C     THE JACOBIAN IS THEN CALCULATED BY A FORWARD-DIFFERENCE
+C     APPROXIMATION.
+C
+C     THE SUBROUTINE STATEMENT IS
+C
+C       SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA)
+C
+C     WHERE
+C
+C       FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH
+C         CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED
+C         IN AN EXTERNAL STATEMENT IN THE USER CALLING
+C         PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
+C
+C         SUBROUTINE FCN(N,X,FVEC,IFLAG)
+C         INTEGER N,IFLAG
+C         DOUBLE PRECISION X(N),FVEC(N)
+C         ----------
+C         CALCULATE THE FUNCTIONS AT X AND
+C         RETURN THIS VECTOR IN FVEC.
+C         ---------
+C         RETURN
+C         END
+C
+C         THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS
+C         THE USER WANTS TO TERMINATE EXECUTION OF HYBRD1.
+C         IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
+C
+C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C         OF FUNCTIONS AND VARIABLES.
+C
+C       X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
+C         AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
+C         CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
+C
+C       FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
+C         THE FUNCTIONS EVALUATED AT THE OUTPUT X.
+C
+C       TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS
+C         WHEN THE ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
+C         BETWEEN X AND THE SOLUTION IS AT MOST TOL.
+C
+C       INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
+C         TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
+C         VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
+C         INFO IS SET AS FOLLOWS.
+C
+C         INFO = 0   IMPROPER INPUT PARAMETERS.
+C
+C         INFO = 1   ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
+C                    BETWEEN X AND THE SOLUTION IS AT MOST TOL.
+C
+C         INFO = 2   NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED
+C                    200*(N+1).
+C
+C         INFO = 3   TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
+C                    THE APPROXIMATE SOLUTION X IS POSSIBLE.
+C
+C         INFO = 4   ITERATION IS NOT MAKING GOOD PROGRESS.
+C
+C       WA IS A WORK ARRAY OF LENGTH LWA.
+C
+C       LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
+C         (N*(3*N+13))/2.
+C
+C     SUBPROGRAMS CALLED
+C
+C       USER-SUPPLIED ...... FCN
+C
+C       MINPACK-SUPPLIED ... HYBRD
+C
+C     MINPACK. VERSION OF JULY 1979.
+C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
+C
+C     **********
+      INTEGER INDEX,J,LR,MAXFEV,ML,MODE,MU,NFEV,NPRINT
+      DOUBLE PRECISION EPSFCN,FACTOR,ONE,XTOL,ZERO
+      DATA FACTOR,ONE,ZERO /1.0D2,1.0D0,0.0D0/
+      INFO = 0
+C
+C     CHECK THE INPUT PARAMETERS FOR ERRORS.
+C
+      IF (N .LE. 0 .OR. TOL .LT. ZERO .OR. LWA .LT. (N*(3*N + 13))/2)
+     *   GO TO 20
+C
+C     CALL HYBRD.
+C
+      MAXFEV = 200*(N + 1)
+      XTOL = TOL
+      ML = N - 1
+      MU = N - 1
+      EPSFCN = ZERO
+      MODE = 2
+      DO 10 J = 1, N
+         WA(J) = ONE
+   10    CONTINUE
+      NPRINT = 0
+      LR = (N*(N + 1))/2
+      INDEX = 6*N + LR
+      CALL HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,WA(1),MODE,
+     *           FACTOR,NPRINT,INFO,NFEV,WA(INDEX+1),N,WA(6*N+1),LR,
+     *           WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1))
+      IF (INFO .EQ. 5) INFO = 4
+   20 CONTINUE
+      RETURN
+C
+C     LAST CARD OF SUBROUTINE HYBRD1.
+C
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/minpack/hybrj.f
@@ -0,0 +1,441 @@
+      SUBROUTINE HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG,MODE,
+     *                 FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF,WA1,WA2,
+     *                 WA3,WA4)
+      INTEGER N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,LR
+      DOUBLE PRECISION XTOL,FACTOR
+      DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N),DIAG(N),R(LR),
+     *                 QTF(N),WA1(N),WA2(N),WA3(N),WA4(N)
+      EXTERNAL FCN
+C     **********
+C
+C     SUBROUTINE HYBRJ
+C
+C     THE PURPOSE OF HYBRJ IS TO FIND A ZERO OF A SYSTEM OF
+C     N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION
+C     OF THE POWELL HYBRID METHOD. THE USER MUST PROVIDE A
+C     SUBROUTINE WHICH CALCULATES THE FUNCTIONS AND THE JACOBIAN.
+C
+C     THE SUBROUTINE STATEMENT IS
+C
+C       SUBROUTINE HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG,
+C                        MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF,
+C                        WA1,WA2,WA3,WA4)
+C
+C     WHERE
+C
+C       FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH
+C         CALCULATES THE FUNCTIONS AND THE JACOBIAN. FCN MUST
+C         BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER
+C         CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
+C
+C         SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
+C         INTEGER N,LDFJAC,IFLAG
+C         DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N)
+C         ----------
+C         IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND
+C         RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC.
+C         IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND
+C         RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC.
+C         ---------
+C         RETURN
+C         END
+C
+C         THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS
+C         THE USER WANTS TO TERMINATE EXECUTION OF HYBRJ.
+C         IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
+C
+C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C         OF FUNCTIONS AND VARIABLES.
+C
+C       X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
+C         AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
+C         CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
+C
+C       FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
+C         THE FUNCTIONS EVALUATED AT THE OUTPUT X.
+C
+C       FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE
+C         ORTHOGONAL MATRIX Q PRODUCED BY THE QR FACTORIZATION
+C         OF THE FINAL APPROXIMATE JACOBIAN.
+C
+C       LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
+C         WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
+C
+C       XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
+C         OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE
+C         ITERATES IS AT MOST XTOL.
+C
+C       MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION
+C         OCCURS WHEN THE NUMBER OF CALLS TO FCN WITH IFLAG = 1
+C         HAS REACHED MAXFEV.
+C
+C       DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE
+C         BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG
+C         MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS IMPLICIT
+C         (MULTIPLICATIVE) SCALE FACTORS FOR THE VARIABLES.
+C
+C       MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE
+C         VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2,
+C         THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER
+C         VALUES OF MODE ARE EQUIVALENT TO MODE = 1.
+C
+C       FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE
+C         INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF
+C         FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE
+C         TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE
+C         INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE.
+C
+C       NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED
+C         PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE,
+C         FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST
+C         ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND
+C         IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE
+C         FOR PRINTING. FVEC AND FJAC SHOULD NOT BE ALTERED.
+C         IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS OF FCN
+C         WITH IFLAG = 0 ARE MADE.
+C
+C       INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
+C         TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
+C         VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
+C         INFO IS SET AS FOLLOWS.
+C
+C         INFO = 0   IMPROPER INPUT PARAMETERS.
+C
+C         INFO = 1   RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES
+C                    IS AT MOST TOL.
+C
+C         INFO = 2   NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS
+C                    REACHED MAXFEV.
+C
+C         INFO = 3   XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
+C                    THE APPROXIMATE SOLUTION X IS POSSIBLE.
+C
+C         INFO = 4   ITERATION IS NOT MAKING GOOD PROGRESS, AS
+C                    MEASURED BY THE IMPROVEMENT FROM THE LAST
+C                    FIVE JACOBIAN EVALUATIONS.
+C
+C         INFO = 5   ITERATION IS NOT MAKING GOOD PROGRESS, AS
+C                    MEASURED BY THE IMPROVEMENT FROM THE LAST
+C                    TEN ITERATIONS.
+C
+C       NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
+C         CALLS TO FCN WITH IFLAG = 1.
+C
+C       NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
+C         CALLS TO FCN WITH IFLAG = 2.
+C
+C       R IS AN OUTPUT ARRAY OF LENGTH LR WHICH CONTAINS THE
+C         UPPER TRIANGULAR MATRIX PRODUCED BY THE QR FACTORIZATION
+C         OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE.
+C
+C       LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
+C         (N*(N+1))/2.
+C
+C       QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
+C         THE VECTOR (Q TRANSPOSE)*FVEC.
+C
+C       WA1, WA2, WA3, AND WA4 ARE WORK ARRAYS OF LENGTH N.
+C
+C     SUBPROGRAMS CALLED
+C
+C       USER-SUPPLIED ...... FCN
+C
+C       MINPACK-SUPPLIED ... DOGLEG,DPMPAR,ENORM,
+C                            QFORM,QRFAC,R1MPYQ,R1UPDT
+C
+C       FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,MOD
+C
+C     MINPACK. VERSION OF SEPTEMBER 1979.
+C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
+C
+C     **********
+      INTEGER I,IFLAG,ITER,J,JM1,L,NCFAIL,NCSUC,NSLOW1,NSLOW2
+      INTEGER IWA(1)
+      LOGICAL JEVAL,SING
+      DOUBLE PRECISION ACTRED,DELTA,EPSMCH,FNORM,FNORM1,ONE,PNORM,
+     *                 PRERED,P1,P5,P001,P0001,RATIO,SUM,TEMP,XNORM,
+     *                 ZERO
+      DOUBLE PRECISION DPMPAR,ENORM
+      DATA ONE,P1,P5,P001,P0001,ZERO
+     *     /1.0D0,1.0D-1,5.0D-1,1.0D-3,1.0D-4,0.0D0/
+C
+C     EPSMCH IS THE MACHINE PRECISION.
+C
+      EPSMCH = DPMPAR(1)
+C
+      INFO = 0
+      IFLAG = 0
+      NFEV = 0
+      NJEV = 0
+C
+C     CHECK THE INPUT PARAMETERS FOR ERRORS.
+C
+      IF (N .LE. 0 .OR. LDFJAC .LT. N .OR. XTOL .LT. ZERO
+     *    .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO
+     *    .OR. LR .LT. (N*(N + 1))/2) GO TO 300
+      IF (MODE .NE. 2) GO TO 20
+      DO 10 J = 1, N
+         IF (DIAG(J) .LE. ZERO) GO TO 300
+   10    CONTINUE
+   20 CONTINUE
+C
+C     EVALUATE THE FUNCTION AT THE STARTING POINT
+C     AND CALCULATE ITS NORM.
+C
+      IFLAG = 1
+      CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
+      NFEV = 1
+      IF (IFLAG .LT. 0) GO TO 300
+      FNORM = ENORM(N,FVEC)
+C
+C     INITIALIZE ITERATION COUNTER AND MONITORS.
+C
+      ITER = 1
+      NCSUC = 0
+      NCFAIL = 0
+      NSLOW1 = 0
+      NSLOW2 = 0
+C
+C     BEGINNING OF THE OUTER LOOP.
+C
+   30 CONTINUE
+         JEVAL = .TRUE.
+C
+C        CALCULATE THE JACOBIAN MATRIX.
+C
+         IFLAG = 2
+         CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
+         NJEV = NJEV + 1
+         IF (IFLAG .LT. 0) GO TO 300
+C
+C        COMPUTE THE QR FACTORIZATION OF THE JACOBIAN.
+C
+         CALL QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3)
+C
+C        ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING
+C        TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN.
+C
+         IF (ITER .NE. 1) GO TO 70
+         IF (MODE .EQ. 2) GO TO 50
+         DO 40 J = 1, N
+            DIAG(J) = WA2(J)
+            IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE
+   40       CONTINUE
+   50    CONTINUE
+C
+C        ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X
+C        AND INITIALIZE THE STEP BOUND DELTA.
+C
+         DO 60 J = 1, N
+            WA3(J) = DIAG(J)*X(J)
+   60       CONTINUE
+         XNORM = ENORM(N,WA3)
+         DELTA = FACTOR*XNORM
+         IF (DELTA .EQ. ZERO) DELTA = FACTOR
+   70    CONTINUE
+C
+C        FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF.
+C
+         DO 80 I = 1, N
+            QTF(I) = FVEC(I)
+   80       CONTINUE
+         DO 120 J = 1, N
+            IF (FJAC(J,J) .EQ. ZERO) GO TO 110
+            SUM = ZERO
+            DO 90 I = J, N
+               SUM = SUM + FJAC(I,J)*QTF(I)
+   90          CONTINUE
+            TEMP = -SUM/FJAC(J,J)
+            DO 100 I = J, N
+               QTF(I) = QTF(I) + FJAC(I,J)*TEMP
+  100          CONTINUE
+  110       CONTINUE
+  120       CONTINUE
+C
+C        COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R.
+C
+         SING = .FALSE.
+         DO 150 J = 1, N
+            L = J
+            JM1 = J - 1
+            IF (JM1 .LT. 1) GO TO 140
+            DO 130 I = 1, JM1
+               R(L) = FJAC(I,J)
+               L = L + N - I
+  130          CONTINUE
+  140       CONTINUE
+            R(L) = WA1(J)
+            IF (WA1(J) .EQ. ZERO) SING = .TRUE.
+  150       CONTINUE
+C
+C        ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC.
+C
+         CALL QFORM(N,N,FJAC,LDFJAC,WA1)
+C
+C        RESCALE IF NECESSARY.
+C
+         IF (MODE .EQ. 2) GO TO 170
+         DO 160 J = 1, N
+            DIAG(J) = DMAX1(DIAG(J),WA2(J))
+  160       CONTINUE
+  170    CONTINUE
+C
+C        BEGINNING OF THE INNER LOOP.
+C
+  180    CONTINUE
+C
+C           IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
+C
+            IF (NPRINT .LE. 0) GO TO 190
+            IFLAG = 0
+            IF (MOD(ITER-1,NPRINT) .EQ. 0)
+     *         CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
+            IF (IFLAG .LT. 0) GO TO 300
+  190       CONTINUE
+C
+C           DETERMINE THE DIRECTION P.
+C
+            CALL DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3)
+C
+C           STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P.
+C
+            DO 200 J = 1, N
+               WA1(J) = -WA1(J)
+               WA2(J) = X(J) + WA1(J)
+               WA3(J) = DIAG(J)*WA1(J)
+  200          CONTINUE
+            PNORM = ENORM(N,WA3)
+C
+C           ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND.
+C
+            IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM)
+C
+C           EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM.
+C
+            IFLAG = 1
+            CALL FCN(N,WA2,WA4,FJAC,LDFJAC,IFLAG)
+            NFEV = NFEV + 1
+            IF (IFLAG .LT. 0) GO TO 300
+            FNORM1 = ENORM(N,WA4)
+C
+C           COMPUTE THE SCALED ACTUAL REDUCTION.
+C
+            ACTRED = -ONE
+            IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2
+C
+C           COMPUTE THE SCALED PREDICTED REDUCTION.
+C
+            L = 1
+            DO 220 I = 1, N
+               SUM = ZERO
+               DO 210 J = I, N
+                  SUM = SUM + R(L)*WA1(J)
+                  L = L + 1
+  210             CONTINUE
+               WA3(I) = QTF(I) + SUM
+  220          CONTINUE
+            TEMP = ENORM(N,WA3)
+            PRERED = ZERO
+            IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2
+C
+C           COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED
+C           REDUCTION.
+C
+            RATIO = ZERO
+            IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED
+C
+C           UPDATE THE STEP BOUND.
+C
+            IF (RATIO .GE. P1) GO TO 230
+               NCSUC = 0
+               NCFAIL = NCFAIL + 1
+               DELTA = P5*DELTA
+               GO TO 240
+  230       CONTINUE
+               NCFAIL = 0
+               NCSUC = NCSUC + 1
+               IF (RATIO .GE. P5 .OR. NCSUC .GT. 1)
+     *            DELTA = DMAX1(DELTA,PNORM/P5)
+               IF (DABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5
+  240       CONTINUE
+C
+C           TEST FOR SUCCESSFUL ITERATION.
+C
+            IF (RATIO .LT. P0001) GO TO 260
+C
+C           SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS.
+C
+            DO 250 J = 1, N
+               X(J) = WA2(J)
+               WA2(J) = DIAG(J)*X(J)
+               FVEC(J) = WA4(J)
+  250          CONTINUE
+            XNORM = ENORM(N,WA2)
+            FNORM = FNORM1
+            ITER = ITER + 1
+  260       CONTINUE
+C
+C           DETERMINE THE PROGRESS OF THE ITERATION.
+C
+            NSLOW1 = NSLOW1 + 1
+            IF (ACTRED .GE. P001) NSLOW1 = 0
+            IF (JEVAL) NSLOW2 = NSLOW2 + 1
+            IF (ACTRED .GE. P1) NSLOW2 = 0
+C
+C           TEST FOR CONVERGENCE.
+C
+            IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1
+            IF (INFO .NE. 0) GO TO 300
+C
+C           TESTS FOR TERMINATION AND STRINGENT TOLERANCES.
+C
+            IF (NFEV .GE. MAXFEV) INFO = 2
+            IF (P1*DMAX1(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3
+            IF (NSLOW2 .EQ. 5) INFO = 4
+            IF (NSLOW1 .EQ. 10) INFO = 5
+            IF (INFO .NE. 0) GO TO 300
+C
+C           CRITERION FOR RECALCULATING JACOBIAN.
+C
+            IF (NCFAIL .EQ. 2) GO TO 290
+C
+C           CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN
+C           AND UPDATE QTF IF NECESSARY.
+C
+            DO 280 J = 1, N
+               SUM = ZERO
+               DO 270 I = 1, N
+                  SUM = SUM + FJAC(I,J)*WA4(I)
+  270             CONTINUE
+               WA2(J) = (SUM - WA3(J))/PNORM
+               WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM)
+               IF (RATIO .GE. P0001) QTF(J) = SUM
+  280          CONTINUE
+C
+C           COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN.
+C
+            CALL R1UPDT(N,N,R,LR,WA1,WA2,WA3,SING)
+            CALL R1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3)
+            CALL R1MPYQ(1,N,QTF,1,WA2,WA3)
+C
+C           END OF THE INNER LOOP.
+C
+            JEVAL = .FALSE.
+            GO TO 180
+  290    CONTINUE
+C
+C        END OF THE OUTER LOOP.
+C
+         GO TO 30
+  300 CONTINUE
+C
+C     TERMINATION, EITHER NORMAL OR USER IMPOSED.
+C
+      IF (IFLAG .LT. 0) INFO = IFLAG
+      IFLAG = 0
+      IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
+      RETURN
+C
+C     LAST CARD OF SUBROUTINE HYBRJ.
+C
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/minpack/hybrj1.f
@@ -0,0 +1,127 @@
+      SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA)
+      INTEGER N,LDFJAC,INFO,LWA
+      DOUBLE PRECISION TOL
+      DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N),WA(LWA)
+      EXTERNAL FCN
+C     **********
+C
+C     SUBROUTINE HYBRJ1
+C
+C     THE PURPOSE OF HYBRJ1 IS TO FIND A ZERO OF A SYSTEM OF
+C     N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION
+C     OF THE POWELL HYBRID METHOD. THIS IS DONE BY USING THE
+C     MORE GENERAL NONLINEAR EQUATION SOLVER HYBRJ. THE USER
+C     MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE FUNCTIONS
+C     AND THE JACOBIAN.
+C
+C     THE SUBROUTINE STATEMENT IS
+C
+C       SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA)
+C
+C     WHERE
+C
+C       FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH
+C         CALCULATES THE FUNCTIONS AND THE JACOBIAN. FCN MUST
+C         BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER
+C         CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
+C
+C         SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG)
+C         INTEGER N,LDFJAC,IFLAG
+C         DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N)
+C         ----------
+C         IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND
+C         RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC.
+C         IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND
+C         RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC.
+C         ---------
+C         RETURN
+C         END
+C
+C         THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS
+C         THE USER WANTS TO TERMINATE EXECUTION OF HYBRJ1.
+C         IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
+C
+C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C         OF FUNCTIONS AND VARIABLES.
+C
+C       X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
+C         AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
+C         CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
+C
+C       FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
+C         THE FUNCTIONS EVALUATED AT THE OUTPUT X.
+C
+C       FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE
+C         ORTHOGONAL MATRIX Q PRODUCED BY THE QR FACTORIZATION
+C         OF THE FINAL APPROXIMATE JACOBIAN.
+C
+C       LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
+C         WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
+C
+C       TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS
+C         WHEN THE ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
+C         BETWEEN X AND THE SOLUTION IS AT MOST TOL.
+C
+C       INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
+C         TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
+C         VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
+C         INFO IS SET AS FOLLOWS.
+C
+C         INFO = 0   IMPROPER INPUT PARAMETERS.
+C
+C         INFO = 1   ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
+C                    BETWEEN X AND THE SOLUTION IS AT MOST TOL.
+C
+C         INFO = 2   NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS
+C                    REACHED 100*(N+1).
+C
+C         INFO = 3   TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
+C                    THE APPROXIMATE SOLUTION X IS POSSIBLE.
+C
+C         INFO = 4   ITERATION IS NOT MAKING GOOD PROGRESS.
+C
+C       WA IS A WORK ARRAY OF LENGTH LWA.
+C
+C       LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
+C         (N*(N+13))/2.
+C
+C     SUBPROGRAMS CALLED
+C
+C       USER-SUPPLIED ...... FCN
+C
+C       MINPACK-SUPPLIED ... HYBRJ
+C
+C     MINPACK. VERSION OF JULY 1979.
+C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
+C
+C     **********
+      INTEGER J,LR,MAXFEV,MODE,NFEV,NJEV,NPRINT
+      DOUBLE PRECISION FACTOR,ONE,XTOL,ZERO
+      DATA FACTOR,ONE,ZERO /1.0D2,1.0D0,0.0D0/
+      INFO = 0
+C
+C     CHECK THE INPUT PARAMETERS FOR ERRORS.
+C
+      IF (N .LE. 0 .OR. LDFJAC .LT. N .OR. TOL .LT. ZERO
+     *    .OR. LWA .LT. (N*(N + 13))/2) GO TO 20
+C
+C     CALL HYBRJ.
+C
+      MAXFEV = 100*(N + 1)
+      XTOL = TOL
+      MODE = 2
+      DO 10 J = 1, N
+         WA(J) = ONE
+   10    CONTINUE
+      NPRINT = 0
+      LR = (N*(N + 1))/2
+      CALL HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,WA(1),MODE,
+     *           FACTOR,NPRINT,INFO,NFEV,NJEV,WA(6*N+1),LR,WA(N+1),
+     *           WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1))
+      IF (INFO .EQ. 5) INFO = 4
+   20 CONTINUE
+      RETURN
+C
+C     LAST CARD OF SUBROUTINE HYBRJ1.
+C
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/minpack/qform.f
@@ -0,0 +1,95 @@
+      SUBROUTINE QFORM(M,N,Q,LDQ,WA)
+      INTEGER M,N,LDQ
+      DOUBLE PRECISION Q(LDQ,M),WA(M)
+C     **********
+C
+C     SUBROUTINE QFORM
+C
+C     THIS SUBROUTINE PROCEEDS FROM THE COMPUTED QR FACTORIZATION OF
+C     AN M BY N MATRIX A TO ACCUMULATE THE M BY M ORTHOGONAL MATRIX
+C     Q FROM ITS FACTORED FORM.
+C
+C     THE SUBROUTINE STATEMENT IS
+C
+C       SUBROUTINE QFORM(M,N,Q,LDQ,WA)
+C
+C     WHERE
+C
+C       M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C         OF ROWS OF A AND THE ORDER OF Q.
+C
+C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C         OF COLUMNS OF A.
+C
+C       Q IS AN M BY M ARRAY. ON INPUT THE FULL LOWER TRAPEZOID IN
+C         THE FIRST MIN(M,N) COLUMNS OF Q CONTAINS THE FACTORED FORM.
+C         ON OUTPUT Q HAS BEEN ACCUMULATED INTO A SQUARE MATRIX.
+C
+C       LDQ IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
+C         WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY Q.
+C
+C       WA IS A WORK ARRAY OF LENGTH M.
+C
+C     SUBPROGRAMS CALLED
+C
+C       FORTRAN-SUPPLIED ... MIN0
+C
+C     MINPACK. VERSION OF JANUARY 1979.
+C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
+C
+C     **********
+      INTEGER I,J,JM1,K,L,MINMN,NP1
+      DOUBLE PRECISION ONE,SUM,TEMP,ZERO
+      DATA ONE,ZERO /1.0D0,0.0D0/
+C
+C     ZERO OUT UPPER TRIANGLE OF Q IN THE FIRST MIN(M,N) COLUMNS.
+C
+      MINMN = MIN0(M,N)
+      IF (MINMN .LT. 2) GO TO 30
+      DO 20 J = 2, MINMN
+         JM1 = J - 1
+         DO 10 I = 1, JM1
+            Q(I,J) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+   30 CONTINUE
+C
+C     INITIALIZE REMAINING COLUMNS TO THOSE OF THE IDENTITY MATRIX.
+C
+      NP1 = N + 1
+      IF (M .LT. NP1) GO TO 60
+      DO 50 J = NP1, M
+         DO 40 I = 1, M
+            Q(I,J) = ZERO
+   40       CONTINUE
+         Q(J,J) = ONE
+   50    CONTINUE
+   60 CONTINUE
+C
+C     ACCUMULATE Q FROM ITS FACTORED FORM.
+C
+      DO 120 L = 1, MINMN
+         K = MINMN - L + 1
+         DO 70 I = K, M
+            WA(I) = Q(I,K)
+            Q(I,K) = ZERO
+   70       CONTINUE
+         Q(K,K) = ONE
+         IF (WA(K) .EQ. ZERO) GO TO 110
+         DO 100 J = K, M
+            SUM = ZERO
+            DO 80 I = K, M
+               SUM = SUM + Q(I,J)*WA(I)
+   80          CONTINUE
+            TEMP = SUM/WA(K)
+            DO 90 I = K, M
+               Q(I,J) = Q(I,J) - TEMP*WA(I)
+   90          CONTINUE
+  100       CONTINUE
+  110    CONTINUE
+  120    CONTINUE
+      RETURN
+C
+C     LAST CARD OF SUBROUTINE QFORM.
+C
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/minpack/qrfac.f
@@ -0,0 +1,164 @@
+      SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,SIGMA,ACNORM,WA)
+      INTEGER M,N,LDA,LIPVT
+      INTEGER IPVT(LIPVT)
+      LOGICAL PIVOT
+      DOUBLE PRECISION A(LDA,N),SIGMA(N),ACNORM(N),WA(N)
+C     **********
+C
+C     SUBROUTINE QRFAC
+C
+C     THIS SUBROUTINE USES HOUSEHOLDER TRANSFORMATIONS WITH COLUMN
+C     PIVOTING (OPTIONAL) TO COMPUTE A QR FACTORIZATION OF THE
+C     M BY N MATRIX A. THAT IS, QRFAC DETERMINES AN ORTHOGONAL
+C     MATRIX Q, A PERMUTATION MATRIX P, AND AN UPPER TRAPEZOIDAL
+C     MATRIX R WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE,
+C     SUCH THAT A*P = Q*R. THE HOUSEHOLDER TRANSFORMATION FOR
+C     COLUMN K, K = 1,2,...,MIN(M,N), IS OF THE FORM
+C
+C                           T
+C           I - (1/U(K))*U*U
+C
+C     WHERE U HAS ZEROS IN THE FIRST K-1 POSITIONS. THE FORM OF
+C     THIS TRANSFORMATION AND THE METHOD OF PIVOTING FIRST
+C     APPEARED IN THE CORRESPONDING LINPACK SUBROUTINE.
+C
+C     THE SUBROUTINE STATEMENT IS
+C
+C       SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,SIGMA,ACNORM,WA)
+C
+C     WHERE
+C
+C       M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C         OF ROWS OF A.
+C
+C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C         OF COLUMNS OF A.
+C
+C       A IS AN M BY N ARRAY. ON INPUT A CONTAINS THE MATRIX FOR
+C         WHICH THE QR FACTORIZATION IS TO BE COMPUTED. ON OUTPUT
+C         THE STRICT UPPER TRAPEZOIDAL PART OF A CONTAINS THE STRICT
+C         UPPER TRAPEZOIDAL PART OF R, AND THE LOWER TRAPEZOIDAL
+C         PART OF A CONTAINS A FACTORED FORM OF Q (THE NON-TRIVIAL
+C         ELEMENTS OF THE U VECTORS DESCRIBED ABOVE).
+C
+C       LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
+C         WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A.
+C
+C       PIVOT IS A LOGICAL INPUT VARIABLE. IF PIVOT IS SET TRUE,
+C         THEN COLUMN PIVOTING IS ENFORCED. IF PIVOT IS SET FALSE,
+C         THEN NO COLUMN PIVOTING IS DONE.
+C
+C       IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH LIPVT. IPVT
+C         DEFINES THE PERMUTATION MATRIX P SUCH THAT A*P = Q*R.
+C         COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
+C         IF PIVOT IS FALSE, IPVT IS NOT REFERENCED.
+C
+C       LIPVT IS A POSITIVE INTEGER INPUT VARIABLE. IF PIVOT IS FALSE,
+C         THEN LIPVT MAY BE AS SMALL AS 1. IF PIVOT IS TRUE, THEN
+C         LIPVT MUST BE AT LEAST N.
+C
+C       SIGMA IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE
+C         DIAGONAL ELEMENTS OF R.
+C
+C       ACNORM IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE
+C         NORMS OF THE CORRESPONDING COLUMNS OF THE INPUT MATRIX A.
+C         IF THIS INFORMATION IS NOT NEEDED, THEN ACNORM CAN COINCIDE
+C         WITH SIGMA.
+C
+C       WA IS A WORK ARRAY OF LENGTH N. IF PIVOT IS FALSE, THEN WA
+C         CAN COINCIDE WITH SIGMA.
+C
+C     SUBPROGRAMS CALLED
+C
+C       MINPACK-SUPPLIED ... DPMPAR,ENORM
+C
+C       FORTRAN-SUPPLIED ... DMAX1,DSQRT,MIN0
+C
+C     MINPACK. VERSION OF DECEMBER 1978.
+C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
+C
+C     **********
+      INTEGER I,J,JP1,K,KMAX,MINMN
+      DOUBLE PRECISION AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO
+      DOUBLE PRECISION DPMPAR,ENORM
+      DATA ONE,P05,ZERO /1.0D0,5.0D-2,0.0D0/
+C
+C     EPSMCH IS THE MACHINE PRECISION.
+C
+      EPSMCH = DPMPAR(1)
+C
+C     COMPUTE THE INITIAL COLUMN NORMS AND INITIALIZE SEVERAL ARRAYS.
+C
+      DO 10 J = 1, N
+         ACNORM(J) = ENORM(M,A(1,J))
+         SIGMA(J) = ACNORM(J)
+         WA(J) = SIGMA(J)
+         IF (PIVOT) IPVT(J) = J
+   10    CONTINUE
+C
+C     REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS.
+C
+      MINMN = MIN0(M,N)
+      DO 110 J = 1, MINMN
+         IF (.NOT.PIVOT) GO TO 40
+C
+C        BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION.
+C
+         KMAX = J
+         DO 20 K = J, N
+            IF (SIGMA(K) .GT. SIGMA(KMAX)) KMAX = K
+   20       CONTINUE
+         IF (KMAX .EQ. J) GO TO 40
+         DO 30 I = 1, M
+            TEMP = A(I,J)
+            A(I,J) = A(I,KMAX)
+            A(I,KMAX) = TEMP
+   30       CONTINUE
+         SIGMA(KMAX) = SIGMA(J)
+         WA(KMAX) = WA(J)
+         K = IPVT(J)
+         IPVT(J) = IPVT(KMAX)
+         IPVT(KMAX) = K
+   40    CONTINUE
+C
+C        COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE
+C        J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR.
+C
+         AJNORM = ENORM(M-J+1,A(J,J))
+         IF (AJNORM .EQ. ZERO) GO TO 100
+         IF (A(J,J) .LT. ZERO) AJNORM = -AJNORM
+         DO 50 I = J, M
+            A(I,J) = A(I,J)/AJNORM
+   50       CONTINUE
+         A(J,J) = A(J,J) + ONE
+C
+C        APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS
+C        AND UPDATE THE NORMS.
+C
+         JP1 = J + 1
+         IF (N .LT. JP1) GO TO 100
+         DO 90 K = JP1, N
+            SUM = ZERO
+            DO 60 I = J, M
+               SUM = SUM + A(I,J)*A(I,K)
+   60          CONTINUE
+            TEMP = SUM/A(J,J)
+            DO 70 I = J, M
+               A(I,K) = A(I,K) - TEMP*A(I,J)
+   70          CONTINUE
+            IF (.NOT.PIVOT .OR. SIGMA(K) .EQ. ZERO) GO TO 80
+            TEMP = A(J,K)/SIGMA(K)
+            SIGMA(K) = SIGMA(K)*DSQRT(DMAX1(ZERO,ONE-TEMP**2))
+            IF (P05*(SIGMA(K)/WA(K))**2 .GT. EPSMCH) GO TO 80
+            SIGMA(K) = ENORM(M-J,A(JP1,K))
+            WA(K) = SIGMA(K)
+   80       CONTINUE
+   90       CONTINUE
+  100    CONTINUE
+         SIGMA(J) = -AJNORM
+  110    CONTINUE
+      RETURN
+C
+C     LAST CARD OF SUBROUTINE QRFAC.
+C
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/minpack/r1mpyq.f
@@ -0,0 +1,92 @@
+      SUBROUTINE R1MPYQ(M,N,A,LDA,V,W)
+      INTEGER M,N,LDA
+      DOUBLE PRECISION A(LDA,N),V(N),W(N)
+C     **********
+C
+C     SUBROUTINE R1MPYQ
+C
+C     GIVEN AN M BY N MATRIX A, THIS SUBROUTINE COMPUTES A*Q WHERE
+C     Q IS THE PRODUCT OF 2*(N - 1) TRANSFORMATIONS
+C
+C           GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
+C
+C     AND GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE WHICH
+C     ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES, RESPECTIVELY.
+C     Q ITSELF IS NOT GIVEN, RATHER THE INFORMATION TO RECOVER THE
+C     GV, GW ROTATIONS IS SUPPLIED.
+C
+C     THE SUBROUTINE STATEMENT IS
+C
+C       SUBROUTINE R1MPYQ(M,N,A,LDA,V,W)
+C
+C     WHERE
+C
+C       M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C         OF ROWS OF A.
+C
+C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C         OF COLUMNS OF A.
+C
+C       A IS AN M BY N ARRAY. ON INPUT A MUST CONTAIN THE MATRIX
+C         TO BE POSTMULTIPLIED BY THE ORTHOGONAL MATRIX Q
+C         DESCRIBED ABOVE. ON OUTPUT A*Q HAS REPLACED A.
+C
+C       LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
+C         WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A.
+C
+C       V IS AN INPUT ARRAY OF LENGTH N. V(I) MUST CONTAIN THE
+C         INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GV(I)
+C         DESCRIBED ABOVE.
+C
+C       W IS AN INPUT ARRAY OF LENGTH N. W(I) MUST CONTAIN THE
+C         INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GW(I)
+C         DESCRIBED ABOVE.
+C
+C     SUBROUTINES CALLED
+C
+C       FORTRAN-SUPPLIED ... DABS,DSQRT
+C
+C     MINPACK. VERSION OF DECEMBER 1978.
+C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
+C
+C     **********
+      INTEGER I,J,NMJ,NM1
+      DOUBLE PRECISION COS,ONE,SIN,TEMP
+      DATA ONE /1.0D0/
+C
+C     APPLY THE FIRST SET OF GIVENS ROTATIONS TO A.
+C
+      NM1 = N - 1
+      IF (NM1 .LT. 1) GO TO 50
+      DO 20 NMJ = 1, NM1
+         J = N - NMJ
+         IF (DABS(V(J)) .GT. ONE) COS = ONE/V(J)
+         IF (DABS(V(J)) .GT. ONE) SIN = DSQRT(ONE-COS**2)
+         IF (DABS(V(J)) .LE. ONE) SIN = V(J)
+         IF (DABS(V(J)) .LE. ONE) COS = DSQRT(ONE-SIN**2)
+         DO 10 I = 1, M
+            TEMP = COS*A(I,J) - SIN*A(I,N)
+            A(I,N) = SIN*A(I,J) + COS*A(I,N)
+            A(I,J) = TEMP
+   10       CONTINUE
+   20    CONTINUE
+C
+C     APPLY THE SECOND SET OF GIVENS ROTATIONS TO A.
+C
+      DO 40 J = 1, NM1
+         IF (DABS(W(J)) .GT. ONE) COS = ONE/W(J)
+         IF (DABS(W(J)) .GT. ONE) SIN = DSQRT(ONE-COS**2)
+         IF (DABS(W(J)) .LE. ONE) SIN = W(J)
+         IF (DABS(W(J)) .LE. ONE) COS = DSQRT(ONE-SIN**2)
+         DO 30 I = 1, M
+            TEMP = COS*A(I,J) + SIN*A(I,N)
+            A(I,N) = -SIN*A(I,J) + COS*A(I,N)
+            A(I,J) = TEMP
+   30       CONTINUE
+   40    CONTINUE
+   50 CONTINUE
+      RETURN
+C
+C     LAST CARD OF SUBROUTINE R1MPYQ.
+C
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/minpack/r1updt.f
@@ -0,0 +1,207 @@
+      SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING)
+      INTEGER M,N,LS
+      LOGICAL SING
+      DOUBLE PRECISION S(LS),U(M),V(N),W(M)
+C     **********
+C
+C     SUBROUTINE R1UPDT
+C
+C     GIVEN AN M BY N LOWER TRAPEZOIDAL MATRIX S, AN M-VECTOR U,
+C     AND AN N-VECTOR V, THE PROBLEM IS TO DETERMINE AN
+C     ORTHOGONAL MATRIX Q SUCH THAT
+C
+C                   T
+C           (S + U*V )*Q
+C
+C     IS AGAIN LOWER TRAPEZOIDAL.
+C
+C     THIS SUBROUTINE DETERMINES Q AS THE PRODUCT OF 2*(N - 1)
+C     TRANSFORMATIONS
+C
+C           GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
+C
+C     WHERE GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE
+C     WHICH ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES,
+C     RESPECTIVELY. Q ITSELF IS NOT ACCUMULATED, RATHER THE
+C     INFORMATION TO RECOVER THE GV, GW ROTATIONS IS RETURNED.
+C
+C     THE SUBROUTINE STATEMENT IS
+C
+C       SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING)
+C
+C     WHERE
+C
+C       M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C         OF ROWS OF S.
+C
+C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C         OF COLUMNS OF S. N MUST NOT EXCEED M.
+C
+C       S IS AN ARRAY OF LENGTH LS. ON INPUT S MUST CONTAIN THE LOWER
+C         TRAPEZOIDAL MATRIX S STORED BY COLUMNS. ON OUTPUT S CONTAINS
+C         THE LOWER TRAPEZOIDAL MATRIX PRODUCED AS DESCRIBED ABOVE.
+C
+C       LS IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
+C         (N*(2*M-N+1))/2.
+C
+C       U IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE
+C         VECTOR U.
+C
+C       V IS AN ARRAY OF LENGTH N. ON INPUT V MUST CONTAIN THE VECTOR
+C         V. ON OUTPUT V(I) CONTAINS THE INFORMATION NECESSARY TO
+C         RECOVER THE GIVENS ROTATION GV(I) DESCRIBED ABOVE.
+C
+C       W IS AN OUTPUT ARRAY OF LENGTH M. W(I) CONTAINS INFORMATION
+C         NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) DESCRIBED
+C         ABOVE.
+C
+C       SING IS A LOGICAL OUTPUT VARIABLE. SING IS SET TRUE IF ANY
+C         OF THE DIAGONAL ELEMENTS OF THE OUTPUT S ARE ZERO. OTHERWISE
+C         V IS SET FALSE.
+C
+C     SUBPROGRAMS CALLED
+C
+C       MINPACK-SUPPLIED ... DPMPAR
+C
+C       FORTRAN-SUPPLIED ... DABS,DSQRT
+C
+C     MINPACK. VERSION OF DECEMBER 1978.
+C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE,
+C     JOHN L. NAZARETH
+C
+C     **********
+      INTEGER I,J,JJ,L,NMJ,NM1
+      DOUBLE PRECISION COS,COTAN,GIANT,ONE,P5,P25,SIN,TAN,TAU,TEMP,
+     *                 ZERO
+      DOUBLE PRECISION DPMPAR
+      DATA ONE,P5,P25,ZERO /1.0D0,5.0D-1,2.5D-1,0.0D0/
+C
+C     GIANT IS THE LARGEST MAGNITUDE.
+C
+      GIANT = DPMPAR(3)
+C
+C     INITIALIZE THE DIAGONAL ELEMENT POINTER.
+C
+      JJ = (N*(2*M - N + 1))/2 - (M - N)
+C
+C     MOVE THE NONTRIVIAL PART OF THE LAST COLUMN OF S INTO W.
+C
+      L = JJ
+      DO 10 I = N, M
+         W(I) = S(L)
+         L = L + 1
+   10    CONTINUE
+C
+C     ROTATE THE VECTOR V INTO A MULTIPLE OF THE N-TH UNIT VECTOR
+C     IN SUCH A WAY THAT A SPIKE IS INTRODUCED INTO W.
+C
+      NM1 = N - 1
+      IF (NM1 .LT. 1) GO TO 70
+      DO 60 NMJ = 1, NM1
+         J = N - NMJ
+         JJ = JJ - (M - J + 1)
+         W(J) = ZERO
+         IF (V(J) .EQ. ZERO) GO TO 50
+C
+C        DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE
+C        J-TH ELEMENT OF V.
+C
+         IF (DABS(V(N)) .GE. DABS(V(J))) GO TO 20
+            COTAN = V(N)/V(J)
+            SIN = P5/DSQRT(P25+P25*COTAN**2)
+            COS = SIN*COTAN
+            TAU = ONE
+            IF (DABS(COS)*GIANT .GT. ONE) TAU = ONE/COS
+            GO TO 30
+   20    CONTINUE
+            TAN = V(J)/V(N)
+            COS = P5/DSQRT(P25+P25*TAN**2)
+            SIN = COS*TAN
+            TAU = SIN
+   30    CONTINUE
+C
+C        APPLY THE TRANSFORMATION TO V AND STORE THE INFORMATION
+C        NECESSARY TO RECOVER THE GIVENS ROTATION.
+C
+         V(N) = SIN*V(J) + COS*V(N)
+         V(J) = TAU
+C
+C        APPLY THE TRANSFORMATION TO S AND EXTEND THE SPIKE IN W.
+C
+         L = JJ
+         DO 40 I = J, M
+            TEMP = COS*S(L) - SIN*W(I)
+            W(I) = SIN*S(L) + COS*W(I)
+            S(L) = TEMP
+            L = L + 1
+   40       CONTINUE
+   50    CONTINUE
+   60    CONTINUE
+   70 CONTINUE
+C
+C     ADD THE SPIKE FROM THE RANK 1 UPDATE TO W.
+C
+      DO 80 I = 1, M
+         W(I) = W(I) + V(N)*U(I)
+   80    CONTINUE
+C
+C     ELIMINATE THE SPIKE.
+C
+      SING = .FALSE.
+      IF (NM1 .LT. 1) GO TO 140
+      DO 130 J = 1, NM1
+         IF (W(J) .EQ. ZERO) GO TO 120
+C
+C        DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE
+C        J-TH ELEMENT OF THE SPIKE.
+C
+         IF (DABS(S(JJ)) .GE. DABS(W(J))) GO TO 90
+            COTAN = S(JJ)/W(J)
+            SIN = P5/DSQRT(P25+P25*COTAN**2)
+            COS = SIN*COTAN
+            TAU = ONE
+            IF (DABS(COS)*GIANT .GT. ONE) TAU = ONE/COS
+            GO TO 100
+   90    CONTINUE
+            TAN = W(J)/S(JJ)
+            COS = P5/DSQRT(P25+P25*TAN**2)
+            SIN = COS*TAN
+            TAU = SIN
+  100    CONTINUE
+C
+C        APPLY THE TRANSFORMATION TO S AND REDUCE THE SPIKE IN W.
+C
+         L = JJ
+         DO 110 I = J, M
+            TEMP = COS*S(L) + SIN*W(I)
+            W(I) = -SIN*S(L) + COS*W(I)
+            S(L) = TEMP
+            L = L + 1
+  110       CONTINUE
+C
+C        STORE THE INFORMATION NECESSARY TO RECOVER THE
+C        GIVENS ROTATION.
+C
+         W(J) = TAU
+  120    CONTINUE
+C
+C        TEST FOR ZERO DIAGONAL ELEMENTS IN THE OUTPUT S.
+C
+         IF (S(JJ) .EQ. ZERO) SING = .TRUE.
+         JJ = JJ + (M - J + 1)
+  130    CONTINUE
+  140 CONTINUE
+C
+C     MOVE W BACK INTO THE LAST COLUMN OF THE OUTPUT S.
+C
+      L = JJ
+      DO 150 I = N, M
+         S(L) = W(I)
+         L = L + 1
+  150    CONTINUE
+      IF (S(JJ) .EQ. ZERO) SING = .TRUE.
+      RETURN
+C
+C     LAST CARD OF SUBROUTINE R1UPDT.
+C
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/chcore.f
@@ -0,0 +1,294 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+*     File  CHSUBS FORTRAN
+*
+*     CHCORE   CHFD     CHKGRD   CHKJAC
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE CHCORE( DEBUG, DONE, FIRST, EPSA, EPSR, FX, X,
+     $                   INFORM, ITER, ITMAX,
+     $                   CDEST, FDEST, SDEST, ERRBND, F1,
+     $                   F2, H, HOPT, HPHI )
+
+      IMPLICIT           DOUBLE PRECISION (A-H,O-Z)
+      LOGICAL            DEBUG, DONE, FIRST
+
+************************************************************************
+*  CHCORE  implements algorithm  FD, the method described in
+*  Gill, P.E., Murray, W., Saunders, M.A., and Wright, M. H.,
+*  Computing Forward-Difference Intervals for Numerical Optimization,
+*  Siam Journal on Scientific and Statistical Computing, vol. 4,
+*  pp. 310-321, June 1983.
+*
+*  The procedure is based on finding an interval (HPHI) that
+*  produces an acceptable estimate of the second derivative, and
+*  then using that estimate to compute an interval that should
+*  produce a reasonable forward-difference approximation.
+*
+*  One-sided difference estimates are used to ensure feasibility with
+*  respect to an upper or lower bound on X.  If X is close to an upper
+*  bound, the trial intervals will be negative.  The final interval is
+*  always positive.
+*
+*  CHCORE has been designed to use a reverse communication
+*  control structure, i.e., all evaluations of the function occur
+*  outside this routine.  The calling routine repeatedly calls  CHCORE
+*  after computing the indicated function values.
+*
+*  CHCORE  is similar to subroutine FDCORE described in Report
+*  SOL 83-6, Documentation of FDCORE and FDCALC, by P.E. Gill,
+*  W. Murray,  M.A. Saunders, and M.H. Wright, Department of
+*  Operations Research,  Stanford University, Stanford, California
+*  94305, June 1983.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Based on Fortran 66 Version 2.1 of  FDCORE  written June 1983.
+*  Fortran 77 Version written 25-May-1985.
+*  This version of  CHCORE  dated  11-February-1986.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+
+      LOGICAL            CE1BIG, CE2BIG, TE2BIG, OVERFL
+      SAVE               CDSAVE, FDSAVE, HSAVE, OLDH, RHO, SDSAVE
+      SAVE               CE1BIG, CE2BIG, TE2BIG
+      EXTERNAL           DDIV
+      INTRINSIC          ABS   , MAX   , MIN  , SQRT
+
+      PARAMETER         (BNDLO  =1.0D-3, BNDUP  =1.0D-1                )
+
+      PARAMETER         (ZERO   =0.0D+0, SIXTH  =1.6D-1, FOURTH =2.5D-1)
+      PARAMETER         (HALF   =5.0D-1, ONE    =1.0D+0, TWO    =2.0D+0)
+      PARAMETER         (THREE  =3.0D+0, FOUR   =4.0D+0, TEN    =1.0D+1)
+
+*     ------------------------------------------------------------------
+*     Explanation of local variables...
+*
+*     BNDLO, BNDUP, and RHO control the logic of the routine.
+*     BNDLO and BNDUP are the lower and upper bounds that define an
+*     acceptable value of the bound on the relative condition error in
+*     the second derivative estimate.
+*
+*     The scalar RHO is the factor by which the interval is multiplied
+*     or divided, and also the multiple of the well-scaled interval
+*     that is used as the initial trial interval.
+*
+*     All these values are discussed in the documentation.
+*     ------------------------------------------------------------------
+
+      ITER  = ITER + 1
+
+*     Compute the forward-,  backward-,  central-  and second-order
+*     difference estimates.
+
+      FDEST  = DDIV  ( F1 - FX,     H, OVERFL )
+      FDEST2 = DDIV  ( F2 - FX, TWO*H, OVERFL )
+
+      OLDCD = CDEST
+      CDEST = DDIV  ( FOUR*F1 - THREE*FX - F2, TWO*H, OVERFL )
+
+      OLDSD = SDEST
+      SDEST = DDIV  ( FX      - TWO*F1   + F2, H*H  , OVERFL )
+
+*     Compute  FDCERR  and  SDCERR,  bounds on the relative condition
+*     errors in the first and second derivative estimates.
+
+      AFDMIN = MIN( ABS( FDEST ), ABS( FDEST2 ) )
+      FDCERR = DDIV  ( EPSA, HALF*ABS( H )*AFDMIN, OVERFL )
+      SDCERR = DDIV  ( EPSA, FOURTH*ABS( SDEST )*H*H, OVERFL )
+
+      IF (DEBUG)
+     $   WRITE (NOUT, 9000) ITER  , FX   , H,
+     $                      F1    , FDEST,
+     $                      F2    , FDEST2,
+     $                      CDEST , SDEST,
+     $                      FDCERR, SDCERR
+
+*     ==================================================================
+*     Select the correct case.
+*     ==================================================================
+      IF (FIRST) THEN
+*        ---------------------------------------------------------------
+*        First time through.
+*        Check whether SDCERR lies in the acceptable range.
+*        ------------------------------------------------------------
+         FIRST  = .FALSE.
+         DONE   = SDCERR .GE. BNDLO  .AND.  SDCERR .LE. BNDUP
+         TE2BIG = SDCERR .LT. BNDLO
+         CE2BIG = SDCERR .GT. BNDUP
+         CE1BIG = FDCERR .GT. BNDUP
+
+         IF (.NOT. CE1BIG) THEN
+            HSAVE  = H
+            FDSAVE = FDEST
+            CDSAVE = CDEST
+            SDSAVE = SDEST
+         END IF
+
+         RHO  = EPSR**(-SIXTH)/FOUR
+         IF (TE2BIG) THEN
+
+*           The truncation error may be too big  (same as saying
+*           SDCERR is too small).  Decrease the trial interval.
+
+            RHO    = TEN*RHO
+            OLDH   = H
+            H      = H / RHO
+         ELSE IF (CE2BIG) THEN
+
+*           SDCERR is too large.  Increase the trial interval.
+
+            OLDH   = H
+            H      = H*RHO
+         END IF
+      ELSE IF (CE2BIG) THEN
+*        ---------------------------------------------------------------
+*        During the last iteration,  the trial interval was
+*        increased in order to decrease SDCERR.
+*        ---------------------------------------------------------------
+         IF (CE1BIG  .AND.  FDCERR .LE. BNDUP) THEN
+            CE1BIG = .FALSE.
+            HSAVE  = H
+            FDSAVE = FDEST
+            CDSAVE = CDEST
+            SDSAVE = SDEST
+         END IF
+
+*        If SDCERR is small enough, accept H.  Otherwise,
+*        increase H again.
+
+         DONE   = SDCERR .LE. BNDUP
+         IF (.NOT. DONE) THEN
+            OLDH   = H
+            H      = H*RHO
+         END IF
+      ELSE IF (TE2BIG) THEN
+*        ---------------------------------------------------------------
+*        During the last iteration,  the interval was decreased in order
+*        to reduce the truncation error.
+*        ---------------------------------------------------------------
+         DONE   = SDCERR .GT. BNDUP
+         IF (DONE) THEN
+
+*           SDCERR has jumped from being too small to being too
+*           large.  Accept the previous value of H.
+
+            H     = OLDH
+            SDEST = OLDSD
+            CDEST = OLDCD
+         ELSE
+
+*           Test whether FDCERR is sufficiently small.
+
+            IF (FDCERR .LE. BNDUP) THEN
+               CE1BIG = .FALSE.
+               HSAVE  = H
+               FDSAVE = FDEST
+               CDSAVE = CDEST
+               SDSAVE = SDEST
+            END IF
+
+*           Check whether SDCERR is in range.
+
+            DONE  = SDCERR .GE. BNDLO
+
+            IF (.NOT. DONE) THEN
+
+*              SDCERR is still too small, decrease H again.
+
+               OLDH = H
+               H    = H / RHO
+            END IF
+         END IF
+
+      END IF
+
+*     ==================================================================
+*     We have either finished or have a new estimate of H.
+*     ==================================================================
+      IF (DONE) THEN
+
+*        Sufficiently good second-derivative estimate found.
+*        Compute the optimal interval.
+
+         HPHI   = ABS( H )
+         HOPT   = TWO * SQRT( EPSA ) / SQRT( ABS( SDEST ) )
+
+*        ERR1 is the error bound on the forward-difference estimate
+*        with the final value of H.  ERR2 is the difference of FDEST
+*        and the central-difference estimate with HPHI.
+
+         ERR1   = HOPT*ABS( SDEST )
+         ERR2   = ABS( FDEST - CDEST )
+         ERRBND = MAX( ERR1, ERR2 )
+
+*        Set INFORM = 4  if the forward- and central-difference
+*        estimates are not close.
+
+         INFORM = 0
+         IF (ERRBND .GT. HALF*ABS( FDEST )) INFORM = 4
+      ELSE
+*        ---------------------------------------------------------------
+*        Check whether the maximum number of iterations has been
+*        exceeded.  If not, exit.
+*        ---------------------------------------------------------------
+         DONE = ITER .GE. ITMAX
+         IF (DONE) THEN
+            IF (CE1BIG) THEN
+
+*              FDCERR was never small.  Probably a constant function.
+
+               INFORM = 1
+               HPHI   = HOPT
+               FDEST  = ZERO
+               CDEST  = ZERO
+               SDEST  = ZERO
+               ERRBND = ZERO
+            ELSE IF (CE2BIG) THEN
+
+*              FDCERR was small,  but SDCERR was never small.
+*              Probably a linear or odd function.
+
+               INFORM = 2
+               HPHI   = ABS( HSAVE )
+               HOPT   = HPHI
+               FDEST  = FDSAVE
+               CDEST  = CDSAVE
+               SDEST  = ZERO
+               ERRBND = TWO*EPSA / HOPT
+            ELSE
+
+*              The only remaining case occurs when the second
+*              derivative is changing too rapidly for an adequate
+*              interval to be found (SDCERR remained small even
+*              though H was decreased ITMAX times).
+
+               INFORM = 3
+               HPHI   = ABS( HSAVE )
+               HOPT   = HPHI
+               FDEST  = FDSAVE
+               CDEST  = CDSAVE
+               SDEST  = SDSAVE
+               ERRBND = HOPT*ABS( SDEST )/TWO + TWO*EPSA/HOPT
+            END IF
+         END IF
+      END IF
+
+      IF (DEBUG) THEN
+         WRITE (NOUT, 9001) CE1BIG, CE2BIG, TE2BIG
+         IF (DONE)
+     $      WRITE (NOUT, 9002) INFORM, HOPT, ERRBND
+      END IF
+
+      RETURN
+
+ 9000 FORMAT(/ ' //CHCORE//  ITN ', I3,
+     $                             ' FX     H      ', 5X, 1P2D16.6
+     $       / ' //CHCORE//  F1      FDEST         ', 5X, 1P2D16.6
+     $       / ' //CHCORE//  F2      FDEST2        ', 5X, 1P2D16.6
+     $       / ' //CHCORE//  CDEST   SDEST         ', 5X, 1P2D16.6
+     $       / ' //CHCORE//  FDCERR  SDCERR        ', 5X, 1P2D16.6)
+ 9001 FORMAT(  ' //CHCORE//  CE1BIG  CE2BIG  TE2BIG', 5X, 3L2     )
+ 9002 FORMAT(  ' //CHCORE//  INFORM  HOPT    ERRBND', I5, 1P2D16.6)
+
+*     End of  CHCORE.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/chfd.f
@@ -0,0 +1,399 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE CHFD  ( INFORM, MSGLVL, LVLDER,
+     $                   N, NCNLN, NROWJ, NROWUJ,
+     $                   BIGBND, EPSRF, FDNORM, OBJF,
+     $                   OBJFUN, CONFUN, NEEDC,
+     $                   BL, BU, C, C1, C2, CJAC, UJAC,
+     $                   GRAD, UGRAD, HFORWD, HCNTRL,
+     $                   X, Y, W, LENW )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      INTEGER            NEEDC(*)
+      DOUBLE PRECISION   BL(N), BU(N)
+      DOUBLE PRECISION   C(*), C1(*), C2(*),
+     $                   CJAC(NROWJ,*), UJAC(NROWUJ,*)
+      DOUBLE PRECISION   GRAD(N), UGRAD(N)
+      DOUBLE PRECISION   HFORWD(*), HCNTRL(*)
+      DOUBLE PRECISION   X(N), Y(N), W(LENW)
+      EXTERNAL           OBJFUN, CONFUN
+
+************************************************************************
+*  CHFD    computes difference intervals for the missing gradients of
+*  F(x) and c(x).  Intervals are computed using a procedure that usually
+*  requires about two function evaluations if the function is well
+*  scaled.  Central-difference gradients are obtained as a by-product
+*  of the algorithm.
+*
+*  On entry...
+*     OBJF and C contain the problem functions at the point X.
+*     An element of CJAC or GRAD not equal to RDUMMY signifies a known
+*     gradient value.  Such values are not estimated by differencing.
+*     UJAC and UGRAD have dummy elements in the same positions as
+*     CJAC and UGRAD.
+*
+*  On exit...
+*     CJAC and GRAD contain central-difference derivative estimates.
+*     Elements of UJAC and UGRAD are unaltered except for those
+*     corresponding to constant derivatives, which are given the same
+*     values as CJAC or GRAD.
+*
+*  Systems Optimization Laboratory, Department of Operations Research,
+*  Stanford University, Stanford, California 94305
+*  Original version written 28-July-1985.
+*  This version of CHFD   dated 14-July-1986.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9
+
+      COMMON    /SOL4NP/ LVLDIF, NCDIFF, NFDIFF, LFDSET
+
+      LOGICAL            NPDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /NPDEBG/ INPDBG(LDBG), NPDBG
+
+      LOGICAL            DEBUG , DONE  , FIRST , HEADNG, NEEDED
+      INTRINSIC          ABS   , MAX   , MIN   , SQRT
+      EXTERNAL           DNRM2
+      PARAMETER         (RDUMMY =-11111.0              )
+      PARAMETER         (FACTOR =0.97D+0               )
+      PARAMETER         (ZERO   =0.0D+0, HALF   =0.5D+0, ONE   =1.0D+0)
+      PARAMETER         (TWO    =2.0D+0, FOUR   =4.0D+0, TEN   =1.0D+1)
+
+      INFORM = 0
+      NEEDED = LVLDER .EQ. 0  .OR.  LVLDER .EQ. 2
+     $                        .OR.  LVLDER .EQ. 1  .AND.  NCNLN .GT. 0
+      IF (.NOT. NEEDED) RETURN
+
+      DEBUG  = NPDBG  .AND.  INPDBG(5) .GT. 0
+      IF (LFDSET .EQ. 0) THEN
+         IF (MSGLVL .GT. 0) WRITE (NOUT, 1000)
+
+         NSTATE = 0
+         ITMAX  = 3
+         MODE   = 0
+
+         NCCNST = 0
+         NFCNST = 0
+         HEADNG = .TRUE.
+
+         FDNORM = ZERO
+
+*        ===============================================================
+*        For each column of the Jacobian augmented by the transpose of
+*        the objective gradient, rows IROW1 thru IROW2 are searched for
+*        missing elements.
+*        ===============================================================
+         IROW1  = 1
+         IROW2  = NCNLN + 1
+         IF (LVLDER .EQ. 1) IROW2 = NCNLN
+         IF (LVLDER .EQ. 2) IROW1 = NCNLN + 1
+
+         BIGLOW = - BIGBND
+         BIGUPP =   BIGBND
+
+         IF (NCNLN  .GT. 0)
+     $      CALL ILOAD ( NCNLN, (0), NEEDC, 1 )
+
+         DO 600 J = 1, N
+            XJ     = X(J)
+            NFOUND = 0
+            SUMSD  = ZERO
+            SUMEPS = ZERO
+            HFD    = ZERO
+            HCD    = ZERO
+            HMAX   = ZERO
+            HMIN   = ONE / EPSPT3
+            ERRMAX = ZERO
+            ERRMIN = ZERO
+
+            STEPBL = BIGLOW
+            STEPBU = BIGUPP
+            IF (BL(J) .GT. BIGLOW) STEPBL = BL(J) - XJ
+            IF (BU(J) .LT. BIGUPP) STEPBU = BU(J) - XJ
+
+            SIGNH  = ONE
+            IF (HALF*(STEPBL + STEPBU) .LT. ZERO) SIGNH =  - ONE
+
+            DO 500 I = IROW1, IROW2
+
+               IF (I .LE. NCNLN) THEN
+                  TEST = UJAC(I,J)
+               ELSE
+                  TEST = UGRAD(J)
+               END IF
+
+               IF (TEST .EQ. RDUMMY) THEN
+*                 ======================================================
+*                 Get the difference interval for this component.
+*                 ======================================================
+                  NFOUND = NFOUND + 1
+
+                  IF (I .LE. NCNLN) THEN
+                     NEEDC(I) = 1
+                     FX       = C(I)
+                     EPSA     = EPSRF*(ONE + ABS( C(I) ))
+                  ELSE
+                     FX       = OBJF
+                     EPSA     = EPSRF*(ONE + ABS( FX ))
+                  END IF
+
+*                 ------------------------------------------------------
+*                 Find a finite-difference interval by iteration.
+*                 ------------------------------------------------------
+                  ITER   = 0
+                  HOPT   = TWO*(ONE + ABS( XJ ))*SQRT( EPSRF )
+                  H      = SIGNH*TEN*HOPT
+                  CDEST  = ZERO
+                  SDEST  = ZERO
+                  FIRST  = .TRUE.
+
+*+                REPEAT
+  400                X(J)  = XJ + H
+                     IF (I .LE. NCNLN) THEN
+                        CALL CONFUN( MODE, NCNLN, N, NROWUJ,
+     $                               NEEDC, X, C1, UJAC, NSTATE )
+                        IF (MODE .LT. 0) GO TO 9999
+                        F1 = C1(I)
+                     ELSE
+                        CALL OBJFUN( MODE, N, X, F1, UGRAD, NSTATE )
+                        IF (MODE .LT. 0) GO TO 9999
+                     END IF
+
+                     X(J)  = XJ + H + H
+                    IF (I .LE. NCNLN) THEN
+                       CALL CONFUN( MODE, NCNLN, N, NROWUJ,
+     $                              NEEDC, X, C1, UJAC, NSTATE )
+                        IF (MODE .LT. 0) GO TO 9999
+                        F2 = C1(I)
+                     ELSE
+                        CALL OBJFUN( MODE, N, X, F2, UGRAD, NSTATE )
+                        IF (MODE .LT. 0) GO TO 9999
+                     END IF
+
+                     CALL CHCORE( DEBUG, DONE, FIRST, EPSA, EPSRF,FX,XJ,
+     $                            INFO, ITER, ITMAX,
+     $                            CDEST, FDEST, SDEST, ERRBND, F1,
+     $                            F2, H, HOPT, HPHI )
+
+*+                UNTIL     DONE
+                  IF (.NOT. DONE) GO TO 400
+
+                  IF (I .LE. NCNLN) THEN
+                     CJAC(I,J) = CDEST
+                     IF (INFO .EQ. 1  .OR.  INFO .EQ. 2) THEN
+                        NCCNST    =   NCCNST + 1
+                        NCDIFF    =   NCDIFF - 1
+                        UJAC(I,J) = - RDUMMY
+                     END IF
+                  ELSE
+                     GRAD(J)   = CDEST
+                     IF (INFO .EQ. 1  .OR.  INFO .EQ. 2) THEN
+                        NFCNST    =   NFCNST + 1
+                        NFDIFF    =   NFDIFF - 1
+                        UGRAD(J)  = - RDUMMY
+                     END IF
+                  END IF
+
+                  SUMSD  = SUMSD  + ABS( SDEST )
+                  SUMEPS = SUMEPS +      EPSA
+                  IF (HOPT .GT. HMAX) THEN
+                     HMAX   = HOPT
+                     ERRMAX = ERRBND
+                  END IF
+                  IF (HOPT .LT. HMIN) THEN
+                     HMIN   = HOPT
+                     ERRMIN = ERRBND
+                  END IF
+
+                  IF (INFO .EQ. 0) HCD  = MAX ( HCD, HPHI )
+               END IF
+  500       CONTINUE
+
+            IF (NFOUND .GT. 0) THEN
+               IF (HMIN .GT. HMAX) THEN
+                  HMIN   = HMAX
+                  ERRMIN = ERRMAX
+               END IF
+
+               IF      (FOUR*SUMEPS .LT. HMIN*HMIN*SUMSD) THEN
+                  HFD    = HMIN
+                  ERRMAX = ERRMIN
+               ELSE IF (FOUR*SUMEPS .GT. HMAX*HMAX*SUMSD) THEN
+                  HFD    = HMAX
+               ELSE
+                  HFD    = TWO*SQRT( SUMEPS / SUMSD )
+                  ERRMAX = TWO*SQRT( SUMEPS * SUMSD )
+               END IF
+
+               IF (HCD .EQ. ZERO) HCD = TEN*HFD
+
+               IF (MSGLVL .GT. 0) THEN
+                  IF (HEADNG) WRITE (NOUT, 1100)
+                  WRITE (NOUT, 1200) J, XJ, HFD, HCD, ERRMAX
+                  HEADNG = .FALSE.
+               END IF
+            END IF
+
+            FDNORM    = MAX (FDNORM, HFD)
+            HFORWD(J) = HFD / (ONE + ABS(XJ))
+            HCNTRL(J) = HCD / (ONE + ABS(XJ))
+            X(J)      = XJ
+  600    CONTINUE
+
+         IF (NCCNST + NFCNST .GT. 0) THEN
+
+*           Check that the constants have been set properly by
+*           evaluating the gradients at a strange (but feasible) point.
+
+            D      =   ONE / N
+
+            DO 710 J = 1, N
+               XJ     =   X(J)
+               STEPBL = - ONE
+               STEPBU =   ONE
+               IF (BL(J) .GT. BIGLOW)
+     $            STEPBL = MAX( STEPBL, BL(J) - XJ )
+               IF (BU(J) .LT. BIGUPP  .AND.  BU(J) .GT. BL(J))
+     $            STEPBU = MIN( STEPBU, BU(J) - XJ )
+
+               IF (HALF*(STEPBL + STEPBU) .LT. ZERO) THEN
+                  Y(J) = XJ + D*STEPBL
+               ELSE
+                  Y(J) = XJ + D*STEPBU
+               END IF
+
+               D = FACTOR*D
+  710       CONTINUE
+
+            IF (NCNLN .GT. 0) THEN
+               CALL ILOAD ( NCNLN, (1), NEEDC, 1 )
+               CALL CONFUN( MODE, NCNLN, N, NROWUJ,
+     $                      NEEDC, Y, C2, UJAC, NSTATE )
+               IF (MODE .LT. 0) GO TO 9999
+            END IF
+
+            CALL OBJFUN( MODE, N, Y, OBJF2, UGRAD, NSTATE )
+            IF (MODE .LT. 0) GO TO 9999
+
+*           ------------------------------------------------------------
+*           Loop over each of the components of  x.
+*           ------------------------------------------------------------
+            DO 800 J = 1, N
+               YJ     = Y(J)
+               DX     = HALF*(X(J) - YJ)
+               Y(J)   = YJ + DX
+
+               IF (NCNLN .GT. 0) THEN
+                  NFOUND = 0
+                  DO 720 I = 1, NCNLN
+                     IF (UJAC(I,J) .EQ. - RDUMMY) THEN
+                        NEEDC(I) = 1
+                        NFOUND   = NFOUND + 1
+                     ELSE
+                        NEEDC(I) = 0
+                     END IF
+  720             CONTINUE
+
+                  IF (NFOUND .GT. 0) THEN
+                     CALL CONFUN( MODE, NCNLN, N, NROWUJ,
+     $                            NEEDC, Y, C1, UJAC, NSTATE )
+                     IF (MODE .LT. 0) GO TO 9999
+
+                     DO 730 I = 1, NCNLN
+                        IF (NEEDC(I) .EQ. 1) THEN
+                           CJDIFF = ( C1(I) -  C2(I) ) / DX
+                           IF (CJDIFF .EQ. CJAC(I,J)) THEN
+                              UJAC(I,J) = CJDIFF
+                           ELSE
+                              UJAC(I,J) = RDUMMY
+                              NCCNST    = NCCNST - 1
+                              NCDIFF    = NCDIFF + 1
+                           END IF
+                        END IF
+  730                CONTINUE
+                  END IF
+               END IF
+
+*              Now check the objective gradient component.
+
+               IF (UGRAD(J) .EQ. - RDUMMY) THEN
+
+                  CALL OBJFUN( MODE, N, Y, F1, UGRAD, NSTATE )
+                  IF (MODE .LT. 0) GO TO 9999
+
+                  GDIFF = (F1 - OBJF2)/DX
+                  IF (GDIFF .EQ. GRAD(J)) THEN
+                     UGRAD(J) = GDIFF
+                  ELSE
+                     UGRAD(J) = RDUMMY
+                     NFDIFF   = NFDIFF + 1
+                     NFCNST   = NFCNST - 1
+                  END IF
+               END IF
+
+               Y(J)  = YJ
+  800       CONTINUE
+
+            IF (MSGLVL .GT. 0) THEN
+               IF (LVLDER .LT. 2  .AND.  NCCNST .GT. 0)
+     $            WRITE (NOUT, 1300) NCCNST
+               IF (LVLDER .NE. 1  .AND.  NFCNST .GT. 0)
+     $            WRITE (NOUT, 1400) NFCNST
+            END IF
+
+            IF (NCDIFF .EQ. 0  .AND.  LVLDER .LT. 2) THEN
+               IF (LVLDER .EQ. 0) LVLDER = 2
+               IF (LVLDER .EQ. 1) LVLDER = 3
+               IF (MSGLVL .GT. 0) WRITE (NOUT, 1500) LVLDER
+            END IF
+
+            IF (NFDIFF .EQ. 0  .AND.  LVLDER .NE. 1) THEN
+               IF (LVLDER .EQ. 0) LVLDER = 1
+               IF (LVLDER .EQ. 2) LVLDER = 3
+               IF (MSGLVL .GT. 0) WRITE (NOUT, 1600) LVLDER
+            END IF
+         END IF
+      ELSE IF (LFDSET .EQ. 2) THEN
+
+*        The user has supplied HFORWD and HCNTRL.
+*        Check for wild values.
+
+         DO 900 J = 1, N
+            IF (HFORWD(J) .LE. ZERO) THEN
+               WRITE (NOUT, 2000) J, HFORWD(J), EPSPT5
+               HFORWD(J) = EPSPT5
+            END IF
+  900    CONTINUE
+         DO 910 J = 1, N
+            IF (HCNTRL(J) .LE. ZERO) THEN
+               WRITE (NOUT, 2100) J, HCNTRL(J), EPSPT3
+               HCNTRL(J) = EPSPT3
+            END IF
+  910    CONTINUE
+      END IF
+
+      RETURN
+
+ 9999 INFORM = MODE
+      RETURN
+
+ 1000 FORMAT(//' Computation of the finite-difference intervals'
+     $       / ' ----------------------------------------------' )
+ 1100 FORMAT(//'    J      X(J)   Forward DX(J)   Central DX(J) ',
+     $         '     Error est.' /)
+ 1200 FORMAT(  I5, 1PE10.2, 1PE16.6, 1P2E16.6 )
+ 1300 FORMAT(/ I5,  '  constant constraint gradient elements assigned.')
+ 1400 FORMAT(/ I5,  '  constant  objective gradient elements assigned.')
+ 1500 FORMAT(//' All missing Jacobian elements are constants.  ',
+     $         ' Derivative level increased to ', I4 )
+ 1600 FORMAT(//' All missing objective gradients are constants.  ',
+     $         ' Derivative level increased to ', I4 )
+ 2000 FORMAT(' XXX  ', I4,'-th difference interval ',         1PE10.2,
+     $       ' replaced by ', 1PE10.2 )
+ 2100 FORMAT(' XXX  ', I4,'-th central-difference interval ', 1PE10.2,
+     $       ' replaced by ', 1PE10.2 )
+
+*     End of  CHFD  .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/chkgrd.f
@@ -0,0 +1,293 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE CHKGRD( INFORM, MSGLVL, N,
+     $                   BIGBND, EPSRF, OKTOL, FDCHK, OBJF, XNORM,
+     $                   OBJFUN,
+     $                   BL, BU, GRAD, UGRAD, DX, X, Y, W, LENW )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+
+      DOUBLE PRECISION   BL(N), BU(N), GRAD(N), UGRAD(N), DX(N)
+      DOUBLE PRECISION   X(N), Y(N), W(LENW)
+      EXTERNAL           OBJFUN
+
+************************************************************************
+*  CHKGRD  checks if the gradients of the objective function have
+*  been coded correctly.
+*
+*  On input,  the value of the objective function at the point X is
+*  stored in OBJF.  The corresponding gradient is stored in UGRAD.
+*  If any gradient component has not been specified,  it will have a
+*  dummy value.  Missing values are not checked.
+*
+*  A cheap test is first undertaken by calculating the directional
+*  derivative using two different methods.  If this proves satisfactory
+*  and no further information is desired, CHKGRD is terminated.
+*  Otherwise, the routine CHCORE is called to give optimal step-sizes
+*  and a forward-difference approximation to each component
+*  of the gradient for which a test is deemed necessary,
+*  either by the program or the user.
+*
+*  Other inputs:
+*
+*        X         The n-dimensional point at which the
+*                  gradient is to be verified.
+*        EPSRF     The positive bound on the relative error
+*                  associated with computing the function at
+*                  the point x.
+*        OKTOL     The desired relative accuracy which the
+*                  components of the gradient should satisfy.
+*
+*  LVRFYC has the following meaning...
+*
+*    -1        do not perform any check.
+*     0        do the cheap test only.
+*     1 or 3   do both cheap and full test.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Original version written  19-May-1985.
+*  This version of CHKGRD  dated  12-July-1986.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9
+
+      COMMON    /SOL5NP/ LVRFYC, JVERFY(4)
+
+      LOGICAL            NPDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /NPDEBG/ INPDBG(LDBG), NPDBG
+
+      LOGICAL            CONST , DEBUG , DONE  , FIRST , HEADNG
+      LOGICAL            NEEDED, OK
+      CHARACTER*4        KEY   , LBAD  , LGOOD
+      CHARACTER*18       RESULT(0:4)
+      INTRINSIC          ABS   , MAX   , MIN   , SQRT
+      EXTERNAL           DDOT
+      PARAMETER         (RDUMMY =-11111.0              )
+      PARAMETER         (ZERO   =0.0D+0, HALF  = 0.5D+0, POINT9 =0.9D+0)
+      PARAMETER         (ONE    =1.0D+0, TWO   = 2.0D+0, TEN    =1.0D+1)
+      PARAMETER         (LBAD   ='BAD?', LGOOD = '  OK')
+      DATA               RESULT
+     $                 / '                 ', 'Constant?      ',
+     $                   'Linear or odd?   ', 'Too nonlinear?',
+     $                   'Small derivative?'                   /
+
+      INFORM = 0
+      NEEDED = LVRFYC .EQ. 0  .OR.  LVRFYC .EQ. 1  .OR.  LVRFYC .EQ. 3
+      IF (.NOT. NEEDED) RETURN
+
+      IF (MSGLVL .GT. 0) WRITE (NOUT, 1000)
+      DEBUG  = NPDBG  .AND.  INPDBG(5) .GT. 0
+      NSTATE = 0
+
+      BIGLOW = - BIGBND
+      BIGUPP =   BIGBND
+
+*     ==================================================================
+*     Perform the cheap test.
+*     ==================================================================
+      H =     (ONE + XNORM)*FDCHK
+
+      DXJ  = ONE / N
+      DO 110 J = 1, N
+         DX(J) =   DXJ
+         DXJ   = - DXJ*POINT9
+  110 CONTINUE
+
+*     ------------------------------------------------------------------
+*     Do not perturb X(J) if the  J-th  element is missing.
+*     Compute the directional derivative.
+*     ------------------------------------------------------------------
+      NCHECK = 0
+      DO 120 J = 1, N
+         IF (GRAD(J) .EQ. RDUMMY) THEN
+            DX(J) = ZERO
+         ELSE
+            NCHECK = NCHECK + 1
+
+            XJ     =   X(J)
+            STEPBL = - ONE
+            STEPBU =   ONE
+            IF (BL(J) .GT. BIGLOW)
+     $         STEPBL = MAX( STEPBL, BL(J) - XJ )
+            IF (BU(J) .LT. BIGUPP  .AND.  BU(J) .GT. BL(J))
+     $         STEPBU = MIN( STEPBU, BU(J) - XJ )
+
+            IF (HALF*(STEPBL + STEPBU) .LT. ZERO) THEN
+               DX(J) = DX(J)*STEPBL
+            ELSE
+               DX(J) = DX(J)*STEPBU
+            END IF
+         END IF
+  120 CONTINUE
+
+      IF (NCHECK .EQ. 0) THEN
+         WRITE (NOUT, 3500)
+         RETURN
+      END IF
+      GDX    = DDOT  ( N, UGRAD, 1, DX, 1 )
+
+*     ------------------------------------------------------------------
+*     Make forward-difference approximation along  p.
+*     ------------------------------------------------------------------
+      CALL DCOPY ( N,     X, 1, Y, 1 )
+      CALL DAXPY ( N, H, DX, 1, Y, 1 )
+
+      MODE   = 0
+      CALL OBJFUN( MODE, N, Y, OBJF1, UGRAD, NSTATE )
+      IF (MODE .LT. 0) GO TO 999
+
+      GDIFF =    ( OBJF1 - OBJF) / H
+      ERROR = ABS( GDIFF - GDX ) / (ONE + ABS( GDX ))
+
+      OK    = ERROR .LE. OKTOL
+      IF (OK) THEN
+         IF (MSGLVL .GT. 0) WRITE (NOUT, 1100)
+      ELSE
+         WRITE (NOUT, 1200)
+         IF (ERROR .GE. ONE) INFORM = 1
+      END IF
+
+      IF (MSGLVL .GT. 0) WRITE (NOUT, 1300) GDX, GDIFF
+
+*     ==================================================================
+*     Component-wise check.
+*     ==================================================================
+      IF (LVRFYC .EQ. 1  .OR.  LVRFYC .EQ. 3) THEN
+         HEADNG = .TRUE.
+         ITMAX  = 3
+         NWRONG = 0
+         NGOOD  = 0
+         JMAX   = 0
+         EMAX   = ZERO
+         NCHECK = 0
+         J1     = JVERFY(1)
+         J2     = JVERFY(2)
+
+*        ---------------------------------------------------------------
+*        Loop over each of the components of  x.
+*        ---------------------------------------------------------------
+         DO 500 J = J1, J2
+
+            IF (GRAD(J) .NE. RDUMMY) THEN
+*              ---------------------------------------------------------
+*              Check this gradient component.
+*              ---------------------------------------------------------
+               NCHECK = NCHECK + 1
+               GJ     = GRAD(J)
+               GSIZE  = ONE + ABS( GJ )
+               XJ     = X(J)
+*              ---------------------------------------------------------
+*              Find a finite-difference interval by iteration.
+*              ---------------------------------------------------------
+               ITER   = 0
+               EPSA   = EPSRF*(ONE + ABS( OBJF ))
+               CDEST  = ZERO
+               SDEST  = ZERO
+               FIRST  = .TRUE.
+
+               STEPBL = BIGLOW
+               STEPBU = BIGUPP
+               IF (BL(J) .GT. BIGLOW) STEPBL = BL(J) - XJ
+               IF (BU(J) .LT. BIGUPP) STEPBU = BU(J) - XJ
+
+               HOPT   = TWO*(ONE + ABS( XJ ))*SQRT( EPSRF )
+               H      = TEN*HOPT
+               IF (HALF*(STEPBL + STEPBU) .LT. ZERO) H =  - H
+
+*+             REPEAT
+  400             X(J)  = XJ + H
+                  CALL OBJFUN( MODE, N, X, F1, UGRAD, NSTATE )
+                  IF (MODE .LT. 0) GO TO 999
+
+                  X(J)  = XJ + H + H
+                  CALL OBJFUN( MODE, N, X, F2, UGRAD, NSTATE )
+                  IF (MODE .LT. 0) GO TO 999
+
+                  CALL CHCORE( DEBUG, DONE, FIRST, EPSA, EPSRF, OBJF,XJ,
+     $                         INFO, ITER, ITMAX,
+     $                         CDEST, FDEST, SDEST, ERRBND, F1,
+     $                         F2, H, HOPT, HPHI )
+
+*+             UNTIL     DONE
+               IF (.NOT. DONE) GO TO 400
+
+*              ---------------------------------------------------------
+*              Exit for this variable.
+*              ---------------------------------------------------------
+               GDIFF = CDEST
+               X(J)  = XJ
+
+               ERROR  = ABS( GDIFF - GJ  ) / GSIZE
+               IF (ERROR .GE. EMAX) THEN
+                  EMAX  = ERROR
+                  JMAX  = J
+               END IF
+
+               OK =  ERROR .LE. OKTOL
+               IF (OK) THEN
+                  KEY    = LGOOD
+                  NGOOD  = NGOOD  + 1
+               ELSE
+                  KEY    = LBAD
+                  NWRONG = NWRONG + 1
+               END IF
+
+*              Zero components are not printed.
+
+               CONST = OK .AND. INFO .EQ. 1 .AND. ABS(GJ) .LT. EPSPT8
+               IF (.NOT. CONST) THEN
+                  IF (HEADNG) WRITE (NOUT, 3000)
+                  IF (OK) THEN
+                     WRITE (NOUT, 3100) J, XJ, HOPT, GJ, GDIFF,
+     $                                  KEY, ITER
+                  ELSE
+                     WRITE (NOUT, 3110) J, XJ, HOPT, GJ, GDIFF,
+     $                                  KEY, ITER, RESULT(INFO)
+                  END IF
+                  HEADNG = .FALSE.
+               END IF
+            END IF
+  500    CONTINUE
+
+*        ===============================================================
+*        Done.
+*        ===============================================================
+         IF (NWRONG .EQ. 0) THEN
+            WRITE (NOUT, 3200) NGOOD , NCHECK, J1    , J2
+         ELSE
+            WRITE (NOUT, 3300) NWRONG, NCHECK, J1    , J2
+         END IF
+         WRITE (NOUT, 3400) EMAX, JMAX
+      END IF
+
+      CALL DCOPY ( N, GRAD, 1, UGRAD, 1 )
+
+      RETURN
+
+  999 INFORM = MODE
+      RETURN
+
+ 1000 FORMAT(/// ' Verification of the objective gradients.'
+     $       /   ' ----------------------------------------' )
+ 1100 FORMAT(/   ' The objective gradients seem to be ok.')
+ 1200 FORMAT(/   ' XXX  The objective gradients seem to be incorrect.')
+ 1300 FORMAT(/   ' Directional derivative of the objective', 1PE18.8/
+     $           ' Difference approximation               ', 1PE18.8 )
+ 3000 FORMAT(// 4X, 'J', 4X, 'X(J)', 5X, 'DX(J)', 11X,
+     $           'G(J)', 9X, '  Difference approxn  Itns' /)
+ 3100 FORMAT(  I5, 1P2E10.2,      1P2E18.8, 2X, A4, I6          )
+ 3110 FORMAT(  I5, 1P2E10.2,      1P2E18.8, 2X, A4, I6, 2X, A18 )
+ 3200 FORMAT(/ I7, '  Objective gradients out of the', I6,
+     $             '  set in cols', I6, '  through', I6,
+     $             '  seem to be ok.')
+ 3300 FORMAT(/   ' XXX  There seem to be', I6,
+     $           '  incorrect objective gradients out of the', I6,
+     $           '  set in cols', I6, '  through', I6 )
+ 3400 FORMAT(/   ' The largest relative error was', 1PE12.2,
+     $           '   in element', I6 /)
+ 3500 FORMAT(/   ' No gradient elements assigned.' )
+
+*     End of  CHKGRD.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/chkjac.f
@@ -0,0 +1,367 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE CHKJAC( INFORM, LVLDER, MSGLVL,
+     $                   NCSET, N, NCNLN, NROWJ, NROWUJ,
+     $                   BIGBND, EPSRF, OKTOL, FDCHK, XNORM,
+     $                   CONFUN, NEEDC,
+     $                   BL, BU, C, C1, CJAC, UJAC, CJDX,
+     $                   DX, ERR, X, Y, W, LENW )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      INTEGER            NEEDC(*)
+      DOUBLE PRECISION   BL(N), BU(N), C(*), C1(*), CJDX(*),
+     $                   CJAC(NROWJ,*), UJAC(NROWUJ,*), ERR(*)
+      DOUBLE PRECISION   DX(N), X(N), Y(N), W(LENW)
+      EXTERNAL           CONFUN
+
+************************************************************************
+*  CHKJAC  checks if the gradients of the constraints have been coded
+*  correctly.
+*
+*  On input,  the values of the constraints at the point X are stored
+*  in C.  Their corresponding gradients are stored in UJAC.  If any
+*  Jacobian component has not been specified,  it will have a dummy
+*  value.  Missing values are not checked.
+*
+*  A cheap test is first undertaken by calculating the directional
+*  derivative using two different methods.  If this proves satisfactory
+*  and no further information is desired, CHKJAC is terminated.
+*  Otherwise, CHCORE is called to give optimal step-sizes and a central-
+*  difference approximation to each component of the Jacobian for which
+*  a test is deemed necessary, either by the program or the user.
+*
+*  LVRFYC has the following meaning...
+*
+*    -1        do not perform any check.
+*     0        do the cheap test only.
+*     2 or 3   do both cheap and full test.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Original version written  19-May-1985.
+*  This version of CHKJAC dated 12-July-1986.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9
+
+      COMMON    /SOL5NP/ LVRFYC, JVERFY(4)
+
+      LOGICAL            NPDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /NPDEBG/ INPDBG(LDBG), NPDBG
+
+      LOGICAL            CONST , DEBUG , DONE  , FIRST , HEADNG
+      LOGICAL            NEEDED, OK
+      CHARACTER*4        KEY   , LBAD  , LGOOD
+      CHARACTER*18       RESULT(0:4)
+      INTRINSIC          ABS   , MAX   , MIN   , SQRT
+      EXTERNAL           DDOT  , IDAMAX
+      PARAMETER         (RDUMMY =-11111.0              )
+      PARAMETER         (ZERO   =0.0D+0, HALF   =0.5D+0, POINT9 =0.9D+0)
+      PARAMETER         (ONE    =1.0D+0, TWO    =2.0D+0, TEN    =1.0D+1)
+      PARAMETER         (LBAD   ='BAD?', LGOOD  ='  OK')
+      DATA               RESULT
+     $                 / '                 ', 'Constant?      ',
+     $                   'Linear or odd?   ', 'Too nonlinear?',
+     $                   'Small derivative?'                   /
+
+      INFORM = 0
+      NEEDED = NCNLN  .GT. 0  .AND.
+     $         LVRFYC .EQ. 0  .OR.   LVRFYC .EQ. 2  .OR.  LVRFYC .EQ. 3
+      IF (.NOT. NEEDED) RETURN
+
+      IF (MSGLVL .GT. 0) WRITE (NOUT, 1000)
+      DEBUG  = NPDBG  .AND.  INPDBG(5) .GT. 0
+      NSTATE = 0
+
+      BIGLOW = - BIGBND
+      BIGUPP =   BIGBND
+
+*     ==================================================================
+*     Perform the cheap test.
+*     ==================================================================
+      H = (ONE + XNORM)*FDCHK
+
+      DXJ  = ONE / N
+      DO 110 J = 1, N
+         DX(J) =   DXJ
+         DXJ   = - DXJ*POINT9
+  110 CONTINUE
+
+*     ------------------------------------------------------------------
+*     Do not perturb  X(J)  if the  J-th  column contains any
+*     unknown elements.  Compute the directional derivative for each
+*     constraint gradient.
+*     ------------------------------------------------------------------
+      NCHECK = 0
+      DO 140 J = 1, N
+         DO 130 I = 1, NCNLN
+            IF (CJAC(I,J) .EQ. RDUMMY) THEN
+               DX(J) = ZERO
+               GO TO 140
+            END IF
+  130    CONTINUE
+         NCHECK = NCHECK + 1
+
+         XJ     =   X(J)
+         STEPBL = - ONE
+         STEPBU =   ONE
+         IF (BL(J) .GT. BIGLOW)
+     $      STEPBL = MAX( STEPBL, BL(J) - XJ )
+         IF (BU(J) .LT. BIGUPP  .AND.  BU(J) .GT. BL(J))
+     $      STEPBU = MIN( STEPBU, BU(J) - XJ )
+
+         IF (HALF*(STEPBL + STEPBU) .LT. ZERO) THEN
+            DX(J) = DX(J)*STEPBL
+         ELSE
+            DX(J) = DX(J)*STEPBU
+         END IF
+  140 CONTINUE
+
+      IF (NCHECK .EQ. 0) THEN
+         WRITE (NOUT, 2300)
+      ELSE
+
+*        Compute  (Jacobian)*DX.
+
+         CALL DLOAD ( NCNLN, ZERO, CJDX, 1 )
+         DO 150 J = 1, N
+            IF (DX(J) .NE. ZERO)
+     $         CALL DAXPY ( NCNLN, DX(J), UJAC(1,J), 1, CJDX, 1 )
+  150    CONTINUE
+
+*        ---------------------------------------------------------------
+*        Make forward-difference approximation along DX.
+*        ---------------------------------------------------------------
+         CALL DCOPY ( N,     X, 1, Y, 1 )
+         CALL DAXPY ( N, H, DX, 1, Y, 1 )
+
+         CALL ILOAD ( NCNLN, (1), NEEDC, 1 )
+
+         MODE   = 0
+         CALL CONFUN( MODE, NCNLN, N, NROWUJ,
+     $                NEEDC, Y, C1, UJAC, NSTATE )
+         IF (MODE .LT. 0) GO TO 999
+
+*        Set  ERR = (C1 - C)/H  - Jacobian*DX.  This should be small.
+
+         DO 170 I = 1, NCNLN
+            ERR(I) = (C1(I) - C(I)) / H  -  CJDX(I)
+  170    CONTINUE
+         IMAX  = IDAMAX( NCNLN, ERR, 1 )
+         EMAX  = ABS( ERR(IMAX) ) / (ONE + ABS( CJDX(IMAX) ))
+
+         IF (EMAX .LE. OKTOL) THEN
+            IF (MSGLVL .GT. 0) WRITE (NOUT, 2000)
+         ELSE
+            WRITE (NOUT, 2100)
+            IF (EMAX .GE. ONE) INFORM = 2
+         END IF
+         IF (MSGLVL .GT. 0) WRITE (NOUT, 2200) EMAX, IMAX
+      END IF
+
+*     ==================================================================
+*     Component-wise check.
+*     ==================================================================
+      IF (LVRFYC .GE. 2) THEN
+         IF (LVLDER .EQ. 3) THEN
+
+*           Recompute the Jacobian to find the non-constant elements.
+
+            DO 280 J = 1, N
+               CALL DLOAD ( NCNLN, RDUMMY, UJAC(1,J), 1 )
+  280       CONTINUE
+
+            CALL ILOAD ( NCNLN, (1), NEEDC, 1 )
+            NSTATE = 0
+            MODE   = 2
+
+            CALL CONFUN( MODE, NCNLN, N, NROWUJ,
+     $                   NEEDC, X, C1, UJAC, NSTATE )
+            IF (MODE .LT. 0) GO TO 999
+
+         END IF
+
+         CALL ILOAD ( NCNLN, (0), NEEDC, 1 )
+
+         ITMAX  =   3
+         NCHECK =   0
+         NWRONG =   0
+         NGOOD  =   0
+         COLMAX = - ONE
+         JCOL   =   0
+         IROW   =   0
+         MODE   =   0
+         J3     =   JVERFY(3)
+         J4     =   JVERFY(4)
+
+*        ---------------------------------------------------------------
+*        Loop over each column.
+*        ---------------------------------------------------------------
+         DO 600 J = J3, J4
+
+            CALL DLOAD ( NCNLN, ZERO, ERR, 1 )
+            HEADNG = .TRUE.
+            XJ     = X(J)
+
+            STEPBL = BIGLOW
+            STEPBU = BIGUPP
+            IF (BL(J) .GT. BIGLOW) STEPBL = BL(J) - XJ
+            IF (BU(J) .LT. BIGUPP) STEPBU = BU(J) - XJ
+
+            SIGNH  = ONE
+            IF (HALF*(STEPBL + STEPBU) .LT. ZERO) SIGNH =  - ONE
+
+            DO 500 I = 1, NCNLN
+               EPSACI   = EPSRF*(ONE + ABS( C(I) ))
+
+               IF (UJAC(I,J) .NE. RDUMMY) THEN
+*                 ------------------------------------------------------
+*                 Check this Jacobian element.
+*                 ------------------------------------------------------
+                  NCHECK   = NCHECK + 1
+                  NEEDC(I) = 1
+
+                  CIJ    = CJAC(I,J)
+                  CJSIZE = ONE + ABS( CIJ )
+*                 ------------------------------------------------------
+*                 Find a finite-difference interval by iteration.
+*                 ------------------------------------------------------
+                  ITER   = 0
+                  HOPT   = TWO*(ONE + ABS( XJ ))*SQRT( EPSRF )
+                  H      = TEN*HOPT*SIGNH
+                  CDEST  = ZERO
+                  SDEST  = ZERO
+                  FIRST  = .TRUE.
+
+*+                REPEAT
+  400                X(J)  = XJ + H
+                     CALL CONFUN( MODE, NCNLN, N, NROWUJ,
+     $                            NEEDC, X, C1, UJAC, NSTATE )
+                     IF (MODE .LT. 0) GO TO 999
+                     F1    = C1(I)
+
+                     X(J)  = XJ + H + H
+                     CALL CONFUN( MODE, NCNLN, N, NROWUJ,
+     $                            NEEDC, X, C1, UJAC, NSTATE )
+                     IF (MODE .LT. 0) GO TO 999
+                     F2    = C1(I)
+
+                     CALL CHCORE( DEBUG,DONE,FIRST,EPSACI,EPSRF,C(I),XJ,
+     $                            INFO, ITER, ITMAX,
+     $                            CDEST, FDEST, SDEST, ERRBND, F1,
+     $                            F2, H, HOPT, HPHI )
+
+*+                UNTIL     DONE
+                  IF (.NOT. DONE) GO TO 400
+
+*                 ------------------------------------------------------
+*                 Exit for this element.
+*                 ------------------------------------------------------
+                  CJDIFF   = CDEST
+                  ERR(I)   = ABS( CJDIFF - CIJ  ) / CJSIZE
+
+                  OK       = ERR(I) .LE. OKTOL
+                  IF (OK) THEN
+                     KEY    = LGOOD
+                     NGOOD  = NGOOD  + 1
+                  ELSE
+                     KEY    = LBAD
+                     NWRONG = NWRONG + 1
+                  END IF
+
+                  CONST = OK .AND. INFO       .EQ. 1
+     $                       .AND. ABS( CIJ ) .LT. EPSPT8
+                  IF (.NOT. CONST) THEN
+                     IF (HEADNG) THEN
+                        WRITE (NOUT, 4000)
+                        IF (OK)
+     $                     WRITE (NOUT, 4100)   J, XJ    , HOPT, I,
+     $                                        CIJ, CJDIFF, KEY , ITER
+                        IF (.NOT. OK)
+     $                     WRITE (NOUT, 4110)   J, XJ    , HOPT, I,
+     $                                        CIJ, CJDIFF, KEY , ITER,
+     $                                        RESULT(INFO)
+                        HEADNG = .FALSE.
+                     ELSE
+                        IF (OK)
+     $                     WRITE (NOUT, 4200)              HOPT, I,
+     $                                        CIJ, CJDIFF, KEY , ITER
+                        IF (.NOT. OK)
+     $                     WRITE (NOUT, 4210)              HOPT, I,
+     $                                        CIJ, CJDIFF, KEY , ITER,
+     $                                        RESULT(INFO)
+                     END IF
+                  END IF
+                  NEEDC(I) = 0
+               END IF
+  500       CONTINUE
+
+*           ------------------------------------------------------------
+*           Finished with this column.
+*           ------------------------------------------------------------
+            IF (.NOT. HEADNG) THEN
+               IMAX = IDAMAX( NCNLN, ERR, 1 )
+               EMAX = ABS( ERR(IMAX) )
+
+               IF (EMAX .GE. COLMAX) THEN
+                  IROW   = IMAX
+                  JCOL   = J
+                  COLMAX = EMAX
+               END IF
+            END IF
+            X(J) = XJ
+
+  600    CONTINUE
+
+         IF (NCHECK .EQ. 0) THEN
+            WRITE (NOUT, 4600) NCSET
+         ELSE
+            IF (NWRONG .EQ. 0) THEN
+               WRITE (NOUT, 4300) NGOOD , NCHECK, J3, J4
+            ELSE
+               WRITE (NOUT, 4400) NWRONG, NCHECK, J3, J4
+            END IF
+            WRITE (NOUT, 4500) COLMAX, IROW, JCOL
+         END IF
+
+      END IF
+
+*     Copy  ( constants + gradients + dummy values )  back into UJAC.
+
+      DO 700 J = 1, N
+         CALL DCOPY ( NCNLN, CJAC(1,J), 1, UJAC(1,J), 1 )
+  700 CONTINUE
+
+      RETURN
+
+  999 INFORM = MODE
+      RETURN
+
+ 1000 FORMAT(/// ' Verification of the constraint gradients.'
+     $       /   ' -----------------------------------------' )
+ 2000 FORMAT(/   ' The Jacobian seems to be ok.')
+ 2100 FORMAT(/   ' XXX  The Jacobian seems to be incorrect.')
+ 2200 FORMAT(/   ' The largest relative error was', 1PE12.2,
+     $           '  in constraint', I5 /)
+ 2300 FORMAT(/   ' Every column contains a constant or',
+     $           ' missing element.')
+ 4000 FORMAT(// ' Column    X(J)     DX(J)    Row   ',
+     $          ' Jacobian Value      Difference Approxn  Itns' )
+ 4100 FORMAT(/ I7,     1P2E10.2, I5, 1P2E18.8, 2X, A4, I6         )
+ 4110 FORMAT(/ I7,     1P2E10.2, I5, 1P2E18.8, 2X, A4, I6, 2X, A18)
+ 4200 FORMAT(  7X, 10X, 1PE10.2, I5, 1P2E18.8, 2X, A4, I6         )
+ 4210 FORMAT(  7X, 10X, 1PE10.2, I5, 1P2E18.8, 2X, A4, I6, 2X, A18)
+ 4300 FORMAT(/ I7, '  Jacobian elements out of the', I6,
+     $             '  set in cols', I6, '  through', I6,
+     $             '  seem to be ok.')
+ 4400 FORMAT(/   ' XXX  There seem to be', I6,
+     $           '  incorrect Jacobian elements out of the', I6,
+     $           '  set in cols', I6, '  through', I6 )
+ 4500 FORMAT(/ ' The largest relative error was', 1PE12.2,
+     $         '  in row', I5, ',  column', I5 /)
+ 4600 FORMAT(  ' All', I6, '   assigned Jacobian elements are',
+     $         ' constant.' )
+
+*     End of  CHKJAC.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/cmalf.f
@@ -0,0 +1,294 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE CMALF ( FIRSTV, HITLOW, ISTATE, INFORM, JADD,
+     $                   N, NROWA, NCLIN, NCTOTL, NUMINF,
+     $                   ALFA, PALFA, ATPHIT, BIGALF, BIGBND, PNORM,
+     $                   ANORM, AP, AX, BL, BU, FEATOL, P, X )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      INTEGER            ISTATE(NCTOTL)
+      DOUBLE PRECISION   ANORM(*), AP(*), AX(*),
+     $                   BL(NCTOTL), BU(NCTOTL), FEATOL(NCTOTL),
+     $                   P(N), X(N)
+      LOGICAL            FIRSTV, HITLOW
+
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9
+
+      LOGICAL            CMDBG
+      INTEGER            LCMDBG
+      PARAMETER         (LCMDBG = 5)
+      COMMON    /CMDEBG/ ICMDBG(LCMDBG), CMDBG
+
+************************************************************************
+*  CMALF   finds a step ALFA such that the point x + ALFA*P reaches one
+*  of the linear constraints (including bounds).  Two possible steps are
+*  defined as follows...
+*
+*  ALFA1   is the maximum step that can be taken without violating
+*          one of the linear constraints that is currently satisfied.
+*  ALFA2   reaches a linear constraint that is currently violated.
+*          Usually this will be the furthest such constraint along P,
+*          but if FIRSTV = .TRUE. it will be the first one along P.
+*          This is used only when the problem has been determined to be
+*          infeasible, and the sum of infeasibilities are being
+*          minimized.  (ALFA2  is not defined if NUMINF = 0.)
+*
+*  ALFA will usually be the minimum of ALFA1 and ALFA2.
+*  ALFA could be negative (since we allow inactive constraints
+*  to be violated by as much as FEATOL).  In such cases, a
+*  third possible step is computed, to find the nearest satisfied
+*  constraint (perturbed by FEATOL) along the direction  - P.
+*  ALFA  will be reset to this step if it is shorter.  This is the
+*  only case for which the final step  ALFA  does not move X exactly
+*  onto a constraint (the one denoted by JADD).
+*
+*  Constraints in the working set are ignored  (ISTATE(j) ge 1).
+*
+*  JADD    denotes which linear constraint is reached.
+*
+*  HITLOW  indicates whether it is the lower or upper bound that
+*          has restricted ALFA.
+*
+*  Values of ISTATE(j)....
+*
+*     - 2         - 1         0           1          2         3
+*  a'x lt bl   a'x gt bu   a'x free   a'x = bl   a'x = bu   bl = bu
+*
+*  The values -2 and -1 do not occur once a feasible point has been
+*  found.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Original Fortran 66 version written  May 1980.
+*  This version of  CMALF  dated  10-June-1986.
+************************************************************************
+      LOGICAL            HLOW1, HLOW2, LASTV, NEGSTP, STEP2
+      INTRINSIC          ABS, MIN
+      PARAMETER        ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+
+      INFORM = 0
+
+*     ------------------------------------------------------------------
+*     First pass -- find steps to perturbed constraints, so that
+*     PALFA1 will be slightly larger than the true step, and
+*     PALFA2 will be slightly smaller than it should be.
+*     In degenerate cases, this strategy gives us some freedom in the
+*     second pass.  The general idea follows that described by P.M.J.
+*     Harris, p.21 of Mathematical Programming 5, 1 (1973), 1--28.
+*     ------------------------------------------------------------------
+
+      NEGSTP = .FALSE.
+      CALL CMALF1( FIRSTV, NEGSTP, BIGALF, BIGBND, PNORM,
+     $             JADD1, JADD2, PALFA1, PALFA2,
+     $             ISTATE, N, NROWA, NCTOTL,
+     $             ANORM, AP, AX, BL, BU, FEATOL, P, X )
+
+      JSAVE1 = JADD1
+      JSAVE2 = JADD2
+
+*     ------------------------------------------------------------------
+*     Second pass -- recompute step-lengths without perturbation.
+*     Amongst constraints that are less than the perturbed steps,
+*     choose the one (of each type) that makes the largest angle
+*     with the search direction.
+*     ------------------------------------------------------------------
+      IF (CMDBG  .AND.  ICMDBG(3) .GT. 0) WRITE (NOUT, 1000)
+      ALFA1  = BIGALF
+      ALFA2  = ZERO
+      IF (FIRSTV) ALFA2 = BIGALF
+
+      APMAX1 = ZERO
+      APMAX2 = ZERO
+      ATP1   = ZERO
+      ATP2   = ZERO
+      HLOW1  = .FALSE.
+      HLOW2  = .FALSE.
+      LASTV  = .NOT. FIRSTV
+
+      DO 400 J = 1, NCTOTL
+         JS = ISTATE(J)
+         IF (JS .LE. 0) THEN
+            IF (J  .LE. N)  THEN
+               ATX    = X(J)
+               ATP    = P(J)
+               ROWNRM = ONE
+            ELSE
+               I      = J - N
+               ATX    = AX(I)
+               ATP    = AP(I)
+               ROWNRM = ANORM(I) + ONE
+            END IF
+
+            IF ( ABS( ATP ) .LE. EPSPT9*ROWNRM*PNORM) THEN
+
+*              This constraint appears to be constant along P.  It is
+*              not used to compute the step.  Give the residual a value
+*              that can be spotted in the debug output.
+
+               RES = - ONE
+            ELSE IF (ATP .LE. ZERO  .AND.  JS .NE. -2) THEN
+*              ---------------------------------------------------------
+*              a'x  is decreasing.
+*              ---------------------------------------------------------
+*              The lower bound is satisfied.  Test for smaller ALFA1.
+
+               ABSATP = - ATP
+               IF (BL(J) .GT. (-BIGBND)) THEN
+                  RES    = ATX - BL(J)
+                  IF (PALFA1*ABSATP .GE. RES  .OR.  J .EQ. JSAVE1) THEN
+                     IF (APMAX1*ROWNRM*PNORM .LT. ABSATP) THEN
+                        APMAX1 = ABSATP / (ROWNRM*PNORM)
+                        ALFA1  = RES / ABSATP
+                        JADD1  = J
+                        ATP1   = ATP
+                        HLOW1  = .TRUE.
+                     END IF
+                  END IF
+               END IF
+
+               IF (JS. EQ. -1)  THEN
+
+*                 The upper bound is violated.  Test for either a bigger
+*                 or smaller ALFA2,  depending on the value of FIRSTV.
+
+                  RES    = ATX - BU(J)
+                  IF (     (FIRSTV  .AND.  PALFA2*ABSATP .GE. RES
+     $                 .OR.  LASTV  .AND.  PALFA2*ABSATP .LE. RES)
+     $                 .OR.  J .EQ.  JSAVE2) THEN
+                     IF (APMAX2*ROWNRM*PNORM .LT. ABSATP) THEN
+                        APMAX2 = ABSATP / (ROWNRM*PNORM)
+                        IF      (ABSATP .GE. ONE          ) THEN
+                           ALFA2 = RES / ABSATP
+                        ELSE IF (RES    .LT. BIGALF*ABSATP) THEN
+                           ALFA2 = RES / ABSATP
+                        ELSE
+                           ALFA2 = BIGALF
+                        END IF
+                        JADD2  = J
+                        ATP2   = ATP
+                        HLOW2  = .FALSE.
+                     END IF
+                  END IF
+               END IF
+            ELSE IF (ATP .GT. ZERO  .AND.  JS .NE.  -1)  THEN
+*              ---------------------------------------------------------
+*              a'x  is increasing and the upper bound is not violated.
+*              ---------------------------------------------------------
+*              Test for smaller ALFA1.
+
+               IF (BU(J) .LT. BIGBND) THEN
+                  RES = BU(J) - ATX
+                  IF (PALFA1*ATP .GE. RES  .OR.  J .EQ. JSAVE1) THEN
+                     IF (APMAX1*ROWNRM*PNORM .LT. ATP) THEN
+                        APMAX1 = ATP / (ROWNRM*PNORM)
+                        ALFA1  = RES / ATP
+                        JADD1  = J
+                        ATP1   = ATP
+                        HLOW1  = .FALSE.
+                     END IF
+                  END IF
+               END IF
+
+               IF (JS .EQ. -2)  THEN
+
+*                 The lower bound is violated.  Test for a new ALFA2.
+
+                  RES    = BL(J) - ATX
+                  IF (     (FIRSTV  .AND.  PALFA2*ATP .GE. RES
+     $                 .OR.  LASTV  .AND.  PALFA2*ATP .LE. RES)
+     $                 .OR.  J .EQ.  JSAVE2) THEN
+                     IF (APMAX2*ROWNRM*PNORM .LT. ATP) THEN
+                        APMAX2 = ATP / (ROWNRM*PNORM)
+                        IF      (ATP .GE. ONE       ) THEN
+                           ALFA2 = RES / ATP
+                        ELSE IF (RES .LT. BIGALF*ATP) THEN
+                           ALFA2 = RES / ATP
+                        ELSE
+                           ALFA2 = BIGALF
+                        END IF
+                        JADD2  = J
+                        ATP2   = ATP
+                        HLOW2  = .TRUE.
+                     END IF
+                  END IF
+               END IF
+            END IF
+
+            IF (CMDBG  .AND.  ICMDBG(3) .GT. 0)
+     $      WRITE (NOUT, 1200) J, JS, FEATOL(J), RES, ATP, JADD1,
+     $                         ALFA1, JADD2, ALFA2
+         END IF
+  400 CONTINUE
+
+*     ==================================================================
+*     Determine ALFA, the step to be taken.
+*     ==================================================================
+*     In the infeasible case, check whether to take the step ALFA2
+*     rather than ALFA1...
+
+      STEP2 = NUMINF .GT. 0  .AND.  JADD2 .GT. 0
+
+*     We do so if ALFA2 is less than ALFA1 or (if FIRSTV is false)
+*     lies in the range  (ALFA1, PALFA1)  and has a smaller value of
+*     ATP.
+
+      STEP2 = STEP2 .AND. (ALFA2 .LT. ALFA1   .OR.   LASTV  .AND.
+     $                     ALFA2 .LE. PALFA1  .AND.  APMAX2 .GE. APMAX1)
+
+      IF (STEP2) THEN
+         ALFA   = ALFA2
+         PALFA  = PALFA2
+         JADD   = JADD2
+         ATPHIT = ATP2
+         HITLOW = HLOW2
+      ELSE
+         ALFA   = ALFA1
+         PALFA  = PALFA1
+         JADD   = JADD1
+         ATPHIT = ATP1
+         HITLOW = HLOW1
+
+*        If ALFA1 is negative, the constraint to be added (JADD)
+*        remains unchanged, but ALFA may be shortened to the step
+*        to the nearest perturbed satisfied constraint along  - P.
+
+         NEGSTP = ALFA .LT. ZERO
+         IF (NEGSTP) THEN
+            CALL CMALF1( FIRSTV, NEGSTP, BIGALF, BIGBND, PNORM,
+     $                   JADD1, JADD2, PALFA1, PALFA2,
+     $                   ISTATE, N, NROWA, NCTOTL,
+     $                   ANORM, AP, AX, BL, BU, FEATOL, P, X )
+
+            IF (CMDBG  .AND.  ICMDBG(1) .GT. 0)
+     $         WRITE (NOUT, 9000) ALFA, PALFA1
+
+            ALFA = - MIN( ABS( ALFA ), PALFA1 )
+         END IF
+      END IF
+
+*     Test for undefined or infinite step.
+
+      IF (JADD .EQ. 0) THEN
+         ALFA   = BIGALF
+         PALFA  = BIGALF
+      END IF
+
+      IF (ALFA .GE. BIGALF) INFORM = 3
+      IF (CMDBG  .AND.  ICMDBG(1) .GT. 0  .AND.  INFORM .GT. 0)
+     $   WRITE (NOUT, 9010) JADD, ALFA
+      RETURN
+
+ 1000 FORMAT(/ ' CMALF  entered'
+     $       / '    J  JS         FEATOL        RES             AP',
+     $         '     JADD1        ALFA1     JADD2        ALFA2 '/)
+ 1200 FORMAT( I5, I4, 3G15.5, 2(I6, G17.7) )
+ 9000 FORMAT(/ ' //CMALF //  Negative step',
+     $       / ' //CMALF //           ALFA          PALFA'
+     $       / ' //CMALF //', 2G15.4 )
+ 9010 FORMAT(/ ' //CMALF //  Unbounded step.'
+     $       / ' //CMALF //  JADD           ALFA'
+     $       / ' //CMALF //  ', I4, G15.4 )
+
+*     End of  CMALF .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/cmalf1.f
@@ -0,0 +1,167 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+*     File  CMSUBS FORTRAN
+*
+*     CMALF1   CMALF    CMCHK    CMPERM   CMPRT    CMQMUL   CMR1MD
+*     CMRSWP   CMTSOL
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE CMALF1( FIRSTV, NEGSTP, BIGALF, BIGBND, PNORM,
+     $                   JADD1 , JADD2 , PALFA1, PALFA2,
+     $                   ISTATE, N, NROWA, NCTOTL,
+     $                   ANORM, AP, AX, BL, BU, FEATOL, P, X )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      LOGICAL            FIRSTV, NEGSTP
+      INTEGER            ISTATE(NCTOTL)
+      DOUBLE PRECISION   ANORM(*), AP(*), AX(*)
+      DOUBLE PRECISION   BL(NCTOTL), BU(NCTOTL), FEATOL(NCTOTL),
+     $                   P(N), X(N)
+
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9
+
+      LOGICAL            CMDBG
+      INTEGER            LCMDBG
+      PARAMETER         (LCMDBG = 5)
+      COMMON    /CMDEBG/ ICMDBG(LCMDBG), CMDBG
+
+************************************************************************
+*     CMALF1  finds steps PALFA1, PALFA2 such that
+*        X + PALFA1*P  reaches a linear constraint that is currently not
+*                      in the working set but is satisfied.
+*        X + PALFA2*P  reaches a linear constraint that is currently not
+*                      in the working set but is violated.
+*     The constraints are perturbed by an amount FEATOL, so that PALFA1
+*     is slightly larger than it should be,  and PALFA2 is slightly
+*     smaller than it should be.  This gives some leeway later when the
+*     exact steps are computed by CMALF.
+*
+*     Constraints in the working set are ignored  (ISTATE(j) .GE. 1).
+*
+*     If NEGSTP is true, the search direction will be taken to be  - P.
+*
+*
+*     Values of ISTATE(j)....
+*
+*        - 2         - 1         0           1          2         3
+*     a'x lt bl   a'x gt bu   a'x free   a'x = bl   a'x = bu   bl = bu
+*
+*     The values  -2  and  -1  do not occur once a feasible point has
+*     been found.
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     Original Fortran 66 version written  May 1980.
+*     This version of CMALF1 dated 26-June-1986.
+************************************************************************
+      LOGICAL            LASTV
+      INTRINSIC          ABS
+      PARAMETER        ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+
+      IF (CMDBG  .AND.  ICMDBG(3) .GT. 0) WRITE (NOUT, 1100)
+      LASTV  = .NOT. FIRSTV
+      JADD1  = 0
+      JADD2  = 0
+      PALFA1 = BIGALF
+
+      PALFA2 = ZERO
+      IF (FIRSTV) PALFA2 = BIGALF
+
+      DO 200 J = 1, NCTOTL
+         JS = ISTATE(J)
+         IF (JS .LE. 0) THEN
+            IF (J .LE. N) THEN
+               ATX    = X(J)
+               ATP    = P(J)
+               ROWNRM = ONE
+            ELSE
+               I      = J - N
+               ATX    = AX(I)
+               ATP    = AP(I)
+               ROWNRM = ONE  +  ANORM(I)
+            END IF
+            IF (NEGSTP) ATP = - ATP
+
+            IF ( ABS( ATP ) .LE. EPSPT9*ROWNRM*PNORM) THEN
+
+*              This constraint appears to be constant along P.  It is
+*              not used to compute the step.  Give the residual a value
+*              that can be spotted in the debug output.
+
+               RES = - ONE
+            ELSE IF (ATP .LE. ZERO  .AND.  JS .NE. -2) THEN
+*              ---------------------------------------------------------
+*              a'x  is decreasing and the lower bound is not violated.
+*              ---------------------------------------------------------
+*              First test for smaller PALFA1.
+
+               ABSATP = - ATP
+               IF (BL(J) .GT. (-BIGBND)) THEN
+                  RES    = ATX - BL(J) + FEATOL(J)
+                  IF (BIGALF*ABSATP .GT. ABS( RES )) THEN
+                     IF (PALFA1*ABSATP .GT. RES)  THEN
+                        PALFA1 = RES / ABSATP
+                        JADD1  = J
+                     END IF
+                  END IF
+               END IF
+
+               IF (JS .EQ. -1) THEN
+
+*                 The upper bound is violated.  Test for either larger
+*                 or smaller PALFA2, depending on the value of FIRSTV.
+
+                  RES    = ATX - BU(J) - FEATOL(J)
+                  IF (BIGALF*ABSATP .GT. ABS( RES )) THEN
+                     IF (FIRSTV  .AND.  PALFA2*ABSATP .GT. RES  .OR.
+     $                    LASTV  .AND.  PALFA2*ABSATP .LT. RES) THEN
+                        PALFA2 = RES / ABSATP
+                        JADD2  = J
+                     END IF
+                  END IF
+               END IF
+            ELSE IF (ATP .GT. ZERO  .AND.  JS .NE. -1) THEN
+*              ---------------------------------------------------------
+*              a'x  is increasing and the upper bound is not violated.
+*              ---------------------------------------------------------
+*              Test for smaller PALFA1.
+
+               IF (BU(J) .LT. BIGBND) THEN
+                  RES = BU(J) - ATX + FEATOL(J)
+                  IF (BIGALF*ATP .GT. ABS( RES )) THEN
+                     IF (PALFA1*ATP .GT. RES) THEN
+                        PALFA1 = RES / ATP
+                        JADD1  = J
+                     END IF
+                  END IF
+               END IF
+
+               IF (JS .EQ. -2) THEN
+
+*                 The lower bound is violated.  Test for a new PALFA2.
+
+                  RES  = BL(J) - ATX - FEATOL(J)
+                  IF (BIGALF*ATP .GT. ABS( RES )) THEN
+                     IF (FIRSTV  .AND.  PALFA2*ATP .GT. RES  .OR.
+     $                    LASTV  .AND.  PALFA2*ATP .LT. RES) THEN
+                        PALFA2 = RES / ATP
+                        JADD2  = J
+                     END IF
+                  END IF
+               END IF
+            END IF
+
+            IF (CMDBG  .AND.  ICMDBG(3) .GT. 0)
+     $         WRITE (NOUT, 1200) J, JS, FEATOL(J), RES,
+     $                            ATP, JADD1, PALFA1, JADD2, PALFA2
+         END IF
+  200 CONTINUE
+
+      RETURN
+
+ 1100 FORMAT(/ '    J  JS         FEATOL        RES             AP',
+     $         '     JADD1       PALFA1     JADD2       PALFA2' /)
+ 1200 FORMAT(I5, I4, 3G15.5, 2(I6, G17.7))
+
+*     End of  CMALF1.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/cmchk.f
@@ -0,0 +1,115 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE CMCHK ( NERROR, MSGLVL, COLD, USERKX,
+     $                   LIWORK, LWORK, LITOTL, LWTOTL,
+     $                   N, NCLIN, NCNLN,
+     $                   ISTATE, KX, NAMED, NAMES, LENNAM,
+     $                   BL, BU, X )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      CHARACTER*8        NAMES(*)
+      LOGICAL            COLD, NAMED, USERKX
+      INTEGER            ISTATE(N+NCLIN+NCNLN), KX(N)
+      DOUBLE PRECISION   BL(N+NCLIN+NCNLN), BU(N+NCLIN+NCNLN), X(N)
+
+      COMMON    /SOL1CM/ NOUT
+
+************************************************************************
+*  CMCHK   checks the data input to various optimizers.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Original Fortran 66 version written 10-May-1980.
+*  Fortran 77 version written  5-October-1984.
+*  This version of CMCHK dated  23-January-1987.
+************************************************************************
+      LOGICAL            OK
+      INTRINSIC          ABS
+      PARAMETER        ( ZERO   =  0.0D+0 , ONE    =  1.0D+0 )
+
+      CHARACTER*5        ID(3)
+      DATA                ID(1)   ,  ID(2)   ,  ID(3)
+     $                 / 'VARBL'  , 'LNCON'  , 'NLCON'   /
+
+      NERROR = 0
+
+*     ------------------------------------------------------------------
+*     Check that there is enough workspace to solve the problem.
+*     ------------------------------------------------------------------
+      OK     = LITOTL .LE. LIWORK  .AND.  LWTOTL .LE. LWORK
+      IF (.NOT. OK)  THEN
+         WRITE (NOUT, 1100) LIWORK, LWORK, LITOTL, LWTOTL
+         NERROR = NERROR + 1
+         WRITE (NOUT, 1110)
+      ELSE IF (MSGLVL .GT. 0)  THEN
+         WRITE (NOUT, 1100) LIWORK, LWORK, LITOTL, LWTOTL
+      END IF
+
+      IF (USERKX) THEN
+*        ---------------------------------------------------------------
+*        Check for a valid KX.
+*        ---------------------------------------------------------------
+         IFAIL = 1
+         CALL CMPERM( KX, 1, N, IFAIL )
+         IF (IFAIL .NE. 0) THEN
+            WRITE (NOUT, 1300)
+            NERROR = NERROR + 1
+         END IF
+      END IF
+
+*     ------------------------------------------------------------------
+*     Check the bounds on all variables and constraints.
+*     ------------------------------------------------------------------
+      DO 200 J = 1, N+NCLIN+NCNLN
+         B1     = BL(J)
+         B2     = BU(J)
+         OK     = B1 .LE. B2
+         IF (.NOT. OK)  THEN
+            NERROR = NERROR + 1
+            IF (J .GT. N+NCLIN)  THEN
+               K  = J - N - NCLIN
+               L  = 3
+            ELSE IF (J .GT. N)  THEN
+               K  = J - N
+               L  = 2
+            ELSE
+               K = J
+               L = 1
+            END IF
+            IF (.NOT. NAMED) WRITE (NOUT, 1200) ID(L), K, B1, B2
+            IF (      NAMED) WRITE (NOUT, 1210) NAMES(J), B1, B2
+         END IF
+  200 CONTINUE
+
+*     ------------------------------------------------------------------
+*     If warm start, check  ISTATE.
+*     ------------------------------------------------------------------
+      IF (.NOT. COLD) THEN
+         DO 420 J = 1, N+NCLIN+NCNLN
+            IS     = ISTATE(J)
+            OK     = IS .GE. (- 2)   .AND.   IS .LE. 4
+            IF (.NOT. OK)  THEN
+               NERROR = NERROR + 1
+               WRITE (NOUT, 1500) J, IS
+            END IF
+  420    CONTINUE
+      END IF
+
+      RETURN
+
+ 1100 FORMAT(/ ' Workspace provided is     IW(', I6,
+     $         '),  W(', I6, ').' /
+     $         ' To solve problem we need  IW(', I6,
+     $         '),  W(', I6, ').')
+ 1110 FORMAT(/ ' XXX  Not enough workspace to solve problem.')
+ 1200 FORMAT(/ ' XXX  The bounds on  ', A5, I3,
+     $         '  are inconsistent.   BL =', G16.7, '   BU =', G16.7)
+ 1210 FORMAT(/ ' XXX  The bounds on  ', A8,
+     $         '  are inconsistent.   BL =', G16.7, '   BU =', G16.7)
+ 1300 FORMAT(/ ' XXX  KX has not been supplied as a valid',
+     $         '  permutation.' )
+ 1500 FORMAT(/ ' XXX  Component', I5, '  of  ISTATE  is out of',
+     $         ' range...', I10)
+
+*     End of  CMCHK .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/cmperm.f
@@ -0,0 +1,89 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE CMPERM( KX, M1, M2, IFAIL )
+
+      INTEGER            IFAIL, M1, M2
+      INTEGER            KX(M2)
+
+      COMMON    /SOL1CM/ NOUT
+
+************************************************************************
+*     CMPERM checks that elements M1 to M2 of KX contain a valid
+*     permutation of the integers M1 to M2. The contents of KX are
+*     unchanged on exit.
+*
+*     SOL version of NAG Library routine M01ZBF.
+*     Written by N.N.Maclaren, University of Cambridge.
+*     This version of CMPERM dated 18-June-1986.
+************************************************************************
+
+      LOGICAL            CMDBG
+      INTEGER            LCMDBG
+      PARAMETER         (LCMDBG = 5)
+      COMMON    /CMDEBG/ ICMDBG(LCMDBG), CMDBG
+
+      INTEGER            I, IERR, J, K
+      INTRINSIC          ABS
+
+*     Check the parameters.
+
+      IF (M2 .LT. 1  .OR.  M1 .LT. 1  .OR.  M1 .GT. M2) THEN
+         IERR = 1
+         IF (CMDBG  .AND.  ICMDBG(3) .GT. 0)
+     $      WRITE (NOUT, FMT=1100) M1, M2
+      ELSE
+         IERR = 0
+
+*        Check that KX is within range.
+
+         DO 20 I = M1, M2
+            J = KX(I)
+            IF ((J .LT. M1) .OR. (J .GT. M2)) GO TO 100
+            IF (I .NE. J) KX(I) = -J
+   20    CONTINUE
+
+*        Check that no value is repeated.
+
+         DO 60 I = M1, M2
+            K = - KX(I)
+            IF (K .GE. 0) THEN
+               J     = I
+   40          KX(J) = K
+               J     = K
+               K     = - KX(J)
+               IF (K .GT. 0) GO TO 40
+               IF (J .NE. I) GO TO 120
+            END IF
+   60    CONTINUE
+      END IF
+
+*     Return
+
+   80 IF (IERR .NE. 0) THEN
+         IFAIL = IERR
+      ELSE
+         IFAIL = 0
+      END IF
+      RETURN
+  100 IERR = 2
+      WRITE (NOUT, FMT=1200) I, J
+      GO TO 140
+  120 IERR = 3
+      WRITE (NOUT, FMT=1300) J
+
+*     Restore KX.
+
+  140 DO 160 I = M1, M2
+         KX(I) = ABS(KX(I))
+  160 CONTINUE
+      GO TO 80
+
+ 1100 FORMAT(/ ' //CMPERM//  Illegal parameter values,'
+     $       / ' //CMPERM//    M1    M1'
+     $       / ' //CMPERM//', 2I6 )
+ 1200 FORMAT(/ ' XXX  KX(',I6,') contains an out-of-range value =', I16)
+ 1300 FORMAT(/ ' XXX  KX contains a duplicate value =',             I16)
+
+*     End of CMPERM.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/cmprt.f
@@ -0,0 +1,168 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE CMPRT ( MSGLVL, NFREE, NROWA,
+     $                   N, NCLIN, NCNLN, NCTOTL, BIGBND,
+     $                   NAMED, NAMES, LENNAM,
+     $                   NACTIV, ISTATE, KACTIV, KX,
+     $                   A, BL, BU, C, CLAMDA, RLAMDA, X )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      CHARACTER*8        NAMES(*)
+      LOGICAL            NAMED
+      INTEGER            ISTATE(NCTOTL), KACTIV(N), KX(N)
+      DOUBLE PRECISION   A(NROWA,*), BL(NCTOTL), BU(NCTOTL), C(*),
+     $                   CLAMDA(NCTOTL), RLAMDA(N), X(N)
+
+      COMMON    /SOL1CM/ NOUT
+
+      LOGICAL            CMDBG
+      INTEGER            LCMDBG
+      PARAMETER         (LCMDBG = 5)
+      COMMON    /CMDEBG/ ICMDBG(LCMDBG), CMDBG
+
+***********************************************************************
+*  CMPRT   creates the expanded Lagrange multiplier vector CLAMDA.
+*  If MSGLVL .EQ 1 or MSGLVL .GE. 10,  CMPRT prints  x,  A*x,
+*  c(x),  their bounds, the multipliers, and the residuals (distance
+*  to the nearer bound).
+*  CMPRT is called by LSCORE and NPCORE just before exiting.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Original Fortran 77 version written  October 1984.
+*  This version of  CMPRT  dated  10-June-1986.
+***********************************************************************
+      CHARACTER*2        LS, LSTATE(7)
+      CHARACTER*5        ID(3), ID3
+      CHARACTER*8        ID4
+      EXTERNAL           DDOT
+      INTRINSIC          ABS
+
+      PARAMETER        ( ZERO  = 0.0D+0 )
+      DATA               ID(1) / 'VARBL' /
+      DATA               ID(2) / 'LNCON' /
+      DATA               ID(3) / 'NLCON' /
+      DATA               LSTATE(1) / '--' /, LSTATE(2) / '++' /
+      DATA               LSTATE(3) / 'FR' /, LSTATE(4) / 'LL' /
+      DATA               LSTATE(5) / 'UL' /, LSTATE(6) / 'EQ' /
+      DATA               LSTATE(7) / 'TB' /
+
+
+      NPLIN  = N     + NCLIN
+      NZ     = NFREE - NACTIV
+
+*     Expand multipliers for bounds, linear and nonlinear constraints
+*     into the  CLAMDA  array.
+
+      CALL DLOAD ( NCTOTL, ZERO, CLAMDA, 1 )
+      NFIXED = N - NFREE
+      DO 150 K = 1, NACTIV+NFIXED
+         IF (K .LE. NACTIV) J = KACTIV(K) + N
+         IF (K .GT. NACTIV) J = KX(NZ+K)
+         CLAMDA(J) = RLAMDA(K)
+  150 CONTINUE
+
+      IF (MSGLVL .LT. 10  .AND.  MSGLVL .NE. 1) RETURN
+
+      WRITE (NOUT, 1100)
+      ID3 = ID(1)
+
+      DO 500 J = 1, NCTOTL
+         B1     = BL(J)
+         B2     = BU(J)
+         WLAM   = CLAMDA(J)
+         IS     = ISTATE(J)
+         LS     = LSTATE(IS + 3)
+         IF (J .LE. N) THEN
+
+*           Section 1 -- the variables  x.
+*           ------------------------------
+            K      = J
+            V      = X(J)
+
+         ELSE IF (J .LE. NPLIN) THEN
+
+*           Section 2 -- the linear constraints  A*x.
+*           -----------------------------------------
+            IF (J .EQ. N + 1) THEN
+               WRITE (NOUT, 1200)
+               ID3 = ID(2)
+            END IF
+
+            K      = J - N
+            V      = DDOT  ( N, A(K,1), NROWA, X, 1 )
+         ELSE
+
+*           Section 3 -- the nonlinear constraints  c(x).
+*           ---------------------------------------------
+
+            IF (J .EQ. NPLIN + 1) THEN
+               WRITE (NOUT, 1300)
+               ID3 = ID(3)
+            END IF
+
+            K      = J - NPLIN
+            V      = C(K)
+         END IF
+
+*        Print a line for the j-th variable or constraint.
+*        -------------------------------------------------
+         RES    = V - B1
+         RES2   = B2 - V
+         IF (ABS(RES) .GT. ABS(RES2)) RES = RES2
+         IP     = 1
+         IF (B1 .LE. ( - BIGBND )) IP = 2
+         IF (B2 .GE.     BIGBND  ) IP = IP + 2
+         IF (NAMED) THEN
+
+            ID4 = NAMES(J)
+            IF (IP .EQ. 1) THEN
+               WRITE (NOUT, 2100) ID4,    LS, V, B1, B2, WLAM, RES
+            ELSE IF (IP .EQ. 2) THEN
+               WRITE (NOUT, 2200) ID4,    LS, V,     B2, WLAM, RES
+            ELSE IF (IP .EQ. 3) THEN
+               WRITE (NOUT, 2300) ID4,    LS, V, B1,     WLAM, RES
+            ELSE
+               WRITE (NOUT, 2400) ID4,    LS, V,         WLAM, RES
+           END IF
+
+         ELSE
+
+            IF (IP .EQ. 1) THEN
+               WRITE (NOUT, 3100) ID3, K, LS, V, B1, B2, WLAM, RES
+            ELSE IF (IP .EQ. 2) THEN
+               WRITE (NOUT, 3200) ID3, K, LS, V,     B2, WLAM, RES
+            ELSE IF (IP .EQ. 3) THEN
+               WRITE (NOUT, 3300) ID3, K, LS, V, B1,     WLAM, RES
+            ELSE
+               WRITE (NOUT, 3400) ID3, K, LS, V,         WLAM, RES
+           END IF
+         END IF
+  500 CONTINUE
+      RETURN
+
+ 1100 FORMAT(// ' Variable        State', 5X, ' Value',
+     $   6X, ' Lower bound', 4X, ' Upper bound',
+     $   '  Lagr multiplier', '     Residual' /)
+ 1200 FORMAT(// ' Linear constr   State', 5X, ' Value',
+     $   6X, ' Lower bound', 4X, ' Upper bound',
+     $   '  Lagr multiplier', '     Residual' /)
+ 1300 FORMAT(// ' Nonlnr constr   State', 5X, ' Value',
+     $   6X, ' Lower bound', 4X, ' Upper bound',
+     $   '  Lagr multiplier', '     Residual' /)
+ 2100 FORMAT(1X, A8, 10X, A2, 3G16.7, G16.7, G16.4)
+ 2200 FORMAT(1X, A8, 10X, A2, G16.7, 5X, ' None', 6X, G16.7,
+     $   G16.7, G16.4)
+ 2300 FORMAT(1X, A8, 10X, A2, 2G16.7, 5X, ' None', 6X, G16.7, G16.4)
+ 2400 FORMAT(1X, A8, 10X, A2,  G16.7, 5X, ' None', 11X, ' None',
+     $   6X, G16.7, G16.4)
+ 3100 FORMAT(1X, A5, I3, 10X, A2, 3G16.7, G16.7, G16.4)
+ 3200 FORMAT(1X, A5, I3, 10X, A2,  G16.7,
+     $   5X, ' None', 6X, G16.7, G16.7, G16.4)
+ 3300 FORMAT(1X, A5, I3, 10X, A2, 2G16.7, 5X, ' None', 6X,
+     $   G16.7, G16.4)
+ 3400 FORMAT(1X, A5, I3, 10X, A2,  G16.7,
+     $   5X, ' None', 11X, ' None', 6X, G16.7, G16.4)
+
+*     End of  CMPRT
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/cmqmul.f
@@ -0,0 +1,138 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE CMQMUL( MODE, N, NZ, NFREE, NQ, UNITQ,
+     $                   KX, V, ZY, WRK )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      LOGICAL            UNITQ
+      INTEGER            KX(N)
+      DOUBLE PRECISION   V(N), ZY(NQ,*), WRK(N)
+
+************************************************************************
+*     CMQMUL  transforms the vector  v  in various ways using the
+*     matrix  Q = ( Z  Y )  defined by the input parameters.
+*
+*        MODE               result
+*        ----               ------
+*
+*          1                v = Z v
+*          2                v = Y v
+*          3                v = Q v
+*
+*     On input,  v  is assumed to be ordered as  ( v(free)  v(fixed) ).
+*     on output, v  is a full n-vector.
+*
+*
+*          4                v = Z'v
+*          5                v = Y'v
+*          6                v = Q'v
+*
+*     On input,  v  is a full n-vector.
+*     On output, v  is ordered as  ( v(free)  v(fixed) ).
+*
+*          7                v = Y'v
+*          8                v = Q'v
+*
+*     On input,  v  is a full n-vector.
+*     On output, v  is as in modes 5 and 6 except that v(fixed) is not
+*     set.
+*
+*     Modes  1, 4, 7 and 8  do not involve  v(fixed).
+*     Original F66 version  April 1983.
+*     Fortran 77 version written  9-February-1985.
+*     Level 2 BLAS added 10-June-1986.
+*     This version of CMQMUL dated 10-June-1986.
+************************************************************************
+      EXTERNAL           DDOT
+      PARAMETER        ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+
+      NFIXED = N - NFREE
+      J1     = 1
+      J2     = NFREE
+      IF (MODE .EQ. 1  .OR.  MODE .EQ. 4) J2 = NZ
+      IF (MODE .EQ. 2  .OR.  MODE .EQ. 5  .OR.  MODE .EQ. 7) J1 = NZ + 1
+      LENV   = J2 - J1 + 1
+      IF (MODE .LE. 3) THEN
+*        ===============================================================
+*        Mode = 1, 2  or  3.
+*        ===============================================================
+
+         IF (NFREE .GT. 0) CALL DLOAD ( NFREE, ZERO, WRK, 1 )
+
+*        Copy  v(fixed)  into the end of  wrk.
+
+         IF (MODE .GE. 2  .AND.  NFIXED .GT. 0)
+     $      CALL DCOPY ( NFIXED, V(NFREE+1), 1, WRK(NFREE+1), 1 )
+
+*        Set  WRK  =  relevant part of  ZY * V.
+
+         IF (LENV .GT. 0)  THEN
+            IF (UNITQ) THEN
+               CALL DCOPY ( LENV, V(J1), 1, WRK(J1), 1 )
+            ELSE
+               CALL DGEMV ( 'N', NFREE, J2-J1+1, ONE, ZY(1,J1), NQ,
+     $                      V(J1), 1, ONE, WRK, 1 )
+            END IF
+         END IF
+
+*        Expand  WRK  into  V  as a full n-vector.
+
+         CALL DLOAD ( N, ZERO, V, 1 )
+         DO 220 K = 1, NFREE
+            J    = KX(K)
+            V(J) = WRK(K)
+  220    CONTINUE
+
+*        Copy  WRK(fixed)  into the appropriate parts of  V.
+
+         IF (MODE .GT. 1)  THEN
+            DO 320 L = 1, NFIXED
+               J       = KX(NFREE+L)
+               V(J)    = WRK(NFREE+L)
+  320       CONTINUE
+         END IF
+
+      ELSE
+*        ===============================================================
+*        Mode = 4, 5, 6, 7  or  8.
+*        ===============================================================
+*        Put the fixed components of  V  into the end of  WRK.
+
+         IF (MODE .EQ. 5  .OR.  MODE .EQ. 6)  THEN
+            DO 420 L = 1, NFIXED
+               J            = KX(NFREE+L)
+               WRK(NFREE+L) = V(J)
+  420       CONTINUE
+         END IF
+
+*        Put the free  components of  V  into the beginning of  WRK.
+
+         IF (NFREE .GT. 0)  THEN
+            DO 520 K = 1, NFREE
+               J      = KX(K)
+               WRK(K) = V(J)
+  520       CONTINUE
+
+*           Set  V  =  relevant part of  ZY' * WRK.
+
+            IF (LENV .GT. 0)  THEN
+               IF (UNITQ) THEN
+                  CALL DCOPY ( LENV, WRK(J1), 1, V(J1), 1 )
+               ELSE
+                  CALL DGEMV ( 'T', NFREE, J2-J1+1, ONE, ZY(1,J1), NQ,
+     $                         WRK, 1, ZERO, V(J1), 1 )
+               END IF
+            END IF
+         END IF
+
+*        Copy the fixed components of  WRK  into the end of  V.
+
+         IF (NFIXED .GT. 0  .AND.  (MODE .EQ. 5  .OR.  MODE .EQ. 6))
+     $      CALL DCOPY ( NFIXED, WRK(NFREE+1), 1, V(NFREE+1), 1 )
+      END IF
+
+      RETURN
+
+*     End of  CMQMUL.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/cmr1md.f
@@ -0,0 +1,74 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE CMR1MD( N, NU, NRANK, NROWR, LENV, LENW,
+     $                   R, U, V, W )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      INTEGER            N, NU, NRANK, NROWR, LENV, LENW
+      DOUBLE PRECISION   R(NROWR,*), U(N,*), V(N), W(N)
+************************************************************************
+*     CMR1MD  modifies the  nrank*n  upper-triangular matrix  R  so that
+*     Q*(R + v*w')  is upper triangular,  where  Q  is orthogonal,
+*     v  and  w  are vectors, and the modified  R  overwrites the old.
+*     Q  is the product of two sweeps of plane rotations (not stored).
+*     If required,  the rotations are applied to the NU columns of
+*     the matrix  U.
+*
+*     The matrix V*W' is an (LENV) by (LENW) matrix.
+*     The vector V is overwritten.
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     Original version   October  1984.
+*     This version of  CMR1MD  dated 18-September-1985.
+************************************************************************
+      INTRINSIC          MIN
+
+      J = MIN( LENV, NRANK )
+      IF (NRANK .GT. 0) THEN
+
+*        ===============================================================
+*        Reduce components  1  thru  (J-1)  of  V  to zero,  using a
+*        backward sweep of rotations.  The rotations create a horizontal
+*        spike in the  j-th  row of  R.  This row is stored in  V.
+*        (Note that  DROT3G  sets  V(K) = 0  below as required.)
+*        ===============================================================
+         LROWJ  = N - J + 1
+         VJ     = V(J)
+         CALL DCOPY ( LROWJ, R(J,J), NROWR, V(J), 1 )
+         LROWK  = LROWJ
+         DO 400 K = J-1, 1, -1
+            LROWK  = LROWK + 1
+            CALL DROT3G( VJ, V(K), CS, SN )
+            CALL DROT3 ( LROWK, V(K)  , 1, R(K,K), NROWR, CS, SN )
+
+            IF (NU .GT. 0)
+     $      CALL DROT3 ( NU   , U(J,1), N, U(K,1), N    , CS, SN )
+  400    CONTINUE
+
+*        ===============================================================
+*        Add a multiple of elements  1  thru  LENW  of  W  to the row
+*        spike of  R  (stored in elements  1  thru  N  of  V).
+*        ===============================================================
+         CALL DAXPY ( LENW, VJ, W, 1, V, 1 )
+
+*        ===============================================================
+*        Eliminate the row spike  (held in  V)  using a forward sweep
+*        of rotations.
+*        ===============================================================
+         DO 600 K = 1, J-1
+            LROWK  = LROWK - 1
+            L      = K     + 1
+            CALL DROT3G( R(K,K), V(K), CS, SN )
+            CALL DROT3 ( LROWK, R(K,L), NROWR, V(L)  , 1, CS, SN )
+
+            IF (NU .GT. 0)
+     $      CALL DROT3 ( NU   , U(K,1), N    , U(J,1), N, CS, SN )
+  600    CONTINUE
+         CALL DCOPY ( LROWJ, V(J), 1, R(J,J), NROWR )
+      END IF
+
+      RETURN
+
+*     End of  CMR1MD
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/cmrswp.f
@@ -0,0 +1,89 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE CMRSWP( N, NU, NRANK, NROWR, I, J, R, U, V )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      INTEGER            N, NU, NRANK, NROWR, I, J
+      DOUBLE PRECISION   R(NROWR,*), U(N,*), V(N)
+
+************************************************************************
+*     CMRSWP  interchanges the  I-th  and  J-th  (I .LT. J)  columns of
+*     an  NRANK*N  upper-triangular matrix  R   and restores the
+*     resulting matrix to upper-triangular form.  The final matrix  R
+*     is equal to Q(R + VW')  where  V  and  W  are defined as
+*         V   =  Rj  -  Ri      and    W  =  Ei  -  Ej
+*     with  Ri  and  Rj  the Ith and Jth columns of  R,  Ei  and  Ej
+*     unit vectors.
+*
+*     The vector V is used as workspace.  R is overwritten.  Q is the
+*     product of two sweeps of plane rotations (not stored).
+*     If required,  the rotations are applied to the  nu  columns of
+*     the matrix  U.
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     Original version written 31-October-1984.
+*     This version of  CMRSWP  dated  18-September-1985.
+************************************************************************
+      INTRINSIC          MIN
+      INTEGER            K, L, LENI1, LENJ, LROWJ, LROWK
+      DOUBLE PRECISION   CS, SN, VJ
+
+      LENJ   = MIN( J, NRANK )
+      IF (LENJ .GT. 0) THEN
+         CALL DCOPY ( LENJ, R(1,J), 1, V, 1 )
+         IF (I .LE. NRANK) V(I)  = V(I) - R(I,I)
+         LENI1 = MIN( I-1, NRANK )
+         IF (LENI1 .GT. 0) THEN
+            CALL DCOPY ( LENI1, R(1,I), 1, R(1,J), 1 )
+            CALL DCOPY ( LENI1, V     , 1, R(1,I), 1 )
+         END IF
+      END IF
+      IF (I .LE. NRANK) THEN
+
+*        ===============================================================
+*        Reduce components I thru  (LENJ-1) of V to zero,  using a
+*        backward sweep of rotations.  The rotations create a horizontal
+*        spike in the LENJ-th row of  R.  This row is stored in V.
+*        (Note that  DROT3G  sets  V(K) = 0  below as required.)
+*        ===============================================================
+         LROWJ  = N - LENJ + 1
+         VJ     = V(LENJ)
+         CALL DCOPY ( LROWJ, R(LENJ,LENJ), NROWR, V(LENJ), 1 )
+         LROWK  = LROWJ
+         DO 400 K = LENJ-1, I, -1
+            LROWK  = LROWK + 1
+            CALL DROT3G( VJ, V(K), CS, SN )
+            CALL DROT3 ( LROWK, V(K)     , 1, R(K,K), NROWR, CS, SN )
+
+            IF (NU .GT. 0)
+     $      CALL DROT3 ( NU   , U(LENJ,1), N, U(K,1), N    , CS, SN )
+  400    CONTINUE
+
+*        ===============================================================
+*        Add a multiple of elements I thru J of W to the
+*        horizontal spike of  R  (held in elements I thru J of V).
+*        ===============================================================
+         V(I) = V(I) + VJ
+         V(J) = V(J) - VJ
+
+*        ===============================================================
+*        Eliminate the row spike  (held in V)  using a forward sweep
+*        of rotations.
+*        ===============================================================
+         DO 600 K = I, LENJ-1
+            LROWK  = LROWK - 1
+            L      = K     + 1
+            CALL DROT3G( R(K,K), V(K), CS, SN )
+            CALL DROT3 ( LROWK, R(K,L), NROWR, V(L)     , 1, CS, SN )
+
+            IF (NU .GT. 0)
+     $      CALL DROT3 ( NU   , U(K,1), N    , U(LENJ,1), N, CS, SN )
+  600    CONTINUE
+         CALL DCOPY ( LROWJ, V(LENJ), 1, R(LENJ,LENJ), NROWR )
+      END IF
+
+      RETURN
+
+*     End of  CMRSWP
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/cmtsol.f
@@ -0,0 +1,61 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE CMTSOL( MODE, NROWT, N, T, Y )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      INTEGER            MODE, NROWT, N
+      DOUBLE PRECISION   T(NROWT,*), Y(N)
+
+************************************************************************
+*     CMTSOL  solves equations involving a reverse-triangular matrix  T
+*     and a right-hand-side vector  y,  returning the solution in  y.
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     Original Fortran 77 version written February-1985.
+************************************************************************
+      PARAMETER        ( ZERO = 0.0D+0 )
+
+      N1 = N + 1
+      IF (MODE .EQ. 1) THEN
+
+*        Mode = 1  ---  Solve  T * y(new) = y(old).
+
+         DO 100 J = 1, N
+            JJ = N1 - J
+            YJ = Y(J)/T(J,JJ)
+            Y(J) = YJ
+            L  = JJ - 1
+            IF (L .GT. 0  .AND.  YJ .NE. ZERO)
+     $      CALL DAXPY( L, (-YJ), T(J+1,JJ), 1, Y(J+1), 1 )
+  100    CONTINUE
+      ELSE
+
+*        Mode = 2  ---  Solve  T' y(new) = y(old).
+
+         DO 500 J = 1, N
+            JJ = N1 - J
+            YJ = Y(J)/T(JJ,J)
+            Y(J) = YJ
+            L  = JJ - 1
+            IF (L .GT. 0  .AND.  YJ .NE. ZERO)
+     $      CALL DAXPY( L, (-YJ), T(JJ,J+1), NROWT, Y(J+1), 1 )
+  500    CONTINUE
+      END IF
+
+*     Reverse the solution vector.
+
+      IF (N .GT. 1) THEN
+         L = N/2
+         DO 800 J = 1, L
+            JJ    = N1 - J
+            YJ    = Y(J)
+            Y(J)  = Y(JJ)
+            Y(JJ) = YJ
+  800    CONTINUE
+      END IF
+
+      RETURN
+
+*     End of  CMTSOL.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/dcond.f
@@ -0,0 +1,50 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+*     File  BLAS FORTRAN
+*
+*                         Others
+*                         ------
+*     DCOND*   DDDIV*   DDIV     DDSCL    DGRFG    DLOAD    DNORM
+*     DROT3*   DROT3G*  DSSQ     ICOPY*   ILOAD    IDRANK+
+*
+*    *Not in the Nag Blas.
+*    +Differs from the Nag Blas.
+*
+*                         QR Routines
+*                         -- --------
+*     DGEQR    DGEQRP   DGEAP    DGEAPQ
+*
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE DCOND ( N, X, INCX, AXMAX, AXMIN )
+
+      INTEGER            N, INCX
+      DOUBLE PRECISION   AXMAX, AXMIN
+      DOUBLE PRECISION   X( (N-1)*INCX+1 )
+C
+C     DCOND   finds the elements in  x  that are largest and smallest
+C     in magnitude.
+C
+      DOUBLE PRECISION   ZERO
+      PARAMETER        ( ZERO = 0.0D+0 )
+      INTEGER            I, IX
+      INTRINSIC          ABS, MAX, MIN
+
+      IF (N .EQ. 0) THEN
+         AXMAX = ZERO
+         AXMIN = ZERO
+      ELSE
+         AXMAX = ABS( X(1) )
+         AXMIN = AXMAX
+         IX    = 1
+         DO 100 I = 2, N
+            IX    = IX + INCX
+            AXMAX = MAX( AXMAX, ABS( X(IX) ) )
+            AXMIN = MIN( AXMIN, ABS( X(IX) ) )
+  100    CONTINUE
+      END IF
+
+      RETURN
+
+*     End of  DCOND
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/dddiv.f
@@ -0,0 +1,50 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE DDDIV ( N, D, INCD, X, INCX )
+      INTEGER            N, INCD, INCX
+      DOUBLE PRECISION   D( * ), X( * )
+C
+C     DDDIV  performs the operation
+C
+C     x := diag( d )(inverse)*x
+C
+      PARAMETER        ( ONE = 1.0 )
+      EXTERNAL           DSCAL
+      INTEGER            I     , ID    , IX
+
+      IF( N.GE.1 )THEN
+         IF( INCD.EQ.0 )THEN
+
+            CALL DSCAL ( N, (ONE/D( 1 )), X, INCX )
+
+         ELSE IF( ( INCD.EQ.INCX ).AND.( INCD.GT.0 ) )THEN
+            DO 10, ID = 1, 1 + ( N - 1 )*INCD, INCD
+               X( ID ) = X( ID )/D( ID )
+   10       CONTINUE
+         ELSE
+            IF( INCX.GE.0 )THEN
+               IX = 1
+            ELSE
+               IX = 1 - ( N - 1 )*INCX
+            END IF
+            IF( INCD.GT.0 )THEN
+               DO 20, ID = 1, 1 + ( N - 1 )*INCD, INCD
+                  X( IX ) = X( IX )/D( ID )
+                  IX      = IX + INCX
+   20          CONTINUE
+            ELSE
+               ID = 1 - ( N - 1 )*INCD
+               DO 30, I = 1, N
+                  X( IX ) = X( IX )/D( ID )
+                  ID      = ID + INCD
+                  IX      = IX + INCX
+   30          CONTINUE
+            END IF
+         END IF
+      END IF
+
+      RETURN
+
+*     End of DDDIV .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/ddiv.f
@@ -0,0 +1,88 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      DOUBLE PRECISION FUNCTION DDIV  ( A, B, FAIL )
+      DOUBLE PRECISION                  A, B
+      LOGICAL                           FAIL
+C
+C  DDIV   returns the value div given by
+C
+C     div = ( a/b                 if a/b does not overflow,
+C           (
+C           ( 0.0                 if a .eq. 0.0,
+C           (
+C           ( sign( a/b )*flmax   if a .ne. 0.0 and a/b would overflow,
+C
+C  where flmax is a large value, via the function name. In addition if
+C  a/b would overflow then fail is returned as true, otherwise fail is
+C  returned as false.
+C
+C  Note that when a and b are both zero, fail is returned as true,
+C  but div is returned as 0.0. in all other cases of overflow div is
+C  such that abs( div ) = flmax.
+C
+C
+C  Nag Fortran 77 O( 1 ) basic linear algebra routine.
+C
+C  -- Written on 26-October-1982.
+C     Sven Hammarling, Nag Central Office.
+C
+      INTRINSIC           ABS   , SIGN
+      LOGICAL             FIRST
+      DOUBLE PRECISION    ABSB  , FLMAX , FLMIN
+      DOUBLE PRECISION    ONE   ,         ZERO
+      PARAMETER         ( ONE   = 1.0D+0, ZERO  = 0.0D+0 )
+
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+
+      SAVE                FIRST , FLMIN , FLMAX
+      DATA                FIRST / .TRUE. /
+
+      IF( A.EQ.ZERO )THEN
+         DDIV   = ZERO
+         IF( B.EQ.ZERO )THEN
+            FAIL = .TRUE.
+         ELSE
+            FAIL = .FALSE.
+         END IF
+         RETURN
+      END IF
+
+      IF( FIRST )THEN
+         FIRST  = .FALSE.
+         FLMIN  = WMACH( 5 )
+         FLMAX  = WMACH( 7 )
+      END IF
+
+      IF( B.EQ.ZERO )THEN
+         DDIV   = SIGN( FLMAX, A )
+         FAIL   = .TRUE.
+      ELSE
+         ABSB   = ABS( B )
+         IF( ABSB.GE.ONE )THEN
+            FAIL = .FALSE.
+            IF( ABS( A ).GE.ABSB*FLMIN )THEN
+               DDIV   = A/B
+            ELSE
+               DDIV   = ZERO
+            END IF
+         ELSE
+            IF( ABS( A ).LE.ABSB*FLMAX )THEN
+               FAIL   = .FALSE.
+               DDIV   = A/B
+            ELSE
+               FAIL   = .TRUE.
+               DDIV   = FLMAX
+               IF( ( ( A.LT.ZERO ).AND.( B.GT.ZERO ) ).OR.
+     $             ( ( A.GT.ZERO ).AND.( B.LT.ZERO ) )     )
+     $            DDIV   = -DDIV
+            END IF
+         END IF
+      END IF
+
+      RETURN
+
+*     End of DDIV  .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/ddscl.f
@@ -0,0 +1,55 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE DDSCL ( N, D, INCD, X, INCX )
+      INTEGER            N, INCD, INCX
+      DOUBLE PRECISION   D( * ), X( * )
+C
+C  DDSCL  performs the operation
+C
+C     x := diag( d )*x
+C
+C
+C  Nag Fortran 77 O( n ) basic linear algebra routine.
+C
+C  -- Written on 22-September-1983.
+C     Sven Hammarling, Nag Central Office.
+C
+      EXTERNAL           DSCAL
+      INTEGER            I     , ID    , IX
+
+      IF( N.GE.1 )THEN
+         IF( INCD.EQ.0 )THEN
+
+            CALL DSCAL ( N, D( 1 ), X, INCX )
+
+         ELSE IF( ( INCD.EQ.INCX ).AND.( INCD.GT.0 ) )THEN
+            DO 10, ID = 1, 1 + ( N - 1 )*INCD, INCD
+               X( ID ) = D( ID )*X( ID )
+   10       CONTINUE
+         ELSE
+            IF( INCX.GE.0 )THEN
+               IX = 1
+            ELSE
+               IX = 1 - ( N - 1 )*INCX
+            END IF
+            IF( INCD.GT.0 )THEN
+               DO 20, ID = 1, 1 + ( N - 1 )*INCD, INCD
+                  X( IX ) = D( ID )*X( IX )
+                  IX      = IX + INCX
+   20          CONTINUE
+            ELSE
+               ID = 1 - ( N - 1 )*INCD
+               DO 30, I = 1, N
+                  X( IX ) = D( ID )*X( IX )
+                  ID      = ID + INCD
+                  IX      = IX + INCX
+   30          CONTINUE
+            END IF
+         END IF
+      END IF
+
+      RETURN
+
+*     End of DDSCL .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/dgeap.f
@@ -0,0 +1,192 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE DGEAP ( SIDE, TRANS, M, N, PERM, K, B, LDB )
+*     .. Scalar Arguments ..
+      INTEGER            K, LDB, M, N
+      CHARACTER*1        SIDE, TRANS
+*     .. Array Arguments ..
+      DOUBLE PRECISION   B( LDB, * )
+      INTEGER            PERM( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEAP  performs one of the transformations
+*
+*     B := P'*B   or   B := P*B,   where B is an m by k matrix,
+*
+*  or
+*
+*     B := B*P'   or   B := B*P,   where B is a k by m matrix,
+*
+*  P being an m by m permutation matrix of the form
+*
+*     P = P( 1, index( 1 ) )*P( 2, index( 2 ) )*...*P( n, index( n ) ),
+*
+*  where  P( i, index( i ) ) is the permutation matrix that interchanges
+*  items i and index( i ). That is P( i, index( i ) ) is the unit matrix
+*  with rows and columns  i and index( i )  interchanged.  Of course, if
+*  index( i ) = i  then  P( i, index( i ) ) = I.
+*
+*  This routine  is intended for use in  conjunction with  Nag auxiliary
+*  routines that  perform  interchange  operations,  such  as  pivoting.
+*
+*  Parameters
+*  ==========
+*
+*  SIDE   - CHARACTER*1.
+*  TRANS
+*           On entry,  SIDE  ( Left-hand side, or Right-hand side )  and
+*           TRANS  ( Transpose, or No transpose )  specify the operation
+*           to be performed as follows.
+*
+*           SIDE = 'L' or 'l'   and   TRANS = 'T' or 't'
+*
+*              Perform the operation   B := P'*B.
+*
+*           SIDE = 'L' or 'l'   and   TRANS = 'N' or 'n'
+*
+*              Perform the operation   B := P*B.
+*
+*           SIDE = 'R' or 'r'   and   TRANS = 'T' or 't'
+*
+*              Perform the operation   B := B*P'.
+*
+*           SIDE = 'R' or 'r'   and   TRANS = 'N' or 'n'
+*
+*              Perform the operation   B := B*P.
+*
+*           Unchanged on exit.
+*
+*  M      - INTEGER.
+*
+*           On entry, M must specify the order of the permutation matrix
+*           P.  M must be at least zero.  When  M = 0  then an immediate
+*           return is effected.
+*
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*
+*           On entry,  N must specify the value of n. N must be at least
+*           zero.  When  N = 0  then an  immediate  return is  effected.
+*
+*           Unchanged on exit.
+*
+*  PERM   - INTEGER array of DIMENSION at least ( n ).
+*
+*           Before  entry,  PERM  must  contain the  n  indices  for the
+*           permutation matrices. index( i ) must satisfy
+*
+*              1 .le. index( i ) .le. m.
+*
+*           It is usual for index( i ) to be at least i, but this is not
+*           necessary for this routine.
+*
+*           Unchanged on exit.
+*
+*  K      - INTEGER.
+*
+*           On entry with  SIDE = 'L' or 'l',  K must specify the number
+*           of columns of B and on entry with  SIDE = 'R' or 'r', K must
+*           specify the  number of rows of B.  K must be at least  zero.
+*           When  K = 0  then an immediate return is effected.
+*
+*           Unchanged on exit.
+*
+*  B      - DOUBLE PRECISION array of  DIMENSION  ( LDB, ncolb ),  where
+*           ncolb = k   when   SIDE = 'L' or 'l'  and   ncolb = m   when
+*           SIDE = 'R' or 'r'.
+*
+*           Before entry  with  SIDE = 'L' or 'l',  the  leading  M by K
+*           part  of  the  array   B  must  contain  the  matrix  to  be
+*           transformed  and  before entry with  SIDE = 'R' or 'r',  the
+*           leading  K by M part of the array  B must contain the matrix
+*           to  be  transformed.  On  exit,  B  is  overwritten  by  the
+*           transformed matrix.
+*
+*  LDB    - INTEGER.
+*
+*           On entry,  LDB  must specify  the  leading dimension  of the
+*           array  B  as declared  in the  calling  (sub) program.  When
+*           SIDE = 'L' or 'l'   then  LDB  must  be  at  least  m,  when
+*           SIDE = 'R' or 'r'   then  LDB  must  be  at  least  k.
+*           Unchanged on exit.
+*
+*
+*  Nag Fortran 77 O( n**2 ) basic linear algebra routine.
+*
+*  -- Written on 13-January-1986.
+*     Sven Hammarling, Nag Central Office.
+*
+*
+*     .. Local Scalars ..
+      DOUBLE PRECISION   TEMP
+      INTEGER            I, J, L
+      LOGICAL            LEFT, NULL, RIGHT, TRNSP
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+      IF( MIN( M, N, K ).EQ.0 )
+     $   RETURN
+      LEFT  = ( SIDE .EQ.'L' ).OR.( SIDE .EQ.'l' )
+      RIGHT = ( SIDE .EQ.'R' ).OR.( SIDE .EQ.'r' )
+      NULL  = ( TRANS.EQ.'N' ).OR.( TRANS.EQ.'n' )
+      TRNSP = ( TRANS.EQ.'T' ).OR.( TRANS.EQ.'t' )
+      IF( LEFT )THEN
+         IF( TRNSP )THEN
+            DO 20, I = 1, N
+               IF( PERM( I ).NE.I )THEN
+                  L = PERM( I )
+                  DO 10, J = 1, K
+                     TEMP      = B( I, J )
+                     B( I, J ) = B( L, J )
+                     B( L, J ) = TEMP
+   10             CONTINUE
+               END IF
+   20       CONTINUE
+         ELSE IF( NULL )THEN
+            DO 40, I = N, 1, -1
+               IF( PERM( I ).NE.I )THEN
+                  L = PERM( I )
+                  DO 30, J = 1, K
+                     TEMP      = B( L, J )
+                     B( L, J ) = B( I, J )
+                     B( I, J ) = TEMP
+   30             CONTINUE
+               END IF
+   40       CONTINUE
+         END IF
+      ELSE IF( RIGHT )THEN
+         IF( TRNSP )THEN
+            DO 60, J = 1, N
+               IF( PERM( J ).NE.J )THEN
+                  L = PERM( J )
+                  DO 50, I = 1, K
+                     TEMP      = B( I, J )
+                     B( I, J ) = B( L, J )
+                     B( L, J ) = TEMP
+   50             CONTINUE
+               END IF
+   60       CONTINUE
+         ELSE IF( NULL )THEN
+            DO 80, J = N, 1, -1
+               IF( PERM( J ).NE.J )THEN
+                  L = PERM( J )
+                  DO 70, I = 1, K
+                     TEMP      = B( L, J )
+                     B( L, J ) = B( I, J )
+                     B( I, J ) = TEMP
+   70             CONTINUE
+               END IF
+   80       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DGEAP . ( F06QJF )
+*
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/dgeapq.f
@@ -0,0 +1,262 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE DGEAPQ( TRANS, WHEREZ, M, N, A, LDA, ZETA,
+     $                   NCOLB, B, LDB, WORK, INFORM )
+      CHARACTER*1        TRANS, WHEREZ
+      INTEGER            M, N, LDA, NCOLB, LDB, INFORM
+      DOUBLE PRECISION   A( LDA, * ), ZETA( * ), B( LDB, * ), WORK( * )
+C
+C  1. Purpose
+C     =======
+C
+C  DGEAPQ performs one of the transformations
+C
+C     B := Q'*B   or   B := Q*B,
+C
+C  where B is an m by ncolb matrix and Q is an m by m orthogonal matrix,
+C  given as the product of  Householder transformation matrices, details
+C  of  which are stored in the  m by n ( m.ge.n )  array  A  and, if the
+C  parameter  WHEREZ = 'S' or 's', in the array ZETA.
+C
+C  This  routine is  intended for use following auxiliary linear algebra
+C  routines such as  DGEQR , DGEHES and DSLTRI. ( See those routines for
+C  example calls. )
+C
+C  2. Description
+C     ===========
+C
+C  Q is assumed to be given by
+C
+C     Q = ( Q( p )*Q( p - 1 )*...*Q( 1 ) )',
+C
+C  Q( k ) being given in the form
+C
+C     Q( k ) = ( I     0   ),
+C              ( 0  T( k ) )
+C
+C  where
+C
+C     T( k ) = I - u( k )*u( k )',   u( k ) = ( zeta( k ) ),
+C                                             (    z( k ) )
+C
+C  zeta( k )  is a scalar and  z( k )  is an  ( m - k )  element vector.
+C
+C  z( k )  must  be  supplied  in  the  kth  column  of  A  in  elements
+C  a( k + 1, k ), ..., a( m, k )  and  zeta( k ) must be supplied either
+C  in  a( k, k )  or in  zeta( k ), depending upon the parameter WHEREZ.
+C
+C  To obtain Q explicitly B may be set to I and premultiplied by Q. This
+C  is more efficient than obtaining Q'.
+C
+C  3. Parameters
+C     ==========
+C
+C  TRANS  - CHARACTER*1.
+C
+C           On entry, TRANS  specifies the operation to be performed  as
+C           follows.
+C
+C           TRANS = ' ' or 'N' or 'n'
+C
+C              Perform the operation  B := Q*B.
+C
+C           TRANS = 'T' or 't' or 'C' or 'c'
+C
+C              Perform the operation  B := Q'*B.
+C
+C           Unchanged on exit.
+C
+C  WHEREZ - CHARACTER*1.
+C
+C           On entry, WHEREZ specifies where the elements of zeta are to
+C           be found as follows.
+C
+C           WHEREZ = 'I' or 'i'
+C
+C              The elements of zeta are in A.
+C
+C           WHEREZ = 'S' or 's'
+C
+C              The elements of zeta are separate from A, in ZETA.
+C
+C           Unchanged on exit.
+C
+C  M      - INTEGER.
+C
+C           On entry, M  must specify the number of rows of A. M must be
+C           at least n.
+C
+C           Unchanged on exit.
+C
+C  N      - INTEGER.
+C
+C           On entry, N  must specify the number of columns of A. N must
+C           be  at least zero. When  N = 0  then an immediate return  is
+C           effected.
+C
+C           Unchanged on exit.
+C
+C  A      - 'real' array of DIMENSION ( LDA, n ).
+C
+C           Before entry, the leading  M by N  stricly lower  triangular
+C           part of the array  A  must contain details of the matrix  Q.
+C           In  addition, when  WHEREZ = 'I' or 'i'  then  the  diagonal
+C           elements of A must contain the elements of zeta.
+C
+C           Unchanged on exit.
+C
+C  LDA    - INTEGER.
+C
+C           On  entry, LDA  must specify  the leading dimension  of  the
+C           array  A  as declared in the calling (sub) program. LDA must
+C           be at least m.
+C
+C           Unchanged on exit.
+C
+C  ZETA   - 'real' array of DIMENSION at least min( m - 1, n ).
+C
+C           Before entry with  WHEREZ = 'S' or 's', the array  ZETA must
+C           contain the elements of the vector  zeta.
+C
+C           When  WHEREZ = 'I' or 'i', the array ZETA is not referenced.
+C
+C           Unchanged on exit.
+C
+C  NCOLB  - INTEGER.
+C
+C           On  entry, NCOLB  must specify  the number of columns of  B.
+C           NCOLB  must  be  at  least  zero.  When  NCOLB = 0  then  an
+C           immediate return is effected.
+C
+C           Unchanged on exit.
+C
+C  B      - 'real' array of DIMENSION ( LDB, ncolb ).
+C
+C           Before entry, the leading  M by NCOLB  part of  the array  B
+C           must  contain  the matrix to be  transformed.
+C
+C           On  exit,  B  is  overwritten  by  the  transformed  matrix.
+C
+C  LDB    - INTEGER.
+C
+C           On  entry, LDB  must specify  the  leading dimension of  the
+C           array  B as declared in the calling (sub) program. LDB  must
+C           be at least m.
+C
+C           Unchanged on exit.
+C
+C  WORK   - 'real' array of DIMENSION at least ( ncolb ).
+C
+C           Used as internal workspace.
+C
+C  INFORM - INTEGER.
+C
+C           On  successful exit  INFORM  will be zero, otherwise  INFORM
+C           will  be set to unity indicating that an input parameter has
+C           been  incorrectly  set. See  the  next  section  for further
+C           details.
+C
+C  4. Diagnostic Information
+C     ======================
+C
+C  INFORM = 1
+C
+C     One or more of the following conditions holds:
+C
+C        TRANS  .ne. ' ' or 'N' or 'n' or 'T' or 't' or 'C' or 'c'
+C        WHEREZ .ne. 'I' or 'i' or 'S' or 's'
+C        M      .lt. N
+C        N      .lt. 0
+C        LDA    .lt. M
+C        NCOLB  .lt. 0
+C        LDB    .lt. M
+C
+C
+C  Nag Fortran 77 Auxiliary linear algebra routine.
+C
+C  -- Written on 15-November-1984.
+C     Sven Hammarling, Nag Central Office.
+C
+      EXTERNAL           DGEMV , DGER
+      INTRINSIC          MIN
+      INTEGER            J     , K     , KK    , LB
+      DOUBLE PRECISION   TEMP
+      DOUBLE PRECISION   ONE   ,         ZERO
+      PARAMETER        ( ONE   = 1.0D+0, ZERO  = 0.0D+0 )
+
+*     Check the input parameters.
+
+      IF( MIN( N, NCOLB ).EQ.0 )THEN
+         INFORM = 0
+         RETURN
+      END IF
+      IF( ( ( TRANS .NE.' ' ).AND.
+     $      ( TRANS .NE.'N' ).AND.( TRANS .NE.'n' ).AND.
+     $      ( TRANS .NE.'T' ).AND.( TRANS .NE.'t' ).AND.
+     $      ( TRANS .NE.'C' ).AND.( TRANS .NE.'c' )      ).OR.
+     $    ( ( WHEREZ.NE.'I' ).AND.( WHEREZ.NE.'i' ).AND.
+     $      ( WHEREZ.NE.'S' ).AND.( WHEREZ.NE.'s' )      ).OR.
+     $    ( M.LT.N ).OR.( N.LT.0 ).OR.( LDA.LT.M ).OR.
+     $    ( NCOLB.LT.0 ).OR.( LDB.LT.M )                      )THEN
+         INFORM = 1
+         RETURN
+      END IF
+
+*     Perform the transformation.
+
+      LB = LDB
+      DO 20, KK = 1, MIN( M - 1, N )
+         IF( ( TRANS.EQ.'T' ).OR.( TRANS.EQ.'t' ).OR.
+     $       ( TRANS.EQ.'C' ).OR.( TRANS.EQ.'c' )     )THEN
+
+*           Q'*B = Q( p )*...*Q( 2 )*Q( 1 )*B,     p = min( m - 1, n ).
+
+            K = KK
+         ELSE
+
+*           Q*B  = Q( 1 )'*Q( 2 )'*...*Q( p )'*B,  p = min( m - 1, n ).
+*           Note that  Q( k )' = Q( k ).
+
+            K = MIN( N, M - 1 ) + 1 - KK
+         END IF
+         IF( ( WHEREZ.EQ.'S' ).OR.( WHEREZ.EQ.'s' ) )THEN
+            TEMP      = A( K, K )
+            A( K, K ) = ZETA( K )
+         END IF
+
+*        If ZETA( k ) is zero then Q( k ) = I and we can skip the kth
+*        transformation.
+
+         IF( A( K, K ).GT.ZERO )THEN
+            IF( NCOLB.EQ.1 )
+     $         LB = M - K + 1
+
+*           Let C denote the bottom ( m - k + 1 ) by ncolb part of B.
+
+*           First form  work = C'*u.
+
+            DO 10, J = 1, NCOLB
+               WORK( J ) = ZERO
+   10       CONTINUE
+            CALL DGEMV ( 'Transpose', M - K + 1, NCOLB,
+     $                   ONE, B( K, 1 ), LB, A( K, K ), 1,
+     $                   ZERO, WORK, 1 )
+
+*           Now form  C := C - u*work'.
+
+            CALL DGER  ( M - K + 1, NCOLB, -ONE, A( K, K ), 1,
+     $                   WORK, 1, B( K, 1 ), LB )
+         END IF
+
+*        Restore the diagonal element of A.
+
+         IF( ( WHEREZ.EQ.'S' ).OR.( WHEREZ.EQ.'s' ) )
+     $      A( K, K ) = TEMP
+   20 CONTINUE
+
+      INFORM = 0
+      RETURN
+
+*     End of DGEAPQ.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/dgeqr.f
@@ -0,0 +1,222 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE DGEQR ( M, N, A, LDA, ZETA, INFORM )
+      INTEGER            M, N, LDA, INFORM
+      DOUBLE PRECISION   A( LDA, * ), ZETA( * )
+C
+C  1. Purpose
+C     =======
+C
+C  DGEQR  reduces the  m by n, m.ge.n, matrix A to upper triangular form
+C  by means of orthogonal transformations.
+C
+C  2. Description
+C     ===========
+C
+C  The m by n matrix A is factorized as
+C
+C     A = Q*( R )   when   m.gt.n,
+C           ( 0 )
+C
+C     A = Q*R       when   m = n,
+C
+C  where  Q  is an  m by m  orthogonal matrix and  R  is an n by n upper
+C  triangular matrix.
+C
+C  The  factorization  is  obtained  by  Householder's  method. The  kth
+C  transformation matrix, Q( k ), which is used to introduce zeros  into
+C  the kth column of A is given in the form
+C
+C     Q( k ) = ( I     0   ),
+C              ( 0  T( k ) )
+C
+C  where
+C
+C     T( k ) = I - u( k )*u( k )',   u( k ) = ( zeta( k ) ),
+C                                             (    z( k ) )
+C
+C  zeta( k )  is a scalar and  z( k )  is an  ( m - k )  element vector.
+C  zeta( k )  and  z( k ) are chosen to annhilate the elements below the
+C  triangular part of  A.
+C
+C  The vector  u( k )  is returned in the kth element of ZETA and in the
+C  kth column of A, such that zeta( k ) is in ZETA( k ) and the elements
+C  of z( k ) are in a( k + 1, k ), ..., a( m, k ). The elements of R are
+C  returned in the upper triangular part of  A.
+C
+C  Q is given by
+C
+C     Q = ( Q( p )*Q( p - 1 )*...*Q( 1 ) )',
+C
+C  where p = min( n, m - 1 ).
+C
+C  3. Parameters
+C     ==========
+C
+C  M      - INTEGER.
+C
+C           On entry, M must specify the number of rows of  A. M must be
+C           at least  n.
+C
+C           Unchanged on exit.
+C
+C  N      - INTEGER.
+C
+C           On entry, N must specify the number of columns of  A. N must
+C           be  at  least zero. When  N = 0  then an immediate return is
+C           effected.
+C
+C           Unchanged on exit.
+C
+C  A      - 'real' array of DIMENSION ( LDA, n ).
+C
+C           Before entry, the leading  M by N  part of the array  A must
+C           contain the matrix to be factorized.
+C
+C           On exit, the  N by N upper triangular part of A will contain
+C           the  upper  triangular  matrix  R  and the  M by N  strictly
+C           lower triangular part of  A  will  contain  details  of  the
+C           factorization as described above.
+C
+C  LDA    - INTEGER.
+C
+C           On entry, LDA  must  specify  the  leading dimension of  the
+C           array  A  as declared in the calling (sub) program. LDA must
+C           be at least  m.
+C
+C           Unchanged on exit.
+C
+C  ZETA   - 'real' array of DIMENSION at least ( n ).
+C
+C           On  exit, ZETA( k )  contains the scalar  zeta( k )  for the
+C           kth  transformation.  If  T( k ) = I  then   ZETA( k ) = 0.0
+C           otherwise  ZETA( k )  contains  zeta( k ) as described above
+C           and is always in the range ( 1.0, sqrt( 2.0 ) ).
+C
+C  INFORM - INTEGER.
+C
+C           On successful  exit  INFORM  will be zero, otherwise  INFORM
+C           will  be set to unity indicating that an input parameter has
+C           been  incorrectly  set. See  the  next section  for  further
+C           details.
+C
+C  4. Diagnostic Information
+C     ======================
+C
+C  INFORM = 1
+C
+C     One or more of the following conditions holds:
+C
+C        M   .lt. N
+C        N   .lt. 0
+C        LDA .lt. M
+C
+C  5. Further information
+C     ===================
+C
+C  Following the use of this routine the operations
+C
+C     B := Q'*B   and   B := Q*B,
+C
+C  where  B  is an  m by k  matrix, can  be  performed  by calls to  the
+C  auxiliary  linear  algebra routine  DGEAPQ. The  operation  B := Q'*B
+C  can be obtained by the call:
+C
+C     INFORM = 0
+C     CALL DGEAPQ( 'Transpose', 'Separate', M, N, A, LDA, ZETA,
+C    $             K, B, LDB, WORK, INFORM )
+C
+C  and  B := Q*B  can be obtained by the call:
+C
+C     INFORM = 0
+C     CALL DGEAPQ( 'No transpose', 'Separate', M, N, A, LDA, ZETA,
+C    $             K, B, LDB, WORK, INFORM )
+C
+C  In  both  cases  WORK  must be a  k  element array  that  is used  as
+C  workspace. If  B  is a one-dimensional array (single column) then the
+C  parameter  LDB  can be replaced by  M. See routine DGEAPQ for further
+C  details.
+C
+C  Operations involving the matrix  R  are performed by  the
+C  Level 2 BLAS  routines  DTRMV  and DTRSV . Note that no test for near
+C  singularity of R is incorporated in this routine or in routine  DTRSV
+C  and  so it is  strongly recommended that the auxiliary linear algebra
+C  routine  DUTCO  be called, prior to solving equations involving R, in
+C  order  to determine whether  or not  R  is nearly singular. If  R  is
+C  nearly  singular  then  the  auxiliary linear algebra  routine  DUTSV
+C  can  be used to  determine  the  singular value decomposition  of  R.
+C
+C
+C  Nag Fortran 77 Auxiliary linear algebra routine.
+C
+C  -- Written on 13-December-1984.
+C     Sven Hammarling, Nag Central Office.
+C
+      EXTERNAL           DGEMV , DGER  , DGRFG
+      INTRINSIC          MIN
+      INTEGER            J     , K     , LA
+      DOUBLE PRECISION   TEMP
+      DOUBLE PRECISION   ONE   ,         ZERO
+      PARAMETER        ( ONE   = 1.0D+0, ZERO  = 0.0D+0 )
+
+*     Check the input parameters.
+
+      IF( N.EQ.0 )THEN
+         INFORM = 0
+         RETURN
+      END IF
+      IF( ( M.LT.N ).OR.( N.LT.0 ).OR.( LDA.LT.M ) )THEN
+         INFORM = 1
+         RETURN
+      END IF
+
+*     Perform the factorization.
+
+      LA = LDA
+      DO 20, K = 1, MIN( M - 1, N )
+
+*        Use a Householder reflection to zero the kth column of A.
+*        First set up the reflection.
+
+         CALL DGRFG ( M - K, A( K, K ), A( K + 1, K ), 1, ZERO,
+     $                ZETA( K ) )
+         IF( ( ZETA( K ).GT.ZERO ).AND.( K.LT.N ) )THEN
+            IF( ( K + 1 ).EQ.N )
+     $         LA = M - K + 1
+            TEMP      = A( K, K )
+            A( K, K ) = ZETA( K )
+
+*           We now perform the operation  A := Q( k )*A.
+
+*           Let B denote the bottom ( m - k + 1 ) by ( n - k ) part
+*           of A.
+
+*           First form  work = B'*u. ( work is stored in the elements
+*           ZETA( k + 1 ), ..., ZETA( n ). )
+
+            CALL DGEMV ( 'Transpose', M - K + 1, N - K,
+     $                   ONE, A( K, K + 1 ), LA, A( K, K ), 1,
+     $                   ZERO, ZETA( K + 1 ), 1 )
+
+*           Now form  B := B - u*work'.
+
+            CALL DGER  ( M - K + 1, N - K, -ONE, A( K, K ), 1,
+     $                   ZETA( K + 1 ), 1, A( K, K + 1 ), LA )
+
+*           Restore beta.
+
+            A( K, K ) = TEMP
+         END IF
+   20 CONTINUE
+
+*     Store the final zeta when m.eq.n.
+
+      IF( M.EQ.N )
+     $   ZETA( N ) = ZERO
+
+      INFORM = 0
+      RETURN
+
+*     End of DGEQR .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/dgeqrp.f
@@ -0,0 +1,394 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE DGEQRP( PIVOT, M, N, A, LDA, ZETA, PERM, WORK, INFORM )
+      CHARACTER*1        PIVOT
+      INTEGER            M, N, LDA, INFORM
+      INTEGER            PERM( * )
+      DOUBLE PRECISION   A( LDA, * ), ZETA( * ), WORK( * )
+
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+
+C  1. Purpose
+C     =======
+C
+C  DGEQRP reduces the  m by n matrix A to upper triangular form by means
+C  of orthogonal transformations and column permutations.
+C
+C  2. Description
+C     ===========
+C
+C  The m by n matrix A is factorized as
+C
+C     A = Q*( R )*P'      when   m.gt.n,
+C           ( 0 )
+C
+C     A = Q*R*P'          when   m = n,
+C
+C     A = Q*( R  X )*P'   when   m.lt.n,
+C
+C  where  Q  is  an  m by m  orthogonal matrix, R  is a  min( m, n )  by
+C  min( m, n )  upper triangular matrix and  P is an  n by n permutation
+C  matrix.
+C
+C  The  factorization  is  obtained  by  Householder's  method. The  kth
+C  transformation matrix, Q( k ),  which is used to introduce zeros into
+C  the kth column of A is given in the form
+C
+C     Q( k ) = ( I     0   ),
+C              ( 0  T( k ) )
+C
+C  where
+C
+C     T( k ) = I - u( k )*u( k )',   u( k ) = ( zeta( k ) ),
+C                                             (    z( k ) )
+C
+C  zeta( k )  is a scalar and  z( k )  is an  ( m - k )  element vector.
+C  zeta( k )  and  z( k ) are chosen to annhilate the elements below the
+C  triangular part of  A.
+C
+C  The vector  u( k )  is returned in the kth element of ZETA and in the
+C  kth column of A, such that zeta( k ) is in ZETA( k ) and the elements
+C  of z( k ) are in a( k + 1, k ), ..., a( m, k ). The elements of R are
+C  returned in the upper triangular part of A.
+C
+C  Q is given by
+C
+C     Q = ( Q( p )*Q( p - 1 )*...*Q( 1 ) )',
+C
+C  where p = min( m - 1, n ).
+C
+C  Two options are available for the column permutations. In either case
+C  the column for which the  sub-diagonal elements are to be annihilated
+C  at the  kth step is chosen from the remaining ( n - k + 1 )  columns.
+C  The  particular column chosen as the pivot column is either that  for
+C  which  the  unreduced  part  ( elements k onwards )  has the  largest
+C  Euclidean  length, or  is that for  which the ratio of the  Euclidean
+C  length  of the  unreduced part  to the  Euclidean length of the whole
+C  column is a maximum.
+C
+C  3. Parameters
+C     ==========
+C
+C  PIVOT  - CHARACTER*1.
+C
+C           On  entry, PIVOT  specifies  the  pivoting  strategy  to  be
+C           performed as follows.
+C
+C           PIVOT = 'C' or 'c'
+C
+C              Column  interchanges  are  to be  incorporated  into  the
+C              factorization, such that the  column whose unreduced part
+C              has  maximum  Euclidean  length  is chosen  as the  pivot
+C              column at each step.
+C
+C           PIVOT = 'S' or 's'
+C
+C              Scaled  column interchanges  are to be  incorporated into
+C              the  factorization, such  that the  column for which  the
+C              ratio  of the  Euclidean  length of the unreduced part of
+C              the column to the original Euclidean length of the column
+C              is a maximum is chosen as the  pivot column at each step.
+C
+C           Unchanged on exit.
+C
+C  M      - INTEGER.
+C
+C           On entry, M  must specify the number of rows of A. M must be
+C           at  least  zero. When  M = 0  then  an  immediate return  is
+C           effected.
+C
+C           Unchanged on exit.
+C
+C  N      - INTEGER.
+C
+C           On entry, N  must specify the number of columns of A. N must
+C           be  at least zero. When  N = 0  then an immediate return  is
+C           effected.
+C
+C           Unchanged on exit.
+C
+C  A      - 'real' array of DIMENSION ( LDA, n ).
+C
+C           Before entry, the leading  M by N  part of the array  A must
+C           contain the matrix to be factorized.
+C
+C           On  exit, the  min( M, N ) by min( M, N )  upper  triangular
+C           part of A will contain the upper triangular matrix R and the
+C           M by min( M, N )  strictly lower triangular part of  A  will
+C           contain details  of the  factorization  as  described above.
+C           When m.lt.n then the remaining M by ( N - M ) part of A will
+C           contain the matrix X.
+C
+C  LDA    - INTEGER.
+C
+C           On  entry, LDA  must  specify  the leading dimension of  the
+C           array  A  as declared in the calling (sub) program. LDA must
+C           be at least  m.
+C
+C           Unchanged on exit.
+C
+C  ZETA   - 'real' array of DIMENSION at least ( n ).
+C
+C           On exit, ZETA( k )  contains the scalar  zeta  for  the  kth
+C           transformation. If T( k ) = I then ZETA( k) = 0.0, otherwise
+C           ZETA( k )  contains the scalar  zeta( k ) as described above
+C           and  is  always  in  the  range  ( 1.0, sqrt( 2.0 ) ).  When
+C           n .gt. m  the  elements  ZETA( m + 1 ),  ZETA( m + 2 ), ...,
+C           ZETA( n )  are used as internal workspace.
+C
+C  PERM   - INTEGER array of DIMENSION at least min( m, n ).
+C
+C           On exit, PERM  contains details of the permutation matrix P,
+C           such  that  PERM( k ) = k  if no  column interchange occured
+C           at  the  kth  step  and  PERM( k ) = j, ( k .lt. j .le. n ),
+C           if  columns  k and j  were  interchanged at  the  kth  step.
+C           Note  that, although  there are  min( m - 1, n )  orthogonal
+C           transformations, there are min( m, n ) permutations.
+C
+C  WORK   - 'real' array of DIMENSION at least ( 2*n ).
+C
+C           Used as internal workspace.
+C
+C           On exit, WORK( j ), j = 1, 2, ..., n, contains the Euclidean
+C           length  of the  jth  column  of the  permuted  matrix  A*P'.
+C
+C  INFORM - INTEGER.
+C
+C           On  successful exit, INFORM  will be zero, otherwise  INFORM
+C           will  be set to unity indicating that an input parameter has
+C           been  incorrectly supplied. See the next section for further
+C           details.
+C
+C  4. Diagnostic Information
+C     ======================
+C
+C  INFORM = 1
+C
+C     One or more of the following conditions holds:
+C
+C        PIVOT .ne. 'C' or 'c' or 'S' or 's'
+C        M     .lt. 0
+C        N     .lt. 0
+C        LDA   .lt. M
+C
+C  5. Further information
+C     ===================
+C
+C  Following the use of this routine the operations
+C
+C     B := Q'*B   and   B := Q*B,
+C
+C  where  B  is an  m by k  matrix, can  be  performed  by calls to  the
+C  auxiliary  linear algebra  routine  DGEAPQ. The  operation  B := Q'*B
+C  can be obtained by the call:
+C
+C     INFORM = 0
+C     CALL DGEAPQ( 'Transpose', 'Separate', M, N, A, LDA, ZETA,
+C    $             K, B, LDB, WORK, INFORM )
+C
+C  and  B := Q*B  can be obtained by the call:
+C
+C     INFORM = 0
+C     CALL DGEAPQ( 'No transpose', 'Separate', M, N, A, LDA, ZETA,
+C    $             K, B, LDB, WORK, INFORM )
+C
+C  In  both  cases  WORK  must be  a  k  element array  that is used  as
+C  workspace. If B is a one-dimensional array ( single column ) then the
+C  parameter  LDB  can be replaced by  M. See routine DGEAPQ for further
+C  details.
+C
+C  Also following the use of this routine the operations
+C
+C     B := P'*B   and   B := P*B,
+C
+C  where B is an n by k matrix, and the operations
+C
+C     B := B*P    and   B := B*P',
+C
+C  where  B is a k by n  matrix, can  be performed by calls to the basic
+C  linear  algebra  routine  DGEAP .  The  operation  B := P'*B  can  be
+C  obtained by the call:
+C
+C     CALL DGEAP ( 'Left', 'Transpose', N, MIN( M, N ), PERM,
+C    $             K, B, LDB )
+C
+C  the operation  B := P*B  can be obtained by the call:
+C
+C     CALL DGEAP ( 'Left', 'No transpose', N, MIN( M, N ), PERM,
+C    $             K, B, LDB )
+C
+C  If  B is a one-dimensional array ( single column ) then the parameter
+C  LDB  can be replaced by  N  in the above two calls.
+C  The operation  B := B*P  can be obtained by the call:
+C
+C     CALL DGEAP ( 'Right', 'No transpose', K, MIN( M, N ), PERM,
+C    $             M, B, LDB )
+C
+C  and  B := B*P'  can be obtained by the call:
+C
+C     CALL DGEAP ( 'Right', 'Transpose', K, MIN( M, N ), PERM,
+C    $             M, B, LDB )
+C
+C  If  B is a one-dimensional array ( single column ) then the parameter
+C  LDB  can be replaced by  K  in the above two calls.
+C  See routine DGEAP for further details.
+C
+C  Operations involving  the matrix  R  are performed by  the
+C  Level 2 BLAS  routines  DTRSV  and DTRMV.  Note that no test for near
+C  singularity of  R is incorporated in this routine or in routine DTRSV
+C  and  so it is  strongly recommended that the auxiliary linear algebra
+C  routine  DUTCO  be called, prior to solving equations involving R, in
+C  order  to determine whether  or not  R  is nearly singular. If  R  is
+C  nearly  singular then  the  auxiliary  linear algebra  routine  DUTSV
+C  can  be  used  to  determine  the  singular value decomposition of R.
+C  Operations  involving  the  matrix  X  can also be  performed  by the
+C  Level 2  BLAS  routines.  Matrices  of  the  form   ( R  X )  can  be
+C  factorized as
+C
+C     ( R  X ) = ( T  0 )*S',
+C
+C  where  T is upper triangular and S is orthogonal, using the auxiliary
+C  linear algebra routine  DUTRQ .
+C
+C
+C  Nag Fortran 77 Auxiliary linear algebra routine.
+C
+C  -- Written on 13-December-1984.
+C     Sven Hammarling, Nag Central Office.
+C
+      EXTERNAL           MCHPAR, DGEMV , DGER  , DGRFG , DNRM2 , DSWAP
+      INTRINSIC          ABS   , MAX   , MIN   , SQRT
+      INTEGER            J     , JMAX  , K     , LA
+      DOUBLE PRECISION   EPS   , MAXNRM, NORM  , DNRM2 , TEMP  , TOL
+      DOUBLE PRECISION   LAMDA
+      PARAMETER        ( LAMDA = 1.0D-2 )
+      DOUBLE PRECISION   ONE   ,         ZERO
+      PARAMETER        ( ONE   = 1.0D+0, ZERO  = 0.0D+0 )
+
+*     Check the input parameters.
+
+      IF( MIN( M, N ).EQ.0 )THEN
+         INFORM = 0
+         RETURN
+      END IF
+      IF( ( ( PIVOT.NE.'C' ).AND.( PIVOT.NE.'c' ).AND.
+     $      ( PIVOT.NE.'S' ).AND.( PIVOT.NE.'s' )      ).OR.
+     $    ( M.LT.0 ).OR.( N.LT.0 ).OR.( LDA.LT.M )           )THEN
+         INFORM = 1
+         RETURN
+      END IF
+
+*     Compute eps and the initial column norms.
+
+      CALL MCHPAR()
+      EPS = WMACH( 3 )
+      DO 10, J = 1, N
+         WORK( J )     = DNRM2 ( M, A( 1, J ), 1 )
+         WORK( J + N ) = WORK( J )
+   10 CONTINUE
+
+*     Perform the factorization. TOL is the tolerance for DGRFG .
+
+      LA = LDA
+      DO 50, K = 1, MIN( M, N )
+
+*        Find the pivot column.
+
+         MAXNRM = ZERO
+         JMAX   = K
+         DO 20, J = K, N
+            IF( ( PIVOT.EQ.'C' ).OR.( PIVOT.EQ.'c' ) )THEN
+               IF( WORK( J + N  ).GT.MAXNRM )THEN
+                  MAXNRM = WORK( J + N )
+                  JMAX   = J
+               END IF
+            ELSE IF( WORK( J ).GT.ZERO )THEN
+               IF( ( WORK( J + N )/WORK( J ) ).GT.MAXNRM )THEN
+                  MAXNRM = WORK( J + N )/WORK( J )
+                  JMAX   = J
+               END IF
+            END IF
+   20    CONTINUE
+         PERM( K ) = JMAX
+         IF( JMAX.GT.K )THEN
+            CALL DSWAP ( M, A( 1, K ), 1, A( 1, JMAX ), 1 )
+            TEMP             = WORK( K )
+            WORK( K )        = WORK( JMAX )
+            WORK( JMAX )     = TEMP
+            WORK( JMAX + N ) = WORK( K + N )
+            PERM( K )        = JMAX
+         END IF
+         TOL = EPS*WORK( K )
+         IF( K.LT.M )THEN
+
+*           Use a Householder reflection to zero the kth column of A.
+*           First set up the reflection.
+
+            CALL DGRFG ( M - K, A( K, K ), A( K + 1, K ), 1, TOL,
+     $                   ZETA( K ) )
+            IF( K.LT.N )THEN
+               IF( ZETA( K ).GT.ZERO )THEN
+                  IF( ( K + 1 ).EQ.N )
+     $               LA = M - K + 1
+                  TEMP      = A( K, K )
+                  A( K, K ) = ZETA( K )
+
+*                 We now perform the operation  A := Q( k )*A.
+
+*                 Let B denote the bottom ( m - k + 1 ) by ( n - k )
+*                 part of A.
+
+*                 First form  work = B'*u. ( work is stored in the
+*                 elements ZETA( k + 1 ), ..., ZETA( n ). )
+
+                  CALL DGEMV ( 'Transpose', M - K + 1, N - K,
+     $                         ONE, A( K, K + 1 ), LA, A( K, K ), 1,
+     $                         ZERO, ZETA( K + 1 ), 1 )
+
+*                 Now form  B := B - u*work'.
+
+                  CALL DGER  ( M - K + 1, N - K, -ONE, A( K, K ), 1,
+     $                         ZETA( K + 1 ), 1, A( K, K + 1 ), LA )
+
+*                 Restore beta.
+
+                  A( K, K ) = TEMP
+               END IF
+
+*              Update the unreduced column norms. Use the Linpack
+*              criterion for when to recompute the norms, except that
+*              we retain the original column lengths throughout and use
+*              a smaller lamda.
+
+               DO 40, J = K + 1, N
+                  IF( WORK( J + N ).GT.ZERO )THEN
+                     TEMP = ABS( A( K, J ) )/WORK( J + N )
+                     TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ), ZERO )
+                     NORM = TEMP
+                     TEMP = ONE +
+     $                      LAMDA*TEMP*( WORK( J + N )/WORK( J ) )**2
+                     IF( TEMP.GT.ONE )THEN
+                        WORK( J + N ) = WORK( J + N )*SQRT( NORM )
+                     ELSE
+                        WORK( J + N ) = DNRM2 ( M - K,
+     $                                          A( K + 1, J ), 1 )
+                     END IF
+                  END IF
+   40          CONTINUE
+            END IF
+         END IF
+   50 CONTINUE
+
+*     Store the final zeta when m.le.n.
+
+      IF( M.LE.N )
+     $   ZETA( M ) = ZERO
+
+      INFORM = 0
+      RETURN
+
+*     End of DGEQRP.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/dgrfg.f
@@ -0,0 +1,131 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE DGRFG ( N, ALPHA, X, INCX, TOL, ZETA )
+      INTEGER            N, INCX
+      DOUBLE PRECISION   ALPHA, X( * ), TOL, ZETA
+C
+C  DGRFG  generates details of a generalized Householder reflection such
+C  that
+C
+C     P*( alpha ) = ( beta ),   P'*P = I.
+C       (   x   )   (   0  )
+C
+C  P is given in the form
+C
+C     P = I - ( zeta )*( zeta  z' ),
+C             (   z  )
+C
+C  where z is an n element vector and zeta is a scalar that satisfies
+C
+C     1.0 .le. zeta .le. sqrt( 2.0 ).
+C
+C  zeta is returned in ZETA unless x is such that
+C
+C     max( abs( x( i ) ) ) .le. max( eps*abs( alpha ), tol )
+C
+C  where eps is the relative machine precision and tol is the user
+C  supplied value TOL, in which case ZETA is returned as 0.0 and P can
+C  be taken to be the unit matrix.
+C
+C  beta is overwritten on alpha and z is overwritten on x.
+C  the routine may be called with  n = 0  and advantage is taken of the
+C  case where  n = 1.
+C
+C
+C  Nag Fortran 77 O( n ) basic linear algebra routine.
+C
+C  -- Written on 30-August-1984.
+C     Sven Hammarling, Nag Central Office.
+C     This version dated 28-September-1984.
+C
+      EXTERNAL           DSSQ  , DSCAL
+      INTRINSIC          ABS   , MAX   , SIGN  , SQRT
+      LOGICAL            FIRST
+      DOUBLE PRECISION   BETA  , EPS   , SCALE , SSQ
+      DOUBLE PRECISION   ONE   ,         ZERO
+      PARAMETER        ( ONE   = 1.0D+0, ZERO  = 0.0D+0 )
+
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+
+      IF( N.LT.1 )THEN
+         ZETA = ZERO
+      ELSE IF( ( N.EQ.1 ).AND.( X( 1 ).EQ.ZERO ) )THEN
+         ZETA = ZERO
+      ELSE
+
+         EPS    =  WMACH( 3 )
+
+*        Treat case where P is a 2 by 2 matrix specially.
+
+         IF( N.EQ.1 )THEN
+
+*           Deal with cases where  ALPHA = zero  and
+*           abs( X( 1 ) ) .le. max( EPS*abs( ALPHA ), TOL )  first.
+
+            IF( ALPHA.EQ.ZERO )THEN
+               ZETA   =  ONE
+               ALPHA  =  ABS( X( 1 ) )
+               X( 1 ) = -SIGN( ONE, X( 1 ) )
+            ELSE IF( ABS( X( 1 ) ).LE.MAX( EPS*ABS( ALPHA ),
+     $                                     TOL ) )THEN
+               ZETA   =  ZERO
+            ELSE
+               IF( ABS( ALPHA ).GE.ABS( X( 1 ) ) )THEN
+                  BETA = ABS ( ALPHA  )*
+     $                   SQRT( ONE + ( X( 1 )/ALPHA )**2 )
+               ELSE
+                  BETA = ABS ( X( 1 ) )*
+     $                   SQRT( ONE + ( ALPHA/X( 1 ) )**2 )
+               END IF
+               ZETA   =  SQRT( ( ABS( ALPHA ) + BETA )/BETA )
+               IF( ALPHA.GE.ZERO )BETA = -BETA
+               X( 1 ) = -X( 1 )/( ZETA*BETA )
+               ALPHA  =  BETA
+            END IF
+         ELSE
+
+*           Now P is larger than 2 by 2.
+
+            SSQ   = ONE
+            SCALE = ZERO
+
+            CALL DSSQ  ( N, X, INCX, SCALE, SSQ )
+
+*           Treat cases where  SCALE = zero,
+*           SCALE .le. max( EPS*abs( ALPHA ), TOL )  and
+*           ALPHA = zero  specially.
+*           Note that  SCALE = max( abs( X( i ) ) ).
+
+            IF( ( SCALE.EQ.ZERO ).OR.
+     $          ( SCALE.LE.MAX( EPS*ABS( ALPHA ), TOL ) ) )THEN
+               ZETA  = ZERO
+            ELSE IF( ALPHA.EQ.ZERO )THEN
+               ZETA  = ONE
+               ALPHA = SCALE*SQRT( SSQ )
+
+               CALL DSCAL ( N, -ONE/ALPHA, X, INCX )
+
+            ELSE
+               IF( SCALE.LT.ABS( ALPHA ) )THEN
+                  BETA = ABS ( ALPHA )*
+     $                   SQRT( ONE + SSQ*( SCALE/ALPHA )**2 )
+               ELSE
+                  BETA = SCALE*
+     $                   SQRT( SSQ +     ( ALPHA/SCALE )**2 )
+               END IF
+               ZETA = SQRT( ( BETA + ABS( ALPHA ) )/BETA )
+               IF( ALPHA.GT.ZERO )BETA = -BETA
+
+               CALL DSCAL( N, -ONE/( ZETA*BETA ), X, INCX )
+
+               ALPHA = BETA
+            END IF
+         END IF
+      END IF
+      RETURN
+
+*     End of DGRFG .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/dload.f
@@ -0,0 +1,38 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE DLOAD ( N, CONST, X, INCX )
+      INTEGER            N, INCX
+      DOUBLE PRECISION   CONST
+      DOUBLE PRECISION   X( * )
+C
+C  DLOAD  performs the operation
+C
+C     x = const*e,   e' = ( 1  1 ... 1 ).
+C
+C
+C  Nag Fortran 77 O( n ) basic linear algebra routine.
+C
+C  -- Written on 22-September-1983.
+C     Sven Hammarling, Nag Central Office.
+C
+      INTEGER            IX
+      DOUBLE PRECISION   ZERO
+      PARAMETER        ( ZERO = 0.0D+0 )
+
+      IF( N.LT.1 )RETURN
+
+      IF( CONST.NE.ZERO )THEN
+         DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX
+            X( IX ) = CONST
+   10    CONTINUE
+      ELSE
+         DO 20, IX = 1, 1 + ( N - 1 )*INCX, INCX
+            X( IX ) = ZERO
+   20    CONTINUE
+      END IF
+
+      RETURN
+
+*     End of DLOAD .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/dnorm.f
@@ -0,0 +1,49 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      DOUBLE PRECISION FUNCTION DNORM ( SCALE, SSQ )
+      DOUBLE PRECISION                  SCALE, SSQ
+C
+C  DNORM  returns the value norm given by
+C
+C     norm = ( scale*sqrt( ssq ), scale*sqrt( ssq ) .lt. flmax
+C            (
+C            ( flmax,             scale*sqrt( ssq ) .ge. flmax
+C
+C  via the function name.
+C
+C
+C  Nag Fortran 77 O( 1 ) basic linear algebra routine.
+C
+C  -- Written on 22-October-1982.
+C     Sven Hammarling, Nag Central Office.
+C
+      INTRINSIC           SQRT
+      LOGICAL             FIRST
+      DOUBLE PRECISION    FLMAX , SQT
+      DOUBLE PRECISION    ONE
+      PARAMETER         ( ONE   = 1.0D+0 )
+
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+
+      SAVE                FIRST , FLMAX
+      DATA                FIRST / .TRUE. /
+
+      IF( FIRST )THEN
+         FIRST = .FALSE.
+         FLMAX = WMACH( 7 )
+      END IF
+
+      SQT = SQRT( SSQ )
+      IF( SCALE.LT.FLMAX/SQT )THEN
+         DNORM  = SCALE*SQT
+      ELSE
+         DNORM  = FLMAX
+      END IF
+
+      RETURN
+
+*     End of DNORM .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/drot3.f
@@ -0,0 +1,80 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE DROT3 ( N, X, INCX, Y, INCY, CS, SN )
+
+      INTEGER            N, INCX, INCY
+      DOUBLE PRECISION   CS, SN
+      DOUBLE PRECISION   X(*), Y(*)
+
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+
+C
+C  DROT3   applies the plane rotation defined by CS and SN to the
+C  columns of a 2 by N matrix held in X and Y.  The method used requires
+C  3 multiplications and 3 additions per column, as described in Gill,
+C  Golub, Murray and Saunders, Mathematics of Computation 28 (1974) 505-
+C  -535 (see page 508).
+C
+C  DROT3   guards against underflow, and overflow is extremely unlikely.
+C  It is assumed that CS and SN have been generated by DROT3G, ensuring
+C  that CS lies in the closed interval (0, 1),  and that the absolute
+C  value of CS and SN (if nonzero) is no less than the machine precision
+C  EPS.  It is also assumed that  RTMIN .lt. EPS.  Note that the magic
+C  number Z is therefore no less than 0.5*EPS in absolute value, so it
+C  is safe to use TOL = 2*RTMIN in the underflow test involving Z*A.
+C  For efficiency we use the same TOL in the previous two tests.
+C
+C  Systems Optimization Laboratory, Stanford University.
+C  Original version dated January 1982.
+C  F77 version dated 28-June-1986.
+C  This version of DROT3 dated 28-June-1986.
+C
+      INTEGER            I, IX, IY
+      DOUBLE PRECISION   A, B, ONE, RTMIN, TOL, W, Z, ZERO
+      INTRINSIC          ABS
+      PARAMETER        ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+
+      IF (N .LT. 1  .OR.  SN .EQ. ZERO) RETURN
+      IX = 1
+      IY = 1
+      IF (CS .EQ. ZERO) THEN
+
+*        Just swap  x  and  y.
+
+         DO 10 I = 1, N
+            A     = X(IX)
+            X(IX) = Y(IY)
+            Y(IY) = A
+            IX    = IX + INCX
+            IY    = IY + INCY
+   10    CONTINUE
+
+      ELSE
+
+         RTMIN  = WMACH(6)
+         TOL    = RTMIN + RTMIN
+         Z      = SN/(ONE + CS)
+
+         DO 20 I = 1, N
+            A     = X(IX)
+            B     = Y(IY)
+            W     = ZERO
+            IF (ABS(A) .GT. TOL) W = CS*A
+            IF (ABS(B) .GT. TOL) W = W + SN*B
+            X(IX) = W
+            A     = A + W
+            IF (ABS(A) .GT. TOL) B = B - Z*A
+            Y(IY) = - B
+            IX    =   IX + INCX
+            IY    =   IY + INCY
+   20    CONTINUE
+
+      END IF
+
+      RETURN
+
+*     End of  DROT3
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/drot3g.f
@@ -0,0 +1,100 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE DROT3G( X, Y, CS, SN )
+
+      DOUBLE PRECISION   X, Y, CS, SN
+
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+
+C
+C  DROT3G  generates a plane rotation that reduces the vector (X, Y) to
+C  the vector (A, 0),  where A is defined as follows...
+C
+C     If both X and Y are negligibly small, or
+C     if Y is negligible relative to Y,
+C     then  A = X,  and the identity rotation is returned.
+C
+C     If X is negligible relative to Y,
+C     then  A = Y,  and the swap rotation is returned.
+C
+C     Otherwise,  A = sign(X) * sqrt( X**2 + Y**2 ).
+C
+C  In all cases,  X and Y are overwritten by A and 0,  and CS will lie
+C  in the closed interval (0, 1).  Also,  the absolute value of CS and
+C  SN (if nonzero) will be no less than the machine precision,  EPS.
+C
+C  DROT3G  guards against overflow and underflow.
+C  It is assumed that  FLMIN .lt. EPS**2  (i.e.  RTMIN .lt. EPS).
+C
+C  Systems Optimization Laboratory, Stanford University.
+C  Original version dated January 1982.
+C  F77 version dated 28-June-1986.
+C  This version of DROT3G dated 28-June-1986.
+C
+      DOUBLE PRECISION   A, B, EPS, ONE, RTMIN, ZERO
+      LOGICAL            FIRST
+      INTRINSIC          ABS, MAX, SQRT
+      PARAMETER        ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+
+      SAVE               FIRST , EPS   , RTMIN
+      DATA               FIRST / .TRUE. /
+
+      IF( FIRST )THEN
+         FIRST = .FALSE.
+         EPS    = WMACH(3)
+         RTMIN  = WMACH(6)
+      END IF
+
+      IF (Y .EQ. ZERO) THEN
+
+         CS = ONE
+         SN = ZERO
+
+      ELSE IF (X .EQ. ZERO) THEN
+
+         CS = ZERO
+         SN = ONE
+         X  = Y
+
+      ELSE
+
+         A      = ABS(X)
+         B      = ABS(Y)
+         IF (MAX(A,B) .LE. RTMIN) THEN
+            CS = ONE
+            SN = ZERO
+         ELSE
+            IF (A .GE. B) THEN
+               IF (B .LE. EPS*A) THEN
+                  CS = ONE
+                  SN = ZERO
+                  GO TO 900
+               ELSE
+                  A  = A * SQRT( ONE + (B/A)**2 )
+               END IF
+            ELSE
+               IF (A .LE. EPS*B) THEN
+                  CS = ZERO
+                  SN = ONE
+                  X  = Y
+                  GO TO 900
+               ELSE
+                  A  = B * SQRT( ONE + (A/B)**2 )
+               END IF
+            END IF
+            IF (X .LT. ZERO) A = - A
+            CS = X/A
+            SN = Y/A
+            X  = A
+         END IF
+      END IF
+
+  900 Y  = ZERO
+
+      RETURN
+
+*     End of  DROT3G
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/dssq.f
@@ -0,0 +1,55 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE DSSQ  ( N, X, INCX, SCALE, SUMSQ )
+      INTEGER            N, INCX
+      DOUBLE PRECISION   X( * )
+      DOUBLE PRECISION   SCALE, SUMSQ
+C
+C  DSSQ   returns the values scl and smsq such that
+C
+C     ( scl**2 )*smsq = y( 1 )**2 +...+ y( n )**2 + ( scale**2 )*sumsq,
+C
+C  where y( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is assumed
+C  to be at least unity and the value of smsq will then satisfy
+C
+C     1.0 .le. smsq .le. ( sumsq + n ) .
+C
+C  scale is assumed to be non-negative and scl returns the value
+C
+C     scl = max( scale, abs( x( i ) ) ) .
+C
+C  scale and sumsq must be supplied in SCALE and SUMSQ respectively.
+C  scl and smsq are overwritten on SCALE and SUMSQ respectively.
+C
+C  The routine makes only one pass through the vector X.
+C
+C
+C  Nag Fortran 77 O( n ) basic linear algebra routine.
+C
+C  -- Written on 22-October-1982.
+C     Sven Hammarling, Nag Central Office.
+C
+      INTRINSIC          ABS
+      INTEGER            IX
+      DOUBLE PRECISION   ABSXI
+      DOUBLE PRECISION   ONE   ,         ZERO
+      PARAMETER        ( ONE   = 1.0D+0, ZERO  = 0.0D+0 )
+
+      IF( N.GE.1 )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 = ONE   + SUMSQ*( SCALE/ABSXI )**2
+                  SCALE = ABSXI
+               ELSE
+                  SUMSQ = SUMSQ +       ( ABSXI/SCALE )**2
+               END IF
+            END IF
+   10    CONTINUE
+      END IF
+      RETURN
+
+*     End of DSSQ  .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/icopy.f
@@ -0,0 +1,38 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE ICOPY ( N, IX, INCIX, IY, INCIY )
+
+      INTEGER            N, INCIX, INCIY
+      INTEGER            IX(*), IY(*)
+
+C
+C  Copy the first N elements of IX into IY.
+C
+
+      INTEGER            J, JX, JY
+
+      IF (N .GE. 1) THEN
+         IF (INCIX .EQ. 1  .AND.  INCIY .EQ. 1) THEN
+
+            DO 10 J = 1, N
+               IY(J) = IX(J)
+   10       CONTINUE
+
+         ELSE
+
+            JX = 1
+            JY = 1
+            DO 20 J = 1, N
+               IY(JY) = IX(JX)
+               JX = JX + INCIX
+               JY = JY + INCIY
+   20       CONTINUE
+
+         END IF
+      END IF
+
+      RETURN
+
+*     End of  ICOPY
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/idrank.f
@@ -0,0 +1,62 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      INTEGER           FUNCTION IDRANK( N, X, INCX, TOL )
+      INTEGER                            N, INCX
+      DOUBLE PRECISION                   X( * ), TOL
+
+C  IDRANK finds the first element of the n element vector x for which
+C
+C     abs( x( k ) ).le.( tol*max ( abs(x(1)), ..., abs(x(k-1)) )
+C
+C  and returns the value ( k - 1 ) in the function name IDRANK. If no
+C  such k exists then IDRANK is returned as n.
+C
+C  If TOL is supplied as less than zero then the value EPSMCH, where
+C  EPSMCH is the relative machine precision, is used in place of TOL.
+C
+C
+C  Nag Fortran 77 O( n ) basic linear algebra routine.
+C
+C  -- Written on 21-January-1985.
+C     Sven Hammarling, Nag Central Office.
+C     Modified by PEG, 19-December-1985.
+
+      INTRINSIC                          ABS   , MAX
+      INTEGER                            IX    , K
+      DOUBLE PRECISION                   TOLRNK, XMAX  , ZERO
+      PARAMETER                        ( ZERO  = 0.0D+0 )
+
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+
+      K = 0
+      IF (N .GE. 1) THEN
+         TOLRNK = TOL
+         IF (TOL .LT. ZERO) TOLRNK = WMACH(3)
+
+         IF( INCX .GT. 0 )THEN
+            IX = 1
+         ELSE
+            IX = 1 - ( N - 1 )*INCX
+         END IF
+
+         XMAX = ABS( X(IX) )
+
+*+       WHILE (K .LT. N) LOOP
+   10    IF    (K .LT. N) THEN
+            IF (ABS( X(IX) ) .LE. XMAX*TOLRNK) GO TO 20
+            XMAX = MAX( XMAX, ABS( X(IX) ) )
+            K    = K  + 1
+            IX   = IX + INCX
+            GO TO 10
+         END IF
+*+       END WHILE
+
+      END IF
+   20 IDRANK = K
+      RETURN
+
+*     End of IDRANK.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/iload.f
@@ -0,0 +1,36 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE ILOAD ( N, ICONST, IX, INCIX )
+      INTEGER            N, INCIX
+      INTEGER            ICONST
+      INTEGER            IX( * )
+C
+C  ILOAD   performs the operation
+C
+C     ix = iconst*e,   e' = ( 1  1 ... 1 ).
+C
+C
+C  Nag Fortran 77 O( n ) basic linear algebra routine.
+C
+C  -- Written on 22-September-1983.
+C     Sven Hammarling, Nag Central Office.
+C
+      INTEGER            JX
+
+      IF( N.LT.1 )RETURN
+
+      IF( ICONST.NE.0 )THEN
+         DO 10, JX = 1, 1 + ( N - 1 )*INCIX, INCIX
+            IX( JX ) = ICONST
+   10    CONTINUE
+      ELSE
+         DO 20, JX = 1, 1 + ( N - 1 )*INCIX, INCIX
+            IX( JX ) = 0
+   20    CONTINUE
+      END IF
+
+      RETURN
+
+*     End of ILOAD .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lsadd.f
@@ -0,0 +1,301 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+*     File  LSSUBS FORTRAN
+*
+*     LSADD    LSADDS   LSBNDS   LSCHOL   LSCORE   LSCRSH   LSDEL
+*     LSDFLT   LSFEAS   LSFILE   LSGETP   LSGSET   LSKEY    LSLOC
+*     LSMOVE   LSMULS   LSOPTN   LSPRT    LSSETX   LSSOL
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSADD ( UNITQ,
+     $                   INFORM, IFIX, IADD, JADD,
+     $                   NACTIV, NZ, NFREE, NRANK, NRES, NGQ,
+     $                   N, NROWA, NQ, NROWR, NROWT,
+     $                   KX, CONDMX,
+     $                   A, R, T, RES, GQ, ZY, WRK1, WRK2 )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      LOGICAL            UNITQ
+      INTEGER            KX(N)
+      DOUBLE PRECISION   A(NROWA,*), R(NROWR,*), T(NROWT,*),
+     $                   RES(N,*), GQ(N,*), ZY(NQ,*)
+      DOUBLE PRECISION   WRK1(N), WRK2(N)
+************************************************************************
+*  LSADD   updates the factorization,  A(free) * (Z Y) = (0 T),  when a
+*  constraint is added to the working set.  If  NRANK .gt. 0, the
+*  factorization  ( R ) = PWQ  is also updated,  where  W  is the
+*                 ( 0 )
+*  least squares matrix,  R  is upper-triangular,  and  P  is an
+*  orthogonal matrix.  The matrices  W  and  P  are not stored.
+*
+*  There are three separate cases to consider (although each case
+*  shares code with another)...
+*
+*  (1) A free variable becomes fixed on one of its bounds when there
+*      are already some general constraints in the working set.
+*
+*  (2) A free variable becomes fixed on one of its bounds when there
+*      are only bound constraints in the working set.
+*
+*  (3) A general constraint (corresponding to row  IADD  of  A) is
+*      added to the working set.
+*
+*  In cases (1) and (2), we assume that  KX(IFIX) = JADD.
+*  In all cases,  JADD  is the index of the constraint being added.
+*
+*  If there are no general constraints in the working set,  the
+*  matrix  Q = (Z Y)  is the identity and will not be touched.
+*
+*  If  NRES .GT. 0,  the row transformations are applied to the rows of
+*  the  (N by NRES)  matrix  RES.
+*  If  NGQ .GT. 0,  the column transformations are applied to the
+*  columns of the  (NGQ by N)  matrix  GQ'.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Original version written 31-October--1984.
+*  This version of LSADD dated 29-December-1985.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9
+      COMMON    /SOL5CM/ ASIZE, DTMAX, DTMIN
+
+      LOGICAL            LSDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /LSDEBG/ ILSDBG(LDBG), LSDBG
+
+      LOGICAL            BOUND , OVERFL
+      EXTERNAL           DDOT  , DDIV  , DNRM2
+      INTRINSIC          MAX   , MIN
+      PARAMETER         (ZERO = 0.0D+0, ONE = 1.0D+0)
+
+*     If the condition estimator of the updated factors is greater than
+*     CONDBD,  a warning message is printed.
+
+      CONDBD = ONE / EPSPT9
+
+      OVERFL = .FALSE.
+      BOUND  = JADD .LE. N
+      IF (BOUND) THEN
+*        ===============================================================
+*        A simple bound has entered the working set.  IADD  is not used.
+*        ===============================================================
+         IF (LSDBG  .AND.  ILSDBG(1) .GT. 0)
+     $      WRITE (NOUT, 1010) NACTIV, NZ, NFREE, IFIX, JADD, UNITQ
+         NANEW = NACTIV
+
+         IF (UNITQ) THEN
+
+*           Q  is not stored, but KX defines an ordering of the columns
+*           of the identity matrix that implicitly define  Q.
+*           Reorder KX so that variable IFIX is moved to position
+*           NFREE+1 and variables IFIX+1,...,NFREE+1 are moved one
+*           position to the left.
+
+            CALL DLOAD ( NFREE, (ZERO), WRK1, 1 )
+            WRK1(IFIX) = ONE
+
+            DO 100 I = IFIX, NFREE-1
+               KX(I) = KX(I+1)
+  100       CONTINUE
+         ELSE
+*           ------------------------------------------------------------
+*           Q  is stored explicitly.
+*           ------------------------------------------------------------
+*           Set  WRK1 = the  (IFIX)-th  row of  Q.
+*           Move the  (NFREE)-th  row of  Q  to position  IFIX.
+
+            CALL DCOPY ( NFREE, ZY(IFIX,1), NQ, WRK1, 1 )
+            IF (IFIX .LT. NFREE) THEN
+               CALL DCOPY ( NFREE, ZY(NFREE,1), NQ, ZY(IFIX,1), NQ )
+               KX(IFIX) = KX(NFREE)
+            END IF
+         END IF
+         KX(NFREE) = JADD
+      ELSE
+*        ===============================================================
+*        A general constraint has entered the working set.
+*        IFIX  is not used.
+*        ===============================================================
+         IF (LSDBG  .AND.  ILSDBG(1) .GT. 0)
+     $      WRITE (NOUT, 1020) NACTIV, NZ, NFREE, IADD, JADD, UNITQ
+
+         NANEW  = NACTIV + 1
+
+*        Transform the incoming row of  A  by  Q'.
+
+         CALL DCOPY ( N, A(IADD,1), NROWA, WRK1, 1 )
+         CALL CMQMUL( 8, N, NZ, NFREE, NQ, UNITQ, KX, WRK1, ZY, WRK2)
+
+*        Check that the incoming row is not dependent upon those
+*        already in the working set.
+
+         DTNEW  = DNRM2 ( NZ, WRK1, 1 )
+         IF (NACTIV .EQ. 0) THEN
+
+*           This is the only general constraint in the working set.
+
+            COND   = DDIV  ( ASIZE, DTNEW, OVERFL )
+            TDTMAX = DTNEW
+            TDTMIN = DTNEW
+         ELSE
+
+*           There are already some general constraints in the working
+*           set. Update the estimate of the condition number.
+
+            TDTMAX = MAX( DTNEW, DTMAX )
+            TDTMIN = MIN( DTNEW, DTMIN )
+            COND   = DDIV  ( TDTMAX, TDTMIN, OVERFL )
+         END IF
+
+         IF (COND .GT. CONDMX  .OR.  OVERFL) GO TO 900
+
+         IF (UNITQ) THEN
+
+*           This is the first general constraint to be added.
+*           Set  Q = I.
+
+            DO 200 J = 1, NFREE
+               CALL DLOAD ( NFREE, (ZERO), ZY(1,J), 1 )
+               ZY(J,J) = ONE
+  200       CONTINUE
+            UNITQ  = .FALSE.
+         END IF
+      END IF
+
+      NZERO  = NZ - 1
+      IF (BOUND) NZERO = NFREE - 1
+
+*     ------------------------------------------------------------------
+*     Use a sequence of 2*2 column transformations to reduce the
+*     first NZERO elements of WRK1 to zero.  This affects ZY, except
+*     when UNITQ is true.  The transformations may also be applied
+*     to R, T and GQ'.
+*     ------------------------------------------------------------------
+      LROWR  = N
+      NELM   = 1
+      IROWT  = NACTIV
+
+      DO 300 K = 1, NZERO
+
+*        Compute the transformation that reduces WRK1(K) to zero,
+*        then apply it to the relevant columns of  Z  and  GQ'.
+
+         CALL DROT3G( WRK1(K+1), WRK1(K), CS, SN )
+         IF (.NOT. UNITQ)
+     $      CALL DROT3 ( NFREE, ZY(1,K+1), 1, ZY(1,K), 1, CS, SN )
+         IF (NGQ .GT. 0)
+     $      CALL DROT3 ( NGQ  , GQ(K+1,1), N, GQ(K,1), N, CS, SN )
+
+         IF (K .GE. NZ  .AND.  NACTIV .GT. 0) THEN
+
+*           Apply the rotation to  T.
+
+            T(IROWT,K) = ZERO
+            CALL DROT3 ( NELM, T(IROWT,K+1), 1, T(IROWT,K), 1, CS, SN )
+            NELM  = NELM  + 1
+            IROWT = IROWT - 1
+         END IF
+
+         IF (NRANK .GT. 0) THEN
+
+*           Apply the same transformation to the columns of R.
+*           This generates a subdiagonal element in R that must be
+*           eliminated by a row rotation.
+
+            IF (K .LT. NRANK) R(K+1,K) = ZERO
+            LCOL   = MIN( K+1, NRANK )
+
+            CALL DROT3 ( LCOL, R(1,K+1), 1, R(1,K), 1, CS, SN )
+            IF (K .LT. NRANK) THEN
+               CALL DROT3G( R(K,K), R(K+1,K), CS, SN )
+               LROWR  = LROWR - 1
+               CALL DROT3 ( LROWR,   R(K,K+1)  , NROWR,
+     $                               R(K+1,K+1), NROWR, CS, SN )
+
+               IF (NRES .GT. 0)
+     $            CALL DROT3 ( NRES, RES(K,1)  , N    ,
+     $                               RES(K+1,1), N    , CS, SN )
+            END IF
+         END IF
+  300 CONTINUE
+
+      IF (BOUND) THEN
+
+*        The last row and column of ZY has been transformed to plus
+*        or minus the unit vector E(NFREE).  We can reconstitute the
+*        columns of GQ and R corresponding to the new fixed variable.
+
+         IF (WRK1(NFREE) .LT. ZERO) THEN
+            NFMIN = MIN( NRANK, NFREE )
+            IF (NFMIN .GT. 0) CALL DSCAL ( NFMIN, -ONE, R(1,NFREE) , 1 )
+            IF (NGQ   .GT. 0) CALL DSCAL ( NGQ  , -ONE, GQ(NFREE,1), N )
+         END IF
+
+*        ---------------------------------------------------------------
+*        The diagonals of T have been altered.  Recompute the
+*        largest and smallest values.
+*        ---------------------------------------------------------------
+         IF (NACTIV .GT. 0) THEN
+            CALL DCOND( NACTIV, T(NACTIV,NZ), NROWT-1, TDTMAX, TDTMIN )
+            COND   = DDIV  ( TDTMAX, TDTMIN, OVERFL )
+         END IF
+      ELSE
+*        ---------------------------------------------------------------
+*        General constraint.  Install the new row of T.
+*        ---------------------------------------------------------------
+         CALL DCOPY ( NANEW, WRK1(NZ), 1, T(NANEW,NZ), NROWT )
+      END IF
+
+*     ==================================================================
+*     Prepare to exit.  Check the magnitude of the condition estimator.
+*     ==================================================================
+  900 IF (NANEW .GT. 0) THEN
+         IF (COND .LT. CONDMX  .AND.  .NOT. OVERFL) THEN
+
+*           The factorization has been successfully updated.
+
+            INFORM = 0
+            DTMAX  = TDTMAX
+            DTMIN  = TDTMIN
+            IF (COND .GE. CONDBD) WRITE (NOUT, 2000) JADD
+         ELSE
+
+*           The proposed working set appears to be linearly dependent.
+
+            INFORM = 1
+            IF (LSDBG  .AND.  ILSDBG(1) .GT. 0) THEN
+               WRITE( NOUT, 3000 )
+               IF (BOUND) THEN
+                  WRITE (NOUT, 3010) ASIZE, DTMAX, DTMIN
+               ELSE
+                  IF (NACTIV .GT. 0) THEN
+                     WRITE (NOUT, 3020) ASIZE, DTMAX, DTMIN, DTNEW
+                  ELSE
+                     WRITE (NOUT, 3030) ASIZE, DTNEW
+                  END IF
+               END IF
+            END IF
+         END IF
+      END IF
+
+      RETURN
+
+ 1010 FORMAT(/ ' //LSADD //  Simple bound added.'
+     $       / ' //LSADD //  NACTIV    NZ NFREE  IFIX  JADD UNITQ'
+     $       / ' //LSADD //  ', 5I6, L6 )
+ 1020 FORMAT(/ ' //LSADD //  General constraint added.           '
+     $       / ' //LSADD //  NACTIV    NZ NFREE  IADD  JADD UNITQ'
+     $       / ' //LSADD //  ', 5I6, L6 )
+ 2000 FORMAT(/ ' XXX  Serious ill-conditioning in the working set',
+     $         ' after adding constraint ',  I5
+     $       / ' XXX  Overflow may occur in subsequent iterations.'//)
+ 3000 FORMAT(/ ' //LSADD //  Dependent constraint rejected.' )
+ 3010 FORMAT(/ ' //LSADD //     ASIZE     DTMAX     DTMIN        '
+     $       / ' //LSADD //', 1P3E10.2 )
+ 3020 FORMAT(/ ' //LSADD //     ASIZE     DTMAX     DTMIN     DTNEW'
+     $       / ' //LSADD //', 1P4E10.2 )
+ 3030 FORMAT(/ ' //LSADD //     ASIZE     DTNEW'
+     $       / ' //LSADD //', 1P2E10.2 )
+
+*     End of  LSADD .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lsadds.f
@@ -0,0 +1,137 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSADDS( UNITQ, VERTEX,
+     $                   INFORM, K1, K2, NACTIV, NARTIF, NZ, NFREE,
+     $                   NRANK, NREJTD, NRES, NGQ,
+     $                   N, NQ, NROWA, NROWR, NROWT,
+     $                   ISTATE, KACTIV, KX,
+     $                   CONDMX,
+     $                   A, R, T, RES, GQ,
+     $                   ZY, WRK1, WRK2 )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      LOGICAL            UNITQ, VERTEX
+      INTEGER            ISTATE(*), KACTIV(N), KX(N)
+      DOUBLE PRECISION   CONDMX
+      DOUBLE PRECISION   A(NROWA,*), R(NROWR,*),
+     $                   T(NROWT,*), RES(N,*), GQ(N,*), ZY(NQ,*)
+      DOUBLE PRECISION   WRK1(N), WRK2(N)
+
+************************************************************************
+*     LSADDS  includes general constraints K1 thru K2 as new rows of
+*     the TQ factorization stored in T, ZY.  If NRANK is nonzero, the
+*     changes in Q are reflected in NRANK by N triangular factor R such
+*     that
+*                         W  =  P ( R ) Q,
+*                                 ( 0 )
+*     where  P  is orthogonal.
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     Original version written  October-31-1984.
+*     This version of LSADDS dated 30-December-1985.
+************************************************************************
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+      COMMON    /SOL5CM/ ASIZE, DTMAX, DTMIN
+
+      EXTERNAL           DNRM2
+      PARAMETER        ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+
+      RTMAX  = WMACH(8)
+
+*     Estimate the condition number of the constraints that are not
+*     to be refactorized.
+
+      IF (NACTIV .EQ. 0) THEN
+         DTMAX = ZERO
+         DTMIN = ONE
+      ELSE
+         CALL DCOND ( NACTIV, T(NACTIV,NZ+1), NROWT-1, DTMAX, DTMIN )
+      END IF
+
+      DO 200 K = K1, K2
+         IADD = KACTIV(K)
+         JADD = N + IADD
+         IF (NACTIV .LT. NFREE) THEN
+
+            CALL LSADD ( UNITQ,
+     $                   INFORM, IFIX, IADD, JADD,
+     $                   NACTIV, NZ, NFREE, NRANK, NRES, NGQ,
+     $                   N, NROWA, NQ, NROWR, NROWT,
+     $                   KX, CONDMX,
+     $                   A, R, T, RES, GQ, ZY,
+     $                   WRK1, WRK2 )
+
+            IF (INFORM .EQ. 0) THEN
+               NACTIV = NACTIV + 1
+               NZ     = NZ     - 1
+            ELSE
+               ISTATE(JADD) =   0
+               KACTIV(K)    = - KACTIV(K)
+            END IF
+         END IF
+  200 CONTINUE
+
+      IF (NACTIV .LT. K2) THEN
+
+*        Some of the constraints were classed as dependent and not
+*        included in the factorization.  Re-order the part of  KACTIV
+*        that holds the indices of the general constraints in the
+*        working set.  Move accepted indices to the front and shift
+*        rejected indices (with negative values) to the end.
+
+         L      = K1 - 1
+         DO 300 K = K1, K2
+            I         = KACTIV(K)
+            IF (I .GE. 0) THEN
+               L      = L + 1
+               IF (L .NE. K) THEN
+                  ISWAP     = KACTIV(L)
+                  KACTIV(L) = I
+                  KACTIV(K) = ISWAP
+               END IF
+            END IF
+  300    CONTINUE
+
+*        If a vertex is required, add some temporary bounds.
+*        We must accept the resulting condition number of the working
+*        set.
+
+         IF (VERTEX) THEN
+            CNDMAX = RTMAX
+            NZADD  = NZ
+            DO 320 IARTIF = 1, NZADD
+               ROWMAX = ZERO
+               DO 310 I = 1, NFREE
+                  RNORM = DNRM2 ( NZ, ZY(I,1), NQ )
+                  IF (ROWMAX .LT. RNORM) THEN
+                     ROWMAX = RNORM
+                     IFIX   = I
+                  END IF
+  310          CONTINUE
+               JADD = KX(IFIX)
+
+               CALL LSADD ( UNITQ,
+     $                      INFORM, IFIX, IADD, JADD,
+     $                      NACTIV, NZ, NFREE, NRANK, NRES, NGQ,
+     $                      N, NROWA, NQ, NROWR, NROWT,
+     $                      KX, CNDMAX,
+     $                      A, R, T, RES, GQ, ZY,
+     $                      WRK1, WRK2 )
+
+               NFREE  = NFREE  - 1
+               NZ     = NZ     - 1
+               NARTIF = NARTIF + 1
+               ISTATE(JADD) = 4
+  320       CONTINUE
+         END IF
+      END IF
+
+      NREJTD = K2 - NACTIV
+
+      RETURN
+
+*     End of  LSADDS.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lsbnds.f
@@ -0,0 +1,103 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSBNDS( UNITQ,
+     $                   INFORM, NZ, NFREE, NRANK, NRES, NGQ,
+     $                   N, NQ, NROWA, NROWR, NROWT,
+     $                   ISTATE, KX,
+     $                   CONDMX,
+     $                   A, R, T, RES, GQ,
+     $                   ZY, WRK1, WRK2 )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      LOGICAL            UNITQ
+      INTEGER            ISTATE(*), KX(N)
+      DOUBLE PRECISION   CONDMX
+      DOUBLE PRECISION   A(NROWA,*), R(NROWR,*),
+     $                   T(NROWT,*), RES(N,*), GQ(N,*), ZY(NQ,*)
+      DOUBLE PRECISION   WRK1(N), WRK2(N)
+
+************************************************************************
+*     LSBNDS updates the factor R as KX is reordered to reflect the
+*     status of the bound constraints given by ISTATE.  KX is reordered
+*     so that the fixed variables come last.  One of two alternative
+*     are used to reorder KX. One method needs fewer accesses to KX, the
+*     other gives a matrix Rz with more rows and columns.
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     Original version written  30-December-1985.
+*     This version dated 30-December-1985.
+************************************************************************
+
+      NFIXED = N - NFREE
+
+      IF (NRANK .LT. N  .AND.  NRANK .GT. 0) THEN
+*        ---------------------------------------------------------------
+*        R is specified but singular.  Try and keep the dimension of Rz
+*        as large as possible.
+*        ---------------------------------------------------------------
+         NACTV = 0
+         NFREE = N
+         NZ    = N
+
+         J     = N
+*+       WHILE (J .GT. 0  .AND.  N-NFREE .LT. NFIXED) DO
+  100    IF    (J .GT. 0  .AND.  N-NFREE .LT. NFIXED) THEN
+            IF (ISTATE(J) .GT. 0) THEN
+               JADD = J
+               DO 110 IFIX = NFREE, 1, -1
+                  IF (KX(IFIX) .EQ. JADD) GO TO 120
+  110          CONTINUE
+
+*              Add bound JADD.
+
+  120          CALL LSADD ( UNITQ,
+     $                      INFORM, IFIX, IADD, JADD,
+     $                      NACTV, NZ, NFREE, NRANK, NRES, NGQ,
+     $                      N, NROWA, NQ, NROWR, NROWT,
+     $                      KX, CONDMX,
+     $                      A, R, T, RES, GQ, ZY,
+     $                      WRK1, WRK2 )
+
+               NFREE = NFREE - 1
+               NZ    = NZ    - 1
+            END IF
+            J = J - 1
+            GO TO 100
+*+       END WHILE
+         END IF
+      ELSE
+*        ---------------------------------------------------------------
+*        R is of full rank,  or is not specified.
+*        ---------------------------------------------------------------
+         IF (NFIXED .GT. 0) THEN
+
+*           Order KX so that the free variables come first.
+
+            LSTART = NFREE + 1
+            DO 250 K = 1, NFREE
+               J = KX(K)
+               IF (ISTATE(J) .GT. 0) THEN
+                  DO 220 L = LSTART, N
+                     J2 = KX(L)
+                     IF (ISTATE(J2) .EQ. 0) GO TO 230
+  220             CONTINUE
+
+  230             KX(K)  = J2
+                  KX(L)  = J
+                  LSTART = L + 1
+
+                  IF (NRANK .GT. 0)
+     $               CALL CMRSWP( N, NRES, NRANK, NROWR, K, L,
+     $                            R, RES, WRK1 )
+               END IF
+  250       CONTINUE
+
+         END IF
+         NZ = NFREE
+      END IF
+
+      RETURN
+
+*     End of  LSBNDS.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lschol.f
@@ -0,0 +1,109 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSCHOL( NROWH, N, NRANK, TOLRNK, KX, H, INFORM )
+
+      IMPLICIT           DOUBLE PRECISION (A-H,O-Z)
+      INTEGER            KX(*)
+      DOUBLE PRECISION   H(NROWH,*)
+
+************************************************************************
+*     LSCHOL  forms the Cholesky factorization of the positive
+*     semi-definite matrix H such that
+*                   PHP'  =  R'R
+*     where  P  is a permutation matrix and  R  is upper triangular.
+*     The permutation P is chosen to maximize the diagonal of R at each
+*     stage.  Only the diagonal and super-diagonal elements of H are
+*     used.
+*
+*     Output:
+*
+*         INFORM = 0   the factorization was computed successfully,
+*                      with the Cholesky factor written in the upper
+*                      triangular part of H and P stored in KX.
+*                  1   the matrix H was indefinite.
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     Original version of LSCHOL dated  2-February-1981.
+*     Level 2 Blas added 29-June-1986.
+*     This version of LSCHOL dated  30-June-1986.
+************************************************************************
+
+      COMMON    /SOL1CM/ NOUT
+      INTRINSIC          ABS   , MAX   , SQRT
+      EXTERNAL           IDAMAX
+      PARAMETER        ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+
+      INFORM = 0
+      NRANK  = 0
+
+*     Main loop for computing rows of  R.
+
+      DO 200 J = 1, N
+
+*        Find maximum available diagonal.
+
+         KMAX = J - 1 + IDAMAX( N-J+1, H(J,J), NROWH+1 )
+         DMAX = H(KMAX,KMAX)
+
+         IF (DMAX .LE. TOLRNK*ABS(H(1,1))) GO TO 300
+
+*        Perform a symmetric interchange if necessary.
+
+         IF (KMAX .NE. J) THEN
+            K        = KX(KMAX)
+            KX(KMAX) = KX(J)
+            KX(J)    = K
+
+            CALL DSWAP ( J       , H(1,J)   , 1, H(1,KMAX), 1     )
+            CALL DSWAP ( KMAX-J+1, H(J,KMAX), 1, H(J,J)   , NROWH )
+            CALL DSWAP ( N-KMAX+1, H(KMAX,KMAX), NROWH,
+     $                             H(J,KMAX)   , NROWH )
+
+            H(KMAX,KMAX) = H(J,J)
+         END IF
+
+*        Set the diagonal of  R.
+
+         D      = SQRT( DMAX )
+         H(J,J) = D
+         NRANK  = NRANK + 1
+
+         IF (J .LT. N) THEN
+
+*           Set the super-diagonal elements of this row of R and update
+*           the elements of the block that is yet to be factorized.
+
+            CALL DSCAL ( N-J,   (ONE/D), H(J  ,J+1), NROWH )
+            CALL DSYR  ( 'U', N-J, -ONE, H(J  ,J+1), NROWH,
+     $                                   H(J+1,J+1), NROWH )
+         END IF
+
+  200 CONTINUE
+*     ------------------------------------------------------------------
+*     Check for the semi-definite case.
+*     ------------------------------------------------------------------
+  300 IF (NRANK .LT. N) THEN
+
+*        Find the largest element in the unfactorized block.
+
+         SUPMAX = ZERO
+         DO 310 I = J, N-1
+            K      = I + IDAMAX( N-I, H(I,I+1), NROWH )
+            SUPMAX = MAX( SUPMAX, ABS(H(I,K)) )
+  310    CONTINUE
+
+         IF (SUPMAX .GT. TOLRNK*ABS(H(1,1))) THEN
+            WRITE (NOUT, 1000) DMAX, SUPMAX
+            INFORM = 1
+         END IF
+      END IF
+
+      RETURN
+
+ 1000 FORMAT(' XXX  Hessian appears to be indefinite.'
+     $      /' XXX  Maximum diagonal and off-diagonal ignored',
+     $             ' in the Cholesky factorization:', 1P2E22.14 )
+
+*     End of LSCHOL.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lscore.f
@@ -0,0 +1,618 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSCORE( PRBTYP, NAMED, NAMES, LINOBJ, UNITQ,
+     $                   INFORM, ITER, JINF, NCLIN, NCTOTL,
+     $                   NACTIV, NFREE, NRANK, NZ, NZ1,
+     $                   N, NROWA, NROWR,
+     $                   ISTATE, KACTIV, KX,
+     $                   CTX, SSQ, SSQ1, SUMINF, NUMINF, XNORM,
+     $                   BL, BU, A, CLAMDA, AX,
+     $                   FEATOL, R, X, IW, W )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      CHARACTER*2        PRBTYP
+      CHARACTER*8        NAMES(*)
+      INTEGER            ISTATE(NCTOTL), KACTIV(N), KX(N)
+      INTEGER            IW(*)
+      DOUBLE PRECISION   BL(NCTOTL), BU(NCTOTL), A(NROWA,*),
+     $                   CLAMDA(NCTOTL), AX(*),
+     $                   FEATOL(NCTOTL), R(NROWR,*), X(N)
+      DOUBLE PRECISION   W(*)
+      LOGICAL            NAMED, LINOBJ, UNITQ
+
+************************************************************************
+*     LSCORE  is a subroutine for linearly constrained linear-least
+*     squares.  On entry, it is assumed that an initial working set of
+*     linear constraints and bounds is available.
+*     The arrays ISTATE, KACTIV and KX will have been set accordingly
+*     and the arrays T and ZY will contain the TQ factorization of
+*     the matrix whose rows are the gradients of the active linear
+*     constraints with the columns corresponding to the active bounds
+*     removed.  the TQ factorization of the resulting (NACTIV by NFREE)
+*     matrix is  A(free)*Q = (0 T),  where Q is (NFREE by NFREE) and T
+*     is reverse-triangular.
+*
+*     Values of ISTATE(J) for the linear constraints.......
+*
+*     ISTATE(J)
+*     ---------
+*          0    constraint J is not in the working set.
+*          1    constraint J is in the working set at its lower bound.
+*          2    constraint J is in the working set at its upper bound.
+*          3    constraint J is in the working set as an equality.
+*
+*     Constraint J may be violated by as much as FEATOL(J).
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     This version of  LSCORE  dated  1-August-1986.
+*
+*     Copyright  1984  Stanford University.
+*
+*  This material may be reproduced by or for the U.S. Government pursu-
+*  ant to the copyright license under DAR clause 7-104.9(a) (1979 Mar).
+*
+*  This material is based upon work partially supported by the National
+*  Science Foundation under grants MCS-7926009 and ECS-8012974; the
+*  Department of Energy Contract AM03-76SF00326, PA No. DE-AT03-
+*  76ER72018; and the Army Research Office Contract DAA29-79-C-0110.
+************************************************************************
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL3CM/ LENNAM, NROWT, NCOLT, NQ
+      COMMON    /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9
+      COMMON    /SOL5CM/ ASIZE, DTMAX, DTMIN
+
+      INTEGER            LOCLS
+      PARAMETER         (LENLS = 20)
+      COMMON    /SOL1LS/ LOCLS(LENLS)
+
+      LOGICAL            CMDBG, LSDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /LSDEBG/ ILSDBG(LDBG), LSDBG
+      COMMON    /CMDEBG/ ICMDBG(LDBG), CMDBG
+*-----------------------------------------------------------------------
+      PARAMETER         (MXPARM = 30)
+      INTEGER            IPRMLS(MXPARM), IPSVLS
+      DOUBLE PRECISION   RPRMLS(MXPARM), RPSVLS
+
+      COMMON    /LSPAR1/ IPSVLS(MXPARM),
+     $                   IDBGLS, ITMAX1, ITMAX2, LCRASH, LDBGLS, LPROB ,
+     $                   MSGLS , NN    , NNCLIN, NPROB , IPADLS(20)
+
+      COMMON    /LSPAR2/ RPSVLS(MXPARM),
+     $                   BIGBND, BIGDX , BNDLOW, BNDUPP, TOLACT, TOLFEA,
+     $                   TOLRNK, RPADLS(23)
+
+      EQUIVALENCE       (IPRMLS(1), IDBGLS), (RPRMLS(1), BIGBND)
+
+      SAVE      /LSPAR1/, /LSPAR2/
+*-----------------------------------------------------------------------
+      EQUIVALENCE   (MSGLS , MSGLVL), (IDBGLS, IDBG), (LDBGLS, MSGDBG)
+
+      EXTERNAL           DDIV  , DDOT  , DNRM2
+      INTRINSIC          ABS   , MAX   , SQRT
+      LOGICAL            CONVRG, CYCLIN, ERROR , FIRSTV, HITCON,
+     $                   HITLOW, NEEDFG, OVERFL, PRNT  , PRNT1 , ROWERR
+      LOGICAL            SINGLR, STALL , STATPT, UNBNDD, UNCON , UNITGZ,
+     $                   WEAK
+      PARAMETER        ( ZERO   =0.0D+0, HALF   =0.5D+0, ONE   =1.0D+0 )
+      PARAMETER        ( MREFN  =1     , MSTALL =50                    )
+
+*     Specify the machine-dependent parameters.
+
+      EPSMCH = WMACH(3)
+      FLMAX  = WMACH(7)
+      RTMAX  = WMACH(8)
+
+      LANORM = LOCLS( 2)
+      LAP    = LOCLS( 3)
+      LPX    = LOCLS( 4)
+      LRES   = LOCLS( 5)
+      LRES0  = LOCLS( 6)
+      LHZ    = LOCLS( 7)
+      LGQ    = LOCLS( 8)
+      LCQ    = LOCLS( 9)
+      LRLAM  = LOCLS(10)
+      LT     = LOCLS(11)
+      LZY    = LOCLS(12)
+      LWTINF = LOCLS(13)
+      LWRK   = LOCLS(14)
+
+*     Set up the adresses of the contiguous arrays  ( RES0, RES )
+*     and  ( GQ, CQ ).
+
+      NRES   = 0
+      IF (NRANK .GT. 0) NRES = 2
+      NGQ    = 1
+      IF (LINOBJ) NGQ = 2
+
+*     Initialize.
+
+      IREFN  =   0
+      ITER   =   0
+      ITMAX  =   ITMAX1
+      JADD   =   0
+      JDEL   =   0
+      NCNLN  =   0
+      NPHASE =   1
+      NSTALL =   0
+      NUMINF = - 1
+      NZ1    =   0
+
+      ALFA   = ZERO
+      CONDMX = FLMAX
+      DRZMAX = ONE
+      DRZMIN = ONE
+      SSQ    = ZERO
+
+      CYCLIN = .FALSE.
+      ERROR  = .FALSE.
+      FIRSTV = .FALSE.
+      PRNT   = .TRUE.
+      PRNT1  = .TRUE.
+      NEEDFG = .TRUE.
+      STALL  = .TRUE.
+      UNCON  = .FALSE.
+      UNBNDD = .FALSE.
+
+*     If debug output is required,  print nothing until iteration IDBG.
+
+      MSGSVD = MSGLVL
+      IF (IDBG .GT. 0  .AND.  IDBG .LE. ITMAX) THEN
+         MSGLVL = 0
+      END IF
+
+*======================== start of the main loop =======================
+*
+*      cyclin = false
+*      unbndd = false
+*      error  = false
+*      k      = 0
+*
+*      repeat
+*            repeat
+*                  compute Z'g,  print details of this iteration
+*                  stat pt = (Z'g .eq. 0)
+*                  if (not stat pt) then
+*                     error =  k .ge. itmax
+*                     if (not error) then
+*                        compute p, alfa
+*                        error = unbndd  or  cyclin
+*                        if (not error) then
+*                           k = k + 1
+*                           x = x + alfa p
+*                           if (feasible) update Z'g
+*                           if necessary, add a constraint
+*                        end if
+*                     end if
+*                  end if
+*            until  stat pt  or  error
+*
+*            compute lam1, lam2, smllst
+*            optmul =  smllst .gt. 0
+*            if ( not (optmul .or. error) ) then
+*                  delete an artificial or regular constraint
+*            end if
+*      until optmul  or  error
+*
+*=======================================================================
+
+*     REPEAT
+*        REPEAT
+  100       IF (NEEDFG) THEN
+               IF (NRANK .GT. 0) THEN
+                  RESNRM = DNRM2 ( NRANK, W(LRES), 1 )
+                  SSQ    = HALF*(SSQ1**2 + RESNRM**2 )
+               END IF
+
+               IF (NUMINF .NE. 0) THEN
+
+*                 Compute the transformed gradient of either the sum of
+*                 of infeasibilities or the objective.  Initialize
+*                 SINGLR and UNITGZ.
+
+                  CALL LSGSET( PRBTYP, LINOBJ, SINGLR, UNITGZ, UNITQ,
+     $                         N, NCLIN, NFREE,
+     $                         NROWA, NQ, NROWR, NRANK, NZ, NZ1,
+     $                         ISTATE, KX,
+     $                         BIGBND, TOLRNK, NUMINF, SUMINF,
+     $                         BL, BU, A, W(LRES), FEATOL,
+     $                         W(LGQ), W(LCQ), R, X, W(LWTINF),
+     $                         W(LZY), W(LWRK) )
+
+                  IF (PRBTYP .NE. 'FP'  .AND.  NUMINF .EQ. 0
+     $                                  .AND.  NPHASE .EQ. 1) THEN
+                     ITMAX  = ITER + ITMAX2
+                     NPHASE = 2
+                  END IF
+               END IF
+            END IF
+
+            GZNORM = ZERO
+            IF (NZ  .GT. 0 ) GZNORM = DNRM2 ( NZ, W(LGQ), 1 )
+
+            IF (NZ1 .EQ. NZ) THEN
+               GZ1NRM = GZNORM
+            ELSE
+               GZ1NRM = ZERO
+               IF (NZ1 .GT. 0) GZ1NRM = DNRM2 ( NZ1, W(LGQ), 1 )
+            END IF
+
+            GFNORM = GZNORM
+            IF (NFREE .GT. 0  .AND.  NACTIV .GT. 0)
+     $         GFNORM = DNRM2 ( NFREE, W(LGQ), 1 )
+
+*           ------------------------------------------------------------
+*           Print the details of this iteration.
+*           ------------------------------------------------------------
+*           Define small quantities that reflect the size of X, R and
+*           the constraints in the working set.  If feasible,  estimate
+*           the rank and condition number of Rz1.
+*           Note that NZ1 .LE. NRANK + 1.
+
+            IF (NZ1 .EQ. 0) THEN
+               SINGLR = .FALSE.
+            ELSE
+               IF (NUMINF .GT. 0  .OR.  NZ1 .GT. NRANK) THEN
+                  ABSRZZ = ZERO
+               ELSE
+                  CALL DCOND ( NZ1, R, NROWR+1, DRZMAX, DRZMIN )
+                  ABSRZZ = ABS( R(NZ1,NZ1) )
+               END IF
+               SINGLR = ABSRZZ .LE. DRZMAX*TOLRNK
+
+               IF (LSDBG  .AND.  ILSDBG(1) .GT. 0)
+     $            WRITE (NOUT, 9100) SINGLR, ABSRZZ, DRZMAX, DRZMIN
+
+            END IF
+
+            CONDRZ = DDIV  ( DRZMAX, DRZMIN, OVERFL )
+            CONDT  = ONE
+            IF (NACTIV .GT. 0)
+     $         CONDT  = DDIV  ( DTMAX , DTMIN , OVERFL )
+
+            IF (PRNT) THEN
+               CALL LSPRT ( PRBTYP, PRNT1, ISDEL, ITER, JADD, JDEL,
+     $                      MSGLVL, NACTIV, NFREE, N, NCLIN,
+     $                      NRANK, NROWR, NROWT, NZ, NZ1,
+     $                      ISTATE,
+     $                      ALFA, CONDRZ, CONDT, GFNORM, GZNORM, GZ1NRM,
+     $                      NUMINF, SUMINF, CTX, SSQ,
+     $                      AX, R, W(LT), X, W(LWRK) )
+
+               JDEL  = 0
+               JADD  = 0
+               ALFA  = ZERO
+            END IF
+
+            IF (NUMINF .GT. 0) THEN
+               DINKY  = ZERO
+            ELSE
+               OBJSIZ = ONE  + ABS( SSQ + CTX )
+               WSSIZE = ZERO
+               IF (NACTIV .GT. 0) WSSIZE = DTMAX
+               DINKY  = EPSPT8 * MAX( WSSIZE, OBJSIZ, GFNORM )
+               IF (UNCON) THEN
+                  UNITGZ = GZ1NRM .LE. DINKY
+               END IF
+            END IF
+
+            IF (LSDBG  .AND.  ILSDBG(1) .GT. 0)
+     $         WRITE (NOUT, 9000) UNITGZ, IREFN, GZ1NRM, DINKY
+
+*           If the projected gradient  Z'g  is small and Rz is of full
+*           rank, X is a minimum on the working set.  An additional
+*           refinement step is allowed to take care of an inaccurate
+*           value of DINKY.
+
+            STATPT = .NOT. SINGLR  .AND.  GZ1NRM .LE. DINKY
+     $                             .OR.   IREFN  .GT. MREFN
+
+            IF (.NOT. STATPT) THEN
+*              ---------------------------------------------------------
+*              Compute a search direction.
+*              ---------------------------------------------------------
+               PRNT  = .TRUE.
+
+               ERROR = ITER .GE. ITMAX
+               IF (.NOT. ERROR) THEN
+
+                  IREFN = IREFN + 1
+                  ITER  = ITER  + 1
+
+                  IF (ITER .EQ. IDBG) THEN
+                     LSDBG  = .TRUE.
+                     CMDBG  =  LSDBG
+                     MSGLVL =  MSGSVD
+                  END IF
+
+                  CALL LSGETP( LINOBJ, SINGLR, UNITGZ, UNITQ,
+     $                         N, NCLIN, NFREE,
+     $                         NROWA, NQ, NROWR, NRANK, NUMINF, NZ1,
+     $                         ISTATE, KX, CTP, PNORM,
+     $                         A, W(LAP), W(LRES), W(LHZ), W(LPX),
+     $                         W(LGQ), W(LCQ), R, W(LZY), W(LWRK) )
+
+*                 ------------------------------------------------------
+*                 Find the constraint we bump into along P.
+*                 Update X and AX if the step ALFA is nonzero.
+*                 ------------------------------------------------------
+*                 ALFHIT is initialized to BIGALF.  If it remains
+*                 that way after the call to CMALF, it will be
+*                 regarded as infinite.
+
+                  BIGALF = DDIV  ( BIGDX, PNORM, OVERFL )
+
+                  CALL CMALF ( FIRSTV, HITLOW,
+     $                         ISTATE, INFORM, JADD, N, NROWA,
+     $                         NCLIN, NCTOTL, NUMINF,
+     $                         ALFHIT, PALFA, ATPHIT,
+     $                         BIGALF, BIGBND, PNORM,
+     $                         W(LANORM), W(LAP), AX,
+     $                         BL, BU, FEATOL, W(LPX), X )
+
+*                 If  Rz1  is nonsingular,  ALFA = 1.0  will be the
+*                 step to the least-squares minimizer on the
+*                 current subspace. If the unit step does not violate
+*                 the nearest constraint by more than FEATOL,  the
+*                 constraint is not added to the working set.
+
+                  HITCON = SINGLR  .OR.  PALFA  .LE. ONE
+                  UNCON  = .NOT. HITCON
+
+                  IF (HITCON) THEN
+                     ALFA = ALFHIT
+                  ELSE
+                     JADD   = 0
+                     ALFA   = ONE
+                  END IF
+
+*                 Check for an unbounded solution or negligible step.
+
+                  UNBNDD =  ALFA .GE. BIGALF
+                  STALL  = ABS( ALFA*PNORM ) .LE. EPSPT9*XNORM
+                  IF (STALL) THEN
+                     NSTALL = NSTALL + 1
+                     CYCLIN = NSTALL .GT. MSTALL
+                  ELSE
+                     NSTALL = 0
+                  END IF
+
+                  ERROR = UNBNDD  .OR.  CYCLIN
+                  IF (.NOT.  ERROR) THEN
+*                    ---------------------------------------------------
+*                    Set X = X + ALFA*P.  Update AX, GQ, RES and CTX.
+*                    ---------------------------------------------------
+                     IF (ALFA .NE. ZERO)
+     $                  CALL LSMOVE( HITCON, HITLOW, LINOBJ, UNITGZ,
+     $                               NCLIN, NRANK, NZ1,
+     $                               N, NROWR, JADD, NUMINF,
+     $                               ALFA, CTP, CTX, XNORM,
+     $                               W(LAP), AX, BL, BU, W(LGQ),
+     $                               W(LHZ), W(LPX), W(LRES),
+     $                               R, X, W(LWRK) )
+
+                     IF (HITCON) THEN
+*                       ------------------------------------------------
+*                       Add a constraint to the working set.
+*                       Update the TQ factors of the working set.
+*                       Use P as temporary work space.
+*                       ------------------------------------------------
+*                       Update  ISTATE.
+
+                        IF (BL(JADD) .EQ. BU(JADD)) THEN
+                           ISTATE(JADD) = 3
+                        ELSE IF (HITLOW) THEN
+                           ISTATE(JADD) = 1
+                        ELSE
+                           ISTATE(JADD) = 2
+                        END IF
+                        IADD = JADD - N
+                        IF (JADD .LE. N) THEN
+
+                           DO 510 IFIX = 1, NFREE
+                              IF (KX(IFIX) .EQ. JADD) GO TO 520
+  510                      CONTINUE
+  520                   END IF
+
+                        CALL LSADD ( UNITQ,
+     $                               INFORM, IFIX, IADD, JADD,
+     $                               NACTIV, NZ, NFREE, NRANK, NRES,NGQ,
+     $                               N, NROWA, NQ, NROWR, NROWT,
+     $                               KX, CONDMX,
+     $                               A, R, W(LT), W(LRES), W(LGQ),
+     $                               W(LZY), W(LWRK), W(LRLAM) )
+
+                        NZ1    = NZ1 - 1
+                        NZ     = NZ  - 1
+
+                        IF (JADD .LE. N) THEN
+
+*                          A simple bound has been added.
+
+                           NFREE  = NFREE  - 1
+                        ELSE
+
+*                          A general constraint has been added.
+
+                           NACTIV = NACTIV + 1
+                           KACTIV(NACTIV) = IADD
+                        END IF
+
+                        IREFN  = 0
+
+                     END IF
+
+*                    ---------------------------------------------------
+*                    Check the feasibility of constraints with non-
+*                    negative ISTATE values.  If some violations have
+*                    occurred.  Refine the current X and set INFORM so
+*                    that feasibility is checked in LSGSET.
+*                    ---------------------------------------------------
+                     CALL LSFEAS( N, NCLIN, ISTATE,
+     $                            BIGBND, CNORM, ERR1, JMAX1, NVIOL,
+     $                            AX, BL, BU, FEATOL, X, W(LWRK) )
+
+                     IF (ERR1 .GT. FEATOL(JMAX1)) THEN
+                        CALL LSSETX( LINOBJ, ROWERR, UNITQ,
+     $                               NCLIN, NACTIV, NFREE, NRANK, NZ,
+     $                               N, NCTOTL, NQ, NROWA, NROWR, NROWT,
+     $                               ISTATE, KACTIV, KX,
+     $                               JMAX1, ERR2, CTX, XNORM,
+     $                               A, AX, BL, BU, W(LCQ),
+     $                               W(LRES), W(LRES0), FEATOL, R,
+     $                               W(LT), X, W(LZY), W(LPX), W(LWRK) )
+
+                        IF (LSDBG  .AND.  ILSDBG(1) .GT. 0)
+     $                     WRITE (NOUT, 2100) ERR1, ERR2
+                        IF (ROWERR)       WRITE (NOUT, 2200)
+
+                        UNCON  =   .FALSE.
+                        IREFN  =   0
+                        NUMINF = - 1
+                     END IF
+                     NEEDFG = ALFA .NE. ZERO
+                  END IF
+               END IF
+            END IF
+
+*        UNTIL      STATPT  .OR.  ERROR
+         IF (.NOT. (STATPT  .OR.  ERROR) ) GO TO 100
+
+*        ===============================================================
+*        Try and find the index JDEL of a constraint to drop from
+*        the working set.
+*        ===============================================================
+         JDEL   = 0
+
+         IF (NUMINF .EQ. 0  .AND.  PRBTYP .EQ. 'FP') THEN
+            IF (N .GT. NZ)
+     $         CALL DLOAD ( N-NZ, (ZERO), W(LRLAM), 1 )
+            JTINY  = 0
+            JSMLST = 0
+            JBIGST = 0
+         ELSE
+
+            CALL LSMULS( PRBTYP,
+     $                   MSGLVL, N, NACTIV, NFREE,
+     $                   NROWA, NROWT, NUMINF, NZ, NZ1,
+     $                   ISTATE, KACTIV, KX, DINKY,
+     $                   JSMLST, KSMLST, JINF, JTINY,
+     $                   JBIGST, KBIGST, TRULAM,
+     $                   A, W(LANORM), W(LGQ), W(LRLAM),
+     $                   W(LT), W(LWTINF) )
+
+         END IF
+
+         IF (.NOT. ERROR) THEN
+            IF (     JSMLST .GT. 0) THEN
+
+*              LSMULS found a regular constraint with multiplier less
+*              than (-DINKY).
+
+               JDEL   = JSMLST
+               KDEL   = KSMLST
+               ISDEL  = ISTATE(JDEL)
+               ISTATE(JDEL) = 0
+
+            ELSE IF (JSMLST .LT. 0) THEN
+
+               JDEL   = JSMLST
+
+            ELSE IF (NUMINF .GT. 0  .AND.  JBIGST .GT. 0) THEN
+
+*              No feasible point exists for the constraints but the
+*              sum of the constraint violations may be reduced by
+*              moving off constraints with multipliers greater than 1.
+
+               JDEL   = JBIGST
+               KDEL   = KBIGST
+               ISDEL  = ISTATE(JDEL)
+               IF (TRULAM .LE. ZERO) IS = - 1
+               IF (TRULAM .GT. ZERO) IS = - 2
+               ISTATE(JDEL) = IS
+               FIRSTV = .TRUE.
+               NUMINF = NUMINF + 1
+            END IF
+
+            IF      (JDEL .NE. 0  .AND.  SINGLR) THEN
+
+*              Cannot delete a constraint when Rz is singular.
+*              Probably a weak minimum.
+
+               JDEL = 0
+            ELSE IF (JDEL .NE. 0               ) THEN
+
+*              Constraint JDEL has been deleted.
+*              Update the matrix factorizations.
+
+               CALL LSDEL ( UNITQ,
+     $                      N, NACTIV, NFREE, NRES, NGQ, NZ, NZ1,
+     $                      NROWA, NQ, NROWR, NROWT, NRANK,
+     $                      JDEL, KDEL, KACTIV, KX,
+     $                      A, W(LRES), R, W(LT), W(LGQ),W(LZY),W(LWRK))
+
+            END IF
+         END IF
+
+         IREFN  =  0
+         CONVRG =  JDEL .EQ. 0
+         PRNT   = .FALSE.
+         UNCON  = .FALSE.
+         NEEDFG = .FALSE.
+
+*     until       convrg  .or.  error
+      IF (.NOT.  (CONVRG  .OR.  ERROR)) GO TO 100
+
+*  .........................End of main loop............................
+
+      WEAK = JTINY .GT. 0  .OR.  SINGLR
+
+      IF (ERROR) THEN
+         IF (UNBNDD) THEN
+            INFORM = 2
+            IF (NUMINF .GT. 0) INFORM = 3
+         ELSE IF (ITER .GE. ITMAX) THEN
+            INFORM = 4
+         ELSE IF (CYCLIN) THEN
+            INFORM = 5
+         END IF
+      ELSE IF (CONVRG) THEN
+         INFORM = 0
+         IF (NUMINF .GT. 0) THEN
+            INFORM = 3
+         ELSE IF (PRBTYP .NE. 'FP'  .AND.  WEAK) THEN
+            INFORM = 1
+         END IF
+      END IF
+
+*     ------------------------------------------------------------------
+*     Set   CLAMDA.  Print the full solution.
+*     ------------------------------------------------------------------
+      MSGLVL = MSGSVD
+      IF (MSGLVL .GT. 0) WRITE (NOUT, 2000) PRBTYP, ITER, INFORM
+
+      CALL CMPRT ( MSGLVL, NFREE, NROWA,
+     $             N, NCLIN, NCNLN, NCTOTL, BIGBND,
+     $             NAMED, NAMES, LENNAM,
+     $             NACTIV, ISTATE, KACTIV, KX,
+     $             A, BL, BU, X, CLAMDA, W(LRLAM), X )
+
+      RETURN
+
+ 2000 FORMAT(/ ' Exit from ', A2, ' problem after ', I4, ' iterations.',
+     $         '  INFORM =', I3 )
+ 2100 FORMAT(  ' XXX  Iterative refinement.  Maximum errors before and',
+     $         ' after refinement are ',  1P2E14.2 )
+ 2200 FORMAT(  ' XXX  Warning.  Cannot satisfy the constraints to the',
+     $         ' accuracy requested.')
+ 9000 FORMAT(/ ' //LSCORE//  UNITGZ IREFN     GZ1NRM      DINKY'
+     $       / ' //LSCORE//  ', L6, I6, 1P2E11.2 )
+ 9100 FORMAT(/ ' //LSCORE//  SINGLR   ABS(RZZ1)      DRZMAX      DRZMIN'
+     $       / ' //LSCORE//  ', L6,     1P3E12.4 )
+
+*     End of  LSCORE.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lscrsh.f
@@ -0,0 +1,260 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSCRSH( COLD, VERTEX,
+     $                   NCLIN, NCTOTL, NACTIV, NARTIF,
+     $                   NFREE, N, NROWA,
+     $                   ISTATE, KACTIV,
+     $                   BIGBND, TOLACT,
+     $                   A, AX, BL, BU, X, WX, WORK )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      LOGICAL            COLD, VERTEX
+      INTEGER            ISTATE(NCTOTL), KACTIV(N)
+      DOUBLE PRECISION   A(NROWA,*), AX(*), BL(NCTOTL), BU(NCTOTL),
+     $                   X(N), WX(N), WORK(N)
+
+************************************************************************
+*     LSCRSH  computes the quantities  ISTATE (optionally), KACTIV,
+*     NACTIV, NZ and NFREE  associated with the working set at X.
+*     The computation depends upon the value of the input parameter
+*     COLD,  as follows...
+*
+*     COLD = TRUE.  An initial working set will be selected. First,
+*                   nearly-satisfied or violated bounds are added.
+*                   Next,  general linear constraints are added that
+*                   have small residuals.
+*
+*     COLD = FALSE. The quantities KACTIV, NACTIV, NZ and NFREE are
+*                   computed from ISTATE,  specified by the user.
+*
+*     Values of ISTATE(j)....
+*
+*        - 2         - 1         0           1          2         3
+*     a'x lt bl   a'x gt bu   a'x free   a'x = bl   a'x = bu   bl = bu
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     Original version written 31-October-1984.
+*     This version of LSCRSH dated 27-December-1985.
+************************************************************************
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+      COMMON    /SOL1CM/ NOUT
+
+      LOGICAL            LSDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /LSDEBG/ ILSDBG(LDBG), LSDBG
+
+      EXTERNAL           DDOT
+      INTRINSIC          ABS, MIN
+      PARAMETER        ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+
+      FLMAX  = WMACH(7)
+      CALL DCOPY ( N, X, 1, WX, 1 )
+
+      IF (LSDBG) THEN
+         IF (ILSDBG(1) .GT. 0)
+     $      WRITE (NOUT, 1000) COLD, NCLIN, NCTOTL
+         IF (ILSDBG(2) .GT. 0)
+     $      WRITE (NOUT, 1100) (WX(J), J = 1, N)
+      END IF
+
+      NFIXED = 0
+      NACTIV = 0
+      NARTIF = 0
+
+*     If a cold start is being made, initialize  ISTATE.
+*     If  BL(j) = BU(j),  set  ISTATE(j)=3  for all variables and linear
+*     constraints.
+
+      IF (COLD) THEN
+         DO 100 J = 1, NCTOTL
+            ISTATE(J) = 0
+            IF (BL(J) .EQ. BU(J)) ISTATE(J) = 3
+  100    CONTINUE
+      ELSE
+         DO 110 J = 1, NCTOTL
+            IF (ISTATE(J) .GT. 3  .OR.  ISTATE(J) .LT. 0) ISTATE(J) = 0
+  110    CONTINUE
+      END IF
+
+*     Initialize NFIXED, NFREE and KACTIV.
+*     Ensure that the number of bounds and general constraints in the
+*     working set does not exceed N.
+
+      DO 200 J = 1, NCTOTL
+         IF (NFIXED + NACTIV .EQ. N) ISTATE(J) = 0
+         IF (ISTATE(J) .GT. 0) THEN
+            IF (J .LE. N) THEN
+               NFIXED = NFIXED + 1
+               IF (ISTATE(J) .EQ. 1) WX(J) = BL(J)
+               IF (ISTATE(J) .GE. 2) WX(J) = BU(J)
+            ELSE
+               NACTIV = NACTIV + 1
+               KACTIV(NACTIV) = J - N
+            END IF
+         END IF
+  200 CONTINUE
+
+*     ------------------------------------------------------------------
+*     If a cold start is required,  attempt to add as many
+*     constraints as possible to the working set.
+*     ------------------------------------------------------------------
+      IF (COLD) THEN
+         BIGLOW = - BIGBND
+         BIGUPP =   BIGBND
+
+*        See if any bounds are violated or nearly satisfied.
+*        If so,  add these bounds to the working set and set the
+*        variables exactly on their bounds.
+
+         J = N
+*+       WHILE (J .GE. 1  .AND.  NFIXED + NACTIV .LT. N) DO
+  300    IF    (J .GE. 1  .AND.  NFIXED + NACTIV .LT. N) THEN
+            IF (ISTATE(J) .EQ. 0) THEN
+               B1     = BL(J)
+               B2     = BU(J)
+               IS     = 0
+               IF (B1 .GT. BIGLOW) THEN
+                  IF (WX(J) - B1 .LE. (ONE + ABS( B1 ))*TOLACT) IS = 1
+               END IF
+               IF (B2 .LT. BIGUPP) THEN
+                  IF (B2 - WX(J) .LE. (ONE + ABS( B2 ))*TOLACT) IS = 2
+               END IF
+               IF (IS .GT. 0) THEN
+                  ISTATE(J) = IS
+                  IF (IS .EQ. 1) WX(J) = B1
+                  IF (IS .EQ. 2) WX(J) = B2
+                  NFIXED = NFIXED + 1
+               END IF
+            END IF
+            J = J - 1
+            GO TO 300
+*+       END WHILE
+         END IF
+
+*        ---------------------------------------------------------------
+*        The following loop finds the linear constraint (if any) with
+*        smallest residual less than or equal to TOLACT  and adds it
+*        to the working set.  This is repeated until the working set
+*        is complete or all the remaining residuals are too large.
+*        ---------------------------------------------------------------
+*        First, compute the residuals for all the constraints not in the
+*        working set.
+
+         IF (NCLIN .GT. 0  .AND.  NACTIV+NFIXED .LT. N) THEN
+            DO 410 I = 1, NCLIN
+               IF (ISTATE(N+I) .LE. 0)
+     $         AX(I) = DDOT  (N, A(I,1), NROWA, WX, 1 )
+  410       CONTINUE
+
+            IS     = 1
+            TOOBIG = TOLACT + TOLACT
+
+*+          WHILE (IS .GT. 0  .AND.  NFIXED + NACTIV .LT. N) DO
+  500       IF    (IS .GT. 0  .AND.  NFIXED + NACTIV .LT. N) THEN
+               IS     = 0
+               RESMIN = TOLACT
+
+               DO 520 I = 1, NCLIN
+                  J      = N + I
+                  IF (ISTATE(J) .EQ. 0) THEN
+                     B1     = BL(J)
+                     B2     = BU(J)
+                     RESL   = TOOBIG
+                     RESU   = TOOBIG
+                     IF (B1 .GT. BIGLOW)
+     $                  RESL  = ABS( AX(I) - B1 ) / (ONE + ABS( B1 ))
+                     IF (B2 .LT. BIGUPP)
+     $                  RESU  = ABS( AX(I) - B2 ) / (ONE + ABS( B2 ))
+                     RESIDL   = MIN( RESL, RESU )
+                     IF(RESIDL .LT. RESMIN) THEN
+                        RESMIN = RESIDL
+                        IMIN   = I
+                        IS     = 1
+                        IF (RESL .GT. RESU) IS = 2
+                     END IF
+                  END IF
+  520          CONTINUE
+
+               IF (IS .GT. 0) THEN
+                  NACTIV = NACTIV + 1
+                  KACTIV(NACTIV) = IMIN
+                  J         = N + IMIN
+                  ISTATE(J) = IS
+               END IF
+               GO TO 500
+*+          END WHILE
+            END IF
+         END IF
+
+*        ---------------------------------------------------------------
+*        If required, add temporary bounds to make a vertex.
+*        ---------------------------------------------------------------
+         IF (VERTEX  .AND.  NACTIV+NFIXED .LT. N) THEN
+
+*           Compute lengths of columns of selected linear constraints
+*           (just the ones corresponding to free variables).
+
+            DO 630 J = 1, N
+               IF (ISTATE(J) .EQ. 0) THEN
+                  COLSIZ = ZERO
+                  DO 620 K = 1, NCLIN
+                     IF (ISTATE(N+K) .GT. 0)
+     $               COLSIZ = COLSIZ + ABS( A(K,J) )
+  620             CONTINUE
+                  WORK(J) = COLSIZ
+               END IF
+  630       CONTINUE
+
+*           Find the  NARTIF  smallest such columns.
+*           This is an expensive loop.  Later we can replace it by a
+*           4-pass process (say), accepting the first col that is within
+*           T  of  COLMIN, where  T = 0.0, 0.001, 0.01, 0.1 (say).
+*           (This comment written in 1980).
+
+*+          WHILE (NFIXED + NACTIV .LT. N) DO
+  640       IF    (NFIXED + NACTIV .LT. N) THEN
+               COLMIN = FLMAX
+               DO 650 J = 1, N
+                  IF (ISTATE(J) .EQ. 0) THEN
+                     IF (NCLIN .EQ. 0) GO TO 660
+                     COLSIZ = WORK(J)
+                     IF (COLMIN .GT. COLSIZ) THEN
+                        COLMIN = COLSIZ
+                        JMIN   = J
+                     END IF
+                  END IF
+  650          CONTINUE
+               J      = JMIN
+  660          ISTATE(J) = 4
+               NARTIF = NARTIF + 1
+               NFIXED = NFIXED + 1
+               GO TO 640
+*+          END WHILE
+            END IF
+         END IF
+      END IF
+
+      NFREE = N - NFIXED
+
+      IF (LSDBG) THEN
+         IF (ILSDBG(1) .GT. 0)
+     $       WRITE (NOUT, 1300) NFIXED, NACTIV, NARTIF
+         IF (ILSDBG(2) .GT. 0)
+     $       WRITE (NOUT, 1200) (WX(J), J = 1, N)
+      END IF
+
+      RETURN
+
+ 1000 FORMAT(/ ' //LSCRSH// COLD NCLIN NCTOTL'
+     $       / ' //LSCRSH// ', L4, I6, I7 )
+ 1100 FORMAT(/ ' //LSCRSH// Variables before crash... '/ (5G12.3))
+ 1200 FORMAT(/ ' //LSCRSH// Variables after  crash... '/ (5G12.3))
+ 1300 FORMAT(/ ' //LSCRSH// Working set selected ...             '
+     $       / ' //LSCRSH// NFIXED NACTIV NARTIF      '
+     $       / ' //LSCRSH// ', I6, 2I7 )
+
+*     End of  LSCRSH.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lsdel.f
@@ -0,0 +1,193 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSDEL ( UNITQ,
+     $                   N, NACTIV, NFREE, NRES, NGQ, NZ, NZ1,
+     $                   NROWA, NQ, NROWR, NROWT, NRANK,
+     $                   JDEL, KDEL, KACTIV, KX,
+     $                   A, RES, R, T, GQ, ZY, WORK )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      LOGICAL            UNITQ
+      INTEGER            KACTIV(N), KX(N)
+      DOUBLE PRECISION   A(NROWA,*), RES(N,*), R(NROWR,*), T(NROWT,*),
+     $                   GQ(N,*), ZY(NQ,*)
+      DOUBLE PRECISION   WORK(N)
+
+************************************************************************
+*     LSDEL   updates the least-squares factor R and the factorization
+*     A(free) (Z Y) = (0 T) when a regular, temporary or artificial
+*     constraint is deleted from the working set.
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     Original version written 31-October-1984.
+*     This version of LSDEL dated 10-June-1986.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL5CM/ ASIZE, DTMAX, DTMIN
+
+      LOGICAL            LSDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /LSDEBG/ ILSDBG(LDBG), LSDBG
+
+      EXTERNAL           IDAMAX
+      PARAMETER        ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+
+      IF (JDEL .GT. 0) THEN
+
+*        Regular constraint or temporary bound deleted.
+
+         IF (JDEL .LE. N) THEN
+
+*           Case 1.  A simple bound has been deleted.
+*           =======  Columns NFREE+1 and IR of R must be swapped.
+
+            IR     = NZ    + KDEL
+            IF (LSDBG  .AND.  ILSDBG(1) .GT. 0)
+     $         WRITE (NOUT, 1100) NACTIV, NZ, NFREE, IR, JDEL, UNITQ
+
+            IBEGIN = 1
+            NFREE  = NFREE + 1
+            IF (NFREE .LT. IR) THEN
+               KX(IR)    = KX(NFREE)
+               KX(NFREE) = JDEL
+               IF (NRANK .GT. 0)
+     $            CALL CMRSWP( N, NRES, NRANK, NROWR, NFREE, IR,
+     $                         R, RES, WORK )
+               CALL DSWAP ( NGQ, GQ(NFREE,1), N, GQ(IR,1), N )
+            END IF
+
+            IF (.NOT. UNITQ) THEN
+
+*              Copy the incoming column of  A(free)  into the end of T.
+
+               DO 130 KA = 1, NACTIV
+                  I = KACTIV(KA)
+                  T(KA,NFREE) = A(I,JDEL)
+  130          CONTINUE
+
+*              Expand Q by adding a unit row and column.
+
+               IF (NFREE .GT. 1) THEN
+                  CALL DLOAD ( NFREE-1, ZERO, ZY(NFREE,1), NQ )
+                  CALL DLOAD ( NFREE-1, ZERO, ZY(1,NFREE), 1  )
+               END IF
+               ZY(NFREE,NFREE) = ONE
+            END IF
+         ELSE
+
+*           Case 2.  A general constraint has been deleted.
+*           =======
+
+            IF (LSDBG  .AND.  ILSDBG(1) .GT. 0)
+     $         WRITE (NOUT, 1200) NACTIV, NZ, NFREE, KDEL, JDEL, UNITQ
+
+            IBEGIN = KDEL
+            NACTIV = NACTIV - 1
+
+*           Delete a row of T and move the ones below it up.
+
+            DO 220 I = KDEL, NACTIV
+               KACTIV(I) = KACTIV(I+1)
+               LD        = NFREE - I
+               CALL DCOPY ( I+1, T(I+1,LD), NROWT, T(I,LD), NROWT )
+  220       CONTINUE
+         END IF
+
+*        ---------------------------------------------------------------
+*        Eliminate the super-diagonal elements of  T,
+*        using a backward sweep of 2*2 transformations.
+*        ---------------------------------------------------------------
+         K     = NFREE  - IBEGIN
+         L     = NACTIV - IBEGIN
+         LROWR = N      - K
+
+         DO 420 I = IBEGIN, NACTIV
+            CALL DROT3G( T(I,K+1), T(I,K), CS, SN )
+
+            IF (L .GT. 0)
+     $      CALL DROT3 ( L    , T(I+1,K+1), 1, T(I+1,K ), 1, CS, SN )
+            CALL DROT3 ( NFREE, ZY(1,K+1) , 1, ZY(1,K  ), 1, CS, SN )
+            CALL DROT3 ( NGQ  , GQ(K+1,1) , N, GQ(K,1)  , N, CS, SN )
+
+*           Apply the column transformations to  R.  The non-zero
+*           sub-diagonal that is generated must be eliminated by a row
+*           rotation.
+
+            IF (K .LT. NRANK) R(K+1,K) = ZERO
+            LCOL   = MIN( K+1, NRANK )
+            IF (LCOL .GT. 0)
+     $         CALL DROT3 ( LCOL, R(1,K+1), 1, R(1,K), 1, CS, SN )
+
+            IF (K .LT. NRANK) THEN
+               CALL DROT3G( R(K,K), R(K+1,K), CS, SN )
+
+               CALL DROT3 ( LROWR, R(K,K+1)    , NROWR,
+     $                             R(K+1,K+1)  , NROWR, CS, SN )
+               CALL DROT3 ( NRES , RES(K,1)    , N    ,
+     $                             RES(K+1,1)  , N    , CS, SN )
+            END IF
+            K     = K     - 1
+            L     = L     - 1
+            LROWR = LROWR + 1
+  420    CONTINUE
+
+         NZ  = NZ  + 1
+
+*        ---------------------------------------------------------------
+*        Estimate the condition number of  T.
+*        ---------------------------------------------------------------
+         IF (NACTIV .EQ. 0) THEN
+            DTMAX = ONE
+            DTMIN = ONE
+         ELSE
+            CALL DCOND ( NACTIV, T(NACTIV,NZ+1), NROWT-1, DTMAX, DTMIN )
+         END IF
+
+      END IF
+
+      NZ1 = NZ1 + 1
+
+      IF (NZ .GT. NZ1) THEN
+         IF (JDEL .GT. 0) THEN
+            JART =   NZ1 - 1 + IDAMAX( NZ-NZ1+1, GQ(NZ1,1), 1 )
+         ELSE
+            JART = - JDEL
+         END IF
+
+         IF (LSDBG  .AND.  ILSDBG(1) .GT. 0)
+     $      WRITE( NOUT, 1000 ) NZ, NZ1, JART
+
+         IF (JART .GT. NZ1) THEN
+
+*           Swap columns NZ1 and JART of R.
+
+            IF (UNITQ) THEN
+               K        = KX(NZ1)
+               KX(NZ1)  = KX(JART)
+               KX(JART) = K
+            ELSE
+               CALL DSWAP ( NFREE, ZY(1,NZ1), 1, ZY(1,JART), 1 )
+            END IF
+
+            CALL DSWAP ( NGQ, GQ(NZ1,1), N, GQ(JART,1), N )
+            IF (NRANK .GT. 0)
+     $         CALL CMRSWP( N, NRES, NRANK, NROWR, NZ1, JART,
+     $                      R, RES, WORK )
+         END IF
+      END IF
+
+      RETURN
+
+ 1000 FORMAT(/ ' //LSDEL //  Artificial constraint deleted.      '
+     $       / ' //LSDEL //      NZ   NZ1   JART                 '
+     $       / ' //LSDEL //  ', 3I6 )
+ 1100 FORMAT(/ ' //LSDEL //  Simple bound deleted.               '
+     $       / ' //LSDEL //  NACTIV    NZ NFREE    IR  JDEL UNITQ'
+     $       / ' //LSDEL //  ', 5I6, L6 )
+ 1200 FORMAT(/ ' //LSDEL //  General constraint deleted.         '
+     $       / ' //LSDEL //  NACTIV    NZ NFREE  KDEL  JDEL UNITQ'
+     $       / ' //LSDEL //  ', 5I6, L6 )
+
+*     End of  LSDEL .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lsdflt.f
@@ -0,0 +1,160 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSDFLT( M, N, NCLIN, TITLE )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+
+      CHARACTER*(*)      TITLE
+
+************************************************************************
+*  LSDFLT  loads the default values of parameters not set by the user.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Original Fortran 77 version written 17-September-1985.
+*  This version of LSDFLT dated   9-September-1986.
+************************************************************************
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9
+
+      LOGICAL            CMDBG, LSDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /LSDEBG/ ILSDBG(LDBG), LSDBG
+      COMMON    /CMDEBG/ ICMDBG(LDBG), CMDBG
+
+      LOGICAL            NEWOPT
+      COMMON    /SOL3LS/ NEWOPT
+      SAVE      /SOL3LS/
+
+*-----------------------------------------------------------------------
+      PARAMETER         (MXPARM = 30)
+      INTEGER            IPRMLS(MXPARM), IPSVLS
+      DOUBLE PRECISION   RPRMLS(MXPARM), RPSVLS
+
+      COMMON    /LSPAR1/ IPSVLS(MXPARM),
+     $                   IDBGLS, ITMAX1, ITMAX2, LCRASH, LDBGLS, LPROB ,
+     $                   MSGLS , NN    , NNCLIN, NPROB , IPADLS(20)
+
+      COMMON    /LSPAR2/ RPSVLS(MXPARM),
+     $                   BIGBND, BIGDX , BNDLOW, BNDUPP, TOLACT, TOLFEA,
+     $                   TOLRNK, RPADLS(23)
+
+      EQUIVALENCE       (IPRMLS(1), IDBGLS), (RPRMLS(1), BIGBND)
+
+      SAVE      /LSPAR1/, /LSPAR2/
+*-----------------------------------------------------------------------
+      EQUIVALENCE   (MSGLS , MSGLVL), (IDBGLS, IDBG), (LDBGLS, MSGDBG)
+
+      LOGICAL            CDEFND
+      CHARACTER*4        ICRSH(0:2)
+      CHARACTER*3        LSTYPE(1:10)
+      CHARACTER*16       KEY
+      INTRINSIC          LEN    ,  MAX   , MOD
+      PARAMETER        ( ZERO   =  0.0D+0, TEN    = 10.0D+0)
+      PARAMETER        ( RDUMMY = -11111., IDUMMY = -11111 )
+      PARAMETER        ( GIGANT = 1.0D+10*.99999           )
+      PARAMETER        ( WRKTOL = 1.0D-2                   )
+      DATA               ICRSH(0), ICRSH(1), ICRSH(2)
+     $                 /'COLD'   ,'WARM'   ,'HOT '   /
+      DATA               LSTYPE(1), LSTYPE(2)
+     $                 /' FP'     ,' LP'     /
+      DATA               LSTYPE(3), LSTYPE(4), LSTYPE(5), LSTYPE(6)
+     $                 /'QP1'     ,'QP2'     ,'QP3'     ,'QP4'     /
+      DATA               LSTYPE(7), LSTYPE(8), LSTYPE(9), LSTYPE(10)
+     $                 /'LS1'     ,'LS2'     ,'LS3'     ,'LS4'     /
+
+      EPSMCH = WMACH( 3)
+
+*     Make a dummy call to LSKEY to ensure that the defaults are set.
+
+      CALL LSKEY ( NOUT, '*', KEY )
+      NEWOPT = .TRUE.
+
+*     Save the optional parameters set by the user.  The values in
+*     RPRMLS and IPRMLS may be changed to their default values.
+
+      CALL ICOPY ( MXPARM, IPRMLS, 1, IPSVLS, 1 )
+      CALL DCOPY ( MXPARM, RPRMLS, 1, RPSVLS, 1 )
+
+      IF (       LPROB  .LT. 0      )  LPROB   = 7
+                                       CDEFND  = LPROB .EQ. 2*(LPROB/2)
+      IF (       LCRASH .LT. 0
+     $    .OR.   LCRASH .GT. 2      )  LCRASH  = 0
+      IF (       ITMAX1 .LT. 0      )  ITMAX1  = MAX(50, 5*(N+NCLIN))
+      IF (       ITMAX2 .LT. 0      )  ITMAX2  = MAX(50, 5*(N+NCLIN))
+      IF (       MSGLVL .EQ. IDUMMY )  MSGLVL  = 10
+      IF (       IDBG   .LT. 0
+     $    .OR.   IDBG   .GT. ITMAX1 + ITMAX2
+     $                              )  IDBG    = 0
+      IF (       MSGDBG .LT. 0      )  MSGDBG  = 0
+      IF (       MSGDBG .EQ. 0      )  IDBG    = ITMAX1 + ITMAX2 + 1
+      IF (       TOLACT .LT. ZERO   )  TOLACT  = WRKTOL
+      IF (       TOLFEA .EQ. RDUMMY
+     $    .OR.  (TOLFEA .GE. ZERO
+     $    .AND.  TOLFEA .LT. EPSMCH))  TOLFEA  = EPSPT5
+      IF (       TOLRNK .LE. ZERO
+     $    .AND.  CDEFND             )  TOLRNK  = EPSPT5
+      IF (       TOLRNK .LE. ZERO   )  TOLRNK  = TEN*EPSMCH
+      IF (       BIGBND .LE. ZERO   )  BIGBND  = GIGANT
+      IF (       BIGDX  .LE. ZERO   )  BIGDX   = MAX(GIGANT, BIGBND)
+
+      LSDBG = IDBG .EQ. 0
+      CMDBG = LSDBG
+      K     = 1
+      MSG   = MSGDBG
+      DO 200 I = 1, LDBG
+         ILSDBG(I) = MOD( MSG/K, 10 )
+         ICMDBG(I) = ILSDBG(I)
+         K = K*10
+  200 CONTINUE
+
+      IF (MSGLVL .GT. 0) THEN
+
+*        Print the title.
+
+         LENT = LEN( TITLE )
+         IF (LENT .GT. 0) THEN
+            NSPACE = (81 - LENT)/2 + 1
+            WRITE (NOUT, '(///// (80A1) )')
+     $         (' ', J=1, NSPACE), (TITLE(J:J), J=1,LENT)
+            WRITE (NOUT, '(80A1 //)')
+     $         (' ', J=1, NSPACE), ('='       , J=1,LENT)
+         END IF
+
+         WRITE (NOUT, 2000)
+         WRITE (NOUT, 2100) LSTYPE(LPROB),
+     $                      NCLIN , TOLFEA, ICRSH(LCRASH),
+     $                      N     , BIGBND, TOLACT,
+     $                      M     , BIGDX , TOLRNK
+         WRITE (NOUT, 2200) EPSMCH, ITMAX1, MSGLVL,
+     $                              ITMAX2
+      END IF
+
+      RETURN
+
+ 2000 FORMAT(
+     $//' Parameters'
+     $/ ' ----------' )
+ 2100 FORMAT(
+     $/ ' Problem type...........', 7X, A3
+     $/ ' Linear constraints.....', I10,     6X,
+     $  ' Feasibility tolerance..', 1PE10.2, 6X,
+     $  1X, A4, ' start.............'
+     $/ ' Variables..............', I10,     6X,
+     $  ' Infinite bound size....', 1PE10.2, 6X,
+     $  ' Crash tolerance........', 1PE10.2
+     $/ ' Objective matrix rows..', I10,     6X,
+     $  ' Infinite step size.....', 1PE10.2, 6X,
+     $  ' Rank tolerance.........', 1PE10.2 )
+ 2200 FORMAT(
+     $/ ' EPS (machine precision)', 1PE10.2, 6X,
+     $  ' Feasibility phase itns.', I10, 6X,
+     $  ' Print level............', I10
+     $/ 40X,
+     $  ' Optimality  phase itns.', I10 )
+
+*     End of  LSDFLT.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lsfeas.f
@@ -0,0 +1,97 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSFEAS( N, NCLIN, ISTATE,
+     $                   BIGBND, CVNORM, ERRMAX, JMAX, NVIOL,
+     $                   AX, BL, BU, FEATOL, X, WORK )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      INTEGER            ISTATE(N+NCLIN)
+      DOUBLE PRECISION   AX(*), BL(N+NCLIN), BU(N+NCLIN)
+      DOUBLE PRECISION   FEATOL(N+NCLIN), X(N)
+      DOUBLE PRECISION   WORK(N+NCLIN)
+
+************************************************************************
+*  LSFEAS  computes the following...
+*  (1)  The number of constraints that are violated by more
+*       than  FEATOL  and the 2-norm of the constraint violations.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Original version      April    1984.
+*  This version of  LSFEAS  dated  17-October-1985.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+
+      LOGICAL            LSDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /LSDEBG/ ILSDBG(LDBG), LSDBG
+
+      EXTERNAL           IDAMAX, DNRM2
+      INTRINSIC          ABS
+      PARAMETER        ( ZERO = 0.0D+0 )
+
+      BIGLOW = - BIGBND
+      BIGUPP =   BIGBND
+
+*     ==================================================================
+*     Compute NVIOL,  the number of constraints violated by more than
+*     FEATOL,  and CVNORM,  the 2-norm of the constraint violations and
+*     residuals of the constraints in the working set.
+*     ==================================================================
+      NVIOL  = 0
+
+      DO 200 J = 1, N+NCLIN
+         FEASJ  = FEATOL(J)
+         IS     = ISTATE(J)
+         RES    = ZERO
+
+         IF (IS .GE. 0  .AND.  IS .LT. 4) THEN
+            IF (J .LE. N) THEN
+               CON =  X(J)
+            ELSE
+               I   = J - N
+               CON = AX(I)
+            END IF
+
+            TOLJ   = FEASJ
+
+*           Check for constraint violations.
+
+            IF (BL(J) .GT. BIGLOW) THEN
+               RES    = BL(J) - CON
+               IF (RES .GT.   FEASJ ) NVIOL = NVIOL + 1
+               IF (RES .GT.    TOLJ ) GO TO 190
+            END IF
+
+            IF (BU(J) .LT. BIGUPP) THEN
+               RES    = BU(J) - CON
+               IF (RES .LT. (-FEASJ)) NVIOL = NVIOL + 1
+               IF (RES .LT.  (-TOLJ)) GO TO 190
+            END IF
+
+*           This constraint is satisfied,  but count the residual as a
+*           violation if the constraint is in the working set.
+
+            IF (IS .LE. 0) RES = ZERO
+            IF (IS .EQ. 1) RES = BL(J) - CON
+            IF (IS .GE. 2) RES = BU(J) - CON
+            IF (ABS( RES ) .GT. FEASJ) NVIOL = NVIOL + 1
+         END IF
+  190    WORK(J) = RES
+  200 CONTINUE
+
+      JMAX   = IDAMAX( N+NCLIN, WORK, 1 )
+      ERRMAX = ABS ( WORK(JMAX) )
+
+      IF (LSDBG  .AND.  ILSDBG(1) .GT. 0)
+     $   WRITE (NOUT, 1000) ERRMAX, JMAX
+
+      CVNORM  = DNRM2 ( N+NCLIN, WORK, 1 )
+
+      RETURN
+
+ 1000 FORMAT(/ ' //LSFEAS//  The maximum violation is ', 1PE14.2,
+     $                     ' in constraint', I5 )
+
+*     End of  LSFEAS.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lsfile.f
@@ -0,0 +1,54 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSFILE( IOPTNS, INFORM )
+      INTEGER            IOPTNS, INFORM
+
+************************************************************************
+*     LSFILE  reads the options file from unit  IOPTNS  and loads the
+*     options into the relevant elements of  IPRMLS  and  RPRMLS.
+*
+*     If  IOPTNS .lt. 0  or  IOPTNS .gt. 99  then no file is read,
+*     otherwise the file associated with unit  IOPTNS  is read.
+*
+*     Output:
+*
+*         INFORM = 0  if a complete  OPTIONS  file was found
+*                     (starting with  BEGIN  and ending with  END);
+*                  1  if  IOPTNS .lt. 0  or  IOPTNS .gt. 99;
+*                  2  if  BEGIN  was found, but end-of-file
+*                     occurred before  END  was found;
+*                  3  if end-of-file occurred before  BEGIN  or
+*                     ENDRUN  were found;
+*                  4  if  ENDRUN  was found before  BEGIN.
+************************************************************************
+      LOGICAL             NEWOPT
+      COMMON     /SOL3LS/ NEWOPT
+      SAVE       /SOL3LS/
+
+      DOUBLE PRECISION    WMACH(15)
+      COMMON     /SOLMCH/ WMACH
+      SAVE       /SOLMCH/
+
+      EXTERNAL            MCHPAR, LSKEY
+      LOGICAL             FIRST
+      SAVE                FIRST , NOUT
+      DATA                FIRST /.TRUE./
+
+*     If first time in, set NOUT.
+*     NEWOPT is true first time into LSFILE or LSOPTN
+*     and just after a call to LSSOL.
+
+      IF (FIRST) THEN
+         FIRST  = .FALSE.
+         NEWOPT = .TRUE.
+         CALL MCHPAR()
+         NOUT = WMACH(11)
+      END IF
+
+      CALL OPFILE( IOPTNS, NOUT, INFORM, LSKEY )
+
+      RETURN
+
+*     End of  LSFILE.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lsgetp.f
@@ -0,0 +1,129 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSGETP( LINOBJ, SINGLR, UNITGZ, UNITQ,
+     $                   N, NCLIN, NFREE,
+     $                   NROWA, NQ, NROWR, NRANK, NUMINF, NZ1,
+     $                   ISTATE, KX, CTP, PNORM,
+     $                   A, AP, RES, HZ, P,
+     $                   GQ, CQ, R, ZY, WORK )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      LOGICAL            LINOBJ, SINGLR, UNITGZ, UNITQ
+      INTEGER            ISTATE(N+NCLIN), KX(N)
+      DOUBLE PRECISION   A(NROWA,*), AP(*), RES(*), HZ(*), P(N),
+     $                   GQ(N), CQ(*), R(NROWR,*), ZY(NQ,*)
+      DOUBLE PRECISION   WORK(N)
+
+************************************************************************
+*     LSGETP  computes the following quantities for  LSCORE.
+*     (1) The vector  (hz1) = (Rz1)(pz1).
+*         If X is not yet feasible,  the product is computed directly.
+*         If  Rz1 is singular,  hz1  is zero.  Otherwise  hz1  satisfies
+*         the equations
+*                        Rz1'hz1 = -gz1,
+*         where  g  is the total gradient.  If there is no linear term
+*         in the objective,  hz1  is set to  dz1  directly.
+*     (2) The search direction P (and its 2-norm).  The vector P is
+*         defined as  Z*(pz1), where  (pz1)  depends upon whether or
+*         not X is feasible and the nonsingularity of  (Rz1).
+*         If  NUMINF .GT. 0,  (pz1)  is the steepest-descent direction.
+*         Otherwise,  x  is the solution of the  NZ1*NZ1  triangular
+*         system   (Rz1)*(pz1) = (hz1).
+*     (3) The vector Ap,  where A is the matrix of linear constraints.
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     Original version written 31-October-1984.
+*     Level 2 Blas added 11-June-1986.
+*     This version of LSGETP dated 11-June-1986.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+
+      LOGICAL            LSDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /LSDEBG/ ILSDBG(LDBG), LSDBG
+
+      EXTERNAL           DDOT  , DNRM2
+      INTRINSIC          MIN
+      PARAMETER        ( ZERO = 0.0D+0, ONE  = 1.0D+0 )
+
+      IF (SINGLR) THEN
+*        ---------------------------------------------------------------
+*        The triangular factor for the current objective function is
+*        singular,  i.e., the objective is linear along the last column
+*        of Z1.  This can only occur when UNITGZ is TRUE.
+*        ---------------------------------------------------------------
+         IF (NZ1 .GT. 1) THEN
+            CALL DCOPY ( NZ1-1, R(1,NZ1), 1, P, 1 )
+            CALL DTRSV ( 'U', 'N', 'N', NZ1-1, R, NROWR, P, 1 )
+         END IF
+         P(NZ1) = - ONE
+
+         GTP = DDOT  ( NZ1, GQ, 1, P, 1 )
+         IF (GTP .GT. ZERO) CALL DSCAL ( NZ1, (-ONE), P, 1 )
+
+         IF (NZ1 .LE. NRANK) THEN
+            IF (NUMINF .EQ. 0) THEN
+               IF (UNITGZ) THEN
+                  HZ(NZ1) = R(NZ1,NZ1)*P(NZ1)
+               ELSE
+                  CALL DLOAD ( NZ1, (ZERO), HZ, 1 )
+               END IF
+            ELSE
+               HZ(1)   = R(1,1)*P(1)
+            END IF
+         END IF
+      ELSE
+*        ---------------------------------------------------------------
+*        The objective is quadratic in the space spanned by Z1.
+*        ---------------------------------------------------------------
+         IF (LINOBJ) THEN
+            IF (UNITGZ) THEN
+               IF (NZ1 .GT. 1)
+     $            CALL DLOAD ( NZ1-1, (ZERO), HZ, 1 )
+               HZ(NZ1) = - GQ(NZ1)/R(NZ1,NZ1)
+            ELSE
+               CALL DCOPY ( NZ1, GQ  , 1, HZ, 1 )
+               CALL DSCAL ( NZ1, (-ONE), HZ, 1 )
+               CALL DTRSV ( 'U', 'T', 'N', NZ1, R, NROWR, HZ, 1 )
+            END IF
+         ELSE
+            CALL DCOPY ( NZ1, RES, 1, HZ, 1 )
+         END IF
+
+*        Solve  Rz1*pz1 = hz1.
+
+         CALL DCOPY ( NZ1, HZ, 1, P, 1 )
+         CALL DTRSV ( 'U', 'N', 'N', NZ1, R, NROWR, P, 1 )
+      END IF
+
+*     Compute  p = Z1*pz1  and its norm.
+
+      IF (LINOBJ)
+     $   CTP = DDOT  ( NZ1, CQ, 1, P, 1 )
+      PNORM  = DNRM2 ( NZ1, P, 1 )
+
+      CALL CMQMUL( 1, N, NZ1, NFREE, NQ, UNITQ, KX, P, ZY, WORK )
+
+      IF (LSDBG  .AND.  ILSDBG(2) .GT. 0)
+     $   WRITE (NOUT, 1000) (P(J), J = 1, N)
+
+*     Compute  Ap.
+
+      IF (NCLIN .GT. 0) THEN
+         CALL DLOAD ( NCLIN, ZERO, AP, 1 )
+         DO 410 J = 1, N
+            IF (ISTATE(J) .LE. 0)
+     $         CALL DAXPY( NCLIN, P(J), A(1,J), 1, AP, 1 )
+  410    CONTINUE
+         IF (LSDBG  .AND.  ILSDBG(2) .GT. 0)
+     $   WRITE (NOUT, 1100) (AP(I), I = 1, NCLIN)
+      END IF
+
+      RETURN
+
+ 1000 FORMAT(/ ' //LSGETP//   P ... ' / (1P5E15.5))
+ 1100 FORMAT(/ ' //LSGETP//  AP ... ' / (1P5E15.5))
+
+*     End of  LSGETP.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lsgset.f
@@ -0,0 +1,146 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSGSET( PRBTYP, LINOBJ, SINGLR, UNITGZ, UNITQ,
+     $                   N, NCLIN, NFREE,
+     $                   NROWA, NQ, NROWR, NRANK, NZ, NZ1,
+     $                   ISTATE, KX,
+     $                   BIGBND, TOLRNK, NUMINF, SUMINF,
+     $                   BL, BU, A, RES, FEATOL,
+     $                   GQ, CQ, R, X, WTINF, ZY, WRK )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      CHARACTER*2        PRBTYP
+      LOGICAL            LINOBJ, SINGLR, UNITGZ, UNITQ
+      INTEGER            ISTATE(*), KX(N)
+      DOUBLE PRECISION   BL(*), BU(*), A(NROWA,*),
+     $                   RES(*), FEATOL(*)
+      DOUBLE PRECISION   GQ(N), CQ(*), R(NROWR,*), X(N), WTINF(*),
+     $                   ZY(NQ,*)
+      DOUBLE PRECISION   WRK(N)
+
+************************************************************************
+*     LSGSET  finds the number and weighted sum of infeasibilities for
+*     the bounds and linear constraints.   An appropriate transformed
+*     gradient vector is returned in  GQ.
+*
+*     Positive values of  ISTATE(j)  will not be altered.  These mean
+*     the following...
+*
+*               1             2           3
+*           a'x = bl      a'x = bu     bl = bu
+*
+*     Other values of  ISTATE(j)  will be reset as follows...
+*           a'x lt bl     a'x gt bu     a'x free
+*              - 2           - 1           0
+*
+*     If  x  is feasible,  LSGSET computes the vector Q(free)'g(free),
+*     where  g  is the gradient of the the sum of squares plus the
+*     linear term.  The matrix Q is of the form
+*                    ( Q(free)  0       ),
+*                    (   0      I(fixed))
+*     where  Q(free)  is the orthogonal factor of  A(free)  and  A  is
+*     the matrix of constraints in the working set.  The transformed
+*     gradients are stored in GQ.
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     Original version written 31-October-1984.
+*     Level 2 Blas added 11-June-1986.
+*     This version of LSGSET dated 24-June-1986.
+************************************************************************
+      EXTERNAL           DDOT  , IDRANK
+      INTRINSIC          ABS   , MAX   , MIN
+      PARAMETER        ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
+
+      BIGUPP =   BIGBND
+      BIGLOW = - BIGBND
+
+      NUMINF =   0
+      SUMINF =   ZERO
+      CALL DLOAD ( N, ZERO, GQ, 1 )
+
+      DO 200 J = 1, N+NCLIN
+         IF (ISTATE(J) .LE. 0) THEN
+            FEASJ  = FEATOL(J)
+            IF (J .LE. N) THEN
+               CTX = X(J)
+            ELSE
+               K   = J - N
+               CTX = DDOT  ( N, A(K,1), NROWA, X, 1 )
+            END IF
+            ISTATE(J) = 0
+
+*           See if the lower bound is violated.
+
+            IF (BL(J) .GT. BIGLOW) THEN
+               S = BL(J) - CTX
+               IF (S     .GT. FEASJ ) THEN
+                  ISTATE(J) = - 2
+                  WEIGHT    = - WTINF(J)
+                  GO TO 160
+               END IF
+            END IF
+
+*           See if the upper bound is violated.
+
+            IF (BU(J) .GE. BIGUPP) GO TO 200
+            S = CTX - BU(J)
+            IF (S     .LE. FEASJ ) GO TO 200
+            ISTATE(J) = - 1
+            WEIGHT    =   WTINF(J)
+
+*           Add the infeasibility.
+
+  160       NUMINF = NUMINF + 1
+            SUMINF = SUMINF + ABS( WEIGHT ) * S
+            IF (J .LE. N) THEN
+               GQ(J) = WEIGHT
+            ELSE
+               CALL DAXPY ( N, WEIGHT, A(K,1), NROWA, GQ, 1 )
+            END IF
+         END IF
+  200 CONTINUE
+
+*     ------------------------------------------------------------------
+*     Install  GQ,  the transformed gradient.
+*     ------------------------------------------------------------------
+      SINGLR = .FALSE.
+      UNITGZ = .TRUE.
+
+      IF (NUMINF .GT. 0) THEN
+         CALL CMQMUL( 6, N, NZ, NFREE, NQ, UNITQ, KX, GQ, ZY, WRK )
+      ELSE IF (NUMINF .EQ. 0  .AND.  PRBTYP .EQ. 'FP') THEN
+         CALL DLOAD ( N, ZERO, GQ, 1 )
+      ELSE
+
+*        Ready for the Optimality Phase.
+*        Set NZ1 so that Rz1 is nonsingular.
+
+         IF (NRANK .EQ. 0) THEN
+            IF (LINOBJ) THEN
+               CALL DCOPY ( N, CQ, 1, GQ, 1 )
+            ELSE
+               CALL DLOAD ( N, ZERO, GQ, 1 )
+            END IF
+            NZ1    = 0
+         ELSE
+
+*           Compute  GQ = - R' * (transformed residual)
+
+            CALL DCOPY ( NRANK, RES, 1, GQ, 1 )
+            CALL DSCAL ( NRANK, (-ONE), GQ, 1 )
+            CALL DTRMV ( 'U', 'T', 'N', NRANK, R, NROWR, GQ, 1 )
+            IF (NRANK .LT. N)
+     $         CALL DGEMV( 'T', NRANK, N-NRANK, -ONE,R(1,NRANK+1),NROWR,
+     $                      RES, 1, ZERO, GQ(NRANK+1), 1 )
+
+            IF (LINOBJ) CALL DAXPY ( N, ONE, CQ, 1, GQ, 1 )
+            UNITGZ = .FALSE.
+            NZ1    = IDRANK( MIN(NRANK, NZ), R, NROWR+1, TOLRNK )
+         END IF
+      END IF
+
+      RETURN
+
+*     End of  LSGSET.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lskey.f
@@ -0,0 +1,283 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSKEY ( NOUT, BUFFER, KEY )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      CHARACTER*(*)      BUFFER
+
+************************************************************************
+*     LSKEY   decodes the option contained in  BUFFER  in order to set
+*     a parameter value in the relevant element of  IPRMLS  or  RPRMLS.
+*
+*
+*     Input:
+*
+*     NOUT   A unit number for printing error messages.
+*            NOUT  must be a valid unit.
+*
+*     Output:
+*
+*     KEY    The first keyword contained in BUFFER.
+*
+*
+*     LSKEY  calls OPNUMB and the subprograms
+*                 LOOKUP, SCANNR, TOKENS, UPCASE
+*     (now called OPLOOK, OPSCAN, OPTOKN, OPUPPR)
+*     supplied by Informatics General, Inc., Palo Alto, California.
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     This version dated Jan 22, 1986.
+************************************************************************
+*-----------------------------------------------------------------------
+      PARAMETER         (MXPARM = 30)
+      INTEGER            IPRMLS(MXPARM), IPSVLS
+      DOUBLE PRECISION   RPRMLS(MXPARM), RPSVLS
+
+      COMMON    /LSPAR1/ IPSVLS(MXPARM),
+     $                   IDBGLS, ITMAX1, ITMAX2, LCRASH, LDBGLS, LPROB ,
+     $                   MSGLS , NN    , NNCLIN, NPROB , IPADLS(20)
+
+      COMMON    /LSPAR2/ RPSVLS(MXPARM),
+     $                   BIGBND, BIGDX , BNDLOW, BNDUPP, TOLACT, TOLFEA,
+     $                   TOLRNK, RPADLS(23)
+
+      EQUIVALENCE       (IPRMLS(1), IDBGLS), (RPRMLS(1), BIGBND)
+
+      SAVE      /LSPAR1/, /LSPAR2/
+*-----------------------------------------------------------------------
+
+      EXTERNAL           OPNUMB
+      LOGICAL            FIRST , MORE  , NUMBER, OPNUMB, SORTED
+      SAVE               FIRST
+
+      PARAMETER         (     MAXKEY = 27,  MAXTIE = 10,   MAXTOK = 10,
+     $                        MAXTYP = 16)
+      CHARACTER*16       KEYS(MAXKEY), TIES(MAXTIE), TOKEN(MAXTOK),
+     $                   TYPE(MAXTYP)
+      CHARACTER*16       KEY, KEY2, KEY3, VALUE
+
+      PARAMETER         (IDUMMY = -11111,  RDUMMY = -11111.0,
+     $                   SORTED = .TRUE.,  ZERO   =  0.0     )
+
+      DATA                FIRST
+     $                  /.TRUE./
+      DATA   KEYS
+     $ / 'BEGIN           ',
+     $   'COLD            ', 'CONSTRAINTS     ', 'CRASH           ',
+     $   'DEBUG           ', 'DEFAULTS        ', 'END             ',
+     $   'FEASIBILITY     ', 'HOT             ', 'INFINITE        ',
+     $   'IPRMLS          ', 'ITERATIONS      ', 'ITERS:ITERATIONS',
+     $   'ITNS :ITERATIONS', 'LINEAR          ', 'LIST            ',
+     $   'LOWER           ', 'NOLIST          ', 'OPTIMALITY      ',
+     $   'PRINT           ', 'PROBLEM         ', 'RANK            ',
+     $   'RPRMLS          ', 'START           ', 'UPPER           ',
+     $   'VARIABLES       ', 'WARM            '/
+
+      DATA   TIES
+     $ / 'BOUND           ', 'CONSTRAINTS     ',
+     $   'NO              ', 'NO.      :NUMBER', 'NUMBER          ',
+     $   'PHASE           ', 'STEP            ',
+     $   'TOLERANCE       ', 'TYPE            ', 'YES             '/
+
+      DATA   TYPE
+     $ / 'FP              ',
+     $   'LEAST       :LS1', 'LINEAR       :LP', 'LP              ',
+     $   'LS          :LS1', 'LS1             ', 'LS2             ',
+     $   'LS3             ', 'LS4             ', 'LSQ         :LS1',
+     $   'QP          :QP2', 'QP1             ', 'QP2             ',
+     $   'QP3             ', 'QP4             ', 'QUADRATIC   :QP2'/
+*-----------------------------------------------------------------------
+
+      IF (FIRST) THEN
+         FIRST  = .FALSE.
+         DO 10 I = 1, MXPARM
+            IPRMLS(I) = IDUMMY
+            RPRMLS(I) = RDUMMY
+   10    CONTINUE
+      END IF
+
+*     Eliminate comments and empty lines.
+*     A '*' appearing anywhere in BUFFER terminates the string.
+
+      I      = INDEX( BUFFER, '*' )
+      IF (I .EQ. 0) THEN
+         LENBUF = LEN( BUFFER )
+      ELSE
+         LENBUF = I - 1
+      END IF
+      IF (LENBUF .LE. 0) THEN
+         KEY = '*'
+         GO TO 900
+      END IF
+
+*     ------------------------------------------------------------------
+*     Extract up to MAXTOK tokens from the record.
+*     NTOKEN returns how many were actually found.
+*     KEY, KEY2, KEY3 are the first tokens if any, otherwise blank.
+*     ------------------------------------------------------------------
+      NTOKEN = MAXTOK
+      CALL OPTOKN( BUFFER(1:LENBUF), NTOKEN, TOKEN )
+      KEY    = TOKEN(1)
+      KEY2   = TOKEN(2)
+      KEY3   = TOKEN(3)
+
+*     Certain keywords require no action.
+
+      IF (KEY .EQ. ' '     .OR.  KEY .EQ. 'BEGIN' ) GO TO 900
+      IF (KEY .EQ. 'LIST'  .OR.  KEY .EQ. 'NOLIST') GO TO 900
+      IF (KEY .EQ. 'END'                          ) GO TO 900
+
+*     Most keywords will have an associated integer or real value,
+*     so look for it no matter what the keyword.
+
+      I      = 1
+      NUMBER = .FALSE.
+
+   50 IF (I .LT. NTOKEN  .AND.  .NOT. NUMBER) THEN
+         I      = I + 1
+         VALUE  = TOKEN(I)
+         NUMBER = OPNUMB( VALUE )
+         GO TO 50
+      END IF
+
+      IF (NUMBER) THEN
+         READ (VALUE, '(BN, E16.0)') RVALUE
+      ELSE
+         RVALUE = ZERO
+      END IF
+
+*     Convert the keywords to their most fundamental form
+*     (upper case, no abbreviations).
+*     SORTED says whether the dictionaries are in alphabetic order.
+*     LOCi   says where the keywords are in the dictionaries.
+*     LOCi = 0 signals that the keyword wasn't there.
+
+      CALL OPLOOK( MAXKEY, KEYS, SORTED, KEY , LOC1 )
+      CALL OPLOOK( MAXTIE, TIES, SORTED, KEY2, LOC2 )
+
+*     ------------------------------------------------------------------
+*     Decide what to do about each keyword.
+*     The second keyword (if any) might be needed to break ties.
+*     Some seemingly redundant testing of MORE is used
+*     to avoid compiler limits on the number of consecutive ELSE IFs.
+*     ------------------------------------------------------------------
+      MORE   = .TRUE.
+      IF (MORE) THEN
+         MORE   = .FALSE.
+         IF (KEY .EQ. 'COLD        ') THEN
+            LCRASH = 0
+         ELSE IF (KEY .EQ. 'CONSTRAINTS ') THEN
+            NNCLIN = RVALUE
+         ELSE IF (KEY .EQ. 'CRASH       ') THEN
+            TOLACT = RVALUE
+         ELSE IF (KEY .EQ. 'DEBUG       ') THEN
+            LDBGLS = RVALUE
+         ELSE IF (KEY .EQ. 'DEFAULTS    ') THEN
+            DO 20 I = 1, MXPARM
+               IPRMLS(I) = IDUMMY
+               RPRMLS(I) = RDUMMY
+   20       CONTINUE
+         ELSE IF (KEY .EQ. 'FEASIBILITY ') THEN
+              IF (KEY2.EQ. 'PHASE       ') ITMAX1 = RVALUE
+              IF (KEY2.EQ. 'TOLERANCE   ') TOLFEA = RVALUE
+              IF (LOC2.EQ.  0            ) WRITE(NOUT, 2320) KEY2
+         ELSE
+            MORE   = .TRUE.
+         END IF
+      END IF
+
+      IF (MORE) THEN
+         MORE   = .FALSE.
+         IF (KEY .EQ. 'HOT         ') THEN
+            LCRASH = 2
+         ELSE IF (KEY .EQ. 'INFINITE    ') THEN
+              IF (KEY2.EQ. 'BOUND       ') BIGBND = RVALUE * 0.99999
+              IF (KEY2.EQ. 'STEP        ') BIGDX  = RVALUE
+              IF (LOC2.EQ.  0            ) WRITE(NOUT, 2320) KEY2
+         ELSE IF (KEY .EQ. 'IPRMLS      ') THEN
+*           Allow things like  IPRMLS 21 = 100  to set IPRMLS(21) = 100
+            IVALUE = RVALUE
+            IF (IVALUE .GE. 1  .AND. IVALUE .LE. MXPARM) THEN
+               READ (KEY3, '(BN, I16)') IPRMLS(IVALUE)
+            ELSE
+               WRITE(NOUT, 2400) IVALUE
+            END IF
+         ELSE IF (KEY .EQ. 'ITERATIONS  ') THEN
+            ITMAX2 = RVALUE
+         ELSE IF (KEY .EQ. 'LINEAR      ') THEN
+            NNCLIN = RVALUE
+         ELSE IF (KEY .EQ. 'LOWER       ') THEN
+            BNDLOW = RVALUE
+         ELSE
+            MORE   = .TRUE.
+         END IF
+      END IF
+
+      IF (MORE) THEN
+         MORE   = .FALSE.
+         IF      (KEY .EQ. 'OPTIMALITY  ') THEN
+            ITMAX2 = RVALUE
+         ELSE IF (KEY .EQ. 'PROBLEM     ') THEN
+            IF      (KEY2 .EQ. 'NUMBER') THEN
+               NPROB  = RVALUE
+            ELSE IF (KEY2 .EQ. 'TYPE  ') THEN
+
+*              Recognize     Problem type = LP     etc.
+
+               CALL OPLOOK( MAXTYP, TYPE, SORTED, KEY3, LOC3 )
+               IF (KEY3 .EQ. 'FP' ) LPROB = 1
+               IF (KEY3 .EQ. 'LP' ) LPROB = 2
+               IF (KEY3 .EQ. 'QP1') LPROB = 3
+               IF (KEY3 .EQ. 'QP2') LPROB = 4
+               IF (KEY3 .EQ. 'QP3') LPROB = 5
+               IF (KEY3 .EQ. 'QP4') LPROB = 6
+               IF (KEY3 .EQ. 'LS1') LPROB = 7
+               IF (KEY3 .EQ. 'LS2') LPROB = 8
+               IF (KEY3 .EQ. 'LS3') LPROB = 9
+               IF (KEY3 .EQ. 'LS4') LPROB = 10
+               IF (LOC3 .EQ.  0  ) WRITE(NOUT, 2330) KEY3
+            ELSE
+               WRITE(NOUT, 2320) KEY2
+            END IF
+         ELSE
+            MORE   = .TRUE.
+         END IF
+      END IF
+
+      IF (MORE) THEN
+         MORE   = .FALSE.
+         IF      (KEY .EQ. 'PRINT       ') THEN
+            MSGLS  = RVALUE
+         ELSE IF (KEY .EQ. 'RANK        ') THEN
+            TOLRNK = RVALUE
+         ELSE IF (KEY .EQ. 'RPRMLS      ') THEN
+*           Allow things like  RPRMLS 21 = 2  to set RPRMLS(21) = 2.0
+            IVALUE = RVALUE
+            IF (IVALUE .GE. 1  .AND. IVALUE .LE. MXPARM) THEN
+               READ (KEY3, '(BN, E16.0)') RPRMLS(IVALUE)
+            ELSE
+               WRITE(NOUT, 2400) IVALUE
+            END IF
+         ELSE IF (KEY .EQ. 'START       ') THEN
+            IDBGLS = RVALUE
+         ELSE IF (KEY .EQ. 'UPPER       ') THEN
+            BNDUPP = RVALUE
+         ELSE IF (KEY .EQ. 'VARIABLES   ') THEN
+            NN     = RVALUE
+         ELSE IF (KEY .EQ. 'WARM        ') THEN
+            LCRASH = 1
+         ELSE
+            WRITE(NOUT, 2300) KEY
+         END IF
+      END IF
+
+  900 RETURN
+
+ 2300 FORMAT(' XXX  Keyword not recognized:         ', A)
+ 2320 FORMAT(' XXX  Second keyword not recognized:  ', A)
+ 2330 FORMAT(' XXX  Third  keyword not recognized:  ', A)
+ 2400 FORMAT(' XXX  The PARM subscript is out of range:', I10)
+
+*     End of LSKEY
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lsloc.f
@@ -0,0 +1,90 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSLOC ( LPROB, N, NCLIN, LITOTL, LWTOTL )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+
+************************************************************************
+*     LSLOC   allocates the addresses of the work arrays for  LSCORE.
+*
+*     Note that the arrays  ( GQ, CQ )  and  ( RES, RES0, HZ )  lie in
+*     contiguous areas of workspace.
+*     RES, RES0 and HZ are not needed for LP.
+*     CQ is defined when the objective has an explicit linear term.
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     Original version written  29-October-1984.
+*     This version of LSLOC dated 16-February-1986.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL3CM/ LENNAM, NROWT, NCOLT, NQ
+
+      PARAMETER        ( LENLS = 20 )
+      COMMON    /SOL1LS/ LOCLS(LENLS)
+
+      LOGICAL            LSDBG
+      PARAMETER        ( LDBG = 5 )
+      COMMON    /LSDEBG/ ILSDBG(LDBG), LSDBG
+
+      MINIW     = LITOTL + 1
+      MINW      = LWTOTL + 1
+
+
+*     Assign array lengths that depend upon the problem dimensions.
+
+      IF (NCLIN .EQ. 0) THEN
+         LENT      = 0
+         LENZY     = 0
+      ELSE
+         LENT  = NROWT*NCOLT
+         LENZY = NQ   *NQ
+      END IF
+
+      LENCQ  = 0
+      IF (LPROB .EQ. 2*(LPROB/2)) LENCQ  = N
+      LENRES = 0
+      IF (LPROB .GT. 2          ) LENRES = N
+
+      LKACTV    = MINIW
+      MINIW     = LKACTV + N
+
+      LANORM    = MINW
+      LAP       = LANORM + NCLIN
+      LPX       = LAP    + NCLIN
+      LGQ       = LPX    + N
+      LCQ       = LGQ    + N
+      LRES      = LCQ    + LENCQ
+      LRES0     = LRES   + LENRES
+      LHZ       = LRES0  + LENRES
+      LRLAM     = LHZ    + LENRES
+      LT        = LRLAM  + N
+      LZY       = LT     + LENT
+      LWTINF    = LZY    + LENZY
+      LWRK      = LWTINF + N  + NCLIN
+      LFEATL    = LWRK   + N  + NCLIN
+      MINW      = LFEATL + N  + NCLIN
+
+      LOCLS( 1) = LKACTV
+      LOCLS( 2) = LANORM
+      LOCLS( 3) = LAP
+      LOCLS( 4) = LPX
+      LOCLS( 5) = LRES
+      LOCLS( 6) = LRES0
+      LOCLS( 7) = LHZ
+      LOCLS( 8) = LGQ
+      LOCLS( 9) = LCQ
+      LOCLS(10) = LRLAM
+      LOCLS(11) = LT
+      LOCLS(12) = LZY
+      LOCLS(13) = LWTINF
+      LOCLS(14) = LWRK
+      LOCLS(15) = LFEATL
+
+      LITOTL    = MINIW - 1
+      LWTOTL    = MINW  - 1
+
+      RETURN
+
+*     End of  LSLOC .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lsmove.f
@@ -0,0 +1,83 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSMOVE( HITCON, HITLOW, LINOBJ, UNITGZ,
+     $                   NCLIN, NRANK, NZ1,
+     $                   N, NROWR, JADD, NUMINF,
+     $                   ALFA, CTP, CTX, XNORM,
+     $                   AP, AX, BL, BU, GQ, HZ, P, RES,
+     $                   R, X, WORK )
+
+      IMPLICIT           DOUBLE PRECISION (A-H,O-Z)
+      LOGICAL            HITCON, HITLOW, LINOBJ, UNITGZ
+      DOUBLE PRECISION   AP(*), AX(*), BL(*), BU(*), GQ(*), HZ(*),
+     $                   P(N), RES(*), R(NROWR,*), X(N)
+      DOUBLE PRECISION   WORK(*)
+
+************************************************************************
+*     LSMOVE  changes X to X + ALFA*P and updates CTX, AX, RES and GQ
+*     accordingly.
+*
+*     If a bound was added to the working set,  move X exactly on to it,
+*     except when a negative step was taken (CMALF may have had to move
+*     to some other closer constraint.)
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     Original version written 27-December-1985.
+*     Level 2 BLAS added 11-June-1986.
+*     This version of LSMOVE dated 11-June-1986.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+
+      LOGICAL            LSDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /LSDEBG/ ILSDBG(LDBG), LSDBG
+
+      EXTERNAL           DDOT  , DNRM2
+      INTRINSIC          ABS   , MIN
+      PARAMETER        ( ZERO  = 0.0D+0, ONE = 1.0D+0 )
+
+      CALL DAXPY ( N, ALFA, P, 1, X, 1 )
+      IF (LINOBJ) CTX = CTX + ALFA*CTP
+
+      IF (HITCON  .AND.  JADD .LE. N) THEN
+         BND = BU(JADD)
+         IF (HITLOW) BND = BL(JADD)
+         IF (ALFA .GE. ZERO) X(JADD) = BND
+      END IF
+      XNORM  = DNRM2 ( N, X, 1 )
+
+      IF (NCLIN .GT. 0)
+     $   CALL DAXPY ( NCLIN, ALFA, AP, 1, AX, 1 )
+
+      IF (NZ1 .LE. NRANK) THEN
+         IF (UNITGZ) THEN
+            RES(NZ1) = RES(NZ1) - ALFA*HZ(NZ1)
+         ELSE
+            CALL DAXPY ( NZ1, (-ALFA), HZ, 1, RES, 1  )
+         END IF
+
+         IF (NUMINF .EQ. 0) THEN
+
+*           Update the transformed gradient GQ so that
+*           GQ = GQ + ALFA*R'( HZ ).
+*                            ( 0  )
+
+            IF (UNITGZ) THEN
+               CALL DAXPY ( N-NZ1+1, ALFA*HZ(NZ1), R(NZ1,NZ1), NROWR,
+     $                                             GQ(NZ1)   , 1      )
+            ELSE
+               CALL DCOPY ( NZ1, HZ, 1, WORK, 1 )
+               CALL DTRMV ( 'U', 'T', 'N', NZ1, R, NROWR, WORK, 1 )
+               IF (NZ1 .LT. N)
+     $            CALL DGEMV ( 'T', NZ1, N-NZ1, ONE, R(1,NZ1+1), NROWR,
+     $                         HZ, 1, ZERO, WORK(NZ1+1), 1 )
+               CALL DAXPY ( N, ALFA, WORK, 1, GQ, 1 )
+            END IF
+         END IF
+      END IF
+
+      RETURN
+
+*     End of  LSMOVE.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lsmuls.f
@@ -0,0 +1,196 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSMULS( PRBTYP,
+     $                   MSGLVL, N, NACTIV, NFREE,
+     $                   NROWA, NROWT, NUMINF, NZ, NZ1,
+     $                   ISTATE, KACTIV, KX, DINKY,
+     $                   JSMLST, KSMLST, JINF, JTINY,
+     $                   JBIGST, KBIGST, TRULAM,
+     $                   A, ANORMS, GQ, RLAMDA, T, WTINF )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      CHARACTER*2        PRBTYP
+      INTEGER            ISTATE(*), KACTIV(N), KX(N)
+      DOUBLE PRECISION   A(NROWA,*), ANORMS(*),
+     $                   GQ(N), RLAMDA(N), T(NROWT,*), WTINF(*)
+
+************************************************************************
+*     LSMULS  first computes the Lagrange multiplier estimates for the
+*     given working set.  It then determines the values and indices of
+*     certain significant multipliers.  In this process, the multipliers
+*     for inequalities at their upper bounds are adjusted so that a
+*     negative multiplier for an inequality constraint indicates non-
+*     optimality.  All adjusted multipliers are scaled by the 2-norm
+*     of the associated constraint row.  In the following, the term
+*     minimum refers to the ordering of numbers on the real line,  and
+*     not to their magnitude.
+*
+*     JSMLST  is the index of the minimum of the set of adjusted
+*             multipliers with values less than  - DINKY.  A negative
+*             JSMLST defines the index in Q'g of the artificial
+*             constraint to be deleted.
+*     KSMLST  marks the position of general constraint JSMLST in KACTIV.
+*
+*     JBIGST  is the index of the largest of the set of adjusted
+*             multipliers with values greater than (1 + DINKY).
+*     KBIGST  marks its position in KACTIV.
+*
+*     On exit,  elements 1 thru NACTIV of RLAMDA contain the unadjusted
+*     multipliers for the general constraints.  Elements NACTIV onwards
+*     of RLAMDA contain the unadjusted multipliers for the bounds.
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     Original version written 31-October-1984.
+*     This version of LSMULS dated  30-June-1986.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+
+      LOGICAL            LSDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /LSDEBG/ ILSDBG(LDBG), LSDBG
+
+      INTRINSIC          ABS, MIN
+      PARAMETER        ( ZERO   =0.0D+0,ONE    =1.0D+0 )
+
+      NFIXED =   N - NFREE
+
+      JSMLST =   0
+      KSMLST =   0
+      SMLLST = - DINKY
+
+      TINYLM =   DINKY
+      JTINY  =   0
+
+      JBIGST =   0
+      KBIGST =   0
+      BIGGST =   ONE + DINKY
+
+      IF (NZ1 .LT. NZ) THEN
+*        ---------------------------------------------------------------
+*        Compute JSMLST for the artificial constraints.
+*        ---------------------------------------------------------------
+         DO 100 J = NZ1+1, NZ
+            RLAM = - ABS( GQ(J) )
+            IF (RLAM .LT. SMLLST) THEN
+               SMLLST =   RLAM
+               JSMLST = - J
+            ELSE IF (RLAM .LT. TINYLM) THEN
+               TINYLM =   RLAM
+               JTINY  =   J
+            END IF
+  100    CONTINUE
+
+         IF (MSGLVL .GE. 20)
+     $      WRITE (NOUT, 1000) (GQ(K), K=NZ1+1,NZ)
+
+      END IF
+
+*     ------------------------------------------------------------------
+*     Compute JSMLST for regular constraints and temporary bounds.
+*     ------------------------------------------------------------------
+*     First, compute the Lagrange multipliers for the general
+*     constraints in the working set, by solving  T'*lamda = Y'g.
+
+      IF (N .GT. NZ)
+     $   CALL DCOPY ( N-NZ, GQ(NZ+1), 1, RLAMDA, 1 )
+      IF (NACTIV .GT. 0)
+     $   CALL CMTSOL( 2, NROWT, NACTIV, T(1,NZ+1), RLAMDA )
+
+*     -----------------------------------------------------------------
+*     Now set elements NACTIV, NACTIV+1,... of  RLAMDA  equal to
+*     the multipliers for the bound constraints.
+*     -----------------------------------------------------------------
+      DO 190 L = 1, NFIXED
+         J     = KX(NFREE+L)
+         BLAM  = RLAMDA(NACTIV+L)
+         DO 170 K = 1, NACTIV
+            I    = KACTIV(K)
+            BLAM = BLAM - A(I,J)*RLAMDA(K)
+  170    CONTINUE
+         RLAMDA(NACTIV+L) = BLAM
+  190 CONTINUE
+
+*     -----------------------------------------------------------------
+*     Find JSMLST and KSMLST.
+*     -----------------------------------------------------------------
+      DO 330 K = 1, N - NZ
+         IF (K .GT. NACTIV) THEN
+            J = KX(NZ+K)
+         ELSE
+            J = KACTIV(K) + N
+         END IF
+
+         IS   = ISTATE(J)
+
+         I    = J - N
+         IF (J .LE. N) ANORMJ = ONE
+         IF (J .GT. N) ANORMJ = ANORMS(I)
+
+         RLAM = RLAMDA(K)
+
+*        Change the sign of the estimate if the constraint is in
+*        the working set at its upper bound.
+
+         IF (IS .EQ. 2) RLAM =      - RLAM
+         IF (IS .EQ. 3) RLAM =   ABS( RLAM )
+         IF (IS .EQ. 4) RLAM = - ABS( RLAM )
+
+         IF (IS .NE. 3) THEN
+            SCDLAM = RLAM * ANORMJ
+            IF      (SCDLAM .LT. SMLLST) THEN
+               SMLLST = SCDLAM
+               JSMLST = J
+               KSMLST = K
+            ELSE IF (SCDLAM .LT. TINYLM) THEN
+               TINYLM = SCDLAM
+               JTINY  = J
+            END IF
+         END IF
+
+         IF (NUMINF .GT. 0  .AND.  J .GT. JINF) THEN
+            SCDLAM = RLAM/WTINF(J)
+            IF (SCDLAM .GT. BIGGST) THEN
+               BIGGST = SCDLAM
+               TRULAM = RLAMDA(K)
+               JBIGST = J
+               KBIGST = K
+            END IF
+         END IF
+  330 CONTINUE
+
+*     -----------------------------------------------------------------
+*     If required, print the multipliers.
+*     -----------------------------------------------------------------
+      IF (MSGLVL .GE. 20) THEN
+         IF (NFIXED .GT. 0)
+     $      WRITE (NOUT, 1100) PRBTYP, (KX(NFREE+K),
+     $                         RLAMDA(NACTIV+K), K=1,NFIXED)
+         IF (NACTIV .GT. 0)
+     $      WRITE (NOUT, 1200) PRBTYP, (KACTIV(K),
+     $                         RLAMDA(K), K=1,NACTIV)
+      END IF
+
+      IF (LSDBG  .AND.  ILSDBG(1) .GT. 0) THEN
+         WRITE (NOUT, 9000) JSMLST, SMLLST, KSMLST
+         WRITE (NOUT, 9100) JBIGST, BIGGST, KBIGST
+         WRITE (NOUT, 9200) JTINY , TINYLM
+      END IF
+
+      RETURN
+
+ 1000 FORMAT(/ ' Multipliers for the artificial constraints        '
+     $       / 4(5X, 1PE11.2))
+ 1100 FORMAT(/ ' Multipliers for the ', A2, ' bound  constraints   '
+     $       / 4(I5, 1PE11.2))
+ 1200 FORMAT(/ ' Multipliers for the ', A2, ' linear constraints   '
+     $       / 4(I5, 1PE11.2))
+ 9000 FORMAT(/ ' //LSMULS//  JSMLST     SMLLST     KSMLST (Scaled) '
+     $       / ' //LSMULS//  ', I6, 1PE11.2, 5X, I6 )
+ 9100 FORMAT(  ' //LSMULS//  JBIGST     BIGGST     KBIGST (Scaled) '
+     $       / ' //LSMULS//  ', I6, 1PE11.2, 5X, I6 )
+ 9200 FORMAT(  ' //LSMULS//   JTINY     TINYLM                     '
+     $       / ' //LSMULS//  ', I6, 1PE11.2)
+
+*     End of  LSMULS.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lsoptn.f
@@ -0,0 +1,68 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSOPTN( STRING )
+      CHARACTER*(*)      STRING
+
+************************************************************************
+*     LSOPTN  loads the option supplied in  STRING  into the relevant
+*     element of  IPRMLS  or  RPRMLS.
+************************************************************************
+
+      LOGICAL             NEWOPT
+      COMMON     /SOL3LS/ NEWOPT
+      SAVE       /SOL3LS/
+
+      DOUBLE PRECISION    WMACH(15)
+      COMMON     /SOLMCH/ WMACH
+      SAVE       /SOLMCH/
+
+      EXTERNAL            MCHPAR
+      CHARACTER*16        KEY
+      CHARACTER*72        BUFFER
+      LOGICAL             FIRST , PRNT
+      SAVE                FIRST , NOUT  , PRNT
+      DATA                FIRST /.TRUE./
+
+*     If first time in, set  NOUT.
+*     NEWOPT  is true first time into  LSFILE  or  LSOPTN
+*     and just after a call to  LSSOL.
+*     PRNT    is set to true whenever  NEWOPT  is true.
+
+      IF (FIRST) THEN
+         FIRST  = .FALSE.
+         NEWOPT = .TRUE.
+         CALL MCHPAR()
+         NOUT   =  WMACH(11)
+      END IF
+      BUFFER = STRING
+
+*     Call  LSKEY   to decode the option and set the parameter value.
+*     If NEWOPT is true, reset PRNT and test specially for NOLIST.
+
+      IF (NEWOPT) THEN
+         NEWOPT = .FALSE.
+         PRNT   = .TRUE.
+         CALL LSKEY ( NOUT, BUFFER, KEY )
+
+         IF (KEY .EQ. 'NOLIST') THEN
+            PRNT   = .FALSE.
+         ELSE
+            WRITE (NOUT, '(// A / A /)')
+     $         ' Calls to LSOPTN',
+     $         ' ---------------'
+            WRITE (NOUT, '( 6X, A )') BUFFER
+         END IF
+      ELSE
+         IF (PRNT)
+     $      WRITE (NOUT, '( 6X, A )') BUFFER
+         CALL LSKEY ( NOUT, BUFFER, KEY )
+
+         IF (KEY .EQ.   'LIST') PRNT = .TRUE.
+         IF (KEY .EQ. 'NOLIST') PRNT = .FALSE.
+      END IF
+
+      RETURN
+
+*     End of  LSOPTN.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lsprt.f
@@ -0,0 +1,151 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSPRT ( PRBTYP, PRNT1, ISDEL, ITER, JADD, JDEL,
+     $                   MSGLVL, NACTIV, NFREE, N, NCLIN,
+     $                   NRANK, NROWR, NROWT, NZ, NZ1, ISTATE,
+     $                   ALFA, CONDRZ, CONDT, GFNORM, GZNORM, GZ1NRM,
+     $                   NUMINF, SUMINF, CTX, SSQ,
+     $                   AX, R, T, X, WORK )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      CHARACTER*2        PRBTYP
+      LOGICAL            PRNT1
+      INTEGER            ISTATE(*)
+      DOUBLE PRECISION   AX(*), R(NROWR,*), T(NROWT,*), X(N)
+      DOUBLE PRECISION   WORK(N)
+
+************************************************************************
+*  LSPRT  prints various levels of output for  LSCORE.
+*
+*           Msg        Cumulative result
+*           ---        -----------------
+*
+*        le   0        no output.
+*
+*        eq   1        nothing now (but full output later).
+*
+*        eq   5        one terse line of output.
+*
+*        ge  10        same as 5 (but full output later).
+*
+*        ge  20        constraint status,  x  and  Ax.
+*
+*        ge  30        diagonals of  T  and  R.
+*
+*
+*  Debug printing is performed depending on the logical variable  LSDBG.
+*  LSDBG  is set true when  IDBG  major iterations have been performed.
+*  At this point,  printing is done according to a string of binary
+*  digits of the form  SVT  (stored in the integer array  ILSDBG).
+*
+*  S  set 'on'  gives information from the maximum step routine  CMALF.
+*  V  set 'on'  gives various vectors in  LSCORE  and its auxiliaries.
+*  T  set 'on'  gives a trace of which routine was called and an
+*               indication of the progress of the run.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Original version written 31-October-1984.
+*  This version of LSPRT dated 14-January-1985.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+
+      LOGICAL            LSDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /LSDEBG/ ILSDBG(LDBG), LSDBG
+
+      CHARACTER*2        LADD, LDEL
+      CHARACTER*2        LSTATE(0:5)
+      DATA               LSTATE(0), LSTATE(1), LSTATE(2)
+     $                  /'  '     , 'L '     , 'U '     /
+      DATA               LSTATE(3), LSTATE(4), LSTATE(5)
+     $                  /'E '     , 'T '     , 'Z '     /
+
+      IF (MSGLVL .GE. 15) WRITE (NOUT, 1000) PRBTYP, ITER
+
+      IF (MSGLVL .GE. 5) THEN
+         IF      (JDEL .GT. 0) THEN
+            KDEL =   ISDEL
+         ELSE IF (JDEL .LT. 0) THEN
+            JDEL = - JDEL
+            KDEL =   5
+         ELSE
+            KDEL =   0
+         END IF
+
+         IF (JADD .GT. 0) THEN
+            KADD = ISTATE(JADD)
+         ELSE
+            KADD = 0
+         END IF
+
+         LDEL   = LSTATE(KDEL)
+         LADD   = LSTATE(KADD)
+
+         IF (NUMINF .GT. 0) THEN
+            OBJ    = SUMINF
+         ELSE
+            OBJ    = SSQ + CTX
+         END IF
+
+*        ---------------------------------------------------------------
+*        Print the terse line.
+*        ---------------------------------------------------------------
+         IF (NRANK .EQ. 0) THEN
+            IF (PRNT1  .OR.  MSGLVL .GE. 15) WRITE (NOUT, 1100)
+            WRITE (NOUT, 1200) ITER, JDEL, LDEL, JADD, LADD,
+     $                         ALFA, NUMINF, OBJ, N-NFREE, NACTIV,
+     $                         NZ, NZ1, GFNORM, GZ1NRM, CONDT
+         ELSE
+            IF (PRNT1  .OR.  MSGLVL .GE. 15) WRITE (NOUT, 1110)
+            WRITE (NOUT, 1200) ITER, JDEL, LDEL, JADD, LADD,
+     $                         ALFA, NUMINF, OBJ, N-NFREE, NACTIV,
+     $                         NZ, NZ1, GFNORM, GZ1NRM, CONDT, CONDRZ
+         END IF
+
+         IF (MSGLVL .GE. 20) THEN
+            WRITE (NOUT, 2000) PRBTYP
+            WRITE (NOUT, 2100) (X(J) , ISTATE(J)  ,  J=1,N)
+            IF (NCLIN .GT. 0)
+     $      WRITE (NOUT, 2200) (AX(K), ISTATE(N+K), K=1,NCLIN )
+
+            IF (MSGLVL .GE. 30) THEN
+*              ---------------------------------------------------------
+*              Print the diagonals of  T  and  R.
+*              ---------------------------------------------------------
+               IF (NACTIV .GT. 0) THEN
+                  CALL DCOPY ( NACTIV, T(NACTIV,NZ+1), NROWT-1, WORK,1 )
+                  WRITE (NOUT, 3000) PRBTYP, (WORK(J), J=1,NACTIV)
+               END IF
+               IF (NRANK  .GT. 0)
+     $            WRITE (NOUT, 3100) PRBTYP, (R(J,J) , J=1,NRANK )
+            END IF
+            WRITE (NOUT, 5000)
+         END IF
+      END IF
+
+      PRNT1 = .FALSE.
+
+      RETURN
+
+ 1000 FORMAT(/// ' ', A2, ' iteration', I5
+     $         / ' =================' )
+ 1100 FORMAT(// '  Itn Jdel  Jadd      Step',
+     $          ' Ninf  Sinf/Objective', '  Bnd', '  Lin', '    Nz',
+     $          '   Nz1   Norm Gf  Norm Gz1   Cond T' )
+ 1110 FORMAT(// '  Itn Jdel  Jadd      Step',
+     $          ' Ninf  Sinf/Objective', '  Bnd', '  Lin', '    Nz',
+     $          '   Nz1   Norm Gf  Norm Gz1   Cond T Cond Rz1' )
+ 1200 FORMAT(I5, I5, A1, I5, A1, 1PE9.1, I5, 1X, 1PE15.6, 2I5,
+     $       2I6, 1P2E10.2, 1P2E9.1 )
+ 2000 FORMAT(/ ' Values and status of the ', A2, ' constraints'
+     $       / ' ---------------------------------------' )
+ 2100 FORMAT(/ ' Variables...'                 /   (1X, 5(1PE15.6, I5)))
+ 2200 FORMAT(/ ' General linear constraints...'/   (1X, 5(1PE15.6, I5)))
+ 3000 FORMAT(/ ' Diagonals of ' , A2,' working set factor T'/(1P5E15.6))
+ 3100 FORMAT(/ ' Diagonals of ' , A2, ' triangle R         '/(1P5E15.6))
+ 5000 FORMAT(/// ' ---------------------------------------------------',
+     $           '--------------------------------------------' )
+
+*     End of  LSPRT .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lssetx.f
@@ -0,0 +1,152 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSSETX( LINOBJ, ROWERR, UNITQ,
+     $                   NCLIN, NACTIV, NFREE, NRANK, NZ,
+     $                   N, NCTOTL, NQ, NROWA, NROWR, NROWT,
+     $                   ISTATE, KACTIV, KX,
+     $                   JMAX, ERRMAX, CTX, XNORM,
+     $                   A, AX, BL, BU, CQ, RES, RES0, FEATOL,
+     $                   R, T, X, ZY, P, WORK )
+
+      IMPLICIT           DOUBLE PRECISION (A-H,O-Z)
+      LOGICAL            LINOBJ, ROWERR, UNITQ
+      INTEGER            ISTATE(NCTOTL), KACTIV(N), KX(N)
+      DOUBLE PRECISION   A(NROWA,*), AX(*), BL(NCTOTL), BU(NCTOTL),
+     $                   CQ(*), RES(*), RES0(*), FEATOL(NCTOTL), P(N),
+     $                   R(NROWR,*), T(NROWT,*), ZY(NQ,*), X(N)
+      DOUBLE PRECISION   WORK(NCTOTL)
+
+************************************************************************
+*  LSSETX  computes the point on a working set that is closest to the
+*  input vector  x  (in the least-squares sense).  The norm of  x, the
+*  transformed residual vector  Pr - RQ'x,  and the constraint values
+*  Ax  are also initialized.
+*
+*  If the computed point gives a row error of more than the feasibility
+*  tolerance, an extra step of iterative refinement is used.  If  x  is
+*  still infeasible,  the logical variable  ROWERR  is set.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Original version written 31-October-1984.
+*  This version dated 29-December-1985.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+
+      LOGICAL            LSDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /LSDEBG/ ILSDBG(LDBG), LSDBG
+
+      EXTERNAL           IDAMAX, DDOT
+      INTRINSIC          ABS, MIN
+      PARAMETER        ( NTRY  = 2 )
+      PARAMETER        ( ZERO  = 0.0D+0, ONE = 1.0D+0 )
+
+*     ------------------------------------------------------------------
+*     Move  x  onto the simple bounds in the working set.
+*     ------------------------------------------------------------------
+      DO 100 K = NFREE+1, N
+          J   = KX(K)
+          IS  = ISTATE(J)
+          BND = BL(J)
+          IF (IS .GE. 2) BND  = BU(J)
+          IF (IS .NE. 4) X(J) = BND
+  100 CONTINUE
+
+*     ------------------------------------------------------------------
+*     Move  x  onto the general constraints in the working set.
+*     We shall make  ntry  tries at getting acceptable row errors.
+*     ------------------------------------------------------------------
+      KTRY   = 1
+      JMAX   = 1
+      ERRMAX = ZERO
+
+*     REPEAT
+  200    IF (NACTIV .GT. 0) THEN
+
+*           Set  work = residuals for constraints in the working set.
+*           Solve for p, the smallest correction to x that gives a point
+*           on the constraints in the working set.  Define  p = Y*(py),
+*           where  py  solves the triangular system  T*(py) = residuals.
+
+            DO 220 I = 1, NACTIV
+               K   = KACTIV(I)
+               J   = N + K
+               BND = BL(J)
+               IF (ISTATE(J) .EQ. 2) BND = BU(J)
+               WORK(I) = BND - DDOT  ( N, A(K,1), NROWA, X, 1 )
+  220       CONTINUE
+
+            CALL CMTSOL( 1, NROWT, NACTIV, T(1,NZ+1), WORK )
+            CALL DLOAD ( N, ZERO, P, 1 )
+            CALL DCOPY ( NACTIV, WORK, 1, P(NZ+1), 1 )
+
+            CALL CMQMUL( 2, N, NZ, NFREE, NQ, UNITQ, KX, P, ZY, WORK )
+            CALL DAXPY ( N, ONE, P, 1, X, 1 )
+         END IF
+
+*        ---------------------------------------------------------------
+*        Compute the 2-norm of  x.
+*        Initialize  Ax  for all the general constraints.
+*        ---------------------------------------------------------------
+         XNORM  = DNRM2 ( N, X, 1 )
+         IF (NCLIN .GT. 0)
+     $      CALL DGEMV ( 'N', NCLIN, N, ONE, A, NROWA,
+     $                   X, 1, ZERO, AX, 1 )
+
+*        ---------------------------------------------------------------
+*        Check the row residuals.
+*        ---------------------------------------------------------------
+         IF (NACTIV .GT. 0) THEN
+            DO 300 K = 1, NACTIV
+               I   = KACTIV(K)
+               J   = N + I
+               IS  = ISTATE(J)
+               IF (IS .EQ. 1) WORK(K) = BL(J) - AX(I)
+               IF (IS .GE. 2) WORK(K) = BU(J) - AX(I)
+  300       CONTINUE
+
+            JMAX   = IDAMAX( NACTIV, WORK, 1 )
+            ERRMAX = ABS( WORK(JMAX) )
+         END IF
+
+         KTRY = KTRY + 1
+*     UNTIL    (ERRMAX .LE. FEATOL(JMAX) .OR. KTRY .GT. NTRY
+      IF (.NOT.(ERRMAX .LE. FEATOL(JMAX) .OR. KTRY .GT. NTRY)) GO TO 200
+
+      ROWERR = ERRMAX .GT. FEATOL(JMAX)
+
+*     ==================================================================
+*     Compute the linear objective value  c'x  and the transformed
+*     residual  Pr  -  RQ'x = RES0  -  RQ'x.
+*     ==================================================================
+      IF (NRANK .GT. 0  .OR.  LINOBJ) THEN
+         CALL DCOPY ( N, X, 1, P, 1 )
+         CALL CMQMUL( 6, N, NZ, NFREE, NQ, UNITQ, KX, P, ZY, WORK )
+      END IF
+
+      CTX = ZERO
+      IF (LINOBJ)
+     $   CTX = DDOT  ( N, CQ, 1, P, 1 )
+
+      IF (NRANK .GT. 0) THEN
+
+         CALL DTRMV ( 'U', 'N', 'N', NRANK, R, NROWR, P, 1 )
+         IF (NRANK .LT. N)
+     $      CALL DGEMV ( 'N', NRANK, N-NRANK, ONE, R(1,NRANK+1), NROWR,
+     $                   P(NRANK+1), 1, ONE, P, 1 )
+
+         CALL DCOPY ( NRANK,       RES0, 1, RES, 1 )
+         CALL DAXPY ( NRANK, -ONE, P   , 1, RES, 1 )
+
+      END IF
+
+      IF (LSDBG  .AND.  ILSDBG(2) .GT. 0)
+     $   WRITE (NOUT, 2200) (X(J), J = 1, N)
+
+      RETURN
+
+ 2200 FORMAT(/ ' //LSSETX// Variables after refinement ... '/ (5G12.3))
+
+*     End of  LSSETX.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/lssol.f
@@ -0,0 +1,523 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE LSSOL ( MM, N,
+     $                   NCLIN, NROWA, NROWR,
+     $                   A, BL, BU, CVEC,
+     $                   ISTATE, KX, X, R, B,
+     $                   INFORM, ITER, OBJ, CLAMDA,
+     $                   IW, LENIW, W, LENW )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      INTEGER            LENIW, LENW
+      INTEGER            ISTATE(N+NCLIN), KX(N)
+      INTEGER            IW(LENIW)
+      DOUBLE PRECISION   BL(N+NCLIN), BU(N+NCLIN), A(NROWA,*)
+      DOUBLE PRECISION   CLAMDA(N+NCLIN), CVEC(*)
+      DOUBLE PRECISION   R(NROWR,*), X(N), B(*)
+      DOUBLE PRECISION   W(LENW)
+
+************************************************************************
+*  LSSOL  solves problems of the form
+*
+*           Minimize               F(x)
+*              x
+*                                 (  x )
+*           subject to    bl  .le.(    ).ge.  bu,
+*                                 ( Ax )
+*
+*  where  '  denotes the transpose of a column vector,  x  denotes the
+*  n-vector of parameters and  F(x) is one of the following functions..
+*
+*  FP =  None                         (find a feasible point).
+*  LP =  c'x
+*  QP1=        1/2 x'Rx                R  n times n, symmetric pos. def.
+*  QP2=  c'x + 1/2 x'Rx                .  .   ..        ..       ..  ..
+*  QP3=        1/2 x'R'Rx              R  m times n, upper triangular.
+*  QP4=  c'x + 1/2 x'R'Rx              .  .   ..  .   ..      ...
+*  LS1=        1/2 (b - Rx)'(b - Rx)   R  m times n, rectangular.
+*  LS2=  c'x + 1/2 (b - Rx)'(b - Rx)   .  .   ..  .     ...
+*  LS3=        1/2 (b - Rx)'(b - Rx)   R  m times n, upper triangular.
+*  LS4=  c'x + 1/2 (b - Rx)'(b - Rx)   .  .   ..  .   ..      ...
+*
+*  The matrix  R  is entered as the two-dimensional array  R  (of row
+*  dimension  NROWR).  If  NROWR = 0,  R  is not accessed.
+*
+*  The vector  c  is entered in the one-dimensional array  CVEC.
+*
+*  NCLIN  is the number of general linear constraints (rows of  A).
+*  (NCLIN may be zero.)
+*
+*  The first  N  components of  BL  and   BU  are lower and upper
+*  bounds on the variables.  The next  NCLIN  components are
+*  lower and upper bounds on the general linear constraints.
+*
+*  The matrix  A  of coefficients in the general linear constraints
+*  is entered as the two-dimensional array  A  (of dimension
+*  NROWA by N).  If NCLIN = 0, A is not accessed.
+*
+*  The vector  x  must contain an initial estimate of the solution,
+*  and will contain the computed solution on output.
+*
+*
+*  Complete documentation for  LSSOL  is contained in Report SOL 86-1,
+*  Users Guide for LSSOL (Version 1.0), by P.E. Gill, S. J. Hammarling,
+*  W. Murray, M.A. Saunders and M.H. Wright, Department of
+*  Operations Research, Stanford University, Stanford, California 94305.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Version 1.01 Dated  30-June-1986.
+*
+*  Copyright  1984  Stanford University.
+*
+*  This material may be reproduced by or for the U.S. Government pursu-
+*  ant to the copyright license under DAR clause 7-104.9(a) (1979 Mar).
+*
+*  This material is based upon work partially supported by the National
+*  Science Foundation under Grants MCS-7926009 and ECS-8312142; the
+*  Department of Energy Contract AM03-76SF00326, PA No. DE-AT03-
+*  76ER72018; the Army Research Office Contract DAA29-84-K-0156;
+*  and the Office of Naval Research Grant N00014-75-C-0267.
+************************************************************************
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL3CM/ LENNAM, NROWT, NCOLT, NQ
+      COMMON    /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9
+      COMMON    /SOL5CM/ ASIZE, DTMAX, DTMIN
+
+      PARAMETER         (LENLS = 20)
+      COMMON    /SOL1LS/ LOCLS(LENLS)
+
+      LOGICAL            LSDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /LSDEBG/ ILSDBG(LDBG), LSDBG
+*-----------------------------------------------------------------------
+      PARAMETER         (MXPARM = 30)
+      INTEGER            IPRMLS(MXPARM), IPSVLS
+      DOUBLE PRECISION   RPRMLS(MXPARM), RPSVLS
+
+      COMMON    /LSPAR1/ IPSVLS(MXPARM),
+     $                   IDBGLS, ITMAX1, ITMAX2, LCRASH, LDBGLS, LPROB ,
+     $                   MSGLS , NN    , NNCLIN, NPROB , IPADLS(20)
+
+      COMMON    /LSPAR2/ RPSVLS(MXPARM),
+     $                   BIGBND, BIGDX , BNDLOW, BNDUPP, TOLACT, TOLFEA,
+     $                   TOLRNK, RPADLS(23)
+
+      EQUIVALENCE       (IPRMLS(1), IDBGLS), (RPRMLS(1), BIGBND)
+
+      SAVE      /LSPAR1/, /LSPAR2/
+*-----------------------------------------------------------------------
+      EQUIVALENCE   (MSGLS , MSGLVL), (IDBGLS, IDBG), (LDBGLS, MSGDBG)
+
+      INTRINSIC          MAX, MIN
+
+*     Local variables.
+
+      LOGICAL            COLD  , FACTRZ, LINOBJ, NAMED , ROWERR,
+     $                   UNITQ , VERTEX
+      CHARACTER*2        PRBTYP
+      CHARACTER*8        NAMES(1)
+      PARAMETER        ( ZERO   =0.0D+0, POINT1 =0.1D+0, POINT3 =3.3D-1)
+      PARAMETER        ( POINT8 =0.8D+0, POINT9 =0.9D+0, ONE    =1.0D+0)
+
+      CHARACTER*40       TITLE
+      DATA               TITLE
+     $                 / 'SOL/LSSOL  ---  Version 1.01   June 1986' /
+
+*     Set the machine-dependent constants.
+
+      CALL MCHPAR()
+
+      EPSMCH = WMACH( 3)
+      RTEPS  = WMACH( 4)
+      NOUT   = WMACH(11)
+
+      EPSPT3 = EPSMCH**POINT3
+      EPSPT5 = RTEPS
+      EPSPT8 = EPSMCH**POINT8
+      EPSPT9 = EPSMCH**POINT9
+
+      NAMED  = .FALSE.
+
+      INFORM = 0
+      ITER   = 0
+
+      CONDMX = ONE / EPSPT5
+
+      NCTOTL = N + NCLIN
+
+*     Set the default values of the parameters.
+
+      CALL LSDFLT( MM, N, NCLIN, TITLE )
+
+*     Set all parameters determined by the problem type.
+
+      IF      (LPROB .EQ. 1 ) THEN
+         PRBTYP    = 'FP'
+         M      = 0
+         LINOBJ = .FALSE.
+         FACTRZ = .TRUE.
+      ELSE IF (LPROB .EQ. 2 ) THEN
+         PRBTYP    = 'LP'
+         M      = 0
+         LINOBJ = .TRUE.
+         FACTRZ = .TRUE.
+      ELSE IF (LPROB .EQ. 3 ) THEN
+         PRBTYP    = 'QP'
+         M      = MM
+         LINOBJ = .FALSE.
+         FACTRZ = .TRUE.
+      ELSE IF (LPROB .EQ. 4 ) THEN
+         PRBTYP    = 'QP'
+         M      = MM
+         LINOBJ = .TRUE.
+         FACTRZ = .TRUE.
+      ELSE IF (LPROB .EQ. 5 ) THEN
+         PRBTYP    = 'QP'
+         M      = MM
+         LINOBJ = .FALSE.
+         FACTRZ = .FALSE.
+      ELSE IF (LPROB .EQ. 6 ) THEN
+         PRBTYP    = 'QP'
+         M      = MM
+         LINOBJ = .TRUE.
+         FACTRZ = .FALSE.
+      ELSE IF (LPROB .EQ. 7 ) THEN
+         PRBTYP    = 'LS'
+         M      = MM
+         LINOBJ = .FALSE.
+         FACTRZ = .TRUE.
+      ELSE IF (LPROB .EQ. 8 ) THEN
+         PRBTYP    = 'LS'
+         M      = MM
+         LINOBJ = .TRUE.
+         FACTRZ = .TRUE.
+      ELSE IF (LPROB .EQ. 9 ) THEN
+         PRBTYP    = 'LS'
+         M      = MM
+         LINOBJ = .FALSE.
+         FACTRZ = .FALSE.
+      ELSE IF (LPROB .EQ. 10) THEN
+         PRBTYP    = 'LS'
+         M      = MM
+         LINOBJ = .TRUE.
+         FACTRZ = .FALSE.
+      END IF
+
+*     Assign the dimensions of arrays in the parameter list of LSCORE.
+*     Economies of storage are possible if the minimum number of active
+*     constraints and the minimum number of fixed variables are known in
+*     advance.  The expert user should alter MINACT and MINFXD
+*     accordingly.
+*     If a linear program is being solved and the matrix of general
+*     constraints is fat,  i.e.,  NCLIN .LT. N,  a non-zero value is
+*     known for MINFXD.  Note that in this case, VERTEX must be
+*     set  .TRUE..
+
+      MINACT = 0
+      MINFXD = 0
+
+      VERTEX = .FALSE.
+      IF (      (PRBTYP .EQ. 'LP'  .OR.  PRBTYP .EQ. 'FP')
+     $    .AND.  NCLIN  .LT. N   ) THEN
+         MINFXD = N - NCLIN - 1
+         VERTEX = .TRUE.
+      END IF
+
+      MXFREE = N - MINFXD
+      MAXACT = MAX( 1, MIN( N, NCLIN ) )
+      MAXNZ  = N - ( MINFXD + MINACT )
+
+      IF (NCLIN .EQ. 0) THEN
+         NQ     = 1
+         NROWT  = 1
+         NCOLT  = 1
+         VERTEX = .FALSE.
+      ELSE
+         NQ     = MAX( 1, MXFREE )
+         NROWT  = MAX( MAXNZ, MAXACT )
+         NCOLT  = MXFREE
+      END IF
+
+      NCNLN  = 0
+      LENNAM = 1
+
+*     Allocate certain arrays that are not done in LSLOC.
+
+      LITOTL = 0
+
+      LAX    = 1
+      LWTOTL = LAX + NCLIN  - 1
+
+*     Allocate remaining work arrays.
+
+      CALL LSLOC ( LPROB, N, NCLIN, LITOTL, LWTOTL )
+
+      COLD  = LCRASH .EQ. 0
+
+*     Check input parameters and storage limits.
+
+      CALL CMCHK ( NERROR, MSGLVL, COLD, (.NOT.FACTRZ),
+     $             LENIW, LENW, LITOTL, LWTOTL,
+     $             N, NCLIN, NCNLN,
+     $             ISTATE, KX, NAMED, NAMES, LENNAM,
+     $             BL, BU, X )
+
+      IF (NERROR .GT. 0) THEN
+         INFORM = 6
+         GO TO 800
+      END IF
+
+      LKACTV = LOCLS( 1)
+
+      LANORM = LOCLS( 2)
+      LPX    = LOCLS( 4)
+      LRES   = LOCLS( 5)
+      LRES0  = LOCLS( 6)
+      LGQ    = LOCLS( 8)
+      LCQ    = LOCLS( 9)
+      LRLAM  = LOCLS(10)
+      LT     = LOCLS(11)
+      LZY    = LOCLS(12)
+      LWTINF = LOCLS(13)
+      LWRK   = LOCLS(14)
+      LFEATL = LOCLS(15)
+
+      IF (TOLFEA .GT. ZERO)
+     $   CALL DLOAD ( N+NCLIN, (TOLFEA), W(LFEATL), 1 )
+
+      IANRMJ = LANORM
+      DO 200 J = 1, NCLIN
+         W(IANRMJ) = DNRM2 ( N, A(J,1), NROWA )
+         IANRMJ    = IANRMJ + 1
+  200 CONTINUE
+      IF (NCLIN .GT. 0)
+     $   CALL DCOND ( NCLIN, W(LANORM), 1, ASIZE, AMIN )
+
+      CALL DCOND ( NCTOTL, W(LFEATL), 1, FEAMAX, FEAMIN )
+      CALL DCOPY ( NCTOTL, W(LFEATL), 1, W(LWTINF), 1 )
+      CALL DSCAL ( NCTOTL, (ONE/FEAMIN), W(LWTINF), 1 )
+
+      SSQ1   = ZERO
+
+      IF (FACTRZ) THEN
+*        ===============================================================
+*        Factorize R using QR or Cholesky.  KX must be initialized.
+*        ===============================================================
+         DO 210 I = 1, N
+            KX(I) = I
+  210    CONTINUE
+
+         IF      (PRBTYP .EQ. 'LP'  .OR.  PRBTYP .EQ. 'FP') THEN
+            NRANK = 0
+         ELSE IF (PRBTYP .EQ. 'QP') THEN
+*           ------------------------------------------------------------
+*           Compute the Cholesky factorization of R.  The Hessian is
+*           M times M and resides in the upper left-hand corner of R.
+*           ------------------------------------------------------------
+            DO 220 J = M+1, N
+               CALL DLOAD ( M, (ZERO), R(1,J), 1 )
+  220       CONTINUE
+
+            CALL LSCHOL( NROWR, M, NRANK, TOLRNK, KX, R, INFO )
+
+            IF (NRANK .GT. 0)
+     $         CALL DLOAD ( NRANK, (ZERO), W(LRES0), 1 )
+
+         ELSE IF (PRBTYP .EQ. 'LS') THEN
+*           ------------------------------------------------------------
+*           Compute the orthogonal factorization PRQ = ( U ),  where P
+*                                                      ( 0 )
+*           is an orthogonal matrix and Q is a permutation matrix.
+*           Overwrite R with the upper-triangle U.  The orthogonal
+*           matrix P is applied to the residual and discarded.  The
+*           permutation is stored in the array KX.  Once U has been
+*           computed we need only work with vectors of length N within
+*           LSCORE.  However, it is necessary to store the sum of
+*           squares of the terms  B(NRANK+1),...,B(M),  where B = Pr.
+*           ------------------------------------------------------------
+            CALL DGEQRP( 'Column iterchanges', M, N, R, NROWR,
+     $                   W(LWRK), IW(LKACTV), W(LGQ), INFO )
+
+            LJ  = LKACTV
+            DO 230 J = 1, N
+               JMAX = IW(LJ)
+               IF (JMAX .GT. J) THEN
+                  JSAVE    = KX(JMAX)
+                  KX(JMAX) = KX(J)
+                  KX(J)    = JSAVE
+               END IF
+               LJ = LJ + 1
+  230       CONTINUE
+
+            CALL DGEAPQ( 'Transpose', 'Separate', M, N, R, NROWR,
+     $                   W(LWRK), 1, B, M, W(LGQ), INFO )
+
+            NRANK = IDRANK( MIN(N, M), R, NROWR+1, TOLRNK )
+
+            IF (M .GT. NRANK) SSQ1 = DNRM2 ( M-NRANK, B(NRANK+1), 1 )
+
+            IF (NRANK .GT. 0)
+     $         CALL DCOPY ( NRANK, B, 1, W(LRES0), 1 )
+         END IF
+      ELSE
+*        ===============================================================
+*        R is input as an upper-triangular matrix with M rows.
+*        ===============================================================
+         NRANK = M
+         IF (NRANK .GT. 0) THEN
+            IF      (PRBTYP .EQ. 'QP') THEN
+               CALL DLOAD ( NRANK, (ZERO), W(LRES0), 1 )
+            ELSE IF (PRBTYP .EQ. 'LS') THEN
+               CALL DCOPY ( NRANK, B, 1, W(LRES0), 1 )
+            END IF
+         END IF
+      END IF
+
+      IF (       MSGLVL .GT. 0     .AND.  NRANK  .LT. N
+     $    .AND.  PRBTYP .NE. 'LP'  .AND.  PRBTYP .NE. 'FP')
+     $   WRITE (NOUT, 9000) NRANK
+
+*     ------------------------------------------------------------------
+*     Find an initial working set.
+*     ------------------------------------------------------------------
+      CALL LSCRSH( COLD, VERTEX,
+     $             NCLIN, NCTOTL, NACTIV, NARTIF,
+     $             NFREE, N, NROWA,
+     $             ISTATE, IW(LKACTV),
+     $             BIGBND, TOLACT,
+     $             A, W(LAX), BL, BU, X, W(LGQ), W(LWRK) )
+
+*     ------------------------------------------------------------------
+*     Compute the TQ factorization of the constraints while keeping R in
+*     upper-triangular form.  Transformations associated with Q are
+*     applied to CQ.  Transformations associated with P are applied to
+*     RES0.  If some simple bounds are in the working set,  KX is
+*     re-ordered so that the free variables come first.
+*     ------------------------------------------------------------------
+*     First, add the bounds. To save a bit of work, CQ is not loaded
+*     until after KX has been re-ordered.
+
+      NGQ   = 0
+      NRES  = 0
+      IF (NRANK .GT. 0) NRES = 1
+      UNITQ = .TRUE.
+
+      CALL LSBNDS( UNITQ,
+     $             INFORM, NZ, NFREE, NRANK, NRES, NGQ,
+     $             N, NQ, NROWA, NROWR, NROWT,
+     $             ISTATE, KX,
+     $             CONDMX,
+     $             A, R, W(LT), W(LRES0), W(LCQ),
+     $             W(LZY), W(LGQ), W(LWRK) )
+
+      IF (LINOBJ) THEN
+
+*        Install the transformed linear term in CQ.
+*        CMQMUL applies the permutations in KX to CVEC.
+
+         NGQ = 1
+         CALL DCOPY ( N, CVEC, 1, W(LCQ), 1 )
+         CALL CMQMUL( 6, N, NZ, NFREE, NQ, UNITQ,
+     $                KX, W(LCQ), W(LZY), W(LWRK) )
+      END IF
+
+      IF (NACTIV .GT. 0) THEN
+         NACT1  = NACTIV
+         NACTIV = 0
+
+         CALL LSADDS( UNITQ, VERTEX,
+     $                INFORM, 1, NACT1, NACTIV, NARTIF, NZ, NFREE,
+     $                NRANK, NREJTD, NRES, NGQ,
+     $                N, NQ, NROWA, NROWR, NROWT,
+     $                ISTATE, IW(LKACTV), KX,
+     $                CONDMX,
+     $                A, R, W(LT), W(LRES0), W(LCQ),
+     $                W(LZY), W(LGQ), W(LWRK) )
+      END IF
+
+*     ------------------------------------------------------------------
+*     Move the initial  x  onto the constraints in the working set.
+*     Compute the transformed residual vector  Pr = Pb - RQ'x.
+*     ------------------------------------------------------------------
+      CALL LSSETX( LINOBJ, ROWERR, UNITQ,
+     $             NCLIN, NACTIV, NFREE, NRANK, NZ,
+     $             N, NCTOTL, NQ, NROWA, NROWR, NROWT,
+     $             ISTATE, IW(LKACTV), KX,
+     $             JMAX, ERRMAX, CTX, XNORM,
+     $             A, W(LAX), BL, BU, W(LCQ), W(LRES), W(LRES0),
+     $             W(LFEATL), R, W(LT), X, W(LZY), W(LPX), W(LWRK) )
+
+      JINF = 0
+
+      CALL LSCORE( PRBTYP, NAMED, NAMES, LINOBJ, UNITQ,
+     $             INFORM, ITER, JINF, NCLIN, NCTOTL,
+     $             NACTIV, NFREE, NRANK, NZ, NZ1,
+     $             N, NROWA, NROWR,
+     $             ISTATE, IW(LKACTV), KX,
+     $             CTX, OBJ, SSQ1,
+     $             SUMINF, NUMINF, XNORM,
+     $             BL, BU, A, CLAMDA, W(LAX),
+     $             W(LFEATL), R, X, IW, W )
+
+      OBJ    = OBJ    + CTX
+      IF (PRBTYP .EQ. 'LS'  .AND.  NRANK .GT. 0)
+     $   CALL DCOPY ( NRANK, W(LRES), 1, B, 1 )
+
+*     ==================================================================
+*     Print messages if required.
+*     ==================================================================
+  800 IF (MSGLVL .GT.   0) THEN
+         IF (INFORM .EQ.   0) THEN
+            IF (PRBTYP .EQ. 'FP') THEN
+               WRITE (NOUT, 2001)
+            ELSE
+               WRITE (NOUT, 2002) PRBTYP
+            END IF
+         END IF
+         IF (INFORM .EQ.   1) WRITE (NOUT, 2010) PRBTYP
+         IF (INFORM .EQ.   2) WRITE (NOUT, 2020) PRBTYP
+         IF (INFORM .EQ.   3) WRITE (NOUT, 2030)
+         IF (INFORM .EQ.   4) WRITE (NOUT, 2040)
+         IF (INFORM .EQ.   5) WRITE (NOUT, 2050)
+         IF (INFORM .EQ.   6) WRITE (NOUT, 2060) NERROR
+
+         IF (INFORM .LT.   6) THEN
+            IF      (NUMINF .EQ. 0) THEN
+                IF (PRBTYP .NE. 'FP') WRITE (NOUT, 3000) PRBTYP, OBJ
+            ELSE IF (INFORM .EQ. 3) THEN
+               WRITE (NOUT, 3010) SUMINF
+            ELSE
+               WRITE (NOUT, 3020) SUMINF
+            END IF
+            IF (NUMINF .GT. 0) OBJ = SUMINF
+         END IF
+      END IF
+
+*     Recover the optional parameters set by the user.
+
+      CALL ICOPY ( MXPARM, IPSVLS, 1, IPRMLS, 1 )
+      CALL DCOPY ( MXPARM, RPSVLS, 1, RPRMLS, 1 )
+
+      RETURN
+
+ 2001 FORMAT(/ ' Exit LSSOL - Feasible point found.     ')
+ 2002 FORMAT(/ ' Exit LSSOL - Optimal ', A2, ' solution.')
+ 2010 FORMAT(/ ' Exit LSSOL - Weak ',    A2, ' solution.')
+ 2020 FORMAT(/ ' Exit LSSOL - ', A2,         ' solution is unbounded.' )
+ 2030 FORMAT(/ ' Exit LSSOL - Cannot satisfy the linear constraints. ' )
+ 2040 FORMAT(/ ' Exit LSSOL - Too many iterations.')
+ 2050 FORMAT(/ ' Exit LSSOL - Too many iterations without changing X.' )
+ 2060 FORMAT(/ ' Exit LSSOL - ', I10, ' errors found in the input',
+     $         ' parameters.  Problem abandoned.'         )
+ 3000 FORMAT(/ ' Final ', A2, ' objective value =', G16.7 )
+ 3010 FORMAT(/ ' Minimum sum of infeasibilities =', G16.7 )
+ 3020 FORMAT(/ ' Final sum of infeasibilities =',   G16.7 )
+
+ 9000 FORMAT(/ ' Rank of the objective function data matrix = ', I5 )
+
+*     End of  LSSOL .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/mcenv1.f
@@ -0,0 +1,145 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE MCENV1( BETA, T, RND )
+      LOGICAL            RND
+      INTEGER            BETA, T
+
+*     MCENV1 returns the machine parameters given by:
+*
+*        BETA - INTEGER.
+*               The base of the machine.
+*
+*        T    - INTEGER.
+*               The number of ( BETA ) digits in the mantissa.
+*
+*        RND  - LOGICAL.
+*               Whether proper rounding ( RND = .TRUE. ) or chopping
+*               ( RND = .FALSE. ) occurs in addition. This may not be a
+*               reliable guide to the way in which the machine perfoms
+*               its arithmetic.
+*
+*     The routine is based on the routine ENVRON by Malcolm
+*     and incorporates suggestions by Gentleman and Marovich. See
+*
+*        Malcolm M. A. (1972) Algorithms to reveal properties of
+*           floating-point arithmetic. Comms. of the ACM, 15, 949-951.
+*
+*        Gentleman W. M. and Marovich S. B. (1974) More on algorithms
+*           that reveal properties of floating point arithmetic units.
+*           Comms. of the ACM, 17, 276-277.
+*
+*
+*  Nag Fortran 77 O( 1 ) basic linear algebra routine (ENVRON).
+*
+*  -- Written on 26-November-1984.
+*     Sven Hammarling and Mick Pont, Nag Central Office.
+
+      EXTERNAL           MCSTOR
+      LOGICAL            FIRST , LRND
+      INTEGER            LBETA , LT
+      DOUBLE PRECISION   A     , B     , C     , F     , ONE   , QTR
+      DOUBLE PRECISION   MCSTOR
+
+      SAVE               FIRST , LBETA , LRND  , LT
+      DATA               FIRST / .TRUE. /
+
+      IF( FIRST )THEN
+         FIRST = .FALSE.
+         ONE   = 1
+
+*        LBETA, LT and LRND are the local values of BETA, T and RND.
+*
+*        Throughout this routine we use the function MCSTOR to ensure
+*        that relevant values are stored and not held in registers, or
+*        are not affected by optimizers.
+*
+*        Compute  a = 2.0**m  with the smallest positive integer m such
+*        that
+*
+*           fl( a + 1.0 ) = a.
+
+         A = 1
+         C = 1
+
+*+       WHILE( C.EQ.ONE )LOOP
+   10    IF   ( C.EQ.ONE )THEN
+            A = 2*A
+            C = MCSTOR( A,  ONE )
+            C = MCSTOR( C, -A   )
+            GO TO 10
+         END IF
+*+       END WHILE
+
+*        Now compute  b = 2.0**m  with the smallest positive integer m
+*        such that
+*
+*           fl( a + b ) .gt. a.
+
+         B = 1
+         C = MCSTOR( A, B )
+
+*+       WHILE( C.EQ.A )LOOP
+   20    IF   ( C.EQ.A )THEN
+            B = 2*B
+            C = MCSTOR( A, B )
+            GO TO 20
+         END IF
+*+       END WHILE
+
+*        Now compute the base. a and b are neighbouring floating point
+*        numbers in the interval ( beta**t, beta**( t + 1 ) ) and so
+*        their difference is beta. Adding 0.25 to c is to ensure that it
+*        is truncated to beta and not ( beta - 1 ).
+
+
+         QTR   = ONE/4
+         C     = MCSTOR( C, -A )
+         LBETA = C + QTR
+
+*        Now determine whether rounding or chopping occurs, by adding
+*        a bit less than beta/2 and a bit more than beta/2 to a.
+
+         B = LBETA
+         F = MCSTOR( B/2, -B/100 )
+         C = MCSTOR( F, A )
+         IF( C.EQ.A) THEN
+            LRND = .TRUE.
+         ELSE
+            LRND = .FALSE.
+         END IF
+         F = MCSTOR( B/2,  B/100 )
+         C = MCSTOR( F, A )
+         IF( ( LRND ).AND.( C.EQ.A ) )
+     $      LRND = .FALSE.
+
+*        Now find the mantissa, t. It should be the integer part of
+*        log to the base beta of a, however it is safer to determine t
+*        by powering. So we find t as the smallest positive integer
+*        for which
+*
+*           fl( beta**t + 1.0 ) = 1.0.
+
+         LT = 0
+         A  = 1
+         C  = 1
+
+*+       WHILE( C.EQ.ONE )LOOP
+   30    IF   ( C.EQ.ONE )THEN
+            LT = LT + 1
+            A  = A*LBETA
+            C  = MCSTOR( A,  ONE )
+            C  = MCSTOR( C, -A   )
+            GO TO 30
+         END IF
+*+       END WHILE
+
+      END IF
+
+      BETA = LBETA
+      T    = LT
+      RND  = LRND
+      RETURN
+
+*     End of MCENV1 (ENVRON).
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/mcenv2.f
@@ -0,0 +1,203 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE MCENV2( BETA, T, EPS, EMIN, RMIN )
+      INTEGER            BETA, T, EMIN
+      DOUBLE PRECISION   EPS, RMIN
+
+*     MCENV2 returns the machine parameters given by:
+*
+*        BETA - INTEGER.
+*               The base of the machine.
+*
+*        T    - INTEGER.
+*               The number of ( BETA ) digits in the mantissa.
+*
+*        EPS  - REAL.
+*               The smallest positive number such that
+*
+*                  fl( 1.0 - EPS ) .lt. 1.0,
+*
+*               where fl denotes the computed value.
+*
+*        EMIN - INTEGER.
+*               The minimum exponent before (gradual) underflow occurs.
+*
+*        RMIN - REAL.
+*               The smallest normalized number for the machine given by
+*               BASE**( EMIN - 1 ), where BASE is the floating point
+*               value of BETA.
+*
+*
+*     The computation of EPS, EMIN and RMIN is based on a routine,
+*     PARANOIA by W. Kahan of the University of California at Berkeley.
+*
+*
+*  Nag Fortran 77 O( 1 ) basic linear algebra routine (ENVIRN).
+*
+*  -- Written on 6-January-1986.
+*     Sven Hammarling, Mick Pont and Janet Welding, Nag Central Office.
+
+      EXTERNAL           MCENV1, MCMIN , MCSTOR
+      INTRINSIC          ABS   , MAX
+      LOGICAL            FIRST , IWARN , LRND
+      INTEGER            GNMIN , GPMIN , I     , LBETA , LEMIN , LEMIN1
+      INTEGER            LEMIN2, LT    , NGNMIN, NGPMIN
+      DOUBLE PRECISION   A     , B     , C     , HALF  , LEPS  , LRMIN
+      DOUBLE PRECISION   ONE   , RBASE , SIXTH , SMALL , MCSTOR, THIRD
+      DOUBLE PRECISION   TWO   , XBASE , ZERO
+
+      COMMON    /SOL1CM/ NOUT
+
+      SAVE               FIRST , IWARN , LBETA , LEMIN , LEPS  , LRMIN
+      SAVE               LT
+      DATA               FIRST / .TRUE. /      , IWARN / .FALSE. /
+
+      IF( FIRST )THEN
+         FIRST = .FALSE.
+         ZERO  = 0
+         ONE   = 1
+         TWO   = 2
+
+*        LBETA, LT, LEPS, LEMIN and LRMIN are the local values of BETA,
+*        T, EPS, EMIN and RMIN.
+*
+*        Throughout this routine we use the function MCSTOR to ensure
+*        that relevant values are stored and not held in registers, or
+*        are not affected by optimizers.
+*
+*        MCENV1 returns the parameters LBETA and LT. ( LRND is not used
+*        here. )
+
+         CALL MCENV1( LBETA, LT, LRND )
+
+*        Start to find EPS.
+
+         B    = LBETA
+         A    = B**( -LT )
+         LEPS = A
+
+*        Try some tricks to see whether or not this is the correct EPS.
+
+         B     = TWO/3
+         HALF  = ONE/2
+         SIXTH = MCSTOR( B    , -HALF  )
+         THIRD = MCSTOR( SIXTH,  SIXTH )
+         B     = MCSTOR( THIRD, -HALF  )
+         B     = MCSTOR( B    ,  SIXTH )
+         B     = ABS   ( B )
+         IF( B.LT.LEPS )
+     $      B = LEPS
+
+         LEPS = 1
+
+*+       WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
+   10    IF   ( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )THEN
+            LEPS = B
+            C    = MCSTOR( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
+            C    = MCSTOR( HALF     , -C                     )
+            B    = MCSTOR( HALF     ,  C                     )
+            C    = MCSTOR( HALF     , -B                     )
+            B    = MCSTOR( HALF     ,  C                     )
+            GO TO 10
+         END IF
+*+       END WHILE
+
+         IF( A.LT.LEPS )
+     $      LEPS = A
+
+*        Computation of EPS complete. Now find EMIN.
+*        First compute the next floating point value below 1.0, a, and
+*        keep dividing a by BETA until (gradual) underflow occurs.
+*        This is detected when we cannot recover the previous a.
+
+         XBASE = LBETA
+         RBASE = 1/XBASE
+         SMALL = ONE
+         DO 20, I = 1, LT - 1
+            SMALL = MCSTOR( SMALL/LBETA, ZERO )
+   20    CONTINUE
+         A     = MCSTOR( ONE, SMALL )
+         CALL MCMIN ( NGPMIN,  ONE, XBASE, RBASE, LBETA )
+         CALL MCMIN ( NGNMIN, -ONE, XBASE, RBASE, LBETA )
+         CALL MCMIN (  GPMIN,    A, XBASE, RBASE, LBETA )
+         CALL MCMIN (  GNMIN,   -A, XBASE, RBASE, LBETA )
+         LEMIN = 0
+         IF( ( NGPMIN.EQ.NGNMIN ).AND.( GPMIN.EQ.GNMIN ) )THEN
+            IF( NGPMIN.EQ.GPMIN )THEN
+               LEMIN = NGPMIN
+            ELSE IF( NGPMIN.LT.GPMIN )THEN
+               IF( ABS( GPMIN - NGPMIN - LT ).LT.3 )THEN
+                  LEMIN =  GPMIN
+               ELSE
+                  LEMIN =  NGPMIN
+                  IWARN = .TRUE.
+               END IF
+            ELSE
+               WRITE( NOUT, 9999 )
+               CALL XSTOPX (' ')
+            END IF
+         ELSE
+            IF( NGPMIN.EQ.GPMIN )THEN
+               LEMIN1 = NGPMIN
+            ELSE IF( NGPMIN.LT.GPMIN )THEN
+               IF( ABS( GPMIN - NGPMIN - LT ).LT.3 )THEN
+                  LEMIN1 =  GPMIN
+               ELSE
+                  LEMIN1 =  NGPMIN
+                  IWARN  = .TRUE.
+               END IF
+            ELSE
+               WRITE( NOUT, 9999 )
+               CALL XSTOPX (' ')
+            END IF
+            IF( NGNMIN.EQ.GNMIN )THEN
+               LEMIN2 = NGNMIN
+            ELSE IF( NGNMIN.LT.GNMIN )THEN
+               IF( ABS( GNMIN - NGNMIN - LT ).LT.3 )THEN
+                  LEMIN2 =  GNMIN
+               ELSE
+                  LEMIN2 =  NGNMIN
+                  IWARN  = .TRUE.
+               END IF
+            ELSE
+               WRITE( NOUT, 9999 )
+               CALL XSTOPX (' ')
+            END IF
+            LEMIN = MAX( LEMIN1, LEMIN2 )
+         END IF
+***
+* Comment out this IF block if Emin is ok
+         IF( IWARN )THEN
+            FIRST = .TRUE.
+            WRITE( NOUT, 9998 )LEMIN
+         END IF
+***
+
+*        Finally compute RMIN by successive division by BETA.
+*        We could compute RMIN as base**( EMIN - 1 ), but some machines
+*        underflow during this computation.
+
+         LRMIN = 1
+         DO 30, I = 1, 1 - LEMIN
+            LRMIN = LRMIN/LBETA
+   30    CONTINUE
+      END IF
+
+      BETA = LBETA
+      T    = LT
+      EPS  = LEPS
+      EMIN = LEMIN
+      RMIN = LRMIN
+      RETURN
+
+ 9999 FORMAT( // ' ** ERROR . No reliable value for Emin could be',
+     $           ' found.' / ' Please contact Stanford University.'// )
+ 9998 FORMAT( // ' WARNING. The value Emin may be incorrect:-  Emin = ',
+     $           I8 / ' If after inspection the value Emin looks',
+     $           ' acceptable please comment out ' / ' the IF block',
+     $           ' as marked within the code of routine mcenv2,' /
+     $           ' otherwise contact Stanford University. ' / )
+
+*     End of MCENV2 (ENVIRN).
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/mceps.f
@@ -0,0 +1,51 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      DOUBLE PRECISION FUNCTION MCEPS ()
+
+*     MCEPS  returns approximately the relative machine precision via
+*     the function name.
+*
+*     The value returned is given by
+*
+*        MCEPS  = (1/2)*beta**( 1 - t )   when   rnd = true
+*
+*        MCEPS  =       beta**( 1 - t )   when   rnd = false,
+*
+*     where beta is the base of the machine, t is the number of ( beta )
+*     digits in the mantissa and rnd is true when rounding occurs and is
+*     false when chopping occurs. This is the Wilkinson unit rounding
+*     error.
+*
+*
+*  Nag Fortran 77 O( 1 ) basic linear algebra routine (EPSLON).
+*
+*  -- Written on 26-November-1984.
+*     Sven Hammarling, Nag Central Office.
+
+      EXTERNAL           MCENV1
+      LOGICAL            FIRST , RND
+      INTEGER            BETA  , T
+      DOUBLE PRECISION   BASE  , EPS
+
+      SAVE               EPS   , FIRST
+      DATA               FIRST / .TRUE. /
+
+      IF( FIRST )THEN
+         FIRST = .FALSE.
+
+         CALL MCENV1( BETA, T, RND )
+
+         BASE = BETA
+         IF( RND )THEN
+            EPS = ( BASE**( 1 - T ) )/2
+         ELSE
+            EPS =   BASE**( 1 - T )
+         END IF
+      END IF
+
+      MCEPS  = EPS
+      RETURN
+
+*     End of MCEPS  (EPSLON).
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/mchpar.f
@@ -0,0 +1,87 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+*     File  MCSUBS FORTRAN
+*
+*     MCHPAR   MCEPS    MCENV1   MCENV2   MCSTOR   MCSMAL   MCMIN
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE MCHPAR()
+
+************************************************************************
+*  MCHPAR  must define certain machine parameters as follows:
+*     wmach(1)  = NBASE  = base of floating-point arithmetic.
+*     wmach(2)  = NDIGIT = no. of base wmach(1) digits of precision.
+*     wmach(3)  = EPS    = floating-point precision.
+*     wmach(4)  = RTEPS  = sqrt(EPS).
+*     wmach(5)  = RMIN   = smallest positive normalized floating-point
+*                          number.
+*     wmach(6)  = RTRMIN = sqrt(RMIN).
+*     wmach(7)  = RMAX   = largest positive floating-point number.
+*     wmach(8)  = RTRMAX = sqrt(RMAX).
+*     wmach(9)  = UNDFLW = 0 if underflow is not fatal, +ve otherwise.
+*     wmach(10) = NIN    = standard file number of the input stream.
+*     wmach(11) = NOUT   = standard file number of the output stream.
+************************************************************************
+
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+
+      EXTERNAL           MCENV2, MCEPS , MCSMAL, D1MACH, I1MACH
+      INTRINSIC          SQRT
+      LOGICAL            FIRST , HDWIRE
+      INTEGER            EMIN  , NBASE , NDIGIT, NIN   , NOUT  , I1MACH
+      DOUBLE PRECISION   BASE  , EPS   , MCEPS , MCSMAL, RMAX  , RMIN
+      DOUBLE PRECISION   RTEPS , RTMAX , RTMIN , SMALL , UNDFLW, D1MACH
+      SAVE               FIRST
+      DATA               FIRST / .TRUE. /
+
+      IF (FIRST) THEN
+         FIRST = .FALSE.
+
+*        ---------------------------------------------------------------
+*        Machine-dependent code.
+*        1. Set UNDFLW, NIN, NOUT, HDWIRE as desired.
+*        2. If  HDWIRE = .TRUE.  set the machine constants
+*               NBASE, NDIGIT, EPS, RMIN, RMAX
+*           in-line.  Otherwise, they will be computed by MCENV2.
+*           A call to MCENV2 will cause eight underflows.
+*        ---------------------------------------------------------------
+
+         UNDFLW = 0
+         NIN    = I1MACH(1)
+         NOUT   = I1MACH(2)
+         HDWIRE = .TRUE.
+
+         IF (HDWIRE) THEN
+            NBASE  = I1MACH(10)
+            NDIGIT = I1MACH(14)
+            BASE   = NBASE
+            EPS    = D1MACH(4)
+            RMIN   = D1MACH(1)
+            RMAX   = D1MACH(2)
+         ELSE
+            CALL MCENV2( NBASE, NDIGIT, EPS, EMIN, RMIN )
+
+            EPS    = MCEPS ()
+            SMALL  = MCSMAL()
+            RMAX   = 1/SMALL
+         END IF
+
+         WMACH(1)  = NBASE
+         WMACH(2)  = NDIGIT
+         WMACH(3)  = EPS
+         WMACH(4)  = SQRT( EPS )
+         WMACH(5)  = RMIN
+         WMACH(6)  = SQRT( RMIN )
+         WMACH(7)  = RMAX
+         WMACH(8)  = SQRT( RMAX )
+         WMACH(9)  = UNDFLW
+         WMACH(10) = NIN
+         WMACH(11) = NOUT
+      END IF
+
+      RETURN
+
+*     End of  MCHPAR.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/mcmin.f
@@ -0,0 +1,53 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE MCMIN ( EMIN, START, XBASE, RBASE, BASE )
+      INTEGER            EMIN, BASE
+      DOUBLE PRECISION   START, XBASE, RBASE
+
+*     Service routine for MCENV2.
+*
+*
+*  Nag Fortran 77 O( 1 ) basic linear algebra routine (GETMIN).
+*
+*  -- Written on 6-January-1986.
+*     Sven Hammarling and Mick Pont, Nag Central Office.
+
+      EXTERNAL           MCSTOR
+      INTEGER            I
+      DOUBLE PRECISION   A     , B1    , B2    , C1    , C2    , D1
+      DOUBLE PRECISION   D2    , MCSTOR, ZERO
+
+      A    = START
+      ZERO = 0
+      EMIN = 1
+      B1   = MCSTOR( A/XBASE, ZERO )
+      C1   = A
+      C2   = A
+      D1   = A
+      D2   = A
+*+    WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
+*+   $       ( D1.EQ.A ).AND.( D2.EQ.A )      )LOOP
+   10 IF   ( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
+     $       ( D1.EQ.A ).AND.( D2.EQ.A )      )THEN
+         EMIN = EMIN - 1
+         A    = B1
+         B1   = MCSTOR( A /XBASE, ZERO )
+         C1   = MCSTOR( B1*XBASE, ZERO )
+         D1   = ZERO
+         DO 20, I = 1, BASE
+            D1 = D1 + B1
+   20    CONTINUE
+         B2   = MCSTOR( A *RBASE, ZERO )
+         C2   = MCSTOR( B2/RBASE, ZERO )
+         D2   = ZERO
+         DO 30, I = 1, BASE
+            D2 = D2 + B2
+   30    CONTINUE
+         GO TO 10
+      END IF
+*+    END WHILE
+      RETURN
+
+*     End of MCMIN (GETMIN).
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/mcsmal.f
@@ -0,0 +1,34 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      DOUBLE PRECISION FUNCTION MCSMAL()
+
+*     MCSMAL is intended to return a small positive value such that the
+*     reciprocal of MCSMAL does not overflow.
+*
+*
+*  Nag Fortran 77 O( 1 ) basic linear algebra routine (SMALL).
+*
+*  -- Written on 28-November-1984.
+*     Sven Hammarling, Nag Central Office.
+
+      EXTERNAL                  MCENV2
+      LOGICAL                   FIRST
+      INTEGER                   BETA  , EMIN  , T
+      DOUBLE PRECISION          BASE  , EPS   , FLMIN , RMIN
+
+      SAVE                      FIRST , FLMIN
+      DATA                      FIRST / .TRUE. /
+
+      IF( FIRST )THEN
+         FIRST = .FALSE.
+         CALL MCENV2( BETA, T, EPS, EMIN, RMIN )
+         BASE  =  BETA
+         FLMIN =  RMIN*BASE**4
+      END IF
+
+      MCSMAL = FLMIN
+      RETURN
+
+*     End of MCSMAL (SMALL).
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/mcstor.f
@@ -0,0 +1,22 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      DOUBLE PRECISION  FUNCTION MCSTOR( A, B )
+      DOUBLE PRECISION                   A, B
+
+*     MCSTOR is intended to force A and B to be stored prior to doing
+*     the addition of A and B. For use in situations where optimizers
+*     might hold one of these in a register.
+*
+*
+*  Nag Fortran 77 O( 1 ) basic linear algebra routine (STORE).
+*
+*  -- Written on 28-November-1984.
+*     Sven Hammarling, Nag Central Office.
+
+      MCSTOR  = A + B
+
+      RETURN
+
+*     End of MCSTOR (STORE).
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/npalf.f
@@ -0,0 +1,112 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+*     File  NPSUBS FORTRAN
+*
+*     NPALF    NPCHKD   NPCORE   NPCRSH   NPDFLT   NPFD     NPFEAS
+*     NPFILE   NPIQP    NPKEY    NPLOC    NPMRT    NPOPTN   NPPRT
+*     NPRSET   NPSETX   NPSRCH   NPUPDT   NPSOL
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPALF ( INFORM, N, NCLIN, NCNLN,
+     $                   ALFA, ALFMIN, ALFMAX, BIGBND, DXNORM,
+     $                   ANORM, ADX, AX, BL, BU,
+     $                   DSLK, DX, SLK, X )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      DOUBLE PRECISION   ANORM(*), ADX(*), AX(*), BL(*), BU(*),
+     $                   DSLK(*), DX(N), SLK(*), X(N)
+
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9
+
+      LOGICAL            CMDBG
+      INTEGER            LCMDBG
+      PARAMETER         (LCMDBG = 5)
+      COMMON    /CMDEBG/ ICMDBG(LCMDBG), CMDBG
+
+************************************************************************
+*  NPALF   finds a step ALFA such that the point x + ALFA*P reaches one
+*  of the slacks or linear constraints.  The step ALFA is the maximum
+*  step that can be taken without violating one of the slacks or linear
+*  constraints that is currently satisfied.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Original Fortran 77 version written  June 1986.
+*  This version of NPALF dated  27-June-1986.
+************************************************************************
+      INTRINSIC          ABS, MAX, MIN
+      PARAMETER        ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+
+      IF (CMDBG  .AND.  ICMDBG(3) .GT. 0) WRITE (NOUT, 1000)
+
+      ALFA   = ALFMAX
+      J      = 1
+
+*+    WHILE (J .LE. N+NCLIN+NCNLN .AND. ALFA .GT. ALFMIN) DO
+  100 IF    (J .LE. N+NCLIN+NCNLN .AND. ALFA .GT. ALFMIN) THEN
+
+         IF      (J .LE. N      ) THEN
+            AXI    =  X(J)
+            ADXI   = DX(J)
+            ROWNRM = ONE
+         ELSE IF (J .LE. N+NCLIN) THEN
+            I      = J - N
+            AXI    = AX(I)
+            ADXI   = ADX(I)
+            ROWNRM = ANORM(I) + ONE
+         ELSE
+            I      = J - N - NCLIN
+            AXI    = SLK(I)
+            ADXI   = DSLK(I)
+            ROWNRM = ONE
+         END IF
+
+         RES = - ONE
+         IF (ADXI .LE. - EPSPT9*ROWNRM*DXNORM) THEN
+
+*           Constraint decreasing.
+
+            ADXI = - ADXI
+            IF (BL(J) .GT. -BIGBND) RES = AXI   - BL(J)
+
+         ELSE IF (ADXI .GT.   EPSPT9*ROWNRM*DXNORM) THEN
+
+*           Constraint increasing.
+
+            IF (BU(J) .LT.  BIGBND) RES = BU(J) - AXI
+
+         END IF
+
+         IF (RES .GT. ZERO  .AND.  ALFA*ADXI .GT. RES)
+     $      ALFA  = RES / ADXI
+
+         IF (CMDBG  .AND.  ICMDBG(3) .GT. 0)
+     $      WRITE (NOUT, 1200) J, RES, ADXI, ALFA
+
+         J = J + 1
+         GO TO 100
+*+    END WHILE
+      END IF
+
+*     ==================================================================
+*     Determine ALFA, the bound on the step to be taken.
+*     ==================================================================
+      ALFA   = MAX( ALFA, ALFMIN )
+
+      INFORM = 0
+      IF (ALFA .GE. ALFMAX) INFORM = 1
+
+      IF (CMDBG  .AND.  ICMDBG(1) .GT. 0  .AND.  INFORM .GT. 0)
+     $   WRITE (NOUT, 9010) ALFA
+
+      RETURN
+
+ 1000 FORMAT(/ ' NPALF  entered'
+     $       / '    J            RES             AP           ALFA '/)
+ 1200 FORMAT( I5, 3G15.5 )
+ 9010 FORMAT(/ ' //NPALF //  No finite step.'
+     $       / ' //NPALF //             ALFA'
+     $       / ' //NPALF //  ', G15.4 )
+
+*     End of  NPALF .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/npchkd.f
@@ -0,0 +1,208 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPCHKD( INFORM, MSGNP, NSTATE, LVLDER, NFUN, NGRAD,
+     $                   NROWJ, NROWUJ, N, NCNLN,
+     $                   CONFUN, OBJFUN, NEEDC,
+     $                   BIGBND, EPSRF, CDINT, FDINT,
+     $                   FDCHK, FDNORM, OBJF, XNORM,
+     $                   BL, BU, C, C1, CJAC, UJAC, CJDX,
+     $                   DX, GRAD, UGRAD, HFORWD, HCNTRL,
+     $                   X, WRK1, WRK2, W, LENW )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      INTEGER            NEEDC(*)
+      DOUBLE PRECISION   C(*), C1(*), CJAC(NROWJ,*), UJAC(NROWUJ,*),
+     $                   CJDX(*)
+      DOUBLE PRECISION   BL(N), BU(N), DX(N), GRAD(N), UGRAD(N), X(N)
+      DOUBLE PRECISION   HFORWD(*), HCNTRL(*)
+      DOUBLE PRECISION   WRK1(N+NCNLN), WRK2(N+NCNLN), W(LENW)
+      EXTERNAL           CONFUN, OBJFUN
+
+************************************************************************
+*  NPCHKD  performs the following...
+*  (1)  Computes the objective and constraint values OBJF and C.
+*  (2)  Evaluates the user-provided gradients in UJAC and UGRAD.
+*  (3)  Counts the missing gradients.
+*  (4)  Loads the known gradients into GRAD and CJAC.
+*  (5)  Checks that the known gradients are programmed correctly.
+*  (6)  Computes the missing gradient elements.
+*
+*  Systems Optimization Laboratory, Stanford University, California.
+*  Original version written 4-September-1985.
+*  This version of NPCHKD dated  14-July-1986.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9
+
+      COMMON    /SOL4NP/ LVLDIF, NCDIFF, NFDIFF, LFDSET
+      COMMON    /SOL5NP/ LVRFYC, JVERFY(4)
+
+      LOGICAL            CENTRL, NEEDFD
+      PARAMETER        ( RDUMMY =-11111.0)
+
+      INFORM = 0
+      MODE   = 2
+      NFDIFF = 0
+      NCDIFF = 0
+      NCSET  = N*NCNLN
+
+      IF (NCNLN .GT. 0) THEN
+*        ===============================================================
+*        Compute the constraints and Jacobian matrix.
+*        ===============================================================
+*        If some derivatives are missing, load the Jacobian with dummy
+*        values.  Any elements left unaltered after the call to CONFUN
+*        must be estimated.  A record of the missing Jacobian elements
+*        is stored in  UJAC.
+
+         NEEDFD = LVLDER .EQ. 0  .OR.  LVLDER .EQ. 1
+
+         IF (NEEDFD) THEN
+            DO 100 J = 1, N
+               CALL DLOAD ( NCNLN, RDUMMY, UJAC(1,J), 1 )
+  100       CONTINUE
+         END IF
+
+         CALL ILOAD ( NCNLN, (1), NEEDC, 1 )
+
+         CALL CONFUN( MODE, NCNLN, N, NROWUJ,
+     $                NEEDC, X, C, UJAC, NSTATE )
+         IF (MODE .LT. 0) GO TO 999
+
+         DO 110 J = 1, N
+            CALL DCOPY ( NCNLN, UJAC(1,J), 1, CJAC(1,J), 1 )
+  110    CONTINUE
+
+         IF (NEEDFD) THEN
+
+*           Count the number of missing Jacobian elements.
+
+            DO 220 J = 1, N
+               DO 210 I = 1, NCNLN
+                  IF (UJAC(I,J) .EQ. RDUMMY) NCDIFF = NCDIFF + 1
+  210          CONTINUE
+  220       CONTINUE
+
+            NCSET = NCSET - NCDIFF
+            IF (NSTATE .EQ. 1) THEN
+               IF (NCDIFF .EQ. 0) THEN
+                  IF (LVLDER .EQ. 0) LVLDER = 2
+                  IF (LVLDER .EQ. 1) LVLDER = 3
+                  WRITE (NOUT, 1000) LVLDER
+               ELSE IF (MSGNP .GT. 0) THEN
+                  WRITE (NOUT, 1100) NCSET, N*NCNLN, NCDIFF
+               END IF
+            END IF
+         END IF
+      END IF
+
+*     ==================================================================
+*     Repeat the procedure above for the objective function.
+*     ==================================================================
+      NEEDFD = LVLDER .EQ. 0  .OR.  LVLDER .EQ. 2
+
+      IF (NEEDFD)
+     $   CALL DLOAD ( N, RDUMMY, UGRAD, 1 )
+
+      CALL OBJFUN( MODE, N, X, OBJF, UGRAD, NSTATE )
+      IF (MODE .LT. 0) GO TO 999
+
+      CALL DCOPY ( N, UGRAD, 1, GRAD, 1 )
+
+      IF (NEEDFD) THEN
+
+*        Count the number of missing gradient elements.
+
+         DO 300 J = 1, N
+            IF (UGRAD(J) .EQ. RDUMMY) NFDIFF = NFDIFF + 1
+  300    CONTINUE
+
+         IF (NSTATE .EQ. 1) THEN
+            IF (NFDIFF .EQ. 0) THEN
+               IF (LVLDER .EQ. 0) LVLDER = 1
+               IF (LVLDER .EQ. 2) LVLDER = 3
+               WRITE (NOUT, 2000) LVLDER
+            ELSE IF (MSGNP .GT. 0) THEN
+               WRITE (NOUT, 2100) N - NFDIFF, N, NFDIFF
+            END IF
+         END IF
+      END IF
+
+      NFUN  = NFUN  + 1
+      NGRAD = NGRAD + 1
+
+*     ==================================================================
+*     Check whatever gradient elements have been provided.
+*     ==================================================================
+      IF (LVRFYC .GE. 0) THEN
+         IF (NCSET .GT. 0) THEN
+            CALL CHKJAC( INFORM, LVLDER, MSGNP,
+     $                   NCSET, N, NCNLN, NROWJ, NROWUJ,
+     $                   BIGBND, EPSRF, EPSPT3, FDCHK, XNORM,
+     $                   CONFUN, NEEDC,
+     $                   BL, BU, C, C1, CJAC, UJAC, CJDX,
+     $                   DX, WRK1, X, WRK2, W, LENW )
+            IF (INFORM .LT. 0) GO TO 800
+         END IF
+
+         IF (NFDIFF .LT. N) THEN
+            CALL CHKGRD( INFORM, MSGNP, N,
+     $                   BIGBND, EPSRF, EPSPT3, FDCHK, OBJF, XNORM,
+     $                   OBJFUN,
+     $                   BL, BU, GRAD, UGRAD, DX, X, WRK1, W, LENW )
+            IF (INFORM .LT. 0) GO TO 800
+         END IF
+      END IF
+
+      NEEDFD = NCDIFF .GT. 0  .OR.  NFDIFF .GT. 0
+      IF (NEEDFD) THEN
+*        ===============================================================
+*        Compute the missing gradient elements.
+*        ===============================================================
+         CALL CHFD  ( INFORM, MSGNP, LVLDER,
+     $                N, NCNLN, NROWJ, NROWUJ,
+     $                BIGBND, EPSRF, FDNORM, OBJF,
+     $                OBJFUN, CONFUN, NEEDC,
+     $                BL, BU, C, C1, CJDX, CJAC, UJAC,
+     $                GRAD, UGRAD, HFORWD, HCNTRL, X,
+     $                DX, W, LENW )
+
+         IF (INFORM .LT. 0) GO TO 800
+
+         IF (LFDSET .GT. 0) THEN
+            CENTRL = .FALSE.
+            CALL NPFD  ( CENTRL, INFORM,
+     $                   NROWJ, NROWUJ, N, NCNLN,
+     $                   BIGBND, CDINT, FDINT, FDNORM, OBJF,
+     $                   CONFUN, OBJFUN, NEEDC,
+     $                   BL, BU, C, C1, CJDX, CJAC, UJAC,
+     $                   GRAD, UGRAD, HFORWD, HCNTRL, X,
+     $                   W, LENW )
+
+            IF (INFORM .LT. 0) GO TO 800
+         END IF
+      END IF
+
+  800 RETURN
+
+*     The user requested termination.
+
+  999 INFORM = MODE
+      RETURN
+
+ 1000 FORMAT(//' All Jacobian elements have been set.  ',
+     $         ' Derivative level increased to ', I4 )
+ 1100 FORMAT(//' The user sets ', I6, '   out of', I6,
+     $         '   Jacobian elements.'
+     $       / ' Each iteration, ', I6,
+     $         '   Jacobian elements will be estimated numerically.' )
+ 2000 FORMAT(//' All objective gradient elements have been set.  ',
+     $         ' Derivative level increased to ', I4 )
+ 2100 FORMAT(//' The user sets ', I6, '   out of', I6,
+     $         '   objective gradient elements.'
+     $       / ' Each iteration, ', I6,
+     $         '   gradient elements will be estimated numerically.' )
+
+*     End of  NPCHKD.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/npcore.f
@@ -0,0 +1,662 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPCORE( NAMED, NAMES, UNITQ, INFORM, MAJITS,
+     $                   N, NCLIN, NCNLN, NCTOTL, NACTIV, NFREE, NZ,
+     $                   NROWA, NROWJ, NROWUJ, NROWQP, NROWR,
+     $                   NFUN, NGRAD, ISTATE, KACTIV, KX,
+     $                   OBJF, FDNORM, XNORM, OBJFUN, CONFUN,
+     $                   AQP, AX, BL, BU, C, CJAC, UJAC, CLAMDA,
+     $                   FEATOL, GRAD, UGRAD, R, X, IW, W, LENW )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      LOGICAL            NAMED
+      INTEGER            ISTATE(*), KACTIV(N), KX(N)
+      INTEGER            IW(*)
+      DOUBLE PRECISION   AQP(NROWQP,*), AX(*), BL(NCTOTL), BU(NCTOTL),
+     $                   C(*), CJAC(NROWJ,*), UJAC(NROWUJ,*)
+      DOUBLE PRECISION   CLAMDA(NCTOTL), FEATOL(NCTOTL), GRAD(N),
+     $                   UGRAD(N), R(NROWR,*), X(N)
+      DOUBLE PRECISION   W(LENW)
+      EXTERNAL           OBJFUN, CONFUN
+
+      DOUBLE PRECISION   ASIZE, DTMAX, DTMIN
+      CHARACTER*8        NAMES(*)
+
+************************************************************************
+*  NPCORE  is the core routine for  NPSOL,  a sequential quadratic
+*  programming (SQP) method for nonlinearly constrained optimization.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Original version      February-1982.
+*  This version of NPCORE dated  4-August-1986.
+************************************************************************
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL3CM/ LENNAM, NROWT , NCOLT , NQ
+      COMMON    /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9
+      COMMON    /SOL5CM/ ASIZE , DTMAX , DTMIN
+      COMMON    /SOL6CM/ RCNDBD, RFROBN, DRMAX, DRMIN
+
+      PARAMETER         (LENLS = 20)
+      COMMON    /SOL1LS/ LOCLS(LENLS)
+
+      PARAMETER         (LENNP = 35)
+      COMMON    /SOL1NP/ LOCNP(LENNP)
+      COMMON    /SOL4NP/ LVLDIF, NCDIFF, NFDIFF, LFDSET
+      COMMON    /SOL5NP/ LVRFYC, JVERFY(4)
+      LOGICAL            INCRUN
+      COMMON    /SOL6NP/ RHOMAX, RHONRM, RHODMP, SCALE, INCRUN
+
+      PARAMETER         (LDBG = 5)
+      LOGICAL            CMDBG, NPDBG
+      COMMON    /NPDEBG/ INPDBG(LDBG), NPDBG
+      COMMON    /CMDEBG/ ICMDBG(LDBG), CMDBG
+
+*-----------------------------------------------------------------------
+      PARAMETER         (MXPARM = 30)
+      INTEGER            IPRMLS(MXPARM), IPSVLS
+      DOUBLE PRECISION   RPRMLS(MXPARM), RPSVLS
+
+      COMMON    /LSPAR1/ IPSVLS(MXPARM),
+     $                   IDBGLS, ITMAX1, ITMAX2, LCRASH, LDBGLS, LPROB ,
+     $                   MSGLS , NN    , NNCLIN, NPROB , IPADLS(20)
+
+      COMMON    /LSPAR2/ RPSVLS(MXPARM),
+     $                   BIGBND, BIGDX , BNDLOW, BNDUPP, TOLACT, TOLFEA,
+     $                   TOLRNK, RPADLS(23)
+
+      EQUIVALENCE       (IPRMLS(1), IDBGLS), (RPRMLS(1), BIGBND)
+
+      SAVE      /LSPAR1/, /LSPAR2/
+*-----------------------------------------------------------------------
+*-----------------------------------------------------------------------
+      INTEGER            IPRMNP(MXPARM), IPSVNP
+      DOUBLE PRECISION   RPRMNP(MXPARM), RPSVNP
+
+      COMMON    /NPPAR1/ IPSVNP(MXPARM),
+     $                   IDBGNP, ITMXNP, JVRFY1, JVRFY2, JVRFY3, JVRFY4,
+     $                   LDBGNP, LFORMH, LVLDER, LVERFY, MSGNP , NLNF  ,
+     $                   NLNJ  , NLNX  , NNCNLN, IPADNP(15)
+
+      COMMON    /NPPAR2/ RPSVNP(MXPARM),
+     $                   CDINT , CTOL  , EPSRF , ETA   , FDINT , FTOL  ,
+     $                   RPADNP(24)
+
+      EQUIVALENCE       (IPRMNP(1), IDBGNP), (RPRMNP(1), CDINT)
+
+      SAVE      /NPPAR1/, /NPPAR2/
+*-----------------------------------------------------------------------
+      EQUIVALENCE  (IDBGNP, IDBG  ), (ITMXNP, NMAJOR), (ITMAX2, NMINOR)
+      EQUIVALENCE  (LDBGLS, MNRDBG), (LDBGNP, MJRDBG), (MSGLS , MSGQP )
+
+      LOGICAL            GOODGQ, NEWGQ
+      LOGICAL            CENTRL, CONVRG, CONVPT, DONE  , ERROR , FEASQP
+      LOGICAL            INFEAS, NEEDFD, OPTIML, OVERFL, UNITQ
+      LOGICAL            KTCOND(2)
+      INTRINSIC          ABS   , MAX   , MIN   , MOD   , REAL  , SQRT
+      EXTERNAL           DDIV  , DDOT  , DNRM2
+
+      CHARACTER*4        LSUMRY
+      CHARACTER*2        JOB
+      PARAMETER        ( JOB  = 'NP' )
+      PARAMETER        ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
+      PARAMETER        ( GROWTH=1.0D+2                              )
+
+*     Specify machine-dependent parameters.
+
+      EPSMCH = WMACH(3)
+      FLMAX  = WMACH(7)
+      RTMAX  = WMACH(8)
+
+      LANORM = LOCLS( 2)
+      LRPQ   = LOCLS( 5)
+      LQRWRK = LOCLS( 6)
+      LHPQ   = LOCLS( 8)
+      LGQ    = LOCLS( 9)
+      LRLAM  = LOCLS(10)
+      LT     = LOCLS(11)
+      LZY    = LOCLS(12)
+      LWTINF = LOCLS(13)
+      LWRK1  = LOCLS(14)
+      LQPTOL = LOCLS(15)
+
+      LIPERM = LOCNP( 2)
+      LAQP   = LOCNP( 3)
+      LADX   = LOCNP( 4)
+      LBL    = LOCNP( 5)
+      LBU    = LOCNP( 6)
+      LDX    = LOCNP( 7)
+      LGQ1   = LOCNP( 8)
+      LX1    = LOCNP(11)
+      LWRK2  = LOCNP(12)
+      LCS1   = LOCNP(13)
+      LCS2   = LOCNP(14)
+      LC1MUL = LOCNP(15)
+      LCMUL  = LOCNP(16)
+      LCJDX1 = LOCNP(17)
+      LDLAM  = LOCNP(18)
+      LDSLK  = LOCNP(19)
+      LRHO   = LOCNP(20)
+      LWRK3  = LOCNP(21)
+      LSLK1  = LOCNP(22)
+      LSLK   = LOCNP(23)
+      LNEEDC = LOCNP(24)
+      LHFRWD = LOCNP(25)
+      LHCTRL = LOCNP(26)
+
+      LCJAC1 = LAQP   + NCLIN
+      LCJDX  = LADX   + NCLIN
+      LVIOLN = LWRK3
+
+*     Initialize
+
+      LSUMRY = '    '
+      NQPINF = 0
+
+      NPLIN  = N     + NCLIN
+      NCQP   = NCLIN + NCNLN
+      NL     = MIN( NPLIN + 1, NCTOTL )
+
+      NROWJ1 = MAX( NCQP , 1 )
+
+      NEEDFD = LVLDER .EQ. 0  .OR.  LVLDER .EQ. 2
+     $                        .OR. (LVLDER .EQ. 1  .AND.  NCNLN .GT. 0)
+
+      ALFA   = ZERO
+      ALFDX  = ZERO
+      RTFTOL = SQRT( FTOL )
+      ROOTN  = SQRT( REAL(N) )
+
+*     If debug printing is required,  turn off any extensive printing
+*     until iteration  IDBG.
+
+      MSGSV1 = MSGNP
+      MSGSV2 = MSGQP
+      IF (IDBG .LE. NMAJOR  .AND.  IDBG .GT. 0) THEN
+         MSGNP = 0
+         IF (MSGSV1 .GE. 5) MSGNP = 5
+         MSGQP = 0
+         IF (MSGSV2 .GE. 5) MSGQP = 5
+      END IF
+
+*     ------------------------------------------------------------------
+*     Information from the feasibility phase will be used to generate a
+*     hot start for the first QP subproblem.
+*     ------------------------------------------------------------------
+      CALL DCOPY ( NCTOTL, FEATOL, 1, W(LQPTOL), 1 )
+
+      MAJITS = 0
+      NSTATE = 0
+
+      LVLDIF = 0
+      IF (NEEDFD) LVLDIF = 1
+
+      OBJALF = OBJF
+      IF (NCNLN .GT. 0) THEN
+         OBJALF = OBJALF - DDOT  ( NCNLN, W(LCMUL), 1, C, 1 )
+
+         INCRUN = .TRUE.
+         RHONRM = ZERO
+         RHODMP = ONE
+         SCALE  = ONE
+         CALL DLOAD ( NCNLN, (ZERO), W(LRHO), 1 )
+      END IF
+
+      NEWGQ  = .FALSE.
+
+*+    REPEAT
+*+       REPEAT
+
+  100       CENTRL = LVLDIF .EQ. 2
+
+            IF (NEWGQ) THEN
+               IF (NEEDFD) THEN
+*                 ------------------------------------------------------
+*                 Compute any missing gradient elements and the
+*                 transformed gradient of the objective.
+*                 ------------------------------------------------------
+                  CALL NPFD  ( CENTRL, MODE,
+     $                         NROWJ, NROWUJ, N, NCNLN,
+     $                         BIGBND, CDINT, FDINT, FDNORM, OBJF,
+     $                         CONFUN, OBJFUN, IW(LNEEDC),
+     $                         BL, BU, C, W(LWRK2), W(LWRK3),CJAC,UJAC,
+     $                         GRAD, UGRAD, W(LHFRWD), W(LHCTRL), X,
+     $                         W, LENW )
+                  INFORM = MODE
+                  IF (MODE .LT. 0) GO TO 800
+
+               END IF
+
+               CALL DCOPY ( N, GRAD, 1, W(LGQ), 1 )
+               CALL CMQMUL( 6, N, NZ, NFREE, NQ, UNITQ,
+     $                      KX, W(LGQ), W(LZY), W(LWRK1) )
+
+               NEWGQ  = .FALSE.
+            END IF
+
+*           ============================================================
+*           (1) Solve an inequality quadratic program (IQP) for the
+*               search direction and multiplier estimates.
+*           (2) For each nonlinear inequality constraint,  compute
+*               the slack variable for which the merit function is
+*               minimized.
+*           (3) Compute the search direction for the slack variables
+*               and multipliers.
+*
+*           Note that the array VIOLN is WRK3.
+*           ============================================================
+            CALL NPIQP ( FEASQP, UNITQ, NQPERR, MINITS,
+     $                   N, NCLIN, NCNLN, NROWA, NROWJ, NROWQP,NROWR,
+     $                   LINACT, NLNACT, NACTIV, NFREE, NZ, NUMINF,
+     $                   ISTATE, KACTIV, KX,
+     $                   DXNORM, GDX, QPCURV,
+     $                   AQP, W(LADX), W(LANORM), AX, BL, BU,
+     $                   C, CJAC, CLAMDA, W(LCMUL), W(LCS1),
+     $                   W(LDLAM), W(LDSLK), W(LDX), W(LBL), W(LBU),
+     $                   W(LQPTOL), R, W(LRHO), W(LSLK), W(LVIOLN), X,
+     $                   W(LWTINF), IW, W )
+
+            IF (FEASQP) THEN
+               NQPINF = 0
+            ELSE
+               NQPINF = NQPINF + 1
+               LSUMRY(2:2) = 'Infeasible subproblem'
+            END IF
+
+*           ============================================================
+*           Compute quantities needed for the convergence test.
+*           ============================================================
+*           Compute the norms of the projected gradient and the
+*           gradient with respect to the free variables.
+
+            GZNORM = ZERO
+            IF (NZ .GT. 0)
+     $         GZNORM = DNRM2 ( NZ   , W(LGQ), 1 )
+            GFNORM = GZNORM
+            IF (NFREE .GT. 0  .AND.  NACTIV .GT. 0)
+     $         GFNORM = DNRM2 ( NFREE, W(LGQ), 1 )
+
+*           If the forward-difference estimate of the transformed
+*           gradient of the Lagrangian function is small,  switch to
+*           central differences, recompute the derivatives and re-solve
+*           the QP.
+
+            GOODGQ = .TRUE.
+            IF (NEEDFD  .AND.  .NOT. CENTRL) THEN
+
+               GLNORM = DNRM2 ( N, W(LHPQ), 1 )
+               IF (NCNLN .EQ. 0) THEN
+                  CNORM = ZERO
+               ELSE
+                  CNORM = DNRM2 ( NCNLN, C, 1 )
+               END IF
+
+               GLTEST = (ONE + ABS(OBJF) + ABS(CNORM))*EPSRF/FDNORM
+               IF (GLNORM .LE. GLTEST) THEN
+                  GOODGQ      = .FALSE.
+                  LSUMRY(3:3) = 'Central differences'
+                  LVLDIF      = 2
+                  NEWGQ       = .TRUE.
+               END IF
+
+            END IF
+
+*+       UNTIL     (GOODGQ)
+         IF (.NOT.  GOODGQ ) GO TO 100
+
+*        ===============================================================
+*        (1) Compute the number of constraints that are violated by more
+*            than FEATOL.
+*        (2) Compute the 2-norm of the residuals of the constraints in
+*            the QP working set.
+*        ===============================================================
+         CALL NPFEAS( N, NCLIN, NCNLN, ISTATE,
+     $                BIGBND, CVNORM, ERRMAX, JMAX, NVIOL,
+     $                AX, BL, BU, C, FEATOL, X, W(LWRK2) )
+
+*        Define small quantities that reflect the magnitude of OBJF and
+*        the norm of GRAD(free).
+
+         OBJSIZ = ONE + ABS( OBJF )
+         XSIZE  = ONE +  XNORM
+         GTEST  = MAX( OBJSIZ, GFNORM )
+         DINKY  = RTFTOL * GTEST
+
+         IF (NACTIV .EQ. 0) THEN
+            CONDT = ZERO
+         ELSE IF (NACTIV .EQ. 1) THEN
+            CONDT = DTMIN
+         ELSE
+            CONDT = DDIV  ( DTMAX, DTMIN, OVERFL )
+         END IF
+
+         CALL DCOND ( N, R, NROWR+1, DRMAX, DRMIN )
+
+         CONDH = DDIV  ( DRMAX, DRMIN, OVERFL )
+         IF (CONDH .LT. RTMAX) THEN
+            CONDH = CONDH*CONDH
+         ELSE
+            CONDH = FLMAX
+         END IF
+
+         IF (NZ .EQ. 0) THEN
+            CONDHZ = ONE
+         ELSE IF (NZ .EQ. N) THEN
+            CONDHZ = CONDH
+         ELSE
+            CALL DCOND ( NZ, R, NROWR+1, DRZMAX, DRZMIN )
+            CONDHZ = DDIV  ( DRZMAX, DRZMIN, OVERFL )
+            IF (CONDHZ .LT. RTMAX) THEN
+               CONDHZ = CONDHZ*CONDHZ
+            ELSE
+               CONDHZ = FLMAX
+            END IF
+         END IF
+
+*        ---------------------------------------------------------------
+*        Test for convergence.
+*        The point test CONVPT checks for a K-T point at the initial
+*        point or after a large change in X.
+*        ---------------------------------------------------------------
+         CONVPT    = GZNORM .LE. EPSPT8*GTEST  .AND.  NVIOL  .EQ. 0
+
+         KTCOND(1) = GZNORM .LT. DINKY
+         KTCOND(2) = NVIOL  .EQ. 0
+         OPTIML    = KTCOND(1)  .AND.  KTCOND(2)
+
+         CONVRG    = MAJITS .GT. 0  .AND.  ALFDX .LE. RTFTOL*XSIZE
+
+         INFEAS    =       CONVRG         .AND.  .NOT. FEASQP
+     $               .OR.  NQPINF .GT. 7
+
+         DONE      = CONVPT  .OR.  (CONVRG  .AND. OPTIML)
+     $                       .OR.   INFEAS
+
+         OBJALF = OBJF
+         GRDALF = GDX
+         GLF1   = GDX
+         IF (NCNLN .GT. 0) THEN
+            GLF1   = GLF1
+     $                 - DDOT( NCNLN, W(LCJDX), 1, CLAMDA(NL), 1 )
+
+*           Compute the value and directional derivative of the
+*           augmented Lagrangian merit function.
+*           The penalty parameters may be increased or decreased.
+
+            CALL NPMRT ( FEASQP, N, NCLIN, NCNLN,
+     $                   OBJALF, GRDALF, QPCURV,
+     $                   ISTATE,
+     $                   W(LCJDX), W(LCMUL), W(LCS1),
+     $                   W(LDLAM), W(LRHO), W(LVIOLN),
+     $                   W(LWRK1), W(LWRK2) )
+         END IF
+
+*        ===============================================================
+*        Print the details of this iteration.
+*        ===============================================================
+         CALL NPPRT ( KTCOND, CONVRG, LSUMRY, MSGNP, MSGQP,
+     $                NROWR, NROWT, N, NCLIN, NCNLN,
+     $                NCTOTL, NACTIV, LINACT, NLNACT, NZ, NFREE,
+     $                MAJITS, MINITS, ISTATE, ALFA, NFUN,
+     $                CONDHZ, CONDH, CONDT, OBJALF, OBJF,
+     $                GFNORM, GZNORM, CVNORM,
+     $                AX, C, R, W(LT), W(LVIOLN), X, W(LWRK1) )
+
+         ALFA  = ZERO
+         ERROR = MAJITS .GE. NMAJOR
+
+         IF (.NOT. (DONE  .OR.  ERROR)) THEN
+            MAJITS = MAJITS + 1
+
+            IF (MAJITS .EQ. IDBG) THEN
+               NPDBG = .TRUE.
+               CMDBG =  NPDBG
+               MSGNP =  MSGSV1
+               MSGQP =  MSGSV2
+            END IF
+
+*           Make copies of information needed for the BFGS update.
+
+            CALL DCOPY ( N, X     , 1, W(LX1) , 1 )
+            CALL DCOPY ( N, W(LGQ), 1, W(LGQ1), 1 )
+
+            IF (NCNLN .GT. 0) THEN
+               CALL DCOPY ( NCNLN, W(LCJDX), 1, W(LCJDX1), 1 )
+               CALL DCOPY ( NCNLN, W(LCMUL), 1, W(LC1MUL), 1 )
+               CALL DCOPY ( NCNLN, W(LSLK) , 1, W(LSLK1) , 1 )
+            END IF
+
+*           ============================================================
+*           Compute the parameters for the linesearch.
+*           ============================================================
+*           Compute ALFMAX, the largest feasible step.  Also compute
+*           ALFBND,  a tentative upper bound on the step.  If the
+*           merit function is decreasing at ALFBND and certain
+*           conditions hold,  ALFBND will be increased in multiples
+*           of two (subject to not being greater than ALFMAX).
+
+            ALFMAX = DDIV  ( BIGDX, DXNORM, OVERFL )
+            ALFMIN = ONE
+            IF (.NOT. FEASQP) ALFMIN = ZERO
+
+            CALL NPALF ( INFO, N, NCLIN, NCNLN,
+     $                   ALFA, ALFMIN, ALFMAX, BIGBND, DXNORM,
+     $                   W(LANORM), W(LADX), AX, BL, BU,
+     $                   W(LDSLK), W(LDX), W(LSLK), X )
+
+            ALFMAX = ALFA
+            IF (ALFMAX .LT. ONE + EPSPT3  .AND.  FEASQP)
+     $         ALFMAX = ONE
+
+            IF (NCNLN .EQ. 0) THEN
+               ALFBND = ALFMAX
+            ELSE
+               IF (NEEDFD) ALFMAX = ONE
+               ALFBND = MIN( ONE, ALFMAX )
+            END IF
+            ALFA   = ONE
+
+            ALFSML = ZERO
+            IF (NEEDFD  .AND. .NOT. CENTRL) THEN
+               ALFSML = DDIV  ( FDNORM, DXNORM, OVERFL )
+               ALFSML = MIN   ( ALFSML, ALFMAX )
+            END IF
+
+*           ============================================================
+*           Compute the steplength using safeguarded interpolation.
+*           ============================================================
+            CALL NPSRCH( NEEDFD, NLSERR, N, NCNLN,
+     $                   NROWJ, NROWUJ, NFUN, NGRAD,
+     $                   IW(LNEEDC), CONFUN, OBJFUN,
+     $                   ALFA, ALFBND, ALFMAX, ALFSML, DXNORM,
+     $                   EPSRF, ETA, GDX, GRDALF, GLF1, GLF2,
+     $                   OBJF, OBJALF, QPCURV, XNORM,
+     $                   C, CJAC, UJAC, W(LCJDX),
+     $                   W(LC1MUL), W(LCMUL), W(LCS1),
+     $                   W(LCS2), W(LDX), W(LDLAM), W(LDSLK), GRAD,
+     $                   UGRAD, CLAMDA(NL), W(LRHO),
+     $                   W(LSLK1), W(LSLK), W(LX1), X, W, LENW )
+
+*           ------------------------------------------------------------
+*           NPSRCH  sets NLSERR to the following values...
+*
+*           NLSERR will be negative if the user set MODE LT 0.
+*
+*           Values of NLSERR occurring with a nonzero value of ALFA.
+*           1 -- if the search was successful and ALFA LT ALFMAX.
+*           2 -- if the search was successful and ALFA  = ALFMAX.
+*           3 -- if the search ended after MFSRCH iterations.
+*
+*           Values of NLSERR occurring with a zero value of ALFA....
+*           4 -- if ALFMAX was too small.
+*           6 -- if no improved point could be found.
+*           7 -- if the input value of GDX is non-negative.
+*           ------------------------------------------------------------
+            IF (NLSERR .LT. 0) THEN
+               INFORM = NLSERR
+               GO TO 800
+            END IF
+
+            ERROR  = NLSERR .GE. 4
+            IF (ERROR) THEN
+*              ---------------------------------------------------------
+*              The linesearch failed to find a better point.
+*              If exact gradients or central differences are being used,
+*              or the KT conditions are satisfied, stop.  Otherwise,
+*              switch to central differences and re-solve the QP.
+*              ---------------------------------------------------------
+               IF (NEEDFD  .AND.  .NOT. CENTRL) THEN
+                  IF (.NOT. OPTIML) THEN
+                     ERROR       = .FALSE.
+                     LSUMRY(3:3) = 'Central differences'
+                     LVLDIF      = 2
+                     NEWGQ       = .TRUE.
+                  END IF
+               END IF
+            ELSE
+               IF (NEEDFD) THEN
+*                 ======================================================
+*                 Compute the missing gradients.
+*                 ======================================================
+                  MODE  = 1
+                  NGRAD = NGRAD + 1
+
+                  IF (NCNLN .GT. 0) THEN
+                     CALL ILOAD ( NCNLN, (1), IW(LNEEDC), 1 )
+
+                     CALL CONFUN( MODE, NCNLN, N, NROWUJ, IW(LNEEDC),
+     $                            X, W(LWRK1), UJAC, NSTATE )
+                     INFORM = MODE
+                     IF (MODE .LT. 0) GO TO 800
+
+                     DO 410 J = 1, N
+                        CALL DCOPY (NCNLN, UJAC(1,J), 1, CJAC(1,J), 1 )
+  410                CONTINUE
+                  END IF
+
+                  CALL OBJFUN( MODE, N, X, OBJ, UGRAD, NSTATE )
+                  INFORM = MODE
+                  IF (MODE .LT. 0) GO TO 800
+
+                  CALL DCOPY ( N, UGRAD, 1, GRAD, 1 )
+
+                  CALL NPFD  ( CENTRL, MODE,
+     $                         NROWJ, NROWUJ, N, NCNLN,
+     $                         BIGBND, CDINT, FDINT, FDNORM, OBJF,
+     $                         CONFUN, OBJFUN, IW(LNEEDC),
+     $                         BL, BU, C, W(LWRK2), W(LWRK3),CJAC,UJAC,
+     $                         GRAD, UGRAD, W(LHFRWD), W(LHCTRL), X,
+     $                         W, LENW )
+
+                  INFORM = MODE
+                  IF (MODE .LT. 0) GO TO 800
+
+                  GDX  =  DDOT( N, GRAD, 1, W(LDX), 1 )
+                  GLF2 =  GDX
+                  IF (NCNLN .GT. 0) THEN
+                     CALL DGEMV ( 'N', NCNLN, N, ONE, CJAC, NROWJ,
+     $                            W(LDX), 1, ZERO, W(LCJDX), 1 )
+                     GLF2 = GLF2 -
+     $                      DDOT( NCNLN, W(LCJDX), 1, CLAMDA(NL), 1 )
+                  END IF
+               END IF
+
+               CALL DCOPY ( N, GRAD, 1, W(LGQ), 1 )
+               CALL CMQMUL( 6, N, NZ, NFREE, NQ, UNITQ,
+     $                      KX, W(LGQ), W(LZY), W(LWRK1) )
+
+               XNORM  = DNRM2 ( N, X, 1 )
+
+               IF (NCNLN .GT. 0  .AND.  ALFA .GE. ONE)
+     $            CALL DCOPY ( NCNLN, CLAMDA(NL), 1, W(LCMUL), 1 )
+
+               IF (NCLIN .GT. 0)
+     $            CALL DAXPY ( NCLIN, ALFA, W(LADX), 1, AX, 1 )
+               ALFDX   = ALFA * DXNORM
+
+*              =========================================================
+*              Update the factors of the approximate Hessian of the
+*              Lagrangian function.
+*              =========================================================
+               CALL NPUPDT( LSUMRY, UNITQ,
+     $                      N, NCNLN, NFREE, NZ,
+     $                      NROWJ1, NROWJ, NQ, NROWR, KX,
+     $                      ALFA, GLF1, GLF2, QPCURV,
+     $                      W(LCJAC1), CJAC, W(LCJDX1), W(LCJDX),
+     $                      W(LCS1), W(LCS2), W(LGQ1), W(LGQ),
+     $                      W(LHPQ), W(LRPQ), CLAMDA(NL), R,
+     $                      W(LWRK3), W(LZY), W(LWRK2), W(LWRK1) )
+
+               CALL DCOND ( N, R, NROWR+1, DRMAX, DRMIN )
+               COND   = DDIV  ( DRMAX, DRMIN, OVERFL )
+
+               IF (      COND   .GT. RCNDBD
+     $             .OR.  RFROBN .GT. ROOTN*GROWTH*DRMAX) THEN
+*                 ------------------------------------------------------
+*                 Reset the condition estimator and range-space
+*                 partition of Q'HQ.
+*                 ------------------------------------------------------
+                  IF (NPDBG  .AND.  INPDBG(1) .GT. 0)
+     $               WRITE (NOUT, 9000) RFROBN, DRMAX, DRMIN,COND,RCNDBD
+
+                  LSUMRY(4:4) = 'Refactorize Hessian'
+
+                  CALL NPRSET( UNITQ,
+     $                         N, NFREE, NZ, NQ, NROWR,
+     $                         IW(LIPERM), KX,
+     $                         W(LGQ), R, W(LZY), W(LWRK1), W(LQRWRK) )
+               END IF
+            END IF
+         END IF
+
+*+    UNTIL     (DONE  .OR.  ERROR)
+      IF (.NOT. (DONE  .OR.  ERROR) ) GO TO 100
+
+*     ======================end of main loop============================
+
+      IF (DONE) THEN
+         IF (CONVPT  .OR.  OPTIML) THEN
+            INFORM = 0
+         ELSE IF (INFEAS) THEN
+            INFORM = 3
+         END IF
+      ELSE IF (ERROR) THEN
+         IF (MAJITS .GE. NMAJOR) THEN
+            INFORM = 4
+         ELSE IF (OPTIML) THEN
+            INFORM = 1
+         ELSE
+            INFORM = 6
+         END IF
+      END IF
+
+*     ------------------------------------------------------------------
+*     Set  CLAMDA.  Print the full solution.
+*     ------------------------------------------------------------------
+  800 MSGNP = MSGSV1
+      MSGQP = MSGSV2
+      IF (MSGNP .GT. 0)
+     $   WRITE (NOUT, 2100) INFORM, MAJITS, NFUN, NGRAD
+
+      CALL CMPRT ( MSGNP, NFREE, NROWQP,
+     $             N, NCLIN, NCNLN, NCTOTL, BIGBND,
+     $             NAMED, NAMES, LENNAM,
+     $             NACTIV, ISTATE, KACTIV, KX,
+     $             AQP, BL, BU, C, CLAMDA, W(LRLAM), X )
+
+      RETURN
+
+ 2100 FORMAT(/ ' Exit  NP phase.  INFORM = ', I2, ' MAJITS = ', I5,
+     $         '   NFUN = ', I5, '   NGRAD = ', I5 )
+
+ 9000 FORMAT(/ ' //NPCORE//        RFROBN         DRMAX         DRMIN'
+     $       / ' //NPCORE//', 1P3E14.2
+     $       / ' //NPCORE//          COND        RCNDBD'
+     $       / ' //NPCORE//', 1P2E14.2 )
+
+*     End of  NPCORE.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/npcrsh.f
@@ -0,0 +1,128 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPCRSH( COLD, N, NCLIN, NCNLN,
+     $                   NCTOTL, NACTIV, NFREE, NZ,
+     $                   ISTATE, KACTIV, BIGBND, TOLACT,
+     $                   BL, BU, C )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      LOGICAL            COLD
+      INTEGER            ISTATE(NCTOTL), KACTIV(N)
+      DOUBLE PRECISION   C(*), BL(NCTOTL), BU(NCTOTL)
+************************************************************************
+*  NPCRSH  adds indices of nonlinear constraints to the initial working
+*  set.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Original version   14-February 1985.
+*  This version of  NPCRSH  dated 14-November-1985.
+************************************************************************
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+
+      COMMON    /SOL1CM/ NOUT
+
+      LOGICAL            NPDBG
+      PARAMETER        ( LDBG = 5 )
+      COMMON    /NPDEBG/ INPDBG(LDBG), NPDBG
+
+      INTRINSIC          ABS, MIN
+      PARAMETER        ( ONE = 1.0D+0 )
+
+      NFIXED = N      - NFREE
+      LINACT = NACTIV
+      NPLIN  = N      + NCLIN
+
+*     If a cold start is being made, initialize the status of the QP
+*     working set.  First,  if  BL(j) = BU(j),  set ISTATE(j)=3.
+
+      IF (COLD) THEN
+         DO  130 J = NPLIN+1, NCTOTL
+            ISTATE(J) = 0
+            IF (BL(J) .EQ. BU(J)) ISTATE(J) = 3
+  130    CONTINUE
+      END IF
+
+*     Increment NACTIV and KACTIV.
+*     Ensure that the number of bounds and general constraints in the
+*     QP  working set does not exceed N.
+
+      DO 200 J = NPLIN+1, NCTOTL
+         IF (NFIXED + NACTIV .EQ. N) ISTATE(J) = 0
+         IF (ISTATE(J) .GT. 0) THEN
+            NACTIV = NACTIV + 1
+            KACTIV(NACTIV) = J - N
+         END IF
+  200 CONTINUE
+
+      IF (COLD) THEN
+
+*        ---------------------------------------------------------------
+*        If a cold start is required, an attempt is made to add as many
+*        nonlinear constraints as possible to the working set.
+*        ---------------------------------------------------------------
+*        The following loop finds the most violated constraint.  If
+*        there is room in KACTIV, it will be added to the working set
+*        and the process will be repeated.
+
+
+         IS     =   1
+         BIGLOW = - BIGBND
+         BIGUPP =   BIGBND
+         TOOBIG =   TOLACT + TOLACT
+
+*        while (is .gt. 0  .and.  nfixed + nactiv .lt. n) do
+  500    IF    (IS .GT. 0  .AND.  NFIXED + NACTIV .LT. N) THEN
+            IS   = 0
+            CMIN = TOLACT
+
+            DO 520 I = 1, NCNLN
+               J      = NPLIN + I
+               IF (ISTATE(J) .EQ. 0) THEN
+                  B1     = BL(J)
+                  B2     = BU(J)
+                  RESL   = TOOBIG
+                  RESU   = TOOBIG
+                  IF (B1 .GT. BIGLOW)
+     $            RESL   = ABS( C(I) - B1 ) / (ONE + ABS( B1 ))
+                  IF (B2 .LT. BIGUPP)
+     $            RESU   = ABS( C(I) - B2 ) / (ONE + ABS( B2 ))
+                  RES    = MIN( RESL, RESU )
+                  IF (RES .LT. CMIN) THEN
+                     CMIN = RES
+                     IMIN = I
+                     IS   = 1
+                     IF (RESL .GT. RESU) IS = 2
+                  END IF
+               END IF
+  520       CONTINUE
+
+            IF (IS .GT. 0) THEN
+               NACTIV         = NACTIV + 1
+               KACTIV(NACTIV) = NCLIN  + IMIN
+               J              = NPLIN  + IMIN
+               ISTATE(J)      = IS
+            END IF
+            GO TO 500
+*        end while
+         END IF
+      END IF
+
+*     ------------------------------------------------------------------
+*     An initial working set has now been selected.
+*     ------------------------------------------------------------------
+      NLNACT = NACTIV - LINACT
+      NZ     = NFREE  - NACTIV
+      IF (NPDBG  .AND.  INPDBG(1) .GT. 0)
+     $   WRITE (NOUT, 1000) NFIXED, LINACT, NLNACT
+
+      RETURN
+
+ 1000 FORMAT(/ ' //NPCRSH//  Working set selected....'
+     $       / ' //NPCRSH// NFIXED LINACT NLNACT     '
+     $       / ' //NPCRSH//', 3I7 )
+
+*     End of  NPCRSH.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/npdflt.f
@@ -0,0 +1,256 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPDFLT( N, NCLIN, NCNLN, LENIW, LENW, TITLE )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+
+      CHARACTER*(*)      TITLE
+
+************************************************************************
+*  NPDFLT  loads the default values of parameters not set in the options
+*  file.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Original Fortran 77 version written 10-September-1985.
+*  This version of NPDFLT dated  14-July-1986.
+************************************************************************
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9
+
+      COMMON    /SOL4NP/ LVLDIF, NCDIFF, NFDIFF, LFDSET
+      COMMON    /SOL5NP/ LVRFYC, JVERFY(4)
+
+      LOGICAL            CMDBG, LSDBG, NPDBG
+      PARAMETER        ( LDBG = 5 )
+      COMMON    /NPDEBG/ INPDBG(LDBG), NPDBG
+      COMMON    /LSDEBG/ ILSDBG(LDBG), LSDBG
+      COMMON    /CMDEBG/ ICMDBG(LDBG), CMDBG
+
+      LOGICAL            NEWOPT
+      COMMON    /SOL7NP/ NEWOPT
+      SAVE      /SOL7NP/
+
+*-----------------------------------------------------------------------
+      PARAMETER         (MXPARM = 30)
+      INTEGER            IPRMLS(MXPARM), IPSVLS
+      DOUBLE PRECISION   RPRMLS(MXPARM), RPSVLS
+
+      COMMON    /LSPAR1/ IPSVLS(MXPARM),
+     $                   IDBGLS, ITMAX1, ITMAX2, LCRASH, LDBGLS, LPROB ,
+     $                   MSGLS , NN    , NNCLIN, NPROB , IPADLS(20)
+
+      COMMON    /LSPAR2/ RPSVLS(MXPARM),
+     $                   BIGBND, BIGDX , BNDLOW, BNDUPP, TOLACT, TOLFEA,
+     $                   TOLRNK, RPADLS(23)
+
+      EQUIVALENCE       (IPRMLS(1), IDBGLS), (RPRMLS(1), BIGBND)
+
+      SAVE      /LSPAR1/, /LSPAR2/
+*-----------------------------------------------------------------------
+*-----------------------------------------------------------------------
+      INTEGER            IPRMNP(MXPARM), IPSVNP
+      DOUBLE PRECISION   RPRMNP(MXPARM), RPSVNP
+
+      COMMON    /NPPAR1/ IPSVNP(MXPARM),
+     $                   IDBGNP, ITMXNP, JVRFY1, JVRFY2, JVRFY3, JVRFY4,
+     $                   LDBGNP, LFORMH, LVLDER, LVERFY, MSGNP , NLNF  ,
+     $                   NLNJ  , NLNX  , NNCNLN, IPADNP(15)
+
+      COMMON    /NPPAR2/ RPSVNP(MXPARM),
+     $                   CDINT , CTOL  , EPSRF , ETA   , FDINT , FTOL  ,
+     $                   RPADNP(24)
+
+      EQUIVALENCE       (IPRMNP(1), IDBGNP), (RPRMNP(1), CDINT)
+
+      SAVE      /NPPAR1/, /NPPAR2/
+*-----------------------------------------------------------------------
+      EQUIVALENCE  (IDBGNP, IDBG  ), (ITMXNP, NMAJOR), (ITMAX2, NMINOR)
+      EQUIVALENCE  (LDBGLS, MNRDBG), (LDBGNP, MJRDBG), (MSGLS , MSGQP )
+
+      INTRINSIC          ABS    , LEN    , MOD
+      PARAMETER        ( ZERO   =  0.0D+0, ONE    =  1.0D+0 )
+      PARAMETER        ( POINT3 =  3.3D-1, POINT8 =  0.8D+0 )
+      PARAMETER        ( POINT9 =  0.9D+0                   )
+      PARAMETER        ( RDUMMY = -11111., IDUMMY = -11111  )
+      PARAMETER        ( GIGANT =  1.0D+10*.99999           )
+      PARAMETER        ( WRKTOL =  1.0D-2                   )
+
+      CHARACTER*4        ICRSH(0:2)
+      CHARACTER*16       KEY
+      DATA                ICRSH(0),  ICRSH(1),  ICRSH(2)
+     $                 / 'COLD'   , 'WARM'   , 'HOT '    /
+
+      EPSMCH = WMACH( 3)
+      NOUT   = WMACH(11)
+      NCQP   = NCLIN + NCNLN
+      NPLIN  = N     + NCLIN
+      NCTOTL = NPLIN + NCNLN
+
+*     Make a dummy call NPKEY to ensure that the defaults are set.
+
+      CALL NPKEY ( NOUT, '*', KEY )
+      NEWOPT = .TRUE.
+
+*     Save the optional parameters set by the user.  The values in
+*     IPRMLS, RPRMLS, IPRMNP and RPRMNP may be changed to their
+*     default values.
+
+      CALL ICOPY ( MXPARM, IPRMLS, 1, IPSVLS, 1 )
+      CALL DCOPY ( MXPARM, RPRMLS, 1, RPSVLS, 1 )
+      CALL ICOPY ( MXPARM, IPRMNP, 1, IPSVNP, 1 )
+      CALL DCOPY ( MXPARM, RPRMNP, 1, RPSVNP, 1 )
+
+      IF (          LCRASH .LT. 0
+     $    .OR.      LCRASH .GT. 2     )   LCRASH  =  0
+      IF (          LVLDER .LT. 0
+     $    .OR.      LVLDER .GT. 3     )   LVLDER  =  3
+      IF (          LFORMH .LT. 0
+     $    .OR.      LFORMH .GT. 1     )   LFORMH  =  0
+      IF (          NMAJOR .LT. 0     )   NMAJOR  = MAX(50, 3*NPLIN+
+     $                                                     10*NCNLN )
+      IF (          NMINOR .LT. 1     )   NMINOR  = MAX(50, 3*NCTOTL)
+      IF (          MJRDBG .LT. 0     )   MJRDBG  =  0
+      IF (          MNRDBG .LT. 0     )   MNRDBG  =  0
+      IF (          IDBG   .LT. 0
+     $    .OR.      IDBG   .GT. NMAJOR)   IDBG    =  0
+      IF (          MJRDBG .EQ. 0
+     $    .AND.     MNRDBG .EQ. 0     )   IDBG    = NMAJOR + 1
+      IF (          MSGNP  .EQ. IDUMMY)   MSGNP   = 10
+      IF (          MSGQP  .EQ. IDUMMY)   MSGQP   =  0
+                                          NLNF    =  N
+                                          NLNJ    =  N
+                                          NLNX    =  N
+      IF (          JVRFY2 .LT. 0
+     $    .OR.      JVRFY2 .GT. N     )   JVRFY2  =  N
+      IF (          JVRFY1 .LT. 0
+     $    .OR.      JVRFY1 .GT. JVRFY2)   JVRFY1  =  1
+      IF (          JVRFY4 .LT. 0
+     $    .OR.      JVRFY4 .GT. N     )   JVRFY4  =  N
+      IF (          JVRFY3 .LT. 0
+     $    .OR.      JVRFY3 .GT. JVRFY4)   JVRFY3  =  1
+      IF (          LVERFY .EQ. IDUMMY
+     $    .OR.      LVERFY .GT. 13    )   LVERFY  =  0
+      IF (          TOLACT .LT. ZERO
+     $    .OR.      TOLACT .GE. ONE   )   TOLACT  =  WRKTOL
+      IF (          TOLFEA .LT. EPSMCH
+     $    .OR.      TOLFEA .GE. ONE   )   TOLFEA  =  EPSPT5
+      IF (          EPSRF  .LT. EPSMCH
+     $    .OR.      EPSRF  .GE. ONE   )   EPSRF   =  EPSPT9
+                                          LFDSET  =  0
+      IF (          FDINT  .LT. ZERO  )   LFDSET  =  2
+      IF (          FDINT  .EQ. RDUMMY)   LFDSET  =  0
+      IF (          FDINT  .GE. EPSMCH
+     $    .AND.     FDINT  .LT. ONE   )   LFDSET  =  1
+      IF (          LFDSET .EQ. 1
+     $    .AND.    (CDINT  .LT. EPSMCH
+     $    .OR.      CDINT  .GE. ONE  ))   CDINT   = EPSRF**POINT3
+      IF (          BIGBND .LE. ZERO  )   BIGBND  = GIGANT
+      IF (          BIGDX  .LE. ZERO  )   BIGDX   = MAX( GIGANT,BIGBND )
+      IF (          ETA    .LT. ZERO
+     $    .OR.      ETA    .GE. ONE   )   ETA     = POINT9
+      IF (          FTOL   .LT. EPSRF
+     $    .OR.      FTOL   .GE. ONE   )   FTOL    = EPSRF**POINT8
+
+                                          DCTOL   = EPSPT5
+      IF (          LVLDER .LT. 2     )   DCTOL   = EPSPT3
+      IF (          CTOL   .LT. EPSMCH
+     $    .OR.      CTOL   .GE. ONE   )   CTOL    = DCTOL
+
+      ITMAX1    = MAX( 50, 3*(N + NCLIN + NCNLN) )
+      JVERFY(1) = JVRFY1
+      JVERFY(2) = JVRFY2
+      JVERFY(3) = JVRFY3
+      JVERFY(4) = JVRFY4
+
+      NPDBG = IDBG .EQ. 0
+      CMDBG = NPDBG
+
+      K     = 1
+      MSG1  = MJRDBG
+      MSG2  = MNRDBG
+      DO 200 I = 1, LDBG
+         INPDBG(I) = MOD( MSG1/K, 10 )
+         ICMDBG(I) = INPDBG(I)
+         ILSDBG(I) = MOD( MSG2/K, 10 )
+         K = K*10
+  200 CONTINUE
+
+      IF (MSGNP .GT. 0) THEN
+
+*        Print the title.
+
+         LENT = LEN( TITLE )
+         IF (LENT .GT. 0) THEN
+            NSPACE = (81 - LENT)/2 + 1
+            WRITE (NOUT, '(///// (80A1) )')
+     $         (' ', J=1, NSPACE), (TITLE(J:J), J=1,LENT)
+            WRITE (NOUT, '(80A1 //)')
+     $         (' ', J=1, NSPACE), ('='       , J=1,LENT)
+         END IF
+
+         WRITE (NOUT, 2000)
+         WRITE (NOUT, 2100) NCLIN , TOLFEA, ICRSH(LCRASH) ,
+     $                      N     , BIGBND, TOLACT,
+     $                              BIGDX
+         WRITE (NOUT, 2200) NCNLN , FTOL  , EPSRF ,
+     $                      NLNJ  , CTOL  ,
+     $                      NLNF  , ETA   ,
+     $                      EPSMCH,
+     $                      LVLDER, LVERFY
+         WRITE (NOUT, 2300) NMAJOR, MSGNP,
+     $                      NMINOR, MSGQP
+
+         IF (LVLDER .LT. 3) THEN
+            IF      (LFDSET .EQ. 0) THEN
+               WRITE (NOUT, 2400)
+            ELSE IF (LFDSET .EQ. 1) THEN
+               WRITE (NOUT, 2401) FDINT, CDINT
+            ELSE IF (LFDSET .EQ. 2) THEN
+               WRITE (NOUT, 2402)
+            END IF
+         END IF
+
+      END IF
+
+      RETURN
+
+ 2000 FORMAT(
+     $//' Parameters'
+     $/ ' ----------' )
+ 2100 FORMAT(
+     $/ ' Linear constraints.....', I10,     6X,
+     $  ' Linear feasibility.....', 1PE10.2, 6X,
+     $  1X, A4, ' start.............'
+     $/ ' Variables..............', I10,     6X,
+     $  ' Infinite bound size....', 1PE10.2, 6X,
+     $  ' Crash tolerance........', 1PE10.2
+     $/   24X,                      16X,
+     $  ' Infinite step size.....', 1PE10.2  )
+ 2200 FORMAT(
+     $/ ' Nonlinear constraints..', I10,     6X,
+     $  ' Optimality tolerance...', 1PE10.2, 6X,
+     $  ' Function precision.....', 1PE10.2
+     $/ ' Nonlinear Jacobian vars', I10,     6X,
+     $  ' Nonlinear feasibility..', 1PE10.2
+     $/ ' Nonlinear objectiv vars', I10,     6X,
+     $  ' Linesearch tolerance...', 1PE10.2
+     $/ ' EPS (machine precision)', 1PE10.2, 6X,
+     $  ' Derivative level.......', I10,     6X,
+     $  ' Verify level...........', I10)
+ 2300 FORMAT(
+     $/ ' Major iterations limit.', I10, 6X,
+     $  ' Major print level......', I10
+     $/ ' Minor iterations limit.', I10, 6X,
+     $  ' Minor print level......', I10 )
+ 2400 FORMAT(/ ' Difference intervals to be computed.' )
+ 2401 FORMAT(/ ' Difference interval....', 1PE10.2, 6X,
+     $         ' Central diffce interval', 1PE10.2 )
+ 2402 FORMAT(/ ' User-supplied difference intervals.' )
+
+*     End of  NPDFLT.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/npfd.f
@@ -0,0 +1,165 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPFD  ( CENTRL, INFORM,
+     $                   NROWJ, NROWUJ, N, NCNLN,
+     $                   BIGBND, CDINT, FDINT, FDNORM, OBJF,
+     $                   CONFUN, OBJFUN, NEEDC,
+     $                   BL, BU, C, C1, C2, CJAC, UJAC,
+     $                   GRAD, UGRAD, HFORWD, HCNTRL, X,
+     $                   W, LENW )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      LOGICAL            CENTRL
+      INTEGER            NEEDC(*)
+
+      DOUBLE PRECISION   BL(N), BU(N), C(*), C1(*), C2(*),
+     $                   CJAC(NROWJ,*), UJAC(NROWUJ,*)
+      DOUBLE PRECISION   GRAD(N), UGRAD(N), HFORWD(N), HCNTRL(N), X(N)
+      DOUBLE PRECISION   W(LENW)
+      EXTERNAL           CONFUN, OBJFUN
+
+************************************************************************
+*  NPFD   evaluates any missing gradients.
+*
+*  Systems Optimization Laboratory, Stanford University, California.
+*  Original version written 3-July-1986.
+*  This version of NPFD   dated 14-July-1986.
+************************************************************************
+
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9
+
+      COMMON    /SOL4NP/ LVLDIF, NCDIFF, NFDIFF, LFDSET
+
+      LOGICAL            NPDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /NPDEBG/ INPDBG(LDBG), NPDBG
+
+      INTRINSIC          ABS   , MAX
+
+      PARAMETER         (RDUMMY=-11111.0)
+      PARAMETER         (ZERO  = 0.0D+0, HALF  = 0.5D+0, ONE   = 1.0D+0)
+      PARAMETER         (TWO   = 2.0D+0, THREE = 3.0D+0, FOUR  = 4.0D+0)
+
+      INFORM = 0
+
+*     ==================================================================
+*     Use the pre-assigned difference intervals to approximate the
+*     derivatives.
+*     ==================================================================
+*     Use either the same interval for each component (LFDSET = 1),
+*     or the intervals already in HFORWD or HCNTRL (LFDSET = 0 or 2).
+
+      NSTATE =   0
+      MODE   =   0
+
+      BIGLOW = - BIGBND
+      BIGUPP =   BIGBND
+
+      FDNORM =   ZERO
+
+      DO 340 J  = 1, N
+
+         XJ     = X(J)
+         NFOUND = 0
+         IF (NCDIFF .GT. 0) THEN
+            DO 310 I = 1, NCNLN
+               IF (UJAC(I,J) .EQ. RDUMMY) THEN
+                  NEEDC(I) = 1
+                  NFOUND   = NFOUND + 1
+               ELSE
+                  NEEDC(I) = 0
+               END IF
+  310       CONTINUE
+         END IF
+
+         IF (NFOUND .GT. 0  .OR.  UGRAD(J) .EQ. RDUMMY) THEN
+            STEPBL = BIGLOW
+            STEPBU = BIGUPP
+            IF (BL(J) .GT. BIGLOW) STEPBL = BL(J) - XJ
+            IF (BU(J) .LT. BIGUPP) STEPBU = BU(J) - XJ
+
+            IF (CENTRL) THEN
+               IF (LFDSET .EQ. 1) THEN
+                  DELTA = CDINT
+               ELSE
+                  DELTA = HCNTRL(J)
+               END IF
+            ELSE
+               IF (LFDSET .EQ. 1) THEN
+                  DELTA = FDINT
+               ELSE
+                  DELTA = HFORWD(J)
+               END IF
+            END IF
+
+            DELTA  = DELTA*(ONE + ABS(XJ))
+            FDNORM = MAX (FDNORM, DELTA)
+            IF (HALF*(STEPBL + STEPBU) .LT. ZERO) DELTA =  - DELTA
+
+            X(J) = XJ + DELTA
+            IF (NFOUND .GT. 0) THEN
+               CALL CONFUN( MODE, NCNLN, N, NROWUJ,
+     $                      NEEDC, X, C1, UJAC, NSTATE )
+               IF (MODE .LT. 0) GO TO 999
+            END IF
+
+            IF (UGRAD(J) .EQ. RDUMMY) THEN
+               CALL OBJFUN( MODE, N, X, OBJF1, UGRAD, NSTATE )
+               IF (MODE .LT. 0) GO TO 999
+            END IF
+
+            IF (CENTRL) THEN
+*              ---------------------------------------------------------
+*              Central differences.
+*              ---------------------------------------------------------
+               X(J)  = XJ + DELTA + DELTA
+
+               IF (NFOUND .GT. 0) THEN
+                  CALL CONFUN( MODE, NCNLN, N, NROWUJ,
+     $                         NEEDC, X, C2, UJAC, NSTATE )
+                  IF (MODE .LT. 0) GO TO 999
+
+                  DO 320 I = 1, NCNLN
+                     IF (NEEDC(I) .EQ. 1)
+     $                  CJAC(I,J) = (FOUR*C1(I) - THREE*C(I) - C2(I))
+     $                                  / (DELTA + DELTA)
+  320             CONTINUE
+               END IF
+
+               IF (UGRAD(J) .EQ. RDUMMY) THEN
+                  CALL OBJFUN( MODE, N, X, OBJF2, UGRAD, NSTATE )
+                  IF (MODE .LT. 0) GO TO 999
+
+                  GRAD(J) = (FOUR*OBJF1 - THREE*OBJF - OBJF2)
+     $                                  / (DELTA + DELTA)
+
+               END IF
+            ELSE
+*              ---------------------------------------------------------
+*              Forward Differences.
+*              ---------------------------------------------------------
+               IF (NFOUND .GT. 0) THEN
+                  DO 330 I = 1, NCNLN
+                     IF (NEEDC(I) .EQ. 1)
+     $                  CJAC(I,J) = (C1(I) -  C(I))/  DELTA
+  330             CONTINUE
+               END IF
+
+               IF (UGRAD(J) .EQ. RDUMMY)
+     $            GRAD(J) = (OBJF1 - OBJF) /  DELTA
+
+            END IF
+         END IF
+         X(J) = XJ
+
+  340 CONTINUE
+
+      RETURN
+
+  999 INFORM = MODE
+      RETURN
+
+*     End of  NPFD  .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/npfeas.f
@@ -0,0 +1,113 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPFEAS( N, NCLIN, NCNLN, ISTATE,
+     $                   BIGBND, CVNORM, ERRMAX, JMAX, NVIOL,
+     $                   AX, BL, BU, C, FEATOL, X, WORK )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      INTEGER            ISTATE(N+NCLIN+NCNLN)
+      DOUBLE PRECISION   AX(*), BL(N+NCLIN+NCNLN), BU(N+NCLIN+NCNLN)
+      DOUBLE PRECISION   C(*), FEATOL(N+NCLIN+NCNLN), X(N)
+      DOUBLE PRECISION   WORK(N+NCLIN+NCNLN)
+************************************************************************
+*  NPFEAS  computes the following...
+*  (1)  The number of constraints that are violated by more
+*       than  FEATOL  and the 2-norm of the constraint violations.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Original version      April    1984.
+*  This version of  NPFEAS  dated  16-October-1985.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+
+      LOGICAL            NPDBG
+      PARAMETER        ( LDBG = 5 )
+      COMMON    /NPDEBG/ INPDBG(LDBG), NPDBG
+
+      EXTERNAL           IDAMAX, DNRM2
+      INTRINSIC          ABS
+      PARAMETER        ( ZERO = 0.0D+0 )
+
+      BIGLOW = - BIGBND
+      BIGUPP =   BIGBND
+
+*     ==================================================================
+*     Compute NVIOL, the number of constraints violated by more than
+*     FEATOL,  and CVNORM,  the 2-norm of the constraint
+*     violations and residuals of the constraints in the QP working set.
+*     ==================================================================
+      NVIOL  = 0
+
+      DO 200 J = 1, N+NCLIN+NCNLN
+         FEASJ  = FEATOL(J)
+         RES    = ZERO
+
+         IF (J .LE. N + NCLIN) THEN
+
+*           Bound or general linear constraint.
+
+            IF (J .LE. N) THEN
+               CON =  X(J)
+            ELSE
+               CON = AX(J-N)
+            END IF
+
+            TOLJ   = FEASJ
+         ELSE
+
+*           Nonlinear constraint.
+
+            CON    = C(J-N-NCLIN)
+            TOLJ   = ZERO
+         END IF
+
+*        Check for constraint violations.
+
+         IF (BL(J) .GT. BIGLOW) THEN
+            RES    = BL(J) - CON
+            IF (RES .GT.   FEASJ ) NVIOL = NVIOL + 1
+            IF (RES .GT.    TOLJ ) GO TO 190
+         END IF
+
+         IF (BU(J) .LT. BIGUPP) THEN
+            RES    = BU(J) - CON
+            IF (RES .LT. (-FEASJ)) NVIOL = NVIOL + 1
+            IF (RES .LT.  (-TOLJ)) GO TO 190
+         END IF
+
+*        This constraint is satisfied,  but count the residual as a
+*        violation if the constraint is in the working set.
+
+         IS     = ISTATE(J)
+
+         IF (IS .EQ. 0) THEN
+            RES = ZERO
+         ELSE IF (IS .EQ. 1  .OR.  IS .LE. -2) THEN
+            RES = BL(J) - CON
+         ELSE IF (IS .GE. 2  .OR.  IS .EQ. -1) THEN
+            RES = BU(J) - CON
+         END IF
+
+         IF (ABS( RES ) .GT. FEASJ) NVIOL = NVIOL + 1
+
+*        Set the array of violations.
+
+  190    WORK(J) = RES
+  200 CONTINUE
+
+      JMAX   = IDAMAX( N+NCLIN+NCNLN, WORK, 1 )
+      ERRMAX = ABS ( WORK(JMAX) )
+
+      IF (NPDBG  .AND.  INPDBG(1) .GT. 0)
+     $   WRITE (NOUT, 1000) ERRMAX, JMAX
+
+      CVNORM = DNRM2 ( N+NCLIN+NCNLN, WORK, 1 )
+
+      RETURN
+
+ 1000 FORMAT(/ ' //NPFEAS//  The maximum violation is ', 1PE14.2,
+     $                     ' in constraint', I5 )
+
+*     End of  NPFEAS.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/npfile.f
@@ -0,0 +1,54 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPFILE( IOPTNS, INFORM )
+      INTEGER            IOPTNS, INFORM
+
+************************************************************************
+*     NPFILE  reads the options file from unit  IOPTNS  and loads the
+*     options into the relevant elements of  IPRMNP  and  RPRMNP.
+*
+*     If  IOPTNS .lt. 0  or  IOPTNS .gt. 99  then no file is read,
+*     otherwise the file associated with unit  IOPTNS  is read.
+*
+*     Output:
+*
+*         INFORM = 0  if a complete  OPTIONS  file was found
+*                     (starting with  BEGIN  and ending with  END);
+*                  1  if  IOPTNS .lt. 0  or  IOPTNS .gt. 99;
+*                  2  if  BEGIN  was found, but end-of-file
+*                     occurred before  END  was found;
+*                  3  if end-of-file occurred before  BEGIN  or
+*                     ENDRUN  were found;
+*                  4  if  ENDRUN  was found before  BEGIN.
+************************************************************************
+      LOGICAL             NEWOPT
+      COMMON     /SOL7NP/ NEWOPT
+      SAVE       /SOL7NP/
+
+      DOUBLE PRECISION    WMACH(15)
+      COMMON     /SOLMCH/ WMACH
+      SAVE       /SOLMCH/
+
+      EXTERNAL            MCHPAR, NPKEY
+      LOGICAL             FIRST
+      SAVE                FIRST , NOUT
+      DATA                FIRST /.TRUE./
+
+*     If first time in, set  NOUT.
+*     NEWOPT is true first time into NPFILE or NPOPTN
+*     and just after a call to NPSOL.
+
+      IF (FIRST) THEN
+         FIRST  = .FALSE.
+         NEWOPT = .TRUE.
+         CALL MCHPAR()
+         NOUT = WMACH(11)
+      END IF
+
+      CALL OPFILE( IOPTNS, NOUT, INFORM, NPKEY )
+
+      RETURN
+
+*     End of  NPFILE.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/npiqp.f
@@ -0,0 +1,579 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPIQP ( FEASQP, UNITQ, NQPERR, MINITS,
+     $                   N, NCLIN, NCNLN, NROWA, NROWJ, NROWQP, NROWR,
+     $                   LINACT, NLNACT, NACTIV, NFREE, NZ, NUMINF,
+     $                   ISTATE, KACTIV, KX,
+     $                   DXNORM, GDX, QPCURV,
+     $                   AQP, ADX, ANORM, AX, BL, BU,
+     $                   C, CJAC, CLAMDA, CMUL, CS,
+     $                   DLAM, DSLK, DX, QPBL, QPBU, QPTOL,
+     $                   R, RHO, SLK, VIOLN, X,
+     $                   WTINF, IW, W )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      LOGICAL            FEASQP, UNITQ
+      INTEGER            ISTATE(*), KACTIV(N), KX(N)
+      INTEGER            IW(*)
+      DOUBLE PRECISION   AQP(NROWQP,*), ADX(*), ANORM(*), AX(*),
+     $                   BL(*), BU(*),
+     $                   C(*), CJAC(NROWJ,*), CLAMDA(*), CMUL(*), CS(*)
+      DOUBLE PRECISION   DLAM(*), DSLK(*), DX(N)
+      DOUBLE PRECISION   QPBL(*), QPBU(*),
+     $                   QPTOL(*), R(NROWR,*), RHO(*), SLK(*),
+     $                   VIOLN(*), X(N), WTINF(*)
+      DOUBLE PRECISION   W(*)
+
+************************************************************************
+*     NPIQP   does the following:
+*
+*     (1)  Generate the upper and lower bounds for the QP  subproblem.
+*
+*     (2)  Compute the  TQ  factors of the rows of  AQP  specified by
+*          the array  ISTATE.  The part of the factorization defined by
+*          the first contiguous group of linear constraints does not
+*          need to be recomputed.  The remaining rows (which could be
+*          comprised of both linear and nonlinear constraints) are
+*          included as new rows of the  TQ  factorization stored in
+*          T and ZY.  Note that if there are no nonlinear constraints,
+*          no factorization is required.
+*
+*     (3)  Solve the  QP  subproblem.
+*                 minimize     1/2 (W p - d)'(Wp - d) + g'p
+*
+*                 subject to   qpbl .le. (  p ) .le. qpbu,
+*                                        ( Ap )
+*
+*          where  W  is a matrix (not stored) such that  W'W = H  and
+*          WQ = R,  d  is the zero vector,  and  g  is the gradient.
+*          If the subproblem is infeasible, compute the point which
+*          minimizes the sum of infeasibilities.
+*
+*    (4)   Find the value of each slack variable for which the merit
+*          function is minimized.
+*
+*    (5)   Compute  DSLK,  DLAM  and  DX,  the search directions for
+*          the slack variables, the multipliers and the variables.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Fortran 66 version written 10-January-1983.
+*  This version of NPIQP dated 31-July-1986.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL3CM/ LENNAM, NROWT , NCOLT , NQ
+      COMMON    /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9
+      COMMON    /SOL5CM/ ASIZE , DTMAX , DTMIN
+      COMMON    /SOL6CM/ RCNDBD, RFROBN, DRMAX , DRMIN
+
+      INTEGER            LOCLS
+      PARAMETER         (LENLS = 20)
+      COMMON    /SOL1LS/ LOCLS(LENLS)
+
+      LOGICAL            INCRUN
+      COMMON    /SOL6NP/ RHOMAX, RHONRM, RHODMP, SCALE, INCRUN
+
+      LOGICAL            CMDBG, LSDBG, NPDBG
+      PARAMETER        ( LDBG = 5 )
+      COMMON    /NPDEBG/ INPDBG(LDBG), NPDBG
+      COMMON    /LSDEBG/ ILSDBG(LDBG), LSDBG
+      COMMON    /CMDEBG/ ICMDBG(LDBG), CMDBG
+
+*-----------------------------------------------------------------------
+      PARAMETER         (MXPARM = 30)
+      INTEGER            IPRMLS(MXPARM), IPSVLS
+      DOUBLE PRECISION   RPRMLS(MXPARM), RPSVLS
+
+      COMMON    /LSPAR1/ IPSVLS(MXPARM),
+     $                   IDBGLS, ITMAX1, ITMAX2, LCRASH, LDBGLS, LPROB ,
+     $                   MSGLS , NN    , NNCLIN, NPROB , IPADLS(20)
+
+      COMMON    /LSPAR2/ RPSVLS(MXPARM),
+     $                   BIGBND, BIGDX , BNDLOW, BNDUPP, TOLACT, TOLFEA,
+     $                   TOLRNK, RPADLS(23)
+
+      EQUIVALENCE       (IPRMLS(1), IDBGLS), (RPRMLS(1), BIGBND)
+
+      SAVE      /LSPAR1/, /LSPAR2/
+*-----------------------------------------------------------------------
+*-----------------------------------------------------------------------
+      INTEGER            IPRMNP(MXPARM), IPSVNP
+      DOUBLE PRECISION   RPRMNP(MXPARM), RPSVNP
+
+      COMMON    /NPPAR1/ IPSVNP(MXPARM),
+     $                   IDBGNP, ITMXNP, JVRFY1, JVRFY2, JVRFY3, JVRFY4,
+     $                   LDBGNP, LFORMH, LVLDER, LVERFY, MSGNP , NLNF  ,
+     $                   NLNJ  , NLNX  , NNCNLN, IPADNP(15)
+
+      COMMON    /NPPAR2/ RPSVNP(MXPARM),
+     $                   CDINT , CTOL  , EPSRF , ETA   , FDINT , FTOL  ,
+     $                   RPADNP(24)
+
+      EQUIVALENCE       (IPRMNP(1), IDBGNP), (RPRMNP(1), CDINT)
+
+      SAVE      /NPPAR1/, /NPPAR2/
+*-----------------------------------------------------------------------
+      EQUIVALENCE  (IDBGNP, IDBG  ), (ITMXNP, NMAJOR), (ITMAX2, NMINOR)
+      EQUIVALENCE  (LDBGLS, MNRDBG), (LDBGNP, MJRDBG), (MSGLS , MSGQP )
+
+      CHARACTER*8        NAMES(1)
+      LOGICAL            LINOBJ, OVERFL, QPNAMD, VERTEX
+      INTRINSIC          ABS   , MIN   , MAX
+      EXTERNAL           DDIV  , DDOT  , DNRM2
+      PARAMETER        ( QPNAMD =.FALSE.,VERTEX =.FALSE. )
+      PARAMETER        ( ZERO   =0.0D+0, ONE    =1.0D+0, TWO   =2.0D+0 )
+      PARAMETER        ( HUNDRD =1.0D+2                                )
+
+      IDBGSV = IDBG
+      IF (NPDBG) THEN
+         IDBG   = 0
+      ELSE
+         IDBG = NMINOR + 1
+      END IF
+      LSDBG  = NPDBG
+      CMDBG  = NPDBG
+      CALL ICOPY ( LDBG, ILSDBG, 1, ICMDBG, 1 )
+
+      LRPQ   = LOCLS( 5)
+      LRPQ0  = LOCLS( 6)
+      LHPQ   = LOCLS( 8)
+      LGQ    = LOCLS( 9)
+      LT     = LOCLS(11)
+      LZY    = LOCLS(12)
+      LWRK1  = LOCLS(14)
+
+      NRPQ   = 0
+      NGQ    = 1
+
+      FEASQP =  .TRUE.
+      LINOBJ =  .TRUE.
+
+      BIGLOW = - BIGBND
+      BIGUPP =   BIGBND
+      SSQ1   =   ZERO
+
+      NPLIN  = N     + NCLIN
+      NCTOTL = NPLIN + NCNLN
+      NCQP   = NCLIN + NCNLN
+      NRANK  = N
+      NREJTD = 0
+
+*     ==================================================================
+*     Generate the upper and lower bounds upon the search direction, the
+*     weights on the sum of infeasibilities and the nonlinear constraint
+*     violations.
+*     ==================================================================
+      WSCALE = - ONE
+      DO 170 J = 1, NCTOTL
+
+         IF (J .LE. N) THEN
+            CON = X(J)
+         ELSE IF (J .LE. NPLIN) THEN
+            CON = AX(J-N)
+         ELSE
+            CON = C(J-NPLIN)
+         END IF
+
+         BLJ = BL(J)
+         BUJ = BU(J)
+         IF (BLJ .GT. BIGLOW) BLJ = BLJ - CON
+         IF (BUJ .LT. BIGUPP) BUJ = BUJ - CON
+
+         WEIGHT = ONE
+         IF (J .LE. NPLIN) THEN
+            IF (ABS(BLJ) .LE. QPTOL(J)) BLJ = ZERO
+            IF (ABS(BUJ) .LE. QPTOL(J)) BUJ = ZERO
+         ELSE
+            I    = J - NPLIN
+            VIOL = ZERO
+            IF (BL(J) .GT. BIGLOW) THEN
+               IF (BLJ .GT. ZERO) THEN
+                  VIOL   = BLJ
+                  WEIGHT = BLJ
+                  IF (RHO(I) .GT. ZERO) WEIGHT = VIOL*RHO(I)
+                  WSCALE = MAX( WSCALE,   WEIGHT )
+                  GO TO 160
+               END IF
+            END IF
+
+            IF (BU(J) .LT. BIGUPP) THEN
+               IF (BUJ .LT. ZERO) THEN
+                  VIOL   =   BUJ
+                  WEIGHT = - BUJ
+                  IF (RHO(I) .GT. ZERO) WEIGHT = - VIOL*RHO(I)
+                  WSCALE = MAX( WSCALE, - WEIGHT )
+               END IF
+            END IF
+
+*           Set the vector of nonlinear constraint violations.
+
+  160       VIOLN(I) = VIOL
+         END IF
+
+         WTINF(J) = WEIGHT
+         QPBL(J)  = BLJ
+         QPBU(J)  = BUJ
+
+  170 CONTINUE
+
+      IF (WSCALE .GT. ZERO) THEN
+         WSCALE = ONE/WSCALE
+         CALL DSCAL ( NCTOTL, (WSCALE), WTINF, 1 )
+      END IF
+
+*     Set the maximum allowable condition estimator of the constraints
+*     in the working set.  Note that a relatively well-conditioned
+*     working set is used to start the QP iterations.
+
+      CONDMX = MAX( ONE/EPSPT3, HUNDRD )
+
+      IF (NCNLN .GT. 0) THEN
+*        ===============================================================
+*        Refactorize part of the  QP  constraint matrix.
+*        ===============================================================
+*        Load the new Jacobian into the  QP  matrix  A.  Compute the
+*        2-norms of the rows of the Jacobian.
+
+         DO 180 J = 1, N
+            CALL DCOPY ( NCNLN, CJAC(1,J), 1, AQP(NCLIN+1,J), 1 )
+  180    CONTINUE
+
+         DO 190 J = NCLIN+1, NCQP
+            ANORM(J) = DNRM2 ( N, AQP(J,1), NROWQP )
+  190    CONTINUE
+
+*        Count the number of linear constraints in the working set and
+*        move them to the front of KACTIV.  Compute the norm of the
+*        matrix of constraints in the working set.
+*        Let K1  point to the first nonlinear constraint.  Constraints
+*        with indices KACTIV(K1),..., KACTIV(NACTIV)  must be
+*        refactorized.
+
+         ASIZE  = ZERO
+         LINACT = 0
+         K1     = NACTIV + 1
+         DO 200 K = 1, NACTIV
+            I     = KACTIV(K)
+            ASIZE = MAX( ASIZE, ANORM(I) )
+
+            IF (I .LE. NCLIN) THEN
+               LINACT = LINACT + 1
+               IF (LINACT .NE. K) THEN
+                  ISWAP  = KACTIV(LINACT)
+                  KACTIV(LINACT) = I
+                  KACTIV(K)      = ISWAP
+               END IF
+            ELSE
+
+*              Record the old position of the 1st. nonlinear constraint.
+
+               IF (K1 .GT. NACTIV) K1 = K
+            END IF
+  200    CONTINUE
+
+         IF (NACTIV .LE. 1 )
+     $      CALL DCOND ( NCQP, ANORM, 1, ASIZE, AMIN )
+
+*        Compute the absolute values of the nonlinear constraints in
+*        the working set.  Use DX as workspace.
+
+         DO 210 K = LINACT+1, NACTIV
+            J = N + KACTIV(K)
+            IF (ISTATE(J) .EQ. 1) DX(K) = ABS( QPBL(J) )
+            IF (ISTATE(J) .GE. 2) DX(K) = ABS( QPBU(J) )
+  210    CONTINUE
+
+*        Sort the elements of KACTIV corresponding to nonlinear
+*        constraints in descending order of violation (i.e.,
+*        the first element of KACTIV for a nonlinear constraint
+*        is associated with the most violated constraint.)
+*        In this way, the rows of the Jacobian corresponding
+*        to the more violated constraints tend to be included
+*        in the  TQ  factorization.
+
+*        The sorting procedure is taken from the simple insertion
+*        sort in D. Knuth, ACP Volume 3, Sorting and Searching,
+*        Page 81.  It should be replaced by a faster sort if the
+*        number of active nonlinear constraints becomes large.
+
+         DO 230 K = LINACT+2, NACTIV
+            L     = K
+            VIOL  = DX(L)
+            KVIOL = KACTIV(L)
+*           WHILE (L .GT. LINACT+1  .AND.  DX(L-1) .LT. VIOL) DO
+  220       IF    (L .GT. LINACT+1                          ) THEN
+               IF (                        DX(L-1) .LT. VIOL) THEN
+                  DX(L)     = DX(L-1)
+                  KACTIV(L) = KACTIV(L-1)
+                  L         = L - 1
+                  GO TO 220
+               END IF
+*           END WHILE
+            END IF
+            DX(L)     = VIOL
+            KACTIV(L) = KVIOL
+  230    CONTINUE
+
+         K2     = NACTIV
+         NACTIV = K1     - 1
+         NZ     = NFREE  - NACTIV
+
+*        Update the factors  R,  T  and  Q  to include constraints
+*        K1  through  K2.
+
+         IF (K1 .LE. K2)
+     $      CALL LSADDS( UNITQ, VERTEX,
+     $                   INFORM, K1, K2, NACTIV, NARTIF, NZ, NFREE,
+     $                   NRANK, NREJTD, NRPQ, NGQ,
+     $                   N, NQ, NROWQP, NROWR, NROWT,
+     $                   ISTATE, KACTIV, KX,
+     $                   CONDMX,
+     $                   AQP, R, W(LT), W(LRPQ), W(LGQ),
+     $                   W(LZY), W(LWRK1), DX )
+      END IF
+
+*     ==================================================================
+*     Solve for DX, the vector of minimum two-norm that satisfies the
+*     constraints in the working set.
+*     ==================================================================
+      CALL NPSETX( UNITQ,
+     $             NCQP, NACTIV, NFREE, NZ,
+     $             N, NLNX, NCTOTL, NQ, NROWQP, NROWR, NROWT,
+     $             ISTATE, KACTIV, KX,
+     $             DXNORM, GDX,
+     $             AQP, ADX, QPBL, QPBU, W(LRPQ), W(LRPQ0), DX, W(LGQ),
+     $             R, W(LT), W(LZY), W(LWRK1) )
+
+*     ==================================================================
+*     Solve a quadratic program for the search direction  DX  and
+*     multiplier estimates  CLAMDA.
+*     ==================================================================
+*     If there is no feasible point for the subproblem,  the sum of
+*     infeasibilities is minimized subject to the linear constraints
+*     (1  thru  JINF)  being satisfied.
+
+      JINF  = N + NCLIN
+
+      NTRY  = 1
+*+    REPEAT
+  450    CALL LSCORE( 'QP subproblem', QPNAMD, NAMES, LINOBJ, UNITQ,
+     $                NQPERR, MINITS, JINF, NCQP, NCTOTL,
+     $                NACTIV, NFREE, NRANK, NZ, NZ1,
+     $                N, NROWQP, NROWR,
+     $                ISTATE, KACTIV, KX,
+     $                GDX, SSQ, SSQ1, SUMINF, NUMINF, DXNORM,
+     $                QPBL, QPBU, AQP, CLAMDA, ADX,
+     $                QPTOL, R, DX, IW, W )
+
+         IF (NPDBG  .AND.  INPDBG(1) .GT. 0)
+     $      WRITE (NOUT, 8000) NQPERR
+
+         NVIOL = 0
+         IF (NUMINF .GT. 0) THEN
+
+*           Count the violated linear constraints.
+
+            DO 460 J = 1, NPLIN
+               IF (ISTATE(J) .LT. 0) NVIOL = NVIOL + 1
+  460       CONTINUE
+
+            IF (NVIOL .GT. 0) THEN
+               NTRY   = NTRY + 1
+               UNITQ  = .TRUE.
+               NACTIV = 0
+               NFREE  = N
+               NZ     = N
+               CALL ILOAD ( NCTOTL, (0), ISTATE, 1 )
+
+               CALL NPSETX( UNITQ,
+     $                      NCQP, NACTIV, NFREE, NZ,
+     $                      N, NLNX, NCTOTL, NQ, NROWQP, NROWR, NROWT,
+     $                      ISTATE, KACTIV, KX,
+     $                      DXNORM, GDX,
+     $                      AQP, ADX, QPBL, QPBU, W(LRPQ), W(LRPQ0),
+     $                      DX, W(LGQ), R, W(LT), W(LZY), W(LWRK1) )
+            END IF
+         END IF
+      IF (.NOT. (NVIOL .EQ. 0  .OR.  NTRY .GT. 2)) GO TO 450
+*+    UNTIL (    NVIOL .EQ. 0  .OR.  NTRY .GT. 2)
+
+*     ==================================================================
+*     Count the number of nonlinear constraint gradients in the  QP
+*     working set.  Make sure that all small  QP  multipliers associated
+*     with nonlinear inequality constraints have the correct sign.
+*     ==================================================================
+      NLNACT  = 0
+      IF (NACTIV .GT. 0  .AND.  NCNLN .GT. 0) THEN
+         DO 500 K = 1, NACTIV
+            L     = KACTIV(K)
+            IF (L .GT. NCLIN) THEN
+               NLNACT = NLNACT + 1
+               J      = N      + L
+               IF (ISTATE(J) .EQ. 1) CLAMDA(J) = MAX( ZERO, CLAMDA(J) )
+               IF (ISTATE(J) .EQ. 2) CLAMDA(J) = MIN( ZERO, CLAMDA(J) )
+            END IF
+  500    CONTINUE
+      END IF
+
+      LINACT = NACTIV - NLNACT
+
+*     ------------------------------------------------------------------
+*     Extract various useful quantities from the QP solution.
+*     ------------------------------------------------------------------
+*     Compute  HPQ = R'R(pq)  from the transformed gradient of the QP
+*     objective function and  R(pq)  from the transformed residual.
+
+      CALL DSCAL ( N, (-ONE), W(LRPQ), 1 )
+      CALL DAXPY ( N, (-ONE), W(LGQ) , 1, W(LHPQ), 1 )
+      QPCURV = TWO*SSQ
+
+      IF (NCNLN .GT. 0) THEN
+         IF (NUMINF .GT. 0) THEN
+            FEASQP = .FALSE.
+            CALL DLOAD ( NCTOTL, (ZERO), CLAMDA, 1 )
+
+            IF (NZ .GT. 0) THEN
+*              ---------------------------------------------------------
+*              Compute a null space component for the search direction
+*              as the solution of  Z'HZ(pz) = -Z'g - Z'HY(py).
+*              ---------------------------------------------------------
+*              Overwrite DX with the transformed search direction
+*              Q'(dx).  The first NZ components of DX are zero.
+
+               CALL CMQMUL( 6, N, NZ, NFREE, NQ, UNITQ,
+     $                      KX, DX, W(LZY), W(LWRK1) )
+
+*              Overwrite the first NZ components of DX with the solution
+*              of  (Rz)u = -(v + w),  where  (Rz)'w = Z'g  and  v  is
+*              vector of first NZ components of  R(pq).
+
+               CALL DCOPY ( NZ, W(LGQ), 1, DX, 1 )
+               CALL DTRSV ( 'U', 'T', 'N', NZ, R, NROWR, DX, 1 )
+
+               CALL DAXPY ( NZ, (ONE), W(LRPQ), 1, DX, 1 )
+
+               CALL DTRSV ( 'U', 'N', 'N', NZ, R, NROWR, DX, 1 )
+               CALL DSCAL ( NZ, (-ONE), DX, 1 )
+
+*              Recompute RPQ, HPQ, GDX and QPCURV.
+
+               CALL DCOPY ( NLNX, DX, 1, W(LRPQ), 1 )
+               CALL DTRMV ( 'U', 'N', 'N', NLNX, R, NROWR, W(LRPQ), 1 )
+               IF (NLNX .LT. N)
+     $            CALL DGEMV( 'N', NLNX, N-NLNX, ONE, R(1,NLNX+1),NROWR,
+     $                        DX(NLNX+1), 1, ONE, W(LRPQ), 1 )
+
+               GDX    = DDOT  ( N, W(LGQ) , 1, DX     , 1 )
+               QPCURV = DDOT  ( N, W(LRPQ), 1, W(LRPQ), 1 )
+
+               CALL CMQMUL( 3, N, NZ, NFREE, NQ, UNITQ,
+     $                      KX, DX, W(LZY), W(LWRK1) )
+
+*              ---------------------------------------------------------
+*              Recompute ADX and the 2-norm of DX.
+*              ---------------------------------------------------------
+               DXNORM  = DNRM2 ( N, DX, 1 )
+               IF (NCQP .GT. 0)
+     $            CALL DGEMV ( 'N', NCQP, N, ONE, AQP, NROWQP,
+     $                         DX, 1, ZERO, ADX, 1 )
+
+               IF (NPDBG  .AND.  INPDBG(2) .GT. 0)
+     $            WRITE (NOUT, 8100) (DX(J), J = 1, N)
+            END IF
+
+            CALL DCOPY ( NLNX, W(LRPQ), 1, W(LHPQ), 1 )
+            CALL DTRMV ( 'U', 'T', 'N', NLNX, R, NROWR, W(LHPQ), 1 )
+            IF (NLNX .LT. N)
+     $         CALL DGEMV ( 'T', NLNX, N-NLNX, ONE, R(1,NLNX+1), NROWR,
+     $                      W(LRPQ), 1, ZERO, W(LHPQ+NLNX), 1 )
+         END IF
+
+*        ===============================================================
+*        For given values of the objective function and constraints,
+*        attempt to minimize the merit function with respect to each
+*        slack variable.
+*        ===============================================================
+         DO 600 I = 1, NCNLN
+            J      = NPLIN + I
+            CON    = C(I)
+
+            IF (      .NOT. FEASQP  .AND.
+     $          VIOLN(I) .NE. ZERO  .AND.  RHO(I) .LE. ZERO )
+     $         RHO(I) = ONE
+
+            QUOTNT = DDIV  ( CMUL(I), SCALE*RHO(I), OVERFL )
+
+*           Define the slack variable to be  CON - MULT / RHO.
+*           Force each slack to lie within its upper and lower bounds.
+
+            IF (BL(J) .GT. BIGLOW) THEN
+               IF (QPBL(J) .GE. - QUOTNT) THEN
+                  SLK(I) = BL(J)
+                  GO TO 550
+               END IF
+            END IF
+
+            IF (BU(J) .LT. BIGUPP) THEN
+               IF (QPBU(J) .LE. - QUOTNT) THEN
+                  SLK(I) = BU(J)
+                  GO TO 550
+               END IF
+            END IF
+
+            SLK(I) = CON - QUOTNT
+
+*           The slack has been set within its bounds.
+
+  550       CS(I)  = CON - SLK(I)
+
+*           ------------------------------------------------------------
+*           Compute the search direction for the slacks and multipliers.
+*           ------------------------------------------------------------
+            DSLK(I) = ADX(NCLIN+I) + CS(I)
+
+            IF (FEASQP) THEN
+*
+*              If any constraint is such that  (DLAM)*(C - S)  is
+*              positive,  the merit function may be reduced immediately
+*              by substituting the QP multiplier.
+*
+               DLAM(I)  = CLAMDA(J) - CMUL(I)
+               IF (DLAM(I) * CS(I) .GE. ZERO) THEN
+                  CMUL(I) = CLAMDA(J)
+                  DLAM(I) = ZERO
+               END IF
+            ELSE
+
+*              The  QP  subproblem was infeasible.
+
+               DLAM(I) = ZERO
+
+               IF (ISTATE(J) .LT. 0  .OR.  VIOLN(I) .NE. ZERO)
+     $            DSLK(I)  = ZERO
+
+            END IF
+  600    CONTINUE
+
+         IF (.NOT. FEASQP)
+     $      RHONRM = DNRM2 ( NCNLN, RHO, 1 )
+
+         IF (NPDBG  .AND.  INPDBG(2) .GT. 0) THEN
+            WRITE (NOUT, 8200) (VIOLN(I), I=1,NCNLN)
+            WRITE (NOUT, 8300) (SLK(I)  , I=1,NCNLN)
+         END IF
+      END IF
+
+      CALL ICOPY ( LDBG, INPDBG, 1, ICMDBG, 1 )
+      IDBG   = IDBGSV
+
+      RETURN
+
+ 8000 FORMAT(/ ' //NPIQP // NQPERR'
+     $       / ' //NPIQP // ',  I6 )
+ 8100 FORMAT(/ ' //NPIQP // DX recomputed with null space portion...'
+     $       / (5G12.3))
+ 8200 FORMAT(/ ' //NPIQP // Violations = '/ (1P5E15.6))
+ 8300 FORMAT(/ ' //NPIQP // Slacks     = '/ (1P5E15.6))
+
+*     End of  NPIQP .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/npkey.f
@@ -0,0 +1,332 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPKEY ( NOUT, BUFFER, KEY )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      CHARACTER*(*)      BUFFER
+
+************************************************************************
+*     NPKEY   decodes the option contained in  BUFFER  in order to set
+*     a parameter value in the relevant element of the parameter arrays.
+*
+*
+*     Input:
+*
+*     NOUT   A unit number for printing error messages.
+*            NOUT  must be a valid unit.
+*
+*     Output:
+*
+*     KEY    The first keyword contained in BUFFER.
+*
+*
+*     NPKEY  calls OPNUMB and the subprograms
+*                 LOOKUP, SCANNR, TOKENS, UPCASE
+*     (now called OPLOOK, OPSCAN, OPTOKN, OPUPPR)
+*     supplied by Informatics General, Inc., Palo Alto, California.
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     This version of NPKEY  dated 12-July-1986.
+************************************************************************
+*-----------------------------------------------------------------------
+      PARAMETER         (MXPARM = 30)
+      INTEGER            IPRMLS(MXPARM), IPSVLS
+      DOUBLE PRECISION   RPRMLS(MXPARM), RPSVLS
+
+      COMMON    /LSPAR1/ IPSVLS(MXPARM),
+     $                   IDBGLS, ITMAX1, ITMAX2, LCRASH, LDBGLS, LPROB ,
+     $                   MSGLS , NN    , NNCLIN, NPROB , IPADLS(20)
+
+      COMMON    /LSPAR2/ RPSVLS(MXPARM),
+     $                   BIGBND, BIGDX , BNDLOW, BNDUPP, TOLACT, TOLFEA,
+     $                   TOLRNK, RPADLS(23)
+
+      EQUIVALENCE       (IPRMLS(1), IDBGLS), (RPRMLS(1), BIGBND)
+
+      SAVE      /LSPAR1/, /LSPAR2/
+*-----------------------------------------------------------------------
+*-----------------------------------------------------------------------
+      INTEGER            IPRMNP(MXPARM), IPSVNP
+      DOUBLE PRECISION   RPRMNP(MXPARM), RPSVNP
+
+      COMMON    /NPPAR1/ IPSVNP(MXPARM),
+     $                   IDBGNP, ITMXNP, JVRFY1, JVRFY2, JVRFY3, JVRFY4,
+     $                   LDBGNP, LFORMH, LVLDER, LVERFY, MSGNP , NLNF  ,
+     $                   NLNJ  , NLNX  , NNCNLN, IPADNP(15)
+
+      COMMON    /NPPAR2/ RPSVNP(MXPARM),
+     $                   CDINT , CTOL  , EPSRF , ETA   , FDINT , FTOL  ,
+     $                   RPADNP(24)
+
+      EQUIVALENCE       (IPRMNP(1), IDBGNP), (RPRMNP(1), CDINT)
+
+      SAVE      /NPPAR1/, /NPPAR2/
+*-----------------------------------------------------------------------
+      EQUIVALENCE  (IDBGNP, IDBG  ), (ITMXNP, NMAJOR), (ITMAX2, NMINOR)
+      EQUIVALENCE  (LDBGLS, MNRDBG), (LDBGNP, MJRDBG), (MSGLS , MSGQP )
+
+      EXTERNAL           OPNUMB
+      LOGICAL            FIRST , MORE  , NUMBER, OPNUMB, SORTED
+      SAVE               FIRST
+
+      PARAMETER         (     MAXKEY = 38,  MAXTIE = 19,   MAXTOK = 10)
+      CHARACTER*16       KEYS(MAXKEY), TIES(MAXTIE), TOKEN(MAXTOK)
+      CHARACTER*16       KEY, KEY2, KEY3, VALUE
+
+      PARAMETER         (IDUMMY = -11111,  RDUMMY = -11111.0,
+     $                   SORTED = .TRUE.,  ZERO   =  0.0     )
+
+      DATA                FIRST
+     $                  /.TRUE./
+      DATA   KEYS
+     $ / 'BEGIN           ',
+     $   'CENTRAL         ', 'COLD            ', 'CONSTRAINTS     ',
+     $   'CRASH           ', 'DEBUG           ', 'DEFAULTS        ',
+     $   'DERIVATIVE      ', 'DIFFERENCE      ',
+     $   'END             ', 'FEASIBILITY     ', 'FUNCTION        ',
+     $   'HESSIAN         ', 'HOT             ', 'INFINITE        ',
+     $   'IPRMLS          ', 'ITERATIONS      ', 'ITERS:ITERATIONS',
+     $   'ITNS :ITERATIONS', 'LINEAR          ', 'LINESEARCH      ',
+     $   'LIST            ', 'LOWER           ',
+     $   'MAJOR           ', 'MINOR           ',
+     $   'NOLIST          ',
+     $   'NONLINEAR       ', 'OPTIMALITY      ', 'PRINT           ',
+     $   'PROBLEM         ', 'ROW             ', 'RPRMLS          ',
+     $   'START           ', 'STOP            ', 'UPPER           ',
+     $   'VARIABLES       ', 'VERIFY          ', 'WARM            '/
+
+      DATA   TIES
+     $ / 'BOUND           ', 'CONSTRAINTS     ', 'DEBUG           ',
+     $   'FEASIBILITY     ', 'GRADIENTS       ',
+     $   'ITERATIONS      ', 'ITERS:ITERATIONS',
+     $   'ITNS :ITERATIONS', 'JACOBIAN        ', 'LEVEL           ',
+     $   'NO              ',
+     $   'NO.      :NUMBER',
+     $   'NUMBER          ', 'OBJECTIVE       ', 'PRINT           ',
+     $   'STEP            ', 'TOLERANCE       ',
+     $   'VARIABLES       ', 'YES             '/
+*-----------------------------------------------------------------------
+
+      IF (FIRST) THEN
+         FIRST  = .FALSE.
+         DO 10 I = 1, MXPARM
+            RPRMLS(I) = RDUMMY
+            IPRMLS(I) = IDUMMY
+            RPRMNP(I) = RDUMMY
+            IPRMNP(I) = IDUMMY
+   10    CONTINUE
+      END IF
+
+*     Eliminate comments and empty lines.
+*     A '*' appearing anywhere in BUFFER terminates the string.
+
+      I      = INDEX( BUFFER, '*' )
+      IF (I .EQ. 0) THEN
+         LENBUF = LEN( BUFFER )
+      ELSE
+         LENBUF = I - 1
+      END IF
+      IF (LENBUF .LE. 0) THEN
+         KEY = '*'
+         GO TO 900
+      END IF
+
+*     ------------------------------------------------------------------
+*     Extract up to MAXTOK tokens from the record.
+*     NTOKEN returns how many were actually found.
+*     KEY, KEY2, KEY3 are the first tokens if any, otherwise blank.
+*     ------------------------------------------------------------------
+      NTOKEN = MAXTOK
+      CALL OPTOKN( BUFFER(1:LENBUF), NTOKEN, TOKEN )
+      KEY    = TOKEN(1)
+      KEY2   = TOKEN(2)
+      KEY3   = TOKEN(3)
+
+*     Certain keywords require no action.
+
+      IF (KEY .EQ. ' '     .OR.  KEY .EQ. 'BEGIN' ) GO TO 900
+      IF (KEY .EQ. 'LIST'  .OR.  KEY .EQ. 'NOLIST') GO TO 900
+      IF (KEY .EQ. 'END'                          ) GO TO 900
+
+*     Most keywords will have an associated integer or real value,
+*     so look for it no matter what the keyword.
+
+      I      = 1
+      NUMBER = .FALSE.
+
+   50 IF (I .LT. NTOKEN  .AND.  .NOT. NUMBER) THEN
+         I      = I + 1
+         VALUE  = TOKEN(I)
+         NUMBER = OPNUMB( VALUE )
+         GO TO 50
+      END IF
+
+      IF (NUMBER) THEN
+         READ (VALUE, '(BN, E16.0)') RVALUE
+      ELSE
+         RVALUE = ZERO
+      END IF
+
+*     Convert the keywords to their most fundamental form
+*     (upper case, no abbreviations).
+*     SORTED says whether the dictionaries are in alphabetic order.
+*     LOCi   says where the keywords are in the dictionaries.
+*     LOCi = 0 signals that the keyword wasn't there.
+
+      CALL OPLOOK( MAXKEY, KEYS, SORTED, KEY , LOC1 )
+      CALL OPLOOK( MAXTIE, TIES, SORTED, KEY2, LOC2 )
+
+*     ------------------------------------------------------------------
+*     Decide what to do about each keyword.
+*     The second keyword (if any) might be needed to break ties.
+*     Some seemingly redundant testing of MORE is used
+*     to avoid compiler limits on the number of consecutive ELSE IFs.
+*     ------------------------------------------------------------------
+      MORE   = .TRUE.
+      IF (MORE) THEN
+         MORE   = .FALSE.
+         IF      (KEY .EQ. 'CENTRAL     ') THEN
+            CDINT  = RVALUE
+         ELSE IF (KEY .EQ. 'COLD        ') THEN
+            LCRASH = 0
+         ELSE IF (KEY .EQ. 'CONSTRAINTS ') THEN
+            NNCLIN = RVALUE
+         ELSE IF (KEY .EQ. 'CRASH       ') THEN
+            TOLACT = RVALUE
+         ELSE IF (KEY .EQ. 'DEBUG       ') THEN
+            IDBG   = RVALUE
+         ELSE IF (KEY .EQ. 'DEFAULTS    ') THEN
+            DO 20 I = 1, MXPARM
+               IPRMLS(I) = IDUMMY
+               RPRMLS(I) = RDUMMY
+               IPRMNP(I) = IDUMMY
+               RPRMNP(I) = RDUMMY
+   20       CONTINUE
+         ELSE IF (KEY .EQ. 'DERIVATIVE  ') THEN
+            LVLDER = RVALUE
+         ELSE IF (KEY .EQ. 'DIFFERENCE  ') THEN
+            FDINT  = RVALUE
+         ELSE IF (KEY .EQ. 'FEASIBILITY ') THEN
+            TOLFEA = RVALUE
+            CTOL   = RVALUE
+         ELSE IF (KEY .EQ. 'FUNCTION    ') THEN
+            EPSRF  = RVALUE
+         ELSE
+            MORE   = .TRUE.
+         END IF
+      END IF
+
+      IF (MORE) THEN
+         MORE   = .FALSE.
+         IF      (KEY .EQ. 'HESSIAN     ') THEN
+            LFORMH = 1
+            IF   (KEY2.EQ. 'NO          ') LFORMH = 0
+         ELSE IF (KEY .EQ. 'HOT         ') THEN
+            LCRASH = 2
+         ELSE IF (KEY .EQ. 'INFINITE    ') THEN
+              IF (KEY2.EQ. 'BOUND       ') BIGBND = RVALUE * 0.99999
+              IF (KEY2.EQ. 'STEP        ') BIGDX  = RVALUE
+              IF (LOC2.EQ.  0            ) WRITE(NOUT, 2320) KEY2
+         ELSE IF (KEY .EQ. 'IPRMLS      ') THEN
+*           Allow things like  IPRMLS 21 = 100  to set IPRMLS(21) = 100
+            IVALUE = RVALUE
+            IF (IVALUE .GE. 1  .AND. IVALUE .LE. MXPARM) THEN
+               READ (KEY3, '(BN, I16)') IPRMLS(IVALUE)
+            ELSE
+               WRITE(NOUT, 2400) IVALUE
+            END IF
+         ELSE IF (KEY .EQ. 'ITERATIONS  ') THEN
+            NMAJOR = RVALUE
+         ELSE IF (KEY .EQ. 'LINEAR      ') THEN
+            IF (KEY2  .EQ. 'CONSTRAINTS ') NNCLIN = RVALUE
+            IF (KEY2  .EQ. 'FEASIBILITY ') TOLFEA = RVALUE
+            IF (LOC2 .EQ.  0             ) WRITE(NOUT, 2320) KEY2
+         ELSE IF (KEY .EQ. 'LINESEARCH  ') THEN
+            ETA    = RVALUE
+         ELSE IF (KEY .EQ. 'LOWER       ') THEN
+            BNDLOW = RVALUE
+         ELSE
+            MORE   = .TRUE.
+         END IF
+      END IF
+
+      IF (MORE) THEN
+         MORE   = .FALSE.
+         IF      (KEY .EQ. 'MAJOR       ') THEN
+              IF (KEY2.EQ. 'DEBUG       ') MJRDBG = RVALUE
+              IF (KEY2.EQ. 'ITERATIONS  ') NMAJOR = RVALUE
+              IF (KEY2.EQ. 'PRINT       ') MSGNP  = RVALUE
+              IF (LOC2.EQ.  0            ) WRITE(NOUT, 2320) KEY2
+         ELSE IF (KEY .EQ. 'MINOR       ') THEN
+              IF (KEY2.EQ. 'DEBUG       ') MNRDBG = RVALUE
+              IF (KEY2.EQ. 'ITERATIONS  ') NMINOR = RVALUE
+              IF (KEY2.EQ. 'PRINT       ') MSGQP  = RVALUE
+              IF (LOC2.EQ.  0            ) WRITE(NOUT, 2320) KEY2
+         ELSE IF (KEY .EQ. 'NONLINEAR   ') THEN
+              IF (KEY2.EQ. 'CONSTRAINTS ') NNCNLN = RVALUE
+              IF (KEY2.EQ. 'FEASIBILITY ') CTOL   = RVALUE
+              IF (KEY2.EQ. 'JACOBIAN    ') NLNJ   = RVALUE
+              IF (KEY2.EQ. 'OBJECTIVE   ') NLNF   = RVALUE
+              IF (KEY2.EQ. 'VARIABLES   ') NLNX   = RVALUE
+              IF (LOC2.EQ.  0            ) WRITE(NOUT, 2320) KEY2
+         ELSE IF (KEY .EQ. 'OPTIMALITY  ') THEN
+            FTOL   = RVALUE
+         ELSE
+            MORE   = .TRUE.
+         END IF
+      END IF
+
+      IF (MORE) THEN
+         MORE   = .FALSE.
+         IF      (KEY .EQ. 'PRINT       ') THEN
+            MSGNP  = RVALUE
+         ELSE IF (KEY .EQ. 'PROBLEM     ') THEN
+              IF (KEY2.EQ. 'NUMBER      ') NPROB  = RVALUE
+         ELSE IF (KEY .EQ. 'ROW         ') THEN
+              IF (KEY2.EQ. 'TOLERANCE   ') CTOL   = RVALUE
+              IF (LOC2.EQ.  0            ) WRITE(NOUT, 2320) KEY2
+         ELSE IF (KEY .EQ. 'RPRMLS      ') THEN
+*           Allow things like  RPRMLS 21 = 2  to set RPRMLS(21) = 2.0
+            IVALUE = RVALUE
+            IF (IVALUE .GE. 1  .AND. IVALUE .LE. MXPARM) THEN
+               READ (KEY3, '(BN, E16.0)') RPRMLS(IVALUE)
+            ELSE
+               WRITE(NOUT, 2400) IVALUE
+            END IF
+         ELSE IF (KEY .EQ. 'START       ') THEN
+              IF (KEY2.EQ. 'CONSTRAINTS ') JVRFY3 = RVALUE
+              IF (KEY2.EQ. 'OBJECTIVE   ') JVRFY1 = RVALUE
+              IF (LOC2.EQ.  0            ) WRITE(NOUT, 2320) KEY2
+         ELSE IF (KEY .EQ. 'STOP        ') THEN
+              IF (KEY2.EQ. 'CONSTRAINTS ') JVRFY4 = RVALUE
+              IF (KEY2.EQ. 'OBJECTIVE   ') JVRFY2 = RVALUE
+              IF (LOC2.EQ.  0            ) WRITE(NOUT, 2320) KEY2
+         ELSE IF (KEY .EQ. 'UPPER       ') THEN
+            BNDUPP = RVALUE
+         ELSE IF (KEY .EQ. 'VARIABLES   ') THEN
+            NN     = RVALUE
+         ELSE IF (KEY .EQ. 'VERIFY      ') THEN
+              IF (KEY2.EQ. 'OBJECTIVE   ') LVERFY =  1
+              IF (KEY2.EQ. 'CONSTRAINTS ') LVERFY =  2
+              IF (KEY2.EQ. 'NO          ') LVERFY = -1
+              IF (KEY2.EQ. 'YES         ') LVERFY =  3
+              IF (KEY2.EQ. 'GRADIENTS   ') LVERFY =  3
+              IF (KEY2.EQ. 'LEVEL       ') LVERFY =  RVALUE
+              IF (LOC2.EQ.  0            ) LVERFY =  3
+         ELSE IF (KEY .EQ. 'WARM        ') THEN
+            LCRASH = 1
+         ELSE
+            WRITE(NOUT, 2300) KEY
+         END IF
+      END IF
+
+  900 RETURN
+
+ 2300 FORMAT(' XXX  Keyword not recognized:         ', A)
+ 2320 FORMAT(' XXX  Second keyword not recognized:  ', A)
+ 2330 FORMAT(' XXX  Third  keyword not recognized:  ', A)
+ 2400 FORMAT(' XXX  The PARM subscript is out of range:', I10)
+
+*     End of NPKEY
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/nploc.f
@@ -0,0 +1,159 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPLOC ( N, NCLIN, NCNLN, NCTOTL, LITOTL, LWTOTL)
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+
+************************************************************************
+*     NPLOC   allocates the addresses of the work arrays for NPCORE and
+*     LSCORE.
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     Original version   14-February-1985.
+*     This version of  NPLOC  dated 12-July-1986.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL3CM/ LENNAM, NROWT, NCOLT, NQ
+
+      PARAMETER         (LENLS = 20)
+      COMMON    /SOL1LS/ LOCLS(LENLS)
+
+      PARAMETER         (LENNP = 35)
+      COMMON    /SOL1NP/ LOCNP(LENNP)
+
+      LOGICAL            NPDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /NPDEBG/ INPDBG(LDBG), NPDBG
+
+      MINIW     = LITOTL + 1
+      MINW      = LWTOTL + 1
+
+*     Assign array lengths that depend upon the problem dimensions.
+
+      IF (NCLIN + NCNLN .EQ. 0) THEN
+         LENT      = 0
+         LENZY     = 0
+      ELSE
+         LENT  = NROWT*NCOLT
+         LENZY = NQ   *NQ
+      END IF
+
+      IF (NCNLN .EQ. 0) THEN
+         LENAQP = 0
+      ELSE
+         LENAQP = (NCLIN + NCNLN)*N
+      END IF
+
+      LKACTV    = MINIW
+      LKX       = LKACTV + N
+      LNEEDC    = LKX    + N
+      LIPERM    = LNEEDC + NCNLN
+      MINIW     = LIPERM + NCTOTL
+
+      LHFRWD    = MINW
+      LHCTRL    = LHFRWD + N
+      LANORM    = LHCTRL + N
+      LQPGQ     = LANORM + NCLIN + NCNLN
+      LGQ       = LQPGQ  + N
+      LRLAM     = LGQ    + N
+      LT        = LRLAM  + N
+      LZY       = LT     + LENT
+      MINW      = LZY    + LENZY
+
+      LOCLS( 1) = LKACTV
+      LOCLS( 2) = LANORM
+      LOCLS( 8) = LQPGQ
+      LOCLS( 9) = LGQ
+      LOCLS(10) = LRLAM
+      LOCLS(11) = LT
+      LOCLS(12) = LZY
+
+*     Assign the addresses for the workspace arrays used by  NPIQP.
+
+      LQPADX    = MINW
+      LQPDX     = LQPADX + NCLIN + NCNLN
+      LRPQ      = LQPDX  + N
+      LRPQ0     = LRPQ   + N
+      LQPHZ     = LRPQ0  + N
+      LWTINF    = LQPHZ  + N
+      LWRK1     = LWTINF + NCTOTL
+      LQPTOL    = LWRK1  + NCTOTL
+      MINW      = LQPTOL + NCTOTL
+
+      LOCLS( 3) = LQPADX
+      LOCLS( 4) = LQPDX
+      LOCLS( 5) = LRPQ
+      LOCLS( 6) = LRPQ0
+      LOCLS( 7) = LQPHZ
+      LOCLS(13) = LWTINF
+      LOCLS(14) = LWRK1
+      LOCLS(15) = LQPTOL
+
+*     Assign the addresses for arrays used in NPCORE.
+
+      LAQP      = MINW
+      LADX      = LAQP   + LENAQP
+      LBL       = LADX   + NCLIN  + NCNLN
+      LBU       = LBL    + NCTOTL
+      LDX       = LBU    + NCTOTL
+      LGQ1      = LDX    + N
+      LFEATL    = LGQ1   + N
+      LX1       = LFEATL + NCTOTL
+      LWRK2     = LX1    + N
+      MINW      = LWRK2  + NCTOTL
+
+      LOCNP( 1) = LKX
+      LOCNP( 2) = LIPERM
+      LOCNP( 3) = LAQP
+      LOCNP( 4) = LADX
+      LOCNP( 5) = LBL
+      LOCNP( 6) = LBU
+      LOCNP( 7) = LDX
+      LOCNP( 8) = LGQ1
+      LOCNP(10) = LFEATL
+      LOCNP(11) = LX1
+      LOCNP(12) = LWRK2
+
+      LCS1      = MINW
+      LCS2      = LCS1   + NCNLN
+      LC1MUL    = LCS2   + NCNLN
+      LCMUL     = LC1MUL + NCNLN
+      LCJDX     = LCMUL  + NCNLN
+      LDLAM     = LCJDX  + NCNLN
+      LDSLK     = LDLAM  + NCNLN
+      LRHO      = LDSLK  + NCNLN
+      LWRK3     = LRHO   + NCNLN
+      LSLK1     = LWRK3  + NCNLN
+      LSLK      = LSLK1  + NCNLN
+      MINW      = LSLK   + NCNLN
+
+      LOCNP(13) = LCS1
+      LOCNP(14) = LCS2
+      LOCNP(15) = LC1MUL
+      LOCNP(16) = LCMUL
+      LOCNP(17) = LCJDX
+      LOCNP(18) = LDLAM
+      LOCNP(19) = LDSLK
+      LOCNP(20) = LRHO
+      LOCNP(21) = LWRK3
+      LOCNP(22) = LSLK1
+      LOCNP(23) = LSLK
+      LOCNP(24) = LNEEDC
+
+      LCJAC     = MINW
+      LGRAD     = LCJAC  + NCNLN*N
+      MINW      = LGRAD  + N
+
+      LOCNP(25) = LHFRWD
+      LOCNP(26) = LHCTRL
+      LOCNP(27) = LCJAC
+      LOCNP(28) = LGRAD
+
+      LITOTL    = MINIW - 1
+      LWTOTL    = MINW  - 1
+
+      RETURN
+
+*     End of  NPLOC .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/npmrt.f
@@ -0,0 +1,179 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPMRT ( FEASQP, N, NCLIN, NCNLN,
+     $                   OBJALF, GRDALF, QPCURV,
+     $                   ISTATE,
+     $                   CJDX, CMUL, CS,
+     $                   DLAM, RHO, VIOLN,
+     $                   WORK1, WORK2 )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+
+      LOGICAL            FEASQP
+
+      INTEGER            ISTATE(*)
+
+      DOUBLE PRECISION   CJDX(*), CMUL(*), CS(*),
+     $                   DLAM(*), RHO(*), VIOLN(*)
+      DOUBLE PRECISION   WORK1(*), WORK2(*)
+
+************************************************************************
+*  NPMRT   computes the value and directional derivative of the
+*  augmented Lagrangian merit function.  The penalty parameters RHO(j)
+*  are boosted if the directional derivative of the resulting augmented
+*  Lagrangian function is not sufficiently negative.  If RHO needs to
+*  be increased,  the perturbation with minimum two-norm is found that
+*  gives a directional derivative equal to  - p'Hp.
+*
+*  Systems Optimization Laboratory, Stanford University, California.
+*  Original version written  27-May-1985.
+*  This version of  NPMRT  dated 14-November-1985.
+************************************************************************
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+
+      COMMON    /SOL1CM/ NOUT
+
+      LOGICAL            INCRUN
+      COMMON    /SOL6NP/ RHOMAX, RHONRM, RHODMP, SCALE, INCRUN
+
+      LOGICAL            NPDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /NPDEBG/ INPDBG(LDBG), NPDBG
+
+      LOGICAL            BOOST , OVERFL
+      EXTERNAL           DDIV  , DDOT  , DNRM2
+      INTRINSIC          ABS   , MAX   , MIN   , SQRT
+      PARAMETER        ( ZERO   = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
+      PARAMETER        ( TWO    = 2.0D+0                              )
+
+      IF (NCNLN .EQ. 0) RETURN
+
+      RTMIN  = WMACH(6)
+
+      OBJALF = OBJALF - DDOT  ( NCNLN, CMUL, 1, CS, 1 )
+      GRDALF = GRDALF - DDOT  ( NCNLN, DLAM, 1, CS, 1 )
+
+      CALL DCOPY ( NCNLN, CS, 1, WORK1, 1 )
+
+      IF (.NOT. FEASQP) THEN
+         NPLIN  = N + NCLIN
+
+         DO 100 I = 1, NCNLN
+            IF (ISTATE(NPLIN+I) .LT. 0  .OR.  VIOLN(I) .NE. ZERO)
+     $         WORK1(I) = - CJDX(I)
+  100    CONTINUE
+      END IF
+
+      GRDALF = GRDALF + DDOT  ( NCNLN, WORK1, 1, CMUL, 1 )
+
+      IF (NPDBG  .AND.  INPDBG(1) .GT. 0)
+     $   WRITE (NOUT, 1000) QPCURV, GRDALF
+
+      IF (FEASQP) THEN
+
+*        Find the quantities that define  rhomin, the vector of minimum
+*        two-norm such that the directional derivative is one half of
+*        approximate curvature   - (dx)'H(dx).
+
+         DO 350 I = 1, NCNLN
+            IF (ABS( CS(I) ) .LE. RTMIN) THEN
+               WORK2(I) = ZERO
+            ELSE
+               WORK2(I) = CS(I)**2
+            END IF
+  350    CONTINUE
+
+         QNORM  = DNRM2 ( NCNLN, WORK2, 1 )
+         TSCL   = DDIV  ( GRDALF + HALF*QPCURV, QNORM, OVERFL )
+         IF (ABS( TSCL ) .LE. RHOMAX  .AND.  .NOT. OVERFL) THEN
+*           ------------------------------------------------------------
+*           Bounded  RHOMIN  found.  The final value of  RHO(J)  will
+*           never be less than  RHOMIN(j).  If the  QP  was feasible,  a
+*           trial value  RHONEW  is computed that is equal to the
+*           geometric mean of the previous  RHO  and a damped value of
+*           RHOMIN.  The new  RHO  is defined as  RHONEW  if it is less
+*           than half the previous  RHO  and greater than  RHOMIN.
+*           ------------------------------------------------------------
+            SCALE  = ONE
+            DO 400 I = 1, NCNLN
+               RHOMIN = MAX(  (WORK2(I)/QNORM)*TSCL, ZERO )
+               RHOI   = RHO(I)
+
+               RHONEW = SQRT( RHOI*(RHODMP + RHOMIN) )
+               IF (RHONEW .LT. HALF*RHOI  ) RHOI = RHONEW
+               IF (RHOI   .LT.      RHOMIN) RHOI = RHOMIN
+               RHO(I) = RHOI
+  400       CONTINUE
+
+            RHO1   = RHONRM
+            RHONRM = DNRM2 ( NCNLN, RHO, 1 )
+
+*           ------------------------------------------------------------
+*           If  INCRUN = true,  there has been a run of iterations in
+*           which the norm of  RHO  has not decreased.  Conversely,
+*           INCRUN = false  implies that there has been a run of
+*           iterations in which the norm of RHO has not increased.  If
+*           INCRUN changes during this iteration the damping parameter
+*           RHODMP is increased by a factor of two.  This ensures that
+*           RHO(j) will oscillate only a finite number of times.
+*           ------------------------------------------------------------
+            BOOST  = .FALSE.
+            IF (      INCRUN  .AND.  RHONRM .LT. RHO1) BOOST = .TRUE.
+            IF (.NOT. INCRUN  .AND.  RHONRM .GT. RHO1) BOOST = .TRUE.
+            IF (BOOST) THEN
+               RHODMP = TWO*RHODMP
+               INCRUN = .NOT. INCRUN
+            END IF
+         END IF
+
+         IF (NPDBG  .AND.  INPDBG(2) .GT. 0)
+     $      WRITE (NOUT, 1200) (RHO(L), L=1,NCNLN)
+
+      ELSE
+
+*        The  QP  was infeasible.  Do not alter the penalty parameters,
+*        but compute the scale factor so that the constraint violations
+*        are reduced.
+
+         CALL DDSCL ( NCNLN, RHO, 1, WORK1, 1 )
+         PTERM2 = DDOT  ( NCNLN, WORK1, 1, CS, 1 )
+
+         SCALE  = RHOMAX
+         TSCL   = DDIV  ( GRDALF, PTERM2, OVERFL )
+         IF (TSCL .GT. SCALE  .AND.  TSCL .LE. RHOMAX/(ONE+RHONRM)
+     $                        .AND.  .NOT. OVERFL)
+     $      SCALE = TSCL
+
+         CALL DCOPY ( NCNLN, CS, 1, WORK1, 1 )
+      END IF
+
+*     ------------------------------------------------------------------
+*     Compute the new value and directional derivative of the
+*     merit function.
+*     ------------------------------------------------------------------
+      CALL DDSCL ( NCNLN, RHO, 1, WORK1, 1 )
+
+      PTERM  = DDOT  ( NCNLN, WORK1, 1, CS, 1 )
+      OBJALF = OBJALF + HALF*SCALE*PTERM
+
+      IF (FEASQP)
+     $  PTERM2 = PTERM
+
+      GRDALF = GRDALF -      SCALE*PTERM2
+
+      IF (NPDBG  .AND.  INPDBG(1) .GT. 0)
+     $   WRITE (NOUT, 1100) SCALE, RHONRM, GRDALF
+
+      RETURN
+
+ 1000 FORMAT(/ ' //NPMRT //        QPCURV        GRDALF '
+     $       / ' //NPMRT //', 1P2E14.2 )
+ 1100 FORMAT(/ ' //NPMRT //         SCALE        RHONRM        GRDALF '
+     $       / ' //NPMRT //', 1P3E14.2 )
+ 1200 FORMAT(/ ' //NPMRT //  Penalty parameters =       '/ (1P5E15.6))
+
+*     End of  NPMRT .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/npoptn.f
@@ -0,0 +1,68 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPOPTN( STRING )
+      CHARACTER*(*)      STRING
+
+************************************************************************
+*     NPOPTN  loads the option supplied in STRING into the relevant
+*     element of IPRMLS, RPRMLS, IPRMNP or RPRMNP.
+************************************************************************
+
+      LOGICAL             NEWOPT
+      COMMON     /SOL7NP/ NEWOPT
+      SAVE       /SOL7NP/
+
+      DOUBLE PRECISION    WMACH(15)
+      COMMON     /SOLMCH/ WMACH
+      SAVE       /SOLMCH/
+
+      EXTERNAL            MCHPAR
+      CHARACTER*16        KEY
+      CHARACTER*72        BUFFER
+      LOGICAL             FIRST , PRNT
+      SAVE                FIRST , NOUT  , PRNT
+      DATA                FIRST /.TRUE./
+
+*     If first time in, set NOUT.
+*     NEWOPT is true first time into NPFILE or NPOPTN
+*     and just after a call to an optimization routine.
+*     PRNT is set to true whenever NEWOPT is true.
+
+      IF (FIRST) THEN
+         FIRST  = .FALSE.
+         NEWOPT = .TRUE.
+         CALL MCHPAR()
+         NOUT   =  WMACH(11)
+      END IF
+      BUFFER = STRING
+
+*     Call NPKEY to decode the option and set the parameter value.
+*     If NEWOPT is true, reset PRNT and test specially for NOLIST.
+
+      IF (NEWOPT) THEN
+         NEWOPT = .FALSE.
+         PRNT   = .TRUE.
+         CALL NPKEY ( NOUT, BUFFER, KEY )
+
+         IF (KEY .EQ. 'NOLIST') THEN
+            PRNT   = .FALSE.
+         ELSE
+            WRITE (NOUT, '(// A / A /)')
+     $         ' Calls to NPOPTN',
+     $         ' ---------------'
+            WRITE (NOUT, '( 6X, A )') BUFFER
+         END IF
+      ELSE
+         IF (PRNT)
+     $      WRITE (NOUT, '( 6X, A )') BUFFER
+         CALL NPKEY ( NOUT, BUFFER, KEY )
+
+         IF (KEY .EQ.   'LIST') PRNT = .TRUE.
+         IF (KEY .EQ. 'NOLIST') PRNT = .FALSE.
+      END IF
+
+      RETURN
+
+*     End of  NPOPTN.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/npprt.f
@@ -0,0 +1,158 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPPRT ( KTCOND, CONVRG, LSUMRY, MSGNP, MSGQP,
+     $                   NROWR, NROWT, N, NCLIN, NCNLN,
+     $                   NCTOTL, NACTIV, LINACT, NLNACT, NZ, NFREE,
+     $                   MAJITS, MINITS, ISTATE, ALFA, NFUN,
+     $                   CONDHZ, CONDH, CONDT, OBJALF, OBJF,
+     $                   GFNORM, GZNORM, CVNORM,
+     $                   AX, C, R, T, VIOLN, X, WORK )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      CHARACTER*4        LSUMRY
+      LOGICAL            KTCOND(2), CONVRG
+      INTEGER            ISTATE(NCTOTL)
+      DOUBLE PRECISION   AX(*), C(*), R(NROWR,*), T(NROWT,*), VIOLN(*)
+      DOUBLE PRECISION   X(N)
+      DOUBLE PRECISION   WORK(N)
+************************************************************************
+*  NPPRT  prints various levels of output for NPCORE.
+*
+*           Msg        Cumulative result
+*           ---        -----------------
+*
+*        le   0        no output.
+*
+*        eq   1        nothing now (but full output later).
+*
+*        eq   5        one terse line of output.
+*
+*        ge  10        same as 5 (but full output later).
+*
+*        ge  20        objective function,  x,  Ax  and  c.
+*
+*        ge  30        diagonals of  T  and  R.
+*
+*  Debug print is performed depending on the logical variable NPDBG.
+*  NPDBG is set true when IDBG major iterations have been performed.
+*  At this point,  printing is done according to a string of binary
+*  digits of the form CLSVT (stored in the integer array INPDBG).
+*
+*  C  set 'on'  gives detailed information from the checking routines.
+*  L  set 'on'  gives information from the linesearch.
+*  S  set 'on'  gives information from the maximum step routine NPALF.
+*  V  set 'on'  gives various vectors in  NPCORE  and its auxiliaries.
+*  T  set 'on'  gives a trace of which routine was called and an
+*               indication of the progress of the run.
+*
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Original Fortran 66 version written November-1982.
+*  This version of  NPPRT  dated  14-November-1985.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+
+      LOGICAL            INCRUN
+      COMMON    /SOL6NP/ RHOMAX, RHONRM, RHODMP, SCALE, INCRUN
+
+      LOGICAL            NPDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /NPDEBG/ INPDBG(LDBG), NPDBG
+
+      LOGICAL            PHEAD
+      EXTERNAL           DNRM2
+
+      IF (MSGNP .GE. 20) WRITE (NOUT, 1000) MAJITS
+
+      IF (MSGNP  .GE. 5) THEN
+*        ---------------------------------------------------------------
+*        Print heading and terse line.
+*        ---------------------------------------------------------------
+         PHEAD = MSGQP .GT. 0  .OR.  MAJITS .EQ. 0
+
+         IF (NCNLN .EQ. 0) THEN
+            IF (PHEAD) WRITE (NOUT, 1100)
+            WRITE (NOUT, 1300) MAJITS, MINITS, ALFA, NFUN, OBJALF,
+     $                         N-NFREE, LINACT, NZ,
+     $                         GFNORM, GZNORM, CONDH, CONDHZ, CONDT,
+     $                         CONVRG, KTCOND(1), KTCOND(2), LSUMRY
+
+         ELSE
+            IF (PHEAD) WRITE (NOUT, 1110)
+            WRITE (NOUT, 1310) MAJITS, MINITS, ALFA, NFUN, OBJALF,
+     $                         N-NFREE, LINACT, NLNACT, NZ,
+     $                         GFNORM, GZNORM, CONDH, CONDHZ, CONDT,
+     $                         CVNORM, SCALE*RHONRM,
+     $                         CONVRG, KTCOND(1), KTCOND(2), LSUMRY
+         END IF
+
+         IF (MSGNP .GE. 20) THEN
+            IF (NCNLN .EQ. 0) THEN
+               WRITE (NOUT, 1400) OBJF
+            ELSE
+               CVIOLS = DNRM2 ( NCNLN, VIOLN, 1 )
+               WRITE (NOUT, 1410) OBJF, CVIOLS
+            END IF
+
+*           ------------------------------------------------------------
+*           Print the constraint values.
+*           ------------------------------------------------------------
+            WRITE (NOUT, 2000)
+            WRITE (NOUT, 2100) (X(J), ISTATE(J), J=1,N)
+            IF (NCLIN .GT. 0)
+     $         WRITE (NOUT, 2200) (AX(K), ISTATE(N+K),       K=1,NCLIN )
+            IF (NCNLN .GT. 0)
+     $         WRITE (NOUT, 2300) (C(K) , ISTATE(N+NCLIN+K), K=1,NCNLN )
+
+            IF (MSGNP .GE. 30) THEN
+*              ---------------------------------------------------------
+*              Print the diagonals of  T  and  R.
+*              ---------------------------------------------------------
+               INCT   = NROWT - 1
+               IF (NACTIV .GT. 0) THEN
+                  CALL DCOPY( NACTIV, T(NACTIV,NZ+1), INCT, WORK, 1 )
+                  WRITE (NOUT, 3000) (WORK(J), J=1,NACTIV)
+               END IF
+               WRITE (NOUT, 3100) (R(J,J), J=1,N)
+            END IF
+         END IF
+      END IF
+
+      IF (MSGNP .GE. 20) WRITE (NOUT, 5000)
+
+      LSUMRY(1:2) = '  '
+      LSUMRY(4:4) = ' '
+
+      RETURN
+
+ 1000 FORMAT(/// ' Major iteration', I5
+     $       /   ' ====================' )
+ 1100 FORMAT(//  '  Itn', ' ItQP', '     Step',
+     $           '  Nfun', '     Objective', ' Bnd', ' Lin', '  Nz',
+     $           '  Norm Gf', '  Norm Gz', '  Cond H', ' Cond Hz',
+     $           '  Cond T', ' Conv' )
+ 1110 FORMAT(//  '  Itn', ' ItQP', '     Step',
+     $           '  Nfun', '         Merit', ' Bnd', ' Lin',
+     $           ' Nln', '  Nz',
+     $           '  Norm Gf', '  Norm Gz', '  Cond H', ' Cond Hz',
+     $           '  Cond T' , '   Norm C', '  Penalty', ' Conv' )
+ 1300 FORMAT(2I5, 1PE9.1, I6, 1PE14.6, 3I4, 1P2E9.1, 1P3E8.0,
+     $                        1X, L1, 1X, 2L1, A4 )
+ 1310 FORMAT(2I5, 1PE9.1, I6, 1PE14.6, 4I4, 1P2E9.1, 1P3E8.0,
+     $            1P2E9.1,    1X, L1, 1X, 2L1, A4 )
+ 1400 FORMAT(/ ' Nonlinear objective value = ', 1PE15.6 )
+ 1410 FORMAT(/ ' Nonlinear objective value = ', 1PE15.6, '   Norm of',
+     $         ' the nonlinear constraint violations = ', 1PE15.6 )
+ 2000 FORMAT(/ ' Values of the constraints and their predicted status'
+     $       / ' ----------------------------------------------------')
+ 2100 FORMAT(/ ' Variables                  '/ (1X, 5(1PE15.6, I4)))
+ 2200 FORMAT(/ ' General linear constraints '/ (1X, 5(1PE15.6, I4)))
+ 2300 FORMAT(/ ' Nonlinear constraints      '/ (1X, 5(1PE15.6, I4)))
+ 3000 FORMAT(/ ' Diagonals of  T  =         '/       (1P5E15.6))
+ 3100 FORMAT(/ ' Diagonals of  R  =         '/       (1P5E15.6))
+ 5000 FORMAT(  ' ==================================================',
+     $         '======================================='///)
+
+*     End of  NPPRT .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/nprset.f
@@ -0,0 +1,111 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPRSET( UNITQ,
+     $                   N, NFREE, NZ, NQ, NROWR,
+     $                   IPERM, KX,
+     $                   GQ, R, ZY, WORK, QRWORK )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      LOGICAL            UNITQ
+      INTEGER            IPERM(N), KX(N)
+      DOUBLE PRECISION   GQ(N), R(NROWR,*), ZY(NQ,*)
+      DOUBLE PRECISION   WORK(N), QRWORK(2*N)
+
+************************************************************************
+*  NPRSET  bounds the condition estimator of the transformed Hessian.
+*  On exit, R is of the form
+*               ( DRz   0     )
+*               (  0  sigma*I )
+*  where D is a diagonal matrix such that DRz has a bounded condition
+*  number,  I is the identity matrix and sigma  is the geometric mean
+*  of the largest and smallest elements of DRz. The QR factorization
+*  with interchanges is used to give diagonals of DRz that are
+*  decreasing in modulus.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  This version of NPRSET dated  4-August-1986.
+************************************************************************
+
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL6CM/ RCNDBD, RFROBN, DRMAX, DRMIN
+
+      LOGICAL            NPDBG
+      PARAMETER         (LDBG   = 5)
+      COMMON    /NPDEBG/ INPDBG(LDBG), NPDBG
+
+      LOGICAL            OVERFL
+      INTRINSIC          MAX   , MIN   , LOG   , REAL  , SQRT
+      EXTERNAL           DDIV  , DDOT  , DNORM , DNRM2
+      PARAMETER        ( ZERO   =0.0D+0, HALF =0.5D+0, ONE    =1.0D+0 )
+
+*     ==================================================================
+*     Bound the condition estimator of Q'HQ.
+*     The scheme used here reduces the modulus of the larger
+*     diagonals while increasing the modulus of the smaller ones.
+*     ==================================================================
+      IF (NZ .GT. 1) THEN
+*        ---------------------------------------------------------------
+*        Refactorize Rz.  Interchanges are used to give diagonals
+*        of decreasing magnitude.
+*        ---------------------------------------------------------------
+         CALL DGEQRP( 'Column iterchanges', NZ, NZ, R, NROWR,
+     $                WORK, IPERM, QRWORK, INFO )
+
+         DO 110 J = 1, NZ
+            JMAX = IPERM(J)
+            IF (JMAX .GT. J) THEN
+               IF (UNITQ) THEN
+                  JSAVE    = KX(JMAX)
+                  KX(JMAX) = KX(J)
+                  KX(J)    = JSAVE
+               ELSE
+                  CALL DSWAP ( NFREE, ZY(1,JMAX), 1, ZY(1,J), 1 )
+               END IF
+
+               GJMAX    = GQ(JMAX)
+               GQ(JMAX) = GQ(J)
+               GQ(J)    = GJMAX
+            END IF
+  110    CONTINUE
+      END IF
+
+      IF (NZ .EQ. 0) THEN
+         DRGM  = ONE
+      ELSE
+         COND  = DDIV  ( ABS(R(1,1)), ABS(R(NZ,NZ)), OVERFL )
+
+         IF (COND .GT. RCNDBD) THEN
+            IF (N .GT. 1) THEN
+               PWR = LOG(RCNDBD)/LOG(COND) - ONE
+               DO 120 K = 1, NZ
+                  ROWSCL = ABS( R(K,K) )**PWR
+                  CALL DSCAL ( NZ-K+1, ROWSCL, R(K,K), NROWR )
+  120          CONTINUE
+            END IF
+         END IF
+         DRGM  = HALF*SQRT(ABS( R(1,1)*R(NZ,NZ) ))
+      END IF
+
+*     Reset the range-space partition of the Hessian.
+
+      IF (NZ .LT. N) THEN
+         DO 130 J = NZ+1, N
+            CALL DLOAD ( J, ZERO, R(1,J), 1 )
+  130    CONTINUE
+         CALL DLOAD ( N-NZ, DRGM, R(NZ+1,NZ+1), NROWR+1 )
+      END IF
+
+*     Recompute the Frobenius norm of R.
+
+      SCLE  = SQRT(REAL(N - NZ))*DRGM
+      SUMSQ = ONE
+      DO 140 J = 1, NZ
+         CALL DSSQ  ( J, R(1,J), 1, SCLE, SUMSQ )
+  140 CONTINUE
+      RFROBN = DNORM( SCLE, SUMSQ )
+
+      RETURN
+
+*     End of  NPRSET.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/npsetx.f
@@ -0,0 +1,122 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPSETX( UNITQ,
+     $                   NCQP, NACTIV, NFREE, NZ,
+     $                   N, NLNX, NCTOTL, NQ, NROWQP, NROWR, NROWT,
+     $                   ISTATE, KACTIV, KX,
+     $                   DXNORM, GDX,
+     $                   AQP, ADX, BL, BU, RPQ, RPQ0, DX, GQ,
+     $                   R, T, ZY, WORK )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      LOGICAL            UNITQ
+      INTEGER            ISTATE(NCTOTL), KACTIV(N), KX(N)
+      DOUBLE PRECISION   AQP(NROWQP,*), ADX(*), BL(NCTOTL), BU(NCTOTL),
+     $                   RPQ(NLNX), RPQ0(NLNX), GQ(N), R(NROWR,*),
+     $                   T(NROWT,*), ZY(NQ,*), DX(N), WORK(N)
+************************************************************************
+*  NPSETX   defines a point which lies on the initial working set for
+*  the QP subproblem.  This routine is a similar to LSSETX except that
+*  advantage is taken of the fact that the initial estimate of the
+*  solution of the least-squares subproblem is zero.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Original version written 31-October-1984.
+*  Level 2 BLAS added 12-June-1986.
+*  This version of NPSETX dated 11-June-1986.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+
+      LOGICAL            NPDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /NPDEBG/ INPDBG(LDBG), NPDBG
+
+      EXTERNAL           DDOT, DNRM2
+      INTRINSIC          ABS , MIN
+      PARAMETER        ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+
+      NFIXED = N - NFREE
+
+      GDX    = ZERO
+      CALL DLOAD ( N   , ZERO, DX  , 1 )
+      CALL DLOAD ( NLNX, ZERO, RPQ , 1 )
+      CALL DLOAD ( NLNX, ZERO, RPQ0, 1 )
+
+      IF (NACTIV + NFIXED .GT. 0) THEN
+
+*        Set  work = residuals for constraints in the working set.
+*        Solve for  dx,  the smallest correction to  x  that gives a
+*        point on the constraints in the working set.
+*        Set the fixed variables on their bounds,  solve the triangular
+*        system  T*(dxy) = residuals,  and define  dx = Y*(dxy).
+*        Use  (dxy)  to update  d(=Pr)  as  d = d - R'(  0  ).
+*                                                     ( dxy )
+
+         DO 100 I = 1, NFIXED
+            J   = KX(NFREE+I)
+            IF (ISTATE(J) .LE. 3) THEN
+               BND   = BL(J)
+               IF (ISTATE(J) .EQ. 2) BND = BU(J)
+               DX(J) = BND
+               WORK(NFREE+I) = BND
+            ELSE
+               WORK(NFREE+I) = ZERO
+            END IF
+  100    CONTINUE
+
+         DO 110 I = 1, NACTIV
+            K   = KACTIV(I)
+            J   = N + K
+            BND = BL(J)
+            IF (ISTATE(J) .EQ. 2) BND = BU(J)
+            WORK(NZ+I) = BND - DDOT  ( N, AQP(K,1), NROWQP, DX, 1 )
+  110    CONTINUE
+
+         IF (NACTIV .GT. 0)
+     $      CALL CMTSOL( 1, NROWT, NACTIV, T(1,NZ+1), WORK(NZ+1) )
+         CALL DCOPY ( NACTIV+NFIXED, WORK(NZ+1), 1, DX(NZ+1), 1 )
+         IF (NZ .GT. 0)
+     $      CALL DLOAD ( NZ, ZERO, DX, 1 )
+
+         GDX  = DDOT  ( NACTIV+NFIXED, GQ(NZ+1), 1, DX(NZ+1), 1 )
+
+         IF (NZ .LT. N) THEN
+            CALL DGEMV ('N', NZ, N-NZ, -ONE, R(1,NZ+1), NROWR,
+     $                  DX(NZ+1), 1, ONE, RPQ, 1 )
+            IF (NZ .LT. NLNX) THEN
+               NR  = NROWR
+               IF (NZ+1 .EQ. N) NR = 1
+               CALL DCOPY ( NLNX-NZ, DX(NZ+1), 1, RPQ(NZ+1), 1 )
+               CALL DSCAL ( NLNX-NZ, (-ONE),      RPQ(NZ+1), 1 )
+               CALL DTRMV ( 'U', 'N', 'N', NLNX-NZ, R(NZ+1,NZ+1), NR,
+     $                      RPQ(NZ+1), 1 )
+               IF (NLNX .LT. N) THEN
+                  NR = NROWR
+                  IF (NLNX+1 .EQ. N) NR = N - NZ
+                  CALL DGEMV( 'N', NLNX-NZ, N-NLNX, -ONE,R(NZ+1,NLNX+1),
+     $                        NR, DX(NLNX+1), 1, ONE, RPQ(NZ+1), 1 )
+               END IF
+            END IF
+         END IF
+
+         CALL CMQMUL( 2, N, NZ, NFREE, NQ, UNITQ, KX, DX, ZY, WORK )
+      END IF
+
+*     ------------------------------------------------------------------
+*     Compute the 2-norm of  DX.
+*     Initialize  A*DX.
+*     ------------------------------------------------------------------
+      DXNORM  = DNRM2 ( N, DX, 1 )
+      IF (NCQP .GT. 0)
+     $   CALL DGEMV ( 'N', NCQP, N, ONE, AQP, NROWQP, DX, 1, ZERO,ADX,1)
+
+      IF (NPDBG  .AND.  INPDBG(2) .GT. 0)
+     $   WRITE (NOUT, 1200) (DX(J), J = 1, N)
+
+      RETURN
+
+ 1200 FORMAT(/ ' //NPSETX// Variables after NPSETX ... '/ (5G12.3))
+
+*     End of  NPSETX.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/npsol.f
@@ -0,0 +1,628 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPSOL ( N, NCLIN, NCNLN, NROWA, NROWUJ, NROWR,
+     $                   A, BL, BU,
+     $                   CONFUN, OBJFUN,
+     $                   INFORM, ITER, ISTATE,
+     $                   C, UJAC, CLAMDA, OBJF, UGRAD, R, X,
+     $                   IW, LENIW, W, LENW )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      EXTERNAL           CONFUN, OBJFUN
+      INTEGER            ISTATE(N+NCLIN+NCNLN)
+      INTEGER            IW(LENIW)
+      DOUBLE PRECISION   A(NROWA,*), BL(N+NCLIN+NCNLN),
+     $                   BU(N+NCLIN+NCNLN)
+      DOUBLE PRECISION   C(*), UJAC(NROWUJ,*), CLAMDA(N+NCLIN+NCNLN)
+      DOUBLE PRECISION   UGRAD(N), R(NROWR,*), X(N)
+      DOUBLE PRECISION   W(LENW)
+
+*-----------------------------------------------------------------------
+*
+*  NPSOL   solves the nonlinear programming problem
+*
+*            minimize                   F(x)
+*
+*                                    (    x  )
+*            subject to    bl  .le.  (  A*x  )  .le.  bu
+*                                    (  c(x) )
+*
+*  where  F(x)  is a smooth scalar function,  A  is a constant matrix
+*  and  c(x)  is a vector of smooth nonlinear functions.  The feasible
+*  region is defined by a mixture of linear and nonlinear equality or
+*  inequality constraints on  x.
+*
+*  The dimensions of the problem are...
+*
+*  N        the number of variables (dimension of  x),
+*
+*  NCLIN    the number of linear constraints (rows of the matrix  A),
+*
+*  NCNLN    the number of nonlinear constraints (dimension of  c(x)),
+*
+*
+*  NPSOL   uses a sequential quadratic programming algorithm, with a
+*  positive-definite quasi-Newton approximation to the transformed
+*  Hessian  Q'HQ  of the Lagrangian function (which will be stored in
+*  the array  R).
+*
+*
+*  Complete documentation for  NPSOL  is contained in Report
+*  SOL 86-2, Users guide for NPSOL (Version 4.0), by P.E. Gill,
+*  W. Murray, M.A. Saunders and M.H. Wright, Department of Operations
+*  Research,  Stanford University, Stanford, California 94305.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Version 1.1,  April     12, 1983. (The less said about this one.....)
+*  Version 2.0,  April     30, 1984.
+*  Version 3.0,  March     20, 1985. (First Fortran 77 version).
+*  Version 3.2,  August    20, 1985.
+*  Version 4.0,  April     16, 1986. (First version with differences).
+*  Version 4.01, June      30, 1986. (Level 2 Blas + F77 linesearch).
+*  Version 4.02, August     5, 1986. (Reset SSBFGS. One call to CHFD).
+*
+*  Copyright  1983  Stanford University.
+*
+*  This material may be reproduced by or for the U.S. Government pursu-
+*  ant to the copyright license under DAR Clause 7-104.9(a) (1979 Mar).
+*
+*  This material is based upon work partially supported by the National
+*  Science Foundation under Grants MCS-7926009 and ECS-8312142; the
+*  Department of Energy Contract AM03-76SF00326, PA No. DE-AT03-
+*  76ER72018; the Army Research Office Contract DAA29-84-K-0156;
+*  and the Office of Naval Research Grant N00014-75-C-0267.
+*  ---------------------------------------------------------------------
+
+*  Common blocks.
+
+*-----------------------------------------------------------------------
+      PARAMETER         (MXPARM = 30)
+      INTEGER            IPRMLS(MXPARM), IPSVLS
+      DOUBLE PRECISION   RPRMLS(MXPARM), RPSVLS
+
+      COMMON    /LSPAR1/ IPSVLS(MXPARM),
+     $                   IDBGLS, ITMAX1, ITMAX2, LCRASH, LDBGLS, LPROB ,
+     $                   MSGLS , NN    , NNCLIN, NPROB , IPADLS(20)
+
+      COMMON    /LSPAR2/ RPSVLS(MXPARM),
+     $                   BIGBND, BIGDX , BNDLOW, BNDUPP, TOLACT, TOLFEA,
+     $                   TOLRNK, RPADLS(23)
+
+      EQUIVALENCE       (IPRMLS(1), IDBGLS), (RPRMLS(1), BIGBND)
+
+      SAVE      /LSPAR1/, /LSPAR2/
+*-----------------------------------------------------------------------
+*-----------------------------------------------------------------------
+      INTEGER            IPRMNP(MXPARM), IPSVNP
+      DOUBLE PRECISION   RPRMNP(MXPARM), RPSVNP
+
+      COMMON    /NPPAR1/ IPSVNP(MXPARM),
+     $                   IDBGNP, ITMXNP, JVRFY1, JVRFY2, JVRFY3, JVRFY4,
+     $                   LDBGNP, LFORMH, LVLDER, LVERFY, MSGNP , NLNF  ,
+     $                   NLNJ  , NLNX  , NNCNLN, IPADNP(15)
+
+      COMMON    /NPPAR2/ RPSVNP(MXPARM),
+     $                   CDINT , CTOL  , EPSRF , ETA   , FDINT , FTOL  ,
+     $                   RPADNP(24)
+
+      EQUIVALENCE       (IPRMNP(1), IDBGNP), (RPRMNP(1), CDINT)
+
+      SAVE      /NPPAR1/, /NPPAR2/
+*-----------------------------------------------------------------------
+      EQUIVALENCE  (IDBGNP, IDBG  ), (ITMXNP, NMAJOR), (ITMAX2, NMINOR)
+      EQUIVALENCE  (LDBGLS, MNRDBG), (LDBGNP, MJRDBG), (MSGLS , MSGQP )
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL3CM/ LENNAM, NROWT , NCOLT , NQ
+      COMMON    /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9
+      COMMON    /SOL5CM/ ASIZE , DTMAX , DTMIN
+      COMMON    /SOL6CM/ RCNDBD, RFROBN, DRMAX , DRMIN
+
+      LOGICAL            UNITQ
+      COMMON    /SOL1SV/ NACTIV, NFREE , NZ   , UNITQ
+      SAVE      /SOL1SV/
+
+      PARAMETER         (LENLS = 20)
+      COMMON    /SOL1LS/ LOCLS(LENLS)
+
+      PARAMETER         (LENNP = 35)
+      COMMON    /SOL1NP/ LOCNP(LENNP)
+      COMMON    /SOL4NP/ LVLDIF, NCDIFF, NFDIFF, LFDSET
+      COMMON    /SOL5NP/ LVRFYC, JVERFY(4)
+      LOGICAL            INCRUN
+      COMMON    /SOL6NP/ RHOMAX, RHONRM, RHODMP, SCALE, INCRUN
+
+      LOGICAL            CMDBG, LSDBG, NPDBG
+      PARAMETER         (LDBG = 5)
+      COMMON    /NPDEBG/ INPDBG(LDBG), NPDBG
+      COMMON    /LSDEBG/ ILSDBG(LDBG), LSDBG
+      COMMON    /CMDEBG/ ICMDBG(LDBG), CMDBG
+
+      INTRINSIC          ABS   , MAX   , MIN   , MOD   , SQRT  , REAL
+
+*     Local variables.
+
+      EXTERNAL           DDIV  , DDOT  , DNORM , DNRM2
+      CHARACTER*8        NAMES(1)
+      LOGICAL            COLD  , LINOBJ, NAMED , OVERFL, ROWERR, VERTEX
+      PARAMETER         (ZERO   =0.0D+0, POINT1 =0.1D+0, POINT3 =3.3D-1)
+      PARAMETER         (POINT8 =0.8D+0, POINT9 =0.9D+0, ONE    =1.0D+0)
+      PARAMETER         (GROWTH =1.0D+2                                )
+
+      CHARACTER*40       TITLE
+      DATA               TITLE
+     $                 / 'SOL/NPSOL  ---  Version 4.02   Aug  1986' /
+
+*     Set the machine-dependent constants.
+
+      CALL MCHPAR()
+
+      EPSMCH = WMACH( 3)
+      RTEPS  = WMACH( 4)
+      NOUT   = WMACH(11)
+
+      EPSPT3 = EPSMCH**POINT3
+      EPSPT5 = RTEPS
+      EPSPT8 = EPSMCH**POINT8
+      EPSPT9 = EPSMCH**POINT9
+
+      RHOMAX = ONE/EPSMCH
+      ROOTN  = SQRT(REAL(N))
+
+*     Default names will be provided for variables during printing.
+
+      NAMED  = .FALSE.
+      INFORM = 0
+      ITER   = 0
+
+*     Set the default values for the parameters.
+
+      CALL NPDFLT( N, NCLIN, NCNLN, LENIW, LENW, TITLE )
+
+      COLD   = LCRASH .EQ. 0
+
+      NPLIN  = N     + NCLIN
+      NCTOTL = NPLIN + NCNLN
+
+*     Assign the dimensions of arrays in the parameter list of NPCORE.
+*     Economies of storage are possible if the minimum number of active
+*     constraints and the minimum number of fixed variables are known in
+*     advance.  The expert user should alter MINACT and MINFXD
+*     accordingly.
+
+      MINACT = 0
+      MINFXD = 0
+
+      MXFREE = N - MINFXD
+      MAXACT = MAX( 1, MIN( N, NCLIN ) )
+      MAXNZ  = N - ( MINFXD + MINACT )
+
+      IF (NCLIN + NCNLN .EQ. 0) THEN
+         NQ    = 1
+         NROWT = 1
+         NCOLT = 1
+      ELSE
+         NQ    = MAX( 1, MXFREE )
+         NROWT = MAX( MAXNZ, MAXACT )
+         NCOLT = MXFREE
+      END IF
+
+      LENNAM = 1
+
+      NROWQP = MAX( NCLIN+NCNLN, 1 )
+      IF (NCNLN .EQ. 0  .AND.  NCLIN .GT. 0) NROWQP = NROWA
+
+*     NPLOC  defines the arrays that contain the locations of various
+*     work arrays within  W  and  IW.
+
+      LITOTL = 0
+      LWTOTL = 0
+      CALL NPLOC( N, NCLIN, NCNLN, NCTOTL, LITOTL, LWTOTL)
+
+*     Allocate certain addresses that are not allocated in NPLOC.
+
+      LAX    = LWTOTL + 1
+      LWTOTL = LAX    + NCLIN - 1
+      LAX    = MIN( LAX, LWTOTL )
+
+*     Check input parameters and storage limits.
+
+      CALL CMCHK ( NERROR, MSGNP, COLD, .FALSE.,
+     $             LENIW, LENW, LITOTL, LWTOTL,
+     $             N, NCLIN, NCNLN,
+     $             ISTATE, IW, NAMED, NAMES, LENNAM,
+     $             BL, BU, X )
+
+      IF (NERROR .GT. 0) THEN
+         INFORM = 9
+         GO TO 800
+      END IF
+
+      LKACTV = LOCLS( 1)
+      LANORM = LOCLS( 2)
+      LCJDX  = LOCLS( 3)
+      LRES   = LOCLS( 5)
+      LRES0  = LOCLS( 6)
+      LGQ    = LOCLS( 9)
+      LT     = LOCLS(11)
+      LZY    = LOCLS(12)
+      LWTINF = LOCLS(13)
+      LWRK1  = LOCLS(14)
+
+      LKX    = LOCNP( 1)
+      LIPERM = LOCNP( 2)
+      LAQP   = LOCNP( 3)
+      LDX    = LOCNP( 7)
+      LFEATL = LOCNP(10)
+      LWRK2  = LOCNP(12)
+
+      LCMUL  = LOCNP(16)
+      LWRK3  = LOCNP(21)
+      LNEEDC = LOCNP(24)
+      LHFRWD = LOCNP(25)
+      LHCTRL = LOCNP(26)
+      LCJAC  = LOCNP(27)
+      LGRAD  = LOCNP(28)
+
+      NROWJ  = MAX ( NCNLN, 1 )
+
+      TOLRNK = ZERO
+      RCNDBD = ONE/SQRT(EPSPT5)
+
+      IF (TOLFEA .GT. ZERO)
+     $   CALL DLOAD ( NPLIN, TOLFEA, W(LFEATL), 1 )
+
+      IF (NCNLN .GT. 0  .AND.  CTOL .GT. ZERO)
+     $   CALL DLOAD ( NCNLN, CTOL, W(LFEATL+NPLIN), 1 )
+
+      IF (LFDSET .EQ. 0) THEN
+         FDCHK = SQRT( EPSRF )
+      ELSE IF (LFDSET .EQ. 1) THEN
+         FDCHK = FDINT
+      ELSE
+         FDCHK = W(LHFRWD)
+      END IF
+
+      NFUN   = 0
+      NGRAD  = 0
+      NSTATE = 1
+
+*     ------------------------------------------------------------------
+*     If required,  compute the problem functions.
+*     If the constraints are nonlinear,  the first call of CONFUN
+*     sets up any constant elements in the Jacobian matrix.  A copy of
+*     the Jacobian (with constant elements set) is placed in  UJAC.
+*     ------------------------------------------------------------------
+      IF (LVERFY .GE. 10) THEN
+         XNORM  = DNRM2 ( N, X, 1 )
+         LVRFYC = LVERFY - 10
+
+         CALL NPCHKD( INFO, MSGNP, NSTATE, LVLDER, NFUN, NGRAD,
+     $                NROWJ, NROWUJ, N, NCNLN,
+     $                CONFUN, OBJFUN, IW(LNEEDC),
+     $                BIGBND, EPSRF, CDINT, FDINT,
+     $                FDCHK, FDNORM, OBJF, XNORM,
+     $                BL, BU, C, W(LWRK3), W(LCJAC), UJAC, W(LCJDX),
+     $                W(LDX), W(LGRAD), UGRAD, W(LHFRWD), W(LHCTRL),
+     $                X, W(LWRK1), W(LWRK2), W, LENW )
+
+         IF (INFO .NE. 0) THEN
+            IF (INFO .GT. 0) INFORM = 7
+            IF (INFO .LT. 0) INFORM = INFO
+            GO TO 800
+         END IF
+         NSTATE = 0
+      END IF
+
+      IF (LCRASH .LT. 2) THEN
+*        ===============================================================
+*        Cold or warm start.  Use  LSCORE  to obtain a point that
+*        satisfies the linear constraints.
+*        ===============================================================
+         CALL ICOPY ( LDBG, ILSDBG, 1, ICMDBG, 1 )
+
+         IF (NCLIN .GT. 0) THEN
+            IANRMJ = LANORM
+            DO 110 J = 1, NCLIN
+               W(IANRMJ) = DNRM2 ( N, A(J,1), NROWA )
+               IANRMJ    = IANRMJ + 1
+  110       CONTINUE
+            CALL DCOND ( NCLIN, W(LANORM), 1, ASIZE, AMIN )
+         END IF
+
+         CALL DCOND ( NPLIN, W(LFEATL), 1, FEAMAX, FEAMIN )
+         CALL DCOPY ( NPLIN, W(LFEATL), 1, W(LWTINF), 1 )
+         CALL DSCAL ( NPLIN, (ONE/FEAMIN), W(LWTINF), 1 )
+
+*        ===============================================================
+*        The input values of X and (optionally)  ISTATE are used by
+*        LSCRSH  to define an initial working set.
+*        ===============================================================
+         VERTEX = .FALSE.
+         CALL LSCRSH( COLD, VERTEX,
+     $                NCLIN, NPLIN, NACTIV, NARTIF,
+     $                NFREE, N, NROWA,
+     $                ISTATE, IW(LKACTV),
+     $                BIGBND, TOLACT,
+     $                A, W(LAX), BL, BU, X, W(LWRK1), W(LWRK2) )
+
+         UNITQ  = .TRUE.
+         NRES   = 0
+         NGQ    = 0
+         CONDMX = ONE / EPSPT5
+
+         IKX    = LKX
+         DO 120 I = 1, N
+            IW(IKX) = I
+            IKX     = IKX + 1
+  120    CONTINUE
+
+         IF (COLD) THEN
+            NRANK  = 0
+         ELSE
+            NRANK  = NLNX
+            CALL DLOAD ( NLNX, (ZERO), W(LRES0), 1 )
+         END IF
+
+*        ---------------------------------------------------------------
+*        Re-order KX so that the free variables come first.
+*        If a warm start is required, NRANK will be nonzero and the
+*        factor R will be updated.
+*        ---------------------------------------------------------------
+         CALL LSBNDS( UNITQ,
+     $                INFORM, NZ, NFREE, NRANK, NRES, NGQ,
+     $                N, NQ, NROWA, NROWR, NROWT,
+     $                ISTATE, IW(LKX),
+     $                CONDMX,
+     $                A, R, W(LT), W(LRES0), W(LGQ),
+     $                W(LZY), W(LWRK1), W(LWRK2) )
+
+*        ---------------------------------------------------------------
+*        Factorize the initial working set.
+*        ---------------------------------------------------------------
+         IF (NACTIV .GT. 0) THEN
+            NACT1  = NACTIV
+            NACTIV = 0
+
+            CALL LSADDS( UNITQ, VERTEX,
+     $                   INFORM, 1, NACT1, NACTIV, NARTIF, NZ, NFREE,
+     $                   NRANK, NREJTD, NRES, NGQ,
+     $                   N, NQ, NROWA, NROWR, NROWT,
+     $                   ISTATE, IW(LKACTV), IW(LKX),
+     $                   CONDMX,
+     $                   A, R, W(LT), W(LRES0), W(LGQ),
+     $                   W(LZY), W(LWRK1), W(LWRK2) )
+         END IF
+
+         SSQ1 = ZERO
+
+         LINOBJ = .FALSE.
+         CALL LSSETX( LINOBJ, ROWERR, UNITQ,
+     $                NCLIN, NACTIV, NFREE, NRANK, NZ,
+     $                N, NPLIN, NQ, NROWA, NROWR, NROWT,
+     $                ISTATE, IW(LKACTV), IW(LKX),
+     $                JMAX, ERRMAX, CTX, XNORM,
+     $                A, W(LAX), BL, BU, W(LGQ), W(LRES), W(LRES0),
+     $                W(LFEATL), R, W(LT), X, W(LZY),W(LWRK1),W(LWRK2) )
+
+*        ---------------------------------------------------------------
+*        Call  LSCORE  to find a feasible  x.
+*        ---------------------------------------------------------------
+*        Use  WORK2  as the multiplier vector.
+
+         JINF   = 0
+         LCLAM  = LWRK2
+
+         IDBGSV = IDBG
+         IF (IDBG .GT. 0) THEN
+            IDBG = NMINOR + 1
+         END IF
+
+         CALL LSCORE( 'FP problem', NAMED, NAMES, LINOBJ, UNITQ,
+     $                NLPERR, ITER, JINF, NCLIN, NPLIN,
+     $                NACTIV, NFREE, NRANK, NZ, NZ1,
+     $                N, NROWA, NROWR,
+     $                ISTATE, IW(LKACTV), IW(LKX),
+     $                CTX, OBJ, SSQ1, SUMINF, NUMINF, XNORM,
+     $                BL, BU, A, W(LCLAM), W(LAX),
+     $                W(LFEATL), R, X, IW, W )
+
+         IF (NLPERR .GT. 0) THEN
+            INFORM = 2
+            GO TO 800
+         END IF
+      END IF
+
+      IDBG  = IDBGSV
+      CALL ICOPY ( LDBG, INPDBG, 1, ICMDBG, 1 )
+
+      LVRFYC = LVERFY
+      IF (LVERFY .GE. 10) LVRFYC = -1
+
+      CALL NPCHKD( INFO, MSGNP, NSTATE, LVLDER, NFUN, NGRAD,
+     $             NROWJ, NROWUJ, N, NCNLN,
+     $             CONFUN, OBJFUN, IW(LNEEDC),
+     $             BIGBND, EPSRF, CDINT, FDINT,
+     $             FDCHK, FDNORM, OBJF, XNORM,
+     $             BL, BU, C, W(LWRK3), W(LCJAC), UJAC, W(LCJDX),
+     $             W(LDX), W(LGRAD), UGRAD, W(LHFRWD), W(LHCTRL),
+     $             X, W(LWRK1), W(LWRK2), W, LENW )
+
+      IF (INFO .NE. 0) THEN
+         IF (INFO .GT. 0) INFORM = 7
+         IF (INFO .LT. 0) INFORM = INFO
+         GO TO 800
+      END IF
+
+      CALL DCOPY ( N, W(LGRAD), 1, W(LGQ), 1 )
+      CALL CMQMUL( 6, N, NZ, NFREE, NQ, UNITQ,
+     $             IW(LKX), W(LGQ), W(LZY), W(LWRK1) )
+
+      IF (COLD) THEN
+*        ---------------------------------------------------------------
+*        Cold start.  Initialize  R  as the identity matrix.
+*        ---------------------------------------------------------------
+         DO 210 J = 1, N
+            CALL DLOAD ( N, ZERO, R(1,J), 1 )
+  210    CONTINUE
+         CALL DLOAD ( N, ONE, R, NROWR+1 )
+         RFROBN = ROOTN
+
+         IF (NCNLN .GT. 0) CALL DLOAD ( NCNLN, (ZERO), W(LCMUL), 1 )
+      ELSE
+*        ---------------------------------------------------------------
+*        Warm start.
+*        Set the multipliers for the nonlinear constraints.
+*        Check the condition of the initial factor R.
+*        ---------------------------------------------------------------
+         IF (NCNLN .GT. 0)
+     $      CALL DCOPY ( NCNLN, CLAMDA(NPLIN+1), 1, W(LCMUL), 1 )
+
+         SCLE  = ZERO
+         SUMSQ = ONE
+         DO 220 J = 1, N
+            CALL DSSQ  ( J, R(1,J), 1, SCLE, SUMSQ )
+  220    CONTINUE
+         RFROBN = DNORM( SCLE, SUMSQ )
+
+         CALL DCOND ( N, R, NROWR+1, DRMAX, DRMIN )
+         COND   = DDIV  ( DRMAX, DRMIN, OVERFL )
+
+         IF (      COND   .GT. RCNDBD
+     $       .OR.  RFROBN .GT. ROOTN*GROWTH*DRMAX) THEN
+*           ------------------------------------------------------------
+*           Refactorize the Hessian and bound the condition estimator.
+*           ------------------------------------------------------------
+            CALL NPRSET( UNITQ,
+     $                   N, NFREE, NZ, NQ, NROWR,
+     $                   IW(LIPERM), IW(LKX),
+     $                   W(LGQ), R, W(LZY), W(LWRK1), W(LRES0) )
+         END IF
+      END IF
+
+*     ==================================================================
+*     Solve the problem.
+*     ==================================================================
+      IF (NCNLN .EQ. 0) THEN
+*        ---------------------------------------------------------------
+*        The problem has only linear constraints and bounds.
+*        ---------------------------------------------------------------
+         CALL NPCORE( NAMED, NAMES, UNITQ, INFORM, ITER,
+     $                N, NCLIN, NCNLN, NCTOTL, NACTIV, NFREE, NZ,
+     $                NROWA, NROWJ, NROWUJ, NROWQP, NROWR,
+     $                NFUN, NGRAD, ISTATE, IW(LKACTV), IW(LKX),
+     $                OBJF, FDNORM, XNORM, OBJFUN, CONFUN,
+     $                A, W(LAX), BL, BU, C, W(LCJAC), UJAC, CLAMDA,
+     $                W(LFEATL), W(LGRAD), UGRAD, R, X, IW, W, LENW )
+      ELSE
+*        ---------------------------------------------------------------
+*        The problem has some nonlinear constraints.
+*        ---------------------------------------------------------------
+         IF (NCLIN .GT. 0) THEN
+            LA1J = LAQP
+            DO 520 J = 1, N
+               CALL DCOPY ( NCLIN, A(1,J), 1, W(LA1J), 1 )
+               LA1J = LA1J + NROWQP
+  520       CONTINUE
+         END IF
+
+*        Try and add some nonlinear constraint indices to KACTIV.
+*
+         CALL NPCRSH( COLD, N, NCLIN, NCNLN,
+     $                NCTOTL, NACTIV, NFREE, NZ,
+     $                ISTATE, IW(LKACTV), BIGBND, TOLACT,
+     $                BL, BU, C )
+
+         CALL NPCORE( NAMED, NAMES, UNITQ, INFORM, ITER,
+     $                N, NCLIN, NCNLN, NCTOTL, NACTIV, NFREE, NZ,
+     $                NROWA, NROWJ, NROWUJ, NROWQP, NROWR,
+     $                NFUN, NGRAD, ISTATE, IW(LKACTV),IW(LKX),
+     $                OBJF, FDNORM, XNORM, OBJFUN, CONFUN,
+     $                W(LAQP), W(LAX), BL, BU, C, W(LCJAC),UJAC,CLAMDA,
+     $                W(LFEATL), W(LGRAD), UGRAD, R, X, IW, W, LENW )
+
+      END IF
+
+*     ------------------------------------------------------------------
+*     If required, form the triangular factor of the Hessian.
+*     ------------------------------------------------------------------
+*     First,  form the square matrix  R  such that  H = R'R.
+*     Compute the  QR  factorization of  R.
+
+      IF (LFORMH .GT. 0) THEN
+         LV     = LWRK2
+         DO 400 J = 1, N
+            IF (J .GT. 1)
+     $         CALL DLOAD ( J-1, ZERO, W(LV), 1 )
+
+            LVJ = LV + J - 1
+            CALL DCOPY ( N-J+1, R(J,J), NROWR, W(LVJ), 1     )
+            CALL CMQMUL( 3, N, NZ, NFREE, NQ, UNITQ,
+     $                   IW(LKX), W(LV), W(LZY), W(LWRK1) )
+            CALL DCOPY ( N    , W(LV) , 1    , R(J,1), NROWR )
+  400    CONTINUE
+
+         CALL DGEQR ( N, N, R, NROWR, W(LWRK1), INFO )
+      END IF
+
+*     Print messages if required.
+
+  800 IF (MSGNP .GT.   0) THEN
+         IF (INFORM .LT.   0) WRITE (NOUT, 3000)
+         IF (INFORM .EQ.   0) WRITE (NOUT, 4000)
+         IF (INFORM .EQ.   1) WRITE (NOUT, 4100)
+         IF (INFORM .EQ.   2) WRITE (NOUT, 4200)
+         IF (INFORM .EQ.   3) WRITE (NOUT, 4300)
+         IF (INFORM .EQ.   4) WRITE (NOUT, 4400)
+         IF (INFORM .EQ.   5) WRITE (NOUT, 4500)
+         IF (INFORM .EQ.   6) WRITE (NOUT, 4600)
+         IF (INFORM .EQ.   7) WRITE (NOUT, 4700)
+         IF (INFORM .EQ.   9) WRITE (NOUT, 4900) NERROR
+
+         IF (INFORM .GE. 0  .AND.  INFORM .NE. 9) THEN
+            IF (NLPERR .EQ. 0) THEN
+               WRITE (NOUT, 5000) OBJF
+            ELSE
+               IF (NLPERR .EQ. 3) THEN
+                  WRITE (NOUT, 5010) SUMINF
+               ELSE
+                  WRITE (NOUT, 5020) SUMINF
+               END IF
+            END IF
+         END IF
+      END IF
+
+*     Recover the optional parameters set by the user.
+
+      CALL ICOPY ( MXPARM, IPSVLS, 1, IPRMLS, 1 )
+      CALL DCOPY ( MXPARM, RPSVLS, 1, RPRMLS, 1 )
+      CALL ICOPY ( MXPARM, IPSVNP, 1, IPRMNP, 1 )
+      CALL DCOPY ( MXPARM, RPSVNP, 1, RPRMNP, 1 )
+
+      RETURN
+
+ 3000 FORMAT(/ ' Exit NPSOL - User requested termination.'          )
+ 4000 FORMAT(/ ' Exit NPSOL - Optimal solution found.'              )
+ 4100 FORMAT(/ ' Exit NPSOL - Optimal solution found, ',
+     $         ' but the requested accuracy could not be achieved.' )
+ 4200 FORMAT(/ ' Exit NPSOL - No feasible point for the linear',
+     $         ' constraints.')
+ 4300 FORMAT(/ ' Exit NPSOL - No feasible point for the nonlinear',
+     $         ' constraints.')
+ 4400 FORMAT(/ ' Exit NPSOL - Too many major iterations.             ')
+ 4500 FORMAT(/ ' Exit NPSOL - Problem is unbounded (or badly scaled).')
+ 4600 FORMAT(/ ' Exit NPSOL - Current point cannot be improved upon. ')
+ 4700 FORMAT(/ ' Exit NPSOL - Large errors found in the derivatives. ')
+
+ 4900 FORMAT(/ ' Exit NPSOL - ', I10, ' errors found in the input',
+     $         ' parameters.  Problem abandoned.')
+ 5000 FORMAT(/ ' Final nonlinear objective value =', G16.7 )
+ 5010 FORMAT(/ ' Minimum sum of infeasibilities =',  G16.7 )
+ 5020 FORMAT(/ ' Final sum of infeasibilities =',    G16.7 )
+
+*     End of  NPSOL .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/npsrch.f
@@ -0,0 +1,309 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPSRCH( NEEDFD, INFORM, N, NCNLN,
+     $                   NROWJ, NROWUJ, NFUN, NGRAD,
+     $                   NEEDC, CONFUN, OBJFUN,
+     $                   ALFA, ALFBND, ALFMAX, ALFSML, DXNORM,
+     $                   EPSRF, ETA, GDX, GRDALF, GLF1, GLF,
+     $                   OBJF, OBJALF, QPCURV, XNORM,
+     $                   C, CJAC, UJAC, CJDX, CMUL1, CMUL, CS1, CS,
+     $                   DX, DLAM, DSLK, GRAD, UGRAD, QPMUL, RHO,
+     $                   SLK1, SLK, X1, X, W, LENW )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      LOGICAL            NEEDFD
+      INTEGER            NEEDC(*)
+      DOUBLE PRECISION   DX(N), GRAD(N), UGRAD(N), X1(N), X(N)
+      DOUBLE PRECISION   C(*), CJAC(NROWJ,*), UJAC(NROWUJ,*), CJDX(*),
+     $                   CMUL1(*), CMUL(*), CS1(*), CS(*)
+      DOUBLE PRECISION   DLAM(*), DSLK(*), QPMUL(*),
+     $                   RHO(*), SLK1(*), SLK(*)
+      DOUBLE PRECISION   W(LENW)
+      EXTERNAL           OBJFUN, CONFUN
+
+************************************************************************
+*  NPSRCH finds the steplength ALFA that gives sufficient decrease in
+*  the augmented Lagrangian merit function.
+*
+*  On exit,  if INFORM = 1, 2 or 3,  ALFA will be a nonzero steplength
+*  with an associated merit function value  OBJALF  which is lower than
+*  that at the base point. If  INFORM = 4, 5, 6 or 7,  ALFA  is zero
+*  and  OBJALF will be the merit value at the base point.
+*
+*  Systems Optimization Laboratory, Stanford University, California.
+*  Original version written  27-May-1985.
+*  Level 2 BLAS added 12-June-1986.
+*  This version of NPSRCH dated 12-July-1986.
+************************************************************************
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9
+
+      PARAMETER         (LENLS = 20)
+      COMMON    /SOL1LS/ LOCLS(LENLS)
+
+      PARAMETER         (LENNP = 35)
+      COMMON    /SOL1NP/ LOCNP(LENNP)
+      COMMON    /SOL4NP/ LVLDIF, NCDIFF, NFDIFF, LFDSET
+      LOGICAL            INCRUN
+      COMMON    /SOL6NP/ RHOMAX, RHONRM, RHODMP, SCALE, INCRUN
+
+      LOGICAL            NPDBG
+      PARAMETER        ( LDBG = 5 )
+      COMMON    /NPDEBG/ INPDBG(LDBG), NPDBG
+
+      LOGICAL            DEBUG , DONE  , FIRST , IMPRVD
+      EXTERNAL           DDOT  , DNRM2
+      INTRINSIC          ABS   , MAX   , MIN   , SQRT
+      PARAMETER        ( ZERO   =0.0D+0, HALF   =0.5D+0, ONE   =1.0D+0 )
+      PARAMETER        ( TWO    =2.0D+0                                )
+      PARAMETER        ( TOLG   =1.0D-1                                )
+
+      EPSMCH = WMACH(3)
+
+      LC     = LOCLS(14)
+      LWORK  = LOCNP(12)
+      LCJDX  = LOCNP(21)
+
+      IF (.NOT. NEEDFD  .AND.  NCNLN .GT. 0)
+     $   CS1JDX = DDOT( NCNLN, CS1, 1, CJDX, 1 )
+
+*     ------------------------------------------------------------------
+*     Set the input parameters and tolerances for SRCHC and SRCHQ.
+*
+*     TOLRX   is the tolerance on relative changes in DX resulting from
+*             changes in ALFA.
+*
+*     TOLAX   is the tolerance on absolute changes in DX resulting from
+*             changes in ALFA.
+*
+*     TOLABS  is the tolerance on absolute changes in ALFA.
+*
+*     TOLREL  is the tolerance on relative changes in ALFA.
+*
+*     TOLTNY  is the magnitude of the smallest allowable value of ALFA.
+*             If  M(TOLABS) - M(0) .gt. EPSAF,  the linesearch tries
+*             steps in the range  TOLTNY .LE. ALFA .LE. TOLABS.
+*     ------------------------------------------------------------------
+      NSTATE = 0
+      DEBUG  = NPDBG  .AND.  INPDBG(4) .GT. 0
+
+      EPSAF  = EPSRF*(ONE + ABS( OBJALF ))
+
+      TOLAX  = EPSPT8
+      TOLRX  = EPSPT8
+
+      TOLABS = ALFMAX
+      IF (TOLRX*XNORM + TOLAX .LT. DXNORM*ALFBND)
+     $   TOLABS = (TOLRX*XNORM + TOLAX) /  DXNORM
+      TOLREL = MAX( TOLRX , EPSMCH )
+
+      T      = ZERO
+      DO 10 J = 1, N
+         S = ABS( DX(J) )
+         Q = ABS( X(J) )*TOLRX + TOLAX
+         IF (S .GT. T*Q) T = S / Q
+   10 CONTINUE
+
+      TOLTNY = TOLABS
+      IF (T*TOLABS .GT. ONE) TOLTNY = ONE / T
+
+      OLDF   = OBJALF
+      OLDG   = GRDALF
+
+      IF (NCNLN .GT. 0) CALL ILOAD ( NCNLN, (1), NEEDC, 1 )
+
+      MODE  = 2
+      IF (NEEDFD) MODE = 0
+
+      FIRST  = .TRUE.
+
+*     ------------------------------------------------------------------
+*     Commence main loop, entering SRCHC or SRCHQ two or more times.
+*     FIRST = true for the first entry,  false for subsequent entries.
+*     DONE  = true indicates termination, in which case the value of
+*     INFORM gives the result of the search.
+*     ------------------------------------------------------------------
+*+    REPEAT
+  100    IF (NEEDFD) THEN
+            CALL SRCHQ ( DEBUG, DONE, FIRST, IMPRVD, INFORM,
+     $                   ALFMAX, ALFSML, EPSAF, ETA,
+     $                   XTRY, FTRY,       OLDF, OLDG,
+     $                   TOLABS, TOLREL, TOLTNY,
+     $                   ALFA, ALFBST, FBEST        )
+         ELSE
+            CALL SRCHC ( DEBUG, DONE, FIRST, IMPRVD, INFORM,
+     $                   ALFMAX,         EPSAF, ETA,
+     $                   XTRY, FTRY, GTRY, OLDF, OLDG,
+     $                   TOLABS, TOLREL, TOLTNY,
+     $                   ALFA, ALFBST, FBEST, GBEST )
+         END IF
+
+         IF (IMPRVD) THEN
+            OBJF   = TOBJ
+            OBJALF = FTRY
+
+            IF (NCNLN .GT. 0)
+     $         CALL DCOPY ( NCNLN, W(LC), 1, C, 1 )
+
+            IF (.NOT. NEEDFD) THEN
+               CALL DCOPY ( N, UGRAD, 1, GRAD, 1 )
+               GDX    = TGDX
+               GLF    = TGLF
+
+               IF (NCNLN .GT. 0) THEN
+                  CALL DCOPY ( NCNLN, W(LCJDX), 1, CJDX, 1 )
+                  DO 120  J = 1, N
+                     CALL DCOPY ( NCNLN, UJAC(1,J), 1, CJAC(1,J), 1 )
+  120             CONTINUE
+               END IF
+            END IF
+         END IF
+
+*        ---------------------------------------------------------------
+*        If DONE = FALSE,  the problem functions must be computed for
+*        the next entry to SRCHC or SRCHQ.
+*        If DONE = TRUE,   this is the last time through.
+*        ---------------------------------------------------------------
+         IF (.NOT. DONE) THEN
+
+            NFUN  = NFUN  + 1
+            IF (.NOT. NEEDFD) NGRAD = NGRAD + 1
+
+            CALL DCOPY ( N,       X1, 1, X, 1 )
+            CALL DAXPY ( N, ALFA, DX, 1, X, 1 )
+            IF (NCNLN .GT. 0) THEN
+
+*              Compute the new estimates of the multipliers and slacks.
+*              If the step length is greater than one,  the multipliers
+*              are fixed as the QP-multipliers.
+
+               IF (ALFA .LE. ONE) THEN
+                  CALL DCOPY ( NCNLN,       CMUL1, 1, CMUL, 1 )
+                  CALL DAXPY ( NCNLN, ALFA, DLAM , 1, CMUL, 1 )
+               END IF
+               CALL DCOPY ( NCNLN,       SLK1, 1, SLK, 1 )
+               CALL DAXPY ( NCNLN, ALFA, DSLK, 1, SLK, 1 )
+
+*              ---------------------------------------------------------
+*              Compute the new constraint vector and Jacobian.
+*              ---------------------------------------------------------
+               CALL CONFUN( MODE, NCNLN, N, NROWUJ,
+     $                      NEEDC, X, W(LC), UJAC, NSTATE )
+               IF (MODE .LT. 0) GO TO 999
+
+               CALL DCOPY ( NCNLN,         W(LC), 1, CS, 1 )
+               CALL DAXPY ( NCNLN, (-ONE), SLK  , 1, CS, 1 )
+
+               CALL DCOPY ( NCNLN, CS , 1, W(LWORK), 1 )
+               CALL DDSCL ( NCNLN, RHO, 1, W(LWORK), 1 )
+
+               FTERM  =            DDOT( NCNLN, CMUL    , 1, CS, 1 ) -
+     $                  HALF*SCALE*DDOT( NCNLN, W(LWORK), 1, CS, 1 )
+
+            END IF
+
+*           ------------------------------------------------------------
+*           Compute the value and gradient of the objective function.
+*           ------------------------------------------------------------
+            CALL OBJFUN( MODE, N, X, TOBJ, UGRAD, NSTATE )
+            IF (MODE .LT. 0) GO TO 999
+
+            FTRY   = TOBJ
+            IF (NCNLN .GT. 0) FTRY = TOBJ  - FTERM
+
+*           ------------------------------------------------------------
+*           Compute auxiliary gradient information.
+*           ------------------------------------------------------------
+            IF (.NOT. NEEDFD) THEN
+               GTRY   = DDOT( N, UGRAD, 1, DX, 1 )
+               TGDX   = GTRY
+               TGLF   = GTRY
+               IF (NCNLN .GT. 0) THEN
+
+*                 Compute the Jacobian times the search direction.
+
+                  CALL DGEMV ( 'N', NCNLN, N, ONE, UJAC, NROWUJ, DX, 1,
+     $                         ZERO, W(LCJDX), 1 )
+
+                  CALL DCOPY ( NCNLN,         W(LCJDX), 1, W(LWORK), 1 )
+                  CALL DAXPY ( NCNLN, (-ONE), DSLK    , 1, W(LWORK), 1 )
+
+                  GTRY   = GTRY - DDOT( NCNLN, CMUL, 1, W(LWORK), 1 )
+                  IF (ALFA .LE. ONE)
+     $               GTRY   = GTRY - DDOT( NCNLN, DLAM, 1, CS      , 1 )
+
+                  CALL DDSCL ( NCNLN, RHO , 1, W(LWORK), 1 )
+                  GTRY = GTRY  +
+     $                     SCALE*DDOT( NCNLN, W(LWORK), 1, CS   , 1 )
+
+                  TGLF = TGDX  - DDOT( NCNLN, W(LCJDX), 1, QPMUL, 1 )
+
+*                 ------------------------------------------------------
+*                 If ALFBND .LE. ALFA .LT. ALFMAX and the norm of the
+*                 quasi-Newton update is bounded, set ALFMAX to be ALFA.
+*                 This will cause the linesearch to stop if the merit
+*                 function is decreasing at the boundary.
+*                 ------------------------------------------------------
+                  IF (ALFBND .LE. ALFA  .AND.  ALFA .LT. ALFMAX) THEN
+
+                     CSJDX  = DDOT   ( NCNLN, CS, 1, W(LCJDX), 1 )
+
+                     IF (NPDBG  .AND.  INPDBG(1) .GT. 0)
+     $                  WRITE (NOUT, 1400) CSJDX, CS1JDX, CURVLF
+
+                     CURVLF = TGLF  - GLF1
+                     CURVC  = ABS( CSJDX - CS1JDX )
+                     RHOBFS = MAX( QPCURV*TOLG - CURVLF, ZERO )
+                     IF (RHOBFS .LE. CURVC*RHOMAX) THEN
+                        ALFMAX = ALFA
+                     ELSE
+                        ALFBND = MIN( TWO*ALFA, ALFMAX )
+                     END IF
+                     IF (NPDBG  .AND.  INPDBG(1) .GT. 0)
+     $                  WRITE(NOUT,1300) ALFBND, ALFA, ALFMAX
+                  END IF
+               END IF
+            END IF
+         END IF
+*+    UNTIL (      DONE)
+      IF    (.NOT. DONE) GO TO 100
+
+      ALFA = ALFBST
+      IF (.NOT. IMPRVD) THEN
+         CALL DCOPY ( N,       X1, 1, X, 1 )
+         CALL DAXPY ( N, ALFA, DX, 1, X, 1 )
+         IF (NCNLN .GT. 0) THEN
+            IF (ALFA .LE. ONE) THEN
+               CALL DCOPY ( NCNLN,       CMUL1, 1, CMUL, 1 )
+               CALL DAXPY ( NCNLN, ALFA, DLAM , 1, CMUL, 1 )
+            END IF
+            CALL DCOPY ( NCNLN,         SLK1 , 1, SLK, 1 )
+            CALL DAXPY ( NCNLN,   ALFA, DSLK , 1, SLK, 1 )
+            CALL DCOPY ( NCNLN,         C    , 1, CS , 1 )
+            CALL DAXPY ( NCNLN, (-ONE), SLK  , 1, CS , 1 )
+         END IF
+      END IF
+
+      IF (NPDBG  .AND.  INPDBG(1) .GT. 0)
+     $   WRITE (NOUT, 1200) INFORM
+
+      RETURN
+
+*     The user wants to stop.
+
+  999 INFORM = MODE
+      RETURN
+
+ 1200 FORMAT(/ ' //NPSRCH// INFORM  = ', I4 )
+ 1300 FORMAT(/ ' //NPSRCH//        ALFBND          ALFA        ALFMAX'
+     $       / ' //NPSRCH//', 1P3E14.2 )
+ 1400 FORMAT(/ ' //NPSRCH//         CSJDX        CS1JDX        CURVLF'
+     $       / ' //NPSRCH//', 1P3E14.2 )
+
+*     End of  NPSRCH.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/npupdt.f
@@ -0,0 +1,194 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE NPUPDT( LSUMRY, UNITQ,
+     $                   N, NCNLN, NFREE, NZ,
+     $                   NROWJ1, NROWJ2, NQ, NROWR, KX,
+     $                   ALFA, GLF1, GLF2, QPCURV,
+     $                   CJAC1, CJAC2, CJDX1, CJDX2,
+     $                   CS1, CS2, GQ1, GQ2, HPQ, RPQ,
+     $                   QPMUL, R, OMEGA, ZY, WRK1, WRK2 )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      CHARACTER*4        LSUMRY
+      LOGICAL            UNITQ
+      INTEGER            KX(N)
+      DOUBLE PRECISION   CJAC1(NROWJ1,*), CJAC2(NROWJ2,*),
+     $                   CJDX1(*), CJDX2(*), CS1(*), CS2(*),
+     $                   GQ1(N), GQ2(N), HPQ(N), RPQ(N), QPMUL(*),
+     $                   R(NROWR,*), OMEGA(*), ZY(NQ,*)
+      DOUBLE PRECISION   WRK1(N+NCNLN), WRK2(N)
+
+************************************************************************
+*  NPUPDT  computes the BFGS update for the approximate Hessian of the
+*  Lagrangian.  If the approximate curvature of the Lagrangian function
+*  is negative,  a nonnegative penalty vector OMEGA(i) of minimum two
+*  norm is computed such that the approximate curvature of the augmented
+*  Lagrangian will be positive. If no finite penalty vector exists,  the
+*  BFGS update is performed with the approximate curvature modified to
+*  be a small positive value.
+*
+*  On entry,  GQ1 and GQ2 contain the transformed objective gradients at
+*  X1 and X2,  HPQ contains  R'R(pq), the transformed Hessian times the
+*  transformed search direction.  The vectors GQ1 and HPQ are not saved.
+*  If the regular BFGS quasi-Newton update could not be performed, the
+*  first character of LSUMRY is loaded with 'M'.
+*
+*  Systems Optimization Laboratory, Stanford University.
+*  Original Fortran 66 version written April 1984.
+*  Level 2 BLAS added 12-June-1986.
+*  This version of NPUPTD dated  4-August-1986.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+      COMMON    /SOL6CM/ RCNDBD, RFROBN, DRMAX, DRMIN
+
+      LOGICAL            INCRUN
+      COMMON    /SOL6NP/ RHOMAX, RHONRM, RHODMP, SCALE, INCRUN
+
+      LOGICAL            NPDBG
+      PARAMETER        ( LDBG   = 5 )
+      COMMON    /NPDEBG/ INPDBG(LDBG), NPDBG
+
+      LOGICAL            OVERFL, SSBFGS
+      INTRINSIC          MAX   , MIN   , SQRT
+      EXTERNAL           IDAMAX, DDIV  , DDOT  , DNRM2
+      PARAMETER        ( ZERO   = 0.0D+0, ONE    = 1.0D+0 )
+      PARAMETER        ( TOLG   = 1.0D-1                  )
+
+      IF (NCNLN .GT. 0) CALL DLOAD ( NCNLN, ZERO, OMEGA, 1 )
+
+*     ------------------------------------------------------------------
+*     Set CURVL = (G2 - G1)'DX,  the approximate curvature along DX of
+*     the (augmented) Lagrangian.  At first, the curvature is not scaled
+*     by the steplength ALFA.
+*     ------------------------------------------------------------------
+      CURVL  = GLF2 -   GLF1
+      TINYCL =        QPCURV * TOLG
+      SSBFGS = CURVL .LE. ALFA*TINYCL
+      IF (NPDBG  .AND.  INPDBG(1) .GT. 0)
+     $   WRITE (NOUT, 1000) SSBFGS, TINYCL, CURVL
+
+*     ------------------------------------------------------------------
+*     Test if CURVL is sufficiently positive.  If there are no nonlinear
+*     constraints,  no update can be performed.
+*     ------------------------------------------------------------------
+      IF (CURVL  .LT. TINYCL) THEN
+         LSUMRY(1:1) = 'Modified BFGS'
+         IF (NCNLN .GT. 0) THEN
+            QMAX = ZERO
+            DO 200 I = 1, NCNLN
+               QI  = CJDX2(I)*CS2(I) - CJDX1(I)*CS1(I)
+               QMAX = MAX( QMAX, QI )
+               IF (QI .LE. ZERO) WRK1(I) = ZERO
+               IF (QI .GT. ZERO) WRK1(I) = QI
+  200       CONTINUE
+
+            QNORM = DNRM2 ( NCNLN, WRK1, 1 )
+
+            TEST  = MAX( TINYCL - CURVL, ZERO )
+            BETA  = DDIV  ( QMAX*TEST, QNORM*QNORM, OVERFL )
+            IF (BETA .LT. RHOMAX  .AND.  .NOT. OVERFL) THEN
+               LSUMRY(1:1) = ' '
+               BETA  = TEST/(QNORM*QNORM)
+               DO 210 I = 1, NCNLN
+                  QI       = WRK1(I)
+                  OMEGA(I) =            BETA*QI
+                  CURVL    = CURVL    + BETA*QI*QI
+  210          CONTINUE
+
+               IF (NPDBG) THEN
+                  IMAX = IDAMAX( NCNLN, OMEGA, 1 )
+                  IF (INPDBG(1) .GT. 0)
+     $               WRITE (NOUT, 1250) OMEGA(IMAX)
+
+                  IF (INPDBG(2) .GT. 0)
+     $               WRITE (NOUT, 1300) (OMEGA(I), I=1,NCNLN)
+               END IF
+            END IF
+         END IF
+      END IF
+
+*     ------------------------------------------------------------------
+*     Compute the difference in the augmented Lagrangian gradient.
+*     ------------------------------------------------------------------
+*     Update GQ1 to include the augmented Lagrangian terms.
+
+      IF (NCNLN .GT. 0) THEN
+
+         DO 310 I = 1, NCNLN
+            WRK1(I) = - QPMUL(I) + OMEGA(I) * CS1(I)
+  310    CONTINUE
+         CALL DGEMV ( 'T', NCNLN, N, ONE, CJAC1, NROWJ1, WRK1, 1,
+     $                ZERO, WRK2, 1 )
+
+         DO 320 I = 1, NCNLN
+            WRK1(I) =   QPMUL(I) - OMEGA(I) * CS2(I)
+  320    CONTINUE
+         CALL DGEMV ( 'T', NCNLN, N, ONE, CJAC2, NROWJ2, WRK1, 1,
+     $                ONE, WRK2, 1 )
+
+         CALL CMQMUL( 6, N, NZ, NFREE, NQ, UNITQ, KX, WRK2, ZY, WRK1 )
+         CALL DAXPY ( N, ONE, WRK2, 1, GQ1, 1 )
+      END IF
+
+      IF (NPDBG  .AND.  INPDBG(1) .GT. 0)
+     $   WRITE (NOUT, 1100) ALFA  , CURVL
+
+      IF (CURVL .LT. TINYCL) CURVL  = TINYCL
+
+      DO 330 J = 1, N
+         WRK2(J) = GQ2(J) - GQ1(J)
+  330 CONTINUE
+
+      RTGTP  = SQRT(QPCURV)
+      RTYTS  = SQRT(ALFA*CURVL)
+      ETA    = ONE
+      IF (SSBFGS)
+     $   ETA = RTYTS / (RTGTP*ALFA)
+
+      TRACE1 = DNRM2 ( N,  HPQ, 1 ) /  RTGTP
+      TRACE2 = DNRM2 ( N, WRK2, 1 ) / (RTYTS*ETA)
+      RFROBN = ETA*SQRT( ABS(  (RFROBN - TRACE1)*(RFROBN + TRACE1)
+     $                                 + TRACE2**2) )
+
+*     ==================================================================
+*     Update the Cholesky factor of  Q'HQ.
+*     ==================================================================
+*     Normalize the vector  RPQ ( = R(pq) ).
+
+      CALL DSCAL ( N, (ONE / RTGTP), RPQ, 1 )
+
+*     Do the self-scaled or regular BFGS update.
+*     Form the vector WRK1 = gamma * (GQ2 - GQ1) - beta * R'R*PQ,
+*     where  gamma = 1/SQRT( CURV ) = 1/SQRT( (GQ2 - GQ1)'SQ )
+
+      CALL DSCAL ( N, (ONE / RTGTP), HPQ, 1 )
+
+      IF (SSBFGS) THEN
+         DO 410 J   = 1, N
+            CALL DSCAL ( J, ETA, R(1,J), 1 )
+            WRK1(J) = WRK2(J)/RTYTS  -  ETA * HPQ(J)
+  410    CONTINUE
+      ELSE
+         DO 420 J   = 1, N
+            WRK1(J) = WRK2(J)/RTYTS  -        HPQ(J)
+  420    CONTINUE
+      END IF
+
+*     Perform the update to  R = R + RPQ*WRK1'.
+*     RPQ is overwritten and HPQ is used as workspace.
+
+      CALL CMR1MD( N, 0, N, NROWR, N, N, R, HPQ, RPQ, WRK1 )
+
+      RETURN
+
+ 1000 FORMAT(/ ' //NPUPDT// SSBFGS    min. CURVL         CURVL '
+     $       / ' //NPUPDT//   ', L4, 1P2E14.2 )
+ 1100 FORMAT(/ ' //NPUPDT//          ALFA         CURVL '
+     $       / ' //NPUPDT//', 1P2E14.2 )
+ 1250 FORMAT(/ ' //NPUPDT//   OMEGA(IMAX)'
+     $       / ' //NPUPDT//', 1PE14.2 )
+ 1300 FORMAT(/ ' //NPUPDT//  Penalty parameters = '  / (1P5E15.6))
+
+*     End of  NPUPDT.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/opfile.f
@@ -0,0 +1,115 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+*     File  OPSUBS FORTRAN
+*
+*     OPFILE   OPLOOK   OPNUMB   OPSCAN   OPTOKN   OPUPPR
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE OPFILE( IOPTNS, NOUT, INFORM, OPKEY )
+      INTEGER            IOPTNS, NOUT, INFORM
+      EXTERNAL           OPKEY
+
+************************************************************************
+*     OPFILE  reads the options file from unit  IOPTNS  and loads the
+*     options into the relevant elements of the integer and real
+*     parameter arrays.
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     This version dated December 18, 1985.
+************************************************************************
+      LOGICAL             PRNT
+      CHARACTER*16        KEY   , TOKEN(1)
+      CHARACTER*72        BUFFER, OLDBUF
+
+      PRNT   = .TRUE.
+
+*     Return if the unit number is out of range.
+
+      IF (IOPTNS .LT. 0  .OR.  IOPTNS .GT. 99) THEN
+         INFORM = 1
+         RETURN
+      END IF
+
+*     ------------------------------------------------------------------
+*     Look for  BEGIN, ENDRUN  or  SKIP.
+*     ------------------------------------------------------------------
+      NREAD  = 0
+   50    READ (IOPTNS, '(A)', END = 930) BUFFER
+         NREAD = NREAD + 1
+         NKEY  = 1
+         CALL OPTOKN( BUFFER, NKEY, TOKEN )
+         KEY   = TOKEN(1)
+         IF (KEY .EQ. 'ENDRUN') GO TO 940
+         IF (KEY .NE. 'BEGIN' ) THEN
+            IF (NREAD .EQ. 1  .AND.  KEY .NE. 'SKIP') THEN
+               WRITE (NOUT, 2000) IOPTNS, BUFFER
+            END IF
+            GO TO 50
+         END IF
+
+*     ------------------------------------------------------------------
+*     BEGIN found.
+*     This is taken to be the first line of an OPTIONS file.
+*     Read the second line to see if it is NOLIST.
+*     ------------------------------------------------------------------
+      OLDBUF = BUFFER
+      READ (IOPTNS, '(A)', END = 920) BUFFER
+
+      CALL OPKEY ( NOUT, BUFFER, KEY )
+
+      IF (KEY .EQ. 'NOLIST') THEN
+         PRNT   = .FALSE.
+      END IF
+
+      IF (PRNT) THEN
+         WRITE (NOUT, '(// A / A /)')
+     $      ' OPTIONS file',
+     $      ' ------------'
+         WRITE (NOUT, '(6X, A )') OLDBUF, BUFFER
+      END IF
+
+*     ------------------------------------------------------------------
+*     Read the rest of the file.
+*     ------------------------------------------------------------------
+*+    while (key .ne. 'end') loop
+  100 IF    (KEY .NE. 'END') THEN
+         READ (IOPTNS, '(A)', END = 920) BUFFER
+         IF (PRNT)
+     $      WRITE (NOUT, '( 6X, A )') BUFFER
+
+         CALL OPKEY ( NOUT, BUFFER, KEY )
+
+         IF (KEY .EQ.   'LIST') PRNT = .TRUE.
+         IF (KEY .EQ. 'NOLIST') PRNT = .FALSE.
+         GO TO 100
+      END IF
+*+    end while
+
+      INFORM =  0
+      RETURN
+
+  920 WRITE (NOUT, 2200) IOPTNS
+      INFORM = 2
+      RETURN
+
+  930 WRITE (NOUT, 2300) IOPTNS
+      INFORM = 3
+      RETURN
+
+  940 WRITE (NOUT, '(// 6X, A)') BUFFER
+      INFORM = 4
+      RETURN
+
+ 2000 FORMAT(
+     $ //' XXX  Error while looking for an OPTIONS file on unit', I7
+     $ / ' XXX  The file should start with BEGIN, SKIP or ENDRUN'
+     $ / ' XXX  but the first record found was the following:'
+     $ //' ---->', A
+     $ //' XXX  Continuing to look for OPTIONS file...')
+ 2200 FORMAT(//' XXX  End-of-file encountered while processing',
+     $         ' an OPTIONS file on unit', I6)
+ 2300 FORMAT(//' XXX  End-of-file encountered while looking for',
+     $         ' an OPTIONS file on unit', I6)
+
+*     End of  OPFILE.
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/oplook.f
@@ -0,0 +1,314 @@
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C
+      SUBROUTINE OPLOOK (NDICT, DICTRY, ALPHA, KEY, ENTRY)
+C
+C
+C Description and usage:
+C
+C       Performs dictionary lookups.  A pointer is returned if a
+C    match is found between the input key and the corresponding
+C    initial characters of one of the elements of the dictionary.
+C    If a "synonym" has been provided for an entry, the search is
+C    continued until a match to a primary dictionary entry is found.
+C    Cases of no match, or multiple matches, are also provided for.
+C
+C     Dictionary entries must be left-justified, and may be alphabetized
+C    for faster searches.  Secondary entries, if any, are composed of
+C    two words separated by one or more characters such as blank, tab,
+C    comma, colon, or equal sign which are treated as non-significant
+C    by OPSCAN.  The first entry of each such pair serves as a synonym
+C    for the second, more fundamental keyword.
+C
+C       The ordered search stops after the section of the dictionary
+C    having the same first letters as the key has been checked, or
+C    after a specified number of entries have been examined.  A special
+C    dictionary entry, the vertical bar '|', will also terminate the
+C    search.  This will speed things up if an appropriate dictionary
+C    length parameter cannot be determined.  Both types of search are
+C    sequential.  See "Notes" below for some suggestions if efficiency
+C    is an issue.
+C
+C
+C Parameters:
+C
+C    Name    Dimension  Type  I/O/S  Description
+C    NDICT               I    I      Number of dictionary entries to be
+C                                    examined.
+C    DICTRY  NDICT       C    I      Array of dictionary entries,
+C                                    left-justified in their fields.
+C                                    May be alphabetized for efficiency,
+C                                    in which case ALPHA should be
+C                                    .TRUE.  Entries with synonyms are
+C                                    of the form
+C                                    'ENTRY : SYNONYM', where 'SYNONYM'
+C                                    is a more fundamental entry in the
+C                                    same dictionary.  NOTE: Don't build
+C                                    "circular" dictionaries!
+C    ALPHA               L    I      Indicates whether the dictionary
+C                                    is in alphabetical order, in which
+C                                    case the search can be terminated
+C                                    sooner.
+C    KEY                 C    I/O    String to be compared against the
+C                                    dictionary.  Abbreviations are OK
+C                                    if they correspond to a unique
+C                                    entry in the dictionary.  KEY is
+C                                    replaced on termination by its most
+C                                    fundamental equivalent dictionary
+C                                    entry (uppercase, left-justified)
+C                                    if a match was found.
+C    ENTRY               I      O    Dictionary pointer.  If > 0, it
+C                                    indicates which entry matched KEY.
+C                                    In case of trouble, a negative
+C                                    value means that a UNIQUE match
+C                                    was not found - the absolute value
+C                                    of ENTRY points to the second
+C                                    dictionary entry that matched KEY.
+C                                    Zero means that NO match could be
+C                                    found.  ENTRY always refers to the
+C                                    last search performed -
+C                                    in searching a chain of synonyms,
+C                                    a non-positive value will be
+C                                    returned if there is any break,
+C                                    even if the original input key
+C                                    was found.
+C
+C
+C External references:
+C
+C    Name    Description
+C    OPSCAN  Finds first and last significant characters.
+C
+C
+C Environment:  Digital VAX-11/780 VMS FORTRAN (FORTRAN 77).
+C               Appears to satisfy the ANSI Fortran 77 standard.
+C
+C
+C Notes:
+C
+C    (1)  IMPLICIT NONE is non-standard.  (Has been commented out.)
+C
+C    (2)  We have assumed that the dictionary is not too big.  If
+C         many searches are to be done or if the dictionary has more
+C         than a dozen or so entries, it may be advantageous to build
+C         an index array of pointers to the beginning of the section
+C         of the dictionary containing each letter, then pass in the
+C         portion of the dictionary beginning with DICTRY (INDEX).
+C         (This won't generally work for dictionaries with synonyms.)
+C         For very large problems, a completely different approach may
+C         be advisable, e.g. a binary search for ordered dictionaries.
+C
+C    (3)  OPLOOK is case sensitive.  In most applications it will be
+C         necessary to use an uppercase dictionary, and to convert the
+C         input key to uppercase before calling OPLOOK.  Companion
+C         routines OPTOKN and PAIRS, available from the author, already
+C         take care of this.
+C
+C    (4)  The key need not be left-justified.  Any leading (or
+C         trailing) characters which are "non-significant" to OPSCAN
+C         will be ignored.  These include blanks, horizontal tabs,
+C         commas, colons, and equal signs.  See OPSCAN for details.
+C
+C    (5)  The ASCII collating sequence for character data is assumed.
+C         (N.B. This means the numerals precede the alphabet, unlike
+C         common practice!)  This should not cause trouble on EBCDIC
+C         machines if DICTRY just contains alphabetic keywords.
+C         Otherwise it may be necessary to use the FORTRAN lexical
+C         library routines to force use of the ASCII sequence.
+C
+C    (6)  Parameter NUMSIG sets a limit on the length of significant
+C         dictionary entries.  Special applications may require that
+C         this be increased.  (It is 16 in the present version.)
+C
+C    (7)  No protection against "circular" dictionaries is provided:
+C         don't claim that A is B, and that B is A.  All synonym chains
+C         must terminate!  Other potential errors not checked for
+C         include duplicate or mis-ordered entries.
+C
+C    (8)  The handling of ambiguities introduces some ambiguity:
+C
+C            ALPHA = .TRUE.  A potential problem, when one entry
+C                            looks like an abbreviation for another
+C                            (eg. does 'A' match 'A' or 'AB'?) was
+C                            resolved by dropping out of the search
+C                            immediately when an "exact" match is found.
+C
+C            ALPHA = .FALSE. The programmer must ensure that the above
+C                            situation does not arise: each dictionary
+C                            entry must be recognizable, at least when
+C                            specified to full length.  Otherwise, the
+C                            result of a search will depend on the
+C                            order of entries.
+C
+C
+C Author:  Robert Kennelly, Informatics General Corporation.
+C
+C
+C Development history:
+C
+C    24 Feb. 1984  RAK/DAS  Initial design and coding.
+C    25 Feb. 1984    RAK    Combined the two searches by suitable
+C                           choice of terminator FLAG.
+C    28 Feb. 1984    RAK    Optional synonyms in dictionary, no
+C                           longer update KEY.
+C    29 Mar. 1984    RAK    Put back replacement of KEY by its
+C                           corresponding entry.
+C    21 June 1984    RAK    Corrected bug in error handling for cases
+C                           where no match was found.
+C    23 Apr. 1985    RAK    Introduced test for exact matches, which
+C                           permits use of dictionary entries which
+C                           would appear to be ambiguous (for ordered
+C                           case).  Return -I to point to the entry
+C                           which appeared ambiguous (had been -1).
+C                           Repaired loop termination - had to use
+C                           equal length strings or risk quitting too
+C                           soon when one entry is an abbreviation
+C                           for another.  Eliminated HIT, reduced
+C                           NUMSIG to 16.
+C    15 Nov. 1985    MAS    Loop 20 now tests .LT. FLAG, not .LE. FLAG.
+C                           If ALPHA is false, FLAG is now '|', not '{'.
+C    26 Jan. 1986    PEG    Declaration of FLAG and TARGET modified to
+C                           conform to ANSI-77 standard.
+C-----------------------------------------------------------------------
+
+
+C     Variable declarations.
+C     ----------------------
+
+*     IMPLICIT NONE
+
+C     Parameters.
+
+      INTEGER
+     $   NUMSIG
+      CHARACTER
+     $   BLANK, VBAR
+      PARAMETER
+     $   (BLANK = ' ', VBAR = '|', NUMSIG = 16)
+
+C     Variables.
+
+      LOGICAL
+     $   ALPHA
+      INTEGER
+     $   ENTRY, FIRST, I, LAST, LENGTH, MARK, NDICT
+*     CHARACTER
+*    $   DICTRY (NDICT) * (*), FLAG * (NUMSIG),
+*    $   KEY * (*), TARGET * (NUMSIG)
+      CHARACTER
+     $   DICTRY (NDICT) * (*), FLAG * 16,
+     $   KEY * (*), TARGET * 16
+
+C     Procedures.
+
+      EXTERNAL
+     $   OPSCAN
+
+
+C     Executable statements.
+C     ----------------------
+
+      ENTRY = 0
+
+C     Isolate the significant portion of the input key (if any).
+
+      FIRST = 1
+      LAST  = MIN( LEN(KEY), NUMSIG )
+      CALL OPSCAN (KEY, FIRST, LAST, MARK)
+
+      IF (MARK .GT. 0) THEN
+         TARGET = KEY (FIRST:MARK)
+
+C        Look up TARGET in the dictionary.
+
+   10    CONTINUE
+            LENGTH = MARK - FIRST + 1
+
+C           Select search strategy by cunning choice of termination test
+C           flag.  The vertical bar is just about last in both the
+C           ASCII and EBCDIC collating sequences.
+
+            IF (ALPHA) THEN
+               FLAG = TARGET
+            ELSE
+               FLAG = VBAR
+            END IF
+
+
+C           Perform search.
+C           ---------------
+
+            I = 0
+   20       CONTINUE
+               I = I + 1
+               IF (TARGET (1:LENGTH) .EQ. DICTRY (I) (1:LENGTH)) THEN
+                  IF (ENTRY .EQ. 0) THEN
+
+C                    First "hit" - must still guard against ambiguities
+C                    by searching until we've gone beyond the key
+C                    (ordered dictionary) or until the end-of-dictionary
+C                    mark is reached (exhaustive search).
+
+                     ENTRY = I
+
+C                    Special handling if match is exact - terminate
+C                    search.  We thus avoid confusion if one dictionary
+C                    entry looks like an abbreviation of another.
+C                    This fix won't generally work for un-ordered
+C                    dictionaries!
+
+                     FIRST = 1
+                     LAST = NUMSIG
+                     CALL OPSCAN (DICTRY (ENTRY), FIRST, LAST, MARK)
+                     IF (MARK .EQ. LENGTH) I = NDICT
+                  ELSE
+
+
+C                    Oops - two hits!  Abnormal termination.
+C                    ---------------------------------------
+
+                     ENTRY = -I
+                     RETURN
+                  END IF
+               END IF
+
+C           Check whether we've gone past the appropriate section of the
+C           dictionary.  The test on the index provides insurance and an
+C           optional means for limiting the extent of the search.
+
+            IF (DICTRY (I) (1:LENGTH) .LT. FLAG  .AND.  I .LT. NDICT)
+     $         GO TO 20
+
+
+C           Check for a synonym.
+C           --------------------
+
+            IF (ENTRY .GT. 0) THEN
+
+C              Look for a second entry "behind" the first entry.  FIRST
+C              and MARK were determined above when the hit was detected.
+
+               FIRST = MARK + 2
+               CALL OPSCAN (DICTRY (ENTRY), FIRST, LAST, MARK)
+               IF (MARK .GT. 0) THEN
+
+C                 Re-set target and dictionary pointer, then repeat the
+C                 search for the synonym instead of the original key.
+
+                  TARGET = DICTRY (ENTRY) (FIRST:MARK)
+                  ENTRY = 0
+                  GO TO 10
+
+               END IF
+            END IF
+
+      END IF
+      IF (ENTRY .GT. 0) KEY = DICTRY (ENTRY)
+
+
+C     Normal termination.
+C     -------------------
+
+      RETURN
+
+C     End of OPLOOK
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/opnumb.f
@@ -0,0 +1,102 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      FUNCTION OPNUMB( STRING )
+
+      LOGICAL          OPNUMB
+      CHARACTER*(*)    STRING
+
+************************************************************************
+*     Description and usage:
+*
+*        A simple(-minded) test for numeric data is implemented by
+*        searching an input string for legitimate characters:
+*                digits 0 to 9, D, E, -, + and .
+*        Insurance is provided by requiring that a numeric string
+*        have at least one digit, at most one D, E or .
+*        and at most two -s or +s.  Note that a few ambiguities remain:
+*
+*           (a)  A string might have the form of numeric data but be
+*                intended as text.  No general test can hope to detect
+*                such cases.
+*
+*           (b)  There is no check for correctness of the data format.
+*                For example a meaningless string such as 'E1.+2-'
+*                will be accepted as numeric.
+*
+*        Despite these weaknesses, the method should work in the
+*        majority of cases.
+*
+*
+*     Parameters:
+*
+*        Name    Dimension  Type  I/O/S  Description
+*        OPNUMB              L      O    Set .TRUE. if STRING appears
+*                                        to be numerical data.
+*        STRING              C    I      Input data to be tested.
+*
+*
+*     Environment:  ANSI FORTRAN 77.
+*
+*
+*     Notes:
+*
+*        (1)  It is assumed that STRING is a token extracted by
+*             OPTOKN, which will have converted any lower-case
+*             characters to upper-case.
+*
+*        (2)  OPTOKN pads STRING with blanks, so that a genuine
+*             number is of the form  '1234        '.
+*             Hence, the scan of STRING stops at the first blank.
+*
+*        (3)  COMPLEX data with parentheses will not look numeric.
+*
+*
+*     Systems Optimization Laboratory, Stanford University.
+*     12 Nov  1985    Initial design and coding, starting from the
+*                     routine ALPHA from Informatics General, Inc.
+************************************************************************
+
+      LOGICAL         NUMBER
+      INTEGER         J, LENGTH, NDIGIT, NEXP, NMINUS, NPLUS, NPOINT
+      CHARACTER*1     ATOM
+
+      NDIGIT = 0
+      NEXP   = 0
+      NMINUS = 0
+      NPLUS  = 0
+      NPOINT = 0
+      NUMBER = .TRUE.
+      LENGTH = LEN (STRING)
+      J      = 0
+
+   10    J    = J + 1
+         ATOM = STRING (J:J)
+         IF      (ATOM .GE. '0'  .AND.  ATOM .LE. '9') THEN
+            NDIGIT = NDIGIT + 1
+         ELSE IF (ATOM .EQ. 'D'  .OR.   ATOM .EQ. 'E') THEN
+            NEXP   = NEXP   + 1
+         ELSE IF (ATOM .EQ. '-') THEN
+            NMINUS = NMINUS + 1
+         ELSE IF (ATOM .EQ. '+') THEN
+            NPLUS  = NPLUS  + 1
+         ELSE IF (ATOM .EQ. '.') THEN
+            NPOINT = NPOINT + 1
+         ELSE IF (ATOM .EQ. ' ') THEN
+            J      = LENGTH
+         ELSE
+            NUMBER = .FALSE.
+         END IF
+
+         IF (NUMBER  .AND.  J .LT. LENGTH) GO TO 10
+
+      OPNUMB = NUMBER
+     $         .AND.  NDIGIT .GE. 1
+     $         .AND.  NEXP   .LE. 1
+     $         .AND.  NMINUS .LE. 2
+     $         .AND.  NPLUS  .LE. 2
+     $         .AND.  NPOINT .LE. 1
+
+      RETURN
+
+*     End of OPNUMB
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/opscan.f
@@ -0,0 +1,158 @@
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C
+      SUBROUTINE OPSCAN (STRING, FIRST, LAST, MARK)
+C
+C
+C Description and usage:
+C
+C       Looks for non-blank fields ("tokens") in a string, where the
+C    fields are of arbitrary length, separated by blanks, tabs, commas,
+C    colons, or equal signs.  The position of the end of the 1st token
+C    is also returned, so this routine may be conveniently used within
+C    a loop to process an entire line of text.
+C
+C       The procedure examines a substring, STRING (FIRST : LAST), which
+C    may of course be the entire string (in which case just call OPSCAN
+C    with FIRST <= 1 and LAST >= LEN (STRING) ).  The indices returned
+C    are relative to STRING itself, not the substring.
+C
+C
+C Parameters:
+C
+C    Name    Dimension  Type  I/O/S  Description
+C    STRING              C    I      Text string containing data to be
+C                                    scanned.
+C    FIRST               I    I/O    Index of beginning of substring.
+C                                    If <= 1, the search begins with 1.
+C                                    Output is index of beginning of
+C                                    first non-blank field, or 0 if no
+C                                    token was found.
+C    LAST                I    I/O    Index of end of substring.
+C                                    If >= LEN (STRING), the search
+C                                    begins with LEN (STRING).  Output
+C                                    is index of end of last non-blank
+C                                    field, or 0 if no token was found.
+C    MARK                I      O    Points to end of first non-blank
+C                                    field in the specified substring.
+C                                    Set to 0 if no token was found.
+C
+C
+C Environment:  Digital VAX-11/780 VMS FORTRAN (FORTRAN 77).
+C               ANSI Fortran 77, except for the tab character HT.
+C
+C Notes:
+C
+C    (1)  IMPLICIT NONE is non-standard.  Constant HT (Tab) is defined
+C         in a non-standard way:  the CHAR function is not permitted
+C         in a PARAMETER declaration (OK on VAX, though).  For Absoft
+C         FORTRAN 77 on 68000 machines, use HT = 9.  In other cases, it
+C         may be best to declare HT as a variable and assign
+C         HT = CHAR(9) on ASCII machines, or CHAR(5) for EBCDIC.
+C
+C    (2)  The pseudo-recursive structure was chosen for fun.  It is
+C         equivalent to three DO loops with embedded GO TOs in sequence.
+C
+C    (3)  The variety of separators recognized limits the usefulness of
+C         this routine somewhat.  The intent is to facilitate handling
+C         such tokens as keywords or numerical values.  In other
+C         applications, it may be necessary for ALL printing characters
+C         to be significant.  A simple modification to statement
+C         function SOLID will do the trick.
+C
+C
+C Author:  Robert Kennelly, Informatics General Corporation.
+C
+C
+C Development history:
+C
+C    29 Dec. 1984    RAK    Initial design and coding, (very) loosely
+C                           based on SCAN_STRING by Ralph Carmichael.
+C    25 Feb. 1984    RAK    Added ':' and '=' to list of separators.
+C    16 Apr. 1985    RAK    Defined SOLID in terms of variable DUMMY
+C                           (previous re-use of STRING was ambiguous).
+C
+C-----------------------------------------------------------------------
+
+
+C     Variable declarations.
+C     ----------------------
+
+*     IMPLICIT NONE
+
+C     Parameters.
+
+      CHARACTER
+     $   BLANK, EQUAL, COLON, COMMA, HT
+      PARAMETER
+     $   (BLANK = ' ', EQUAL = '=', COLON = ':', COMMA = ',')
+
+C     Variables.
+
+      LOGICAL
+     $   SOLID
+      INTEGER
+     $   BEGIN, END, FIRST, LAST, LENGTH, MARK
+      CHARACTER
+     $   DUMMY, STRING * (*)
+
+C     Statement functions.
+
+      SOLID (DUMMY) = (DUMMY .NE. BLANK) .AND.
+     $                (DUMMY .NE. COLON) .AND.
+     $                (DUMMY .NE. COMMA) .AND.
+     $                (DUMMY .NE. EQUAL) .AND.
+     $                (DUMMY .NE. HT)
+
+
+C     Executable statements.
+C     ----------------------
+
+****  HT     = CHAR(9) for ASCII machines, CHAR(5) for EBCDIC.
+      HT     = CHAR(9)
+      MARK   = 0
+      LENGTH = LEN (STRING)
+      BEGIN  = MAX (FIRST, 1)
+      END    = MIN (LENGTH, LAST)
+
+C     Find the first significant character ...
+
+      DO 30 FIRST = BEGIN, END, +1
+         IF (SOLID (STRING (FIRST : FIRST))) THEN
+
+C           ... then the end of the first token ...
+
+            DO 20 MARK = FIRST, END - 1, +1
+               IF (.NOT.SOLID (STRING (MARK + 1 : MARK + 1))) THEN
+
+C                 ... and finally the last significant character.
+
+                  DO 10 LAST = END, MARK, -1
+                     IF (SOLID (STRING (LAST : LAST))) THEN
+                        RETURN
+                     END IF
+   10             CONTINUE
+
+C                 Everything past the first token was a separator.
+
+                  LAST = LAST + 1
+                  RETURN
+               END IF
+   20       CONTINUE
+
+C           There was nothing past the first token.
+
+            LAST = MARK
+            RETURN
+         END IF
+   30 CONTINUE
+
+C     Whoops - the entire substring STRING (BEGIN : END) was composed of
+C     separators !
+
+      FIRST = 0
+      MARK = 0
+      LAST = 0
+      RETURN
+
+C     End of OPSCAN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/optokn.f
@@ -0,0 +1,126 @@
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C
+      SUBROUTINE OPTOKN (STRING, NUMBER, LIST)
+C
+C
+C Description and usage:
+C
+C       An aid to parsing input data.  The individual "tokens" in a
+C    character string are isolated, converted to uppercase, and stored
+C    in an array.  Here, a token is a group of significant, contiguous
+C    characters.  The following are NON-significant, and hence may
+C    serve as separators:  blanks, horizontal tabs, commas, colons,
+C    and equal signs.  See OPSCAN for details.  Processing continues
+C    until the requested number of tokens have been found or the end
+C    of the input string is reached.
+C
+C
+C Parameters:
+C
+C    Name    Dimension  Type  I/O/S  Description
+C    STRING              C    I      Input string to be analyzed.
+C    NUMBER              I    I/O    Number of tokens requested (input)
+C                                    and found (output).
+C    LIST    NUMBER      C      O    Array of tokens, changed to upper
+C                                    case.
+C
+C
+C External references:
+C
+C    Name    Description
+C    OPSCAN  Finds positions of first and last significant characters.
+C    OPUPPR  Converts a string to uppercase.
+C
+C
+C Environment:  Digital VAX-11/780 VMS FORTRAN (FORTRAN 77).
+C               Appears to satisfy the ANSI Fortran 77 standard.
+C
+C
+C Notes:
+C
+C    (1)  IMPLICIT NONE is non-standard.  (Has been commented out.)
+C
+C
+C Author:  Robert Kennelly, Informatics General Corporation.
+C
+C
+C Development history:
+C
+C    16 Jan. 1984    RAK    Initial design and coding.
+C    16 Mar. 1984    RAK    Revised header to reflect full list of
+C                           separators, repaired faulty WHILE clause
+C                           in "10" loop.
+C    18 Sep. 1984    RAK    Change elements of LIST to uppercase one
+C                           at a time, leaving STRING unchanged.
+C
+C-----------------------------------------------------------------------
+
+
+C     Variable declarations.
+C     ----------------------
+
+*     IMPLICIT NONE
+
+C     Parameters.
+
+      CHARACTER
+     $   BLANK
+      PARAMETER
+     $   (BLANK = ' ')
+
+C     Variables.
+
+      INTEGER
+     $   COUNT, FIRST, I, LAST, MARK, NUMBER
+      CHARACTER
+     $   STRING * (*), LIST (NUMBER) * (*)
+
+C     Procedures.
+
+      EXTERNAL
+     $   OPUPPR, OPSCAN
+
+
+C     Executable statements.
+C     ----------------------
+
+C     WHILE there are tokens to find, loop UNTIL enough have been found.
+
+      FIRST = 1
+      LAST = LEN (STRING)
+
+      COUNT = 0
+   10 CONTINUE
+
+C        Get delimiting indices of next token, if any.
+
+         CALL OPSCAN (STRING, FIRST, LAST, MARK)
+         IF (LAST .GT. 0) THEN
+            COUNT = COUNT + 1
+
+C           Pass token to output string array, then change case.
+
+            LIST (COUNT) = STRING (FIRST : MARK)
+            CALL OPUPPR (LIST (COUNT))
+            FIRST = MARK + 2
+            IF (COUNT .LT. NUMBER) GO TO 10
+
+         END IF
+
+
+C     Fill the rest of LIST with blanks and set NUMBER for output.
+
+      DO 20 I = COUNT + 1, NUMBER
+         LIST (I) = BLANK
+   20 CONTINUE
+
+      NUMBER = COUNT
+
+
+C     Termination.
+C     ------------
+
+      RETURN
+
+C     End of OPTOKN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/opuppr.f
@@ -0,0 +1,58 @@
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C
+      SUBROUTINE OPUPPR(STRING)
+C
+C ACRONYM:  UPper CASE
+C
+C PURPOSE:  This subroutine changes all lower case letters in the
+C           character string to upper case.
+C
+C METHOD:   Each character in STRING is treated in turn.  The intrinsic
+C           function INDEX effectively allows a table lookup, with
+C           the local strings LOW and UPP acting as two tables.
+C           This method avoids the use of CHAR and ICHAR, which appear
+C           be different on ASCII and EBCDIC machines.
+C
+C ARGUMENTS
+C    ARG       DIM     TYPE I/O/S DESCRIPTION
+C  STRING       *       C   I/O   Character string possibly containing
+C                                 some lower-case letters on input;
+C                                 strictly upper-case letters on output
+C                                 with no change to any non-alphabetic
+C                                 characters.
+C
+C EXTERNAL REFERENCES:
+C  LEN    - Returns the declared length of a CHARACTER variable.
+C  INDEX  - Returns the position of second string within first.
+C
+C ENVIRONMENT:  ANSI FORTRAN 77
+C
+C DEVELOPMENT HISTORY:
+C     DATE  INITIALS  DESCRIPTION
+C   06/28/83   CLH    Initial design.
+C   01/03/84   RAK    Eliminated NCHAR input.
+C   06/14/84   RAK    Used integer PARAMETERs in comparison.
+C   04/21/85   RAK    Eliminated DO/END DO in favor of standard code.
+C   09/10/85   MAS    Eliminated CHAR,ICHAR in favor of LOW, UPP, INDEX.
+C
+C AUTHOR: Charles Hooper, Informatics General, Palo Alto, CA.
+C
+C-----------------------------------------------------------------------
+
+      CHARACTER      STRING * (*)
+      INTEGER        I, J
+      CHARACTER      C*1, LOW*26, UPP*26
+      DATA           LOW /'abcdefghijklmnopqrstuvwxyz'/,
+     $               UPP /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
+
+      DO 10 J = 1, LEN(STRING)
+         C    = STRING(J:J)
+         IF (C .GE. 'a'  .AND.  C .LE. 'z') THEN
+            I           = INDEX( LOW, C )
+            IF (I .GT. 0) STRING(J:J) = UPP(I:I)
+         END IF
+   10 CONTINUE
+      RETURN
+
+*     End of OPUPPR
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/srchc.f
@@ -0,0 +1,621 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+*     File  SRSUBS FORTRAN
+*
+*     SRCHC    SRCHQ
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE SRCHC ( DEBUG, DONE, FIRST, IMPRVD, INFORM,
+     $                   ALFMAX, EPSAF, ETA,
+     $                   XTRY, FTRY, GTRY, OLDF, OLDG,
+     $                   TOLABS, TOLREL, TOLTNY,
+     $                   ALFA, ALFBST, FBEST, GBEST )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      LOGICAL            DEBUG , DONE  , FIRST , IMPRVD
+
+************************************************************************
+*  SRCHC   is a  step-length  algorithm for minimizing a function of one
+*  variable.  It will be called  repeatedly  by a  search  routine whose
+*  purpose is to  estimate a point  ALFA = ALFBST  that  minimizes  some
+*  function  F(alfa)  over the closed interval (0, ALFMAX).
+*
+*  SRCHC  requires both the function  F(alfa)  and its gradient  G(alfa)
+*  to be  evaluated  at various  points within  the interval.  New step-
+*  length  estimates  are  computed  using  cubic  interpolation  with
+*  safeguards.
+*
+*  Reverse communication is used to allow the calling program to
+*  evaluate F and G.  Some of the parameters must be set or tested
+*  by the calling program.  the remainder would ordinarily be local
+*  variables.
+*
+*
+*  Input parameters (relevant to the calling program)
+*  --------------------------------------------------
+*
+*  DEBUG         specifies whether detailed output is wanted.
+*
+*  FIRST         must be .TRUE. on the first entry. It is subsequently
+*                altered by SRCHC.
+*
+*  MFSRCH        is an upper limit on the number of times SRCHC is to be
+*                entered consecutively with DONE = .FALSE. (following
+*                an initial entry with FIRST = .TRUE..
+*
+*  ALFA          is the first estimate of the step length.  ALFA is
+*                subsequently altered by SRCHC (see below).
+*
+*  ALFMAX        is the upper limit of the interval to be searched.
+*
+*  EPSAF         is an estimate of the absolute precision in the
+*                computed value of F.
+*
+*  ETA           controls the accuracy of the search.  It must lie
+*                in the range   0.0  le  ETA  lt  1.0.  Decreasing
+*                ETA  tends to increase the accuracy of the search.
+*
+*  FTRY, GTRY    are the values of F, G  at the new point
+*                ALFA = ALFBST + XTRY.
+*
+*  OLDF, OLDG    are the values of F(0) and G(0). OLDG must be negative.
+*
+*  TOLABS,TOLREL define a function TOL(ALFA) = TOLREL*ALFA + TOLABS such
+*                that if F has already been evaluated at step ALFA,  it
+*                will not be evaluated closer than TOL(ALFA).  These
+*                values may be reduced by SRCHC.
+*
+*  TOLTNY        is the smallest value that TOLABS is allowed to be
+*                reduced to.
+*
+*
+*  Output parameters (relevant to the calling program)
+*  ---------------------------------------------------
+*
+*  IMPRVD        is true if the previous step ALFA was the best point
+*                so far.  Any related quantities should be saved by the
+*                calling program (e.g., gradient arrays) before paying
+*                attention to DONE.
+*
+*  DONE = FALSE  means the calling program should evaluate
+*                      FTRY = F(ALFA),  GTRY = G(ALFA)
+*                for the new trial step ALFA, and then re-enter SRCHC.
+*
+*  DONE = TRUE   means that no new steplength was calculated.  The value
+*                of INFORM gives the result of the linesearch as follows
+*
+*                INFORM = 1 means the search has terminated successfully
+*                           with ALFBST less than ALFMAX.
+*
+*                INFORM = 2 means the search has terminated successfully
+*                           with ALFBST = ALFMAX.
+*
+*                INFORM = 3 means that the search failed to find a point
+*                           of sufficient decrease in MFSRCH functions,
+*                           but an improved point was found.
+*
+*                INFORM = 4 means ALFMAX is so small that a search
+*                           should not have been attempted.
+*
+*                INFORM = 5 is never set by SRCHC.
+*
+*                INFORM = 6 means the search has failed to find a useful
+*                           step.  If the function and gradient have
+*                           been programmed correctly, this will usually
+*                           occur if the minimum lies very close to
+*                           ALFA = 0 or the gradient is not sufficiently
+*                           accurate.
+*
+*  NFSRCH        counts the number of times SRCHC has been entered
+*                consecutively with DONE = FALSE (i.e., with a new
+*                function value FTRY).
+*
+*  ALFA          is the step at which the next function FTRY and
+*                gradient GTRY must be computed.
+*
+*  ALFBST        should be accepted by the calling program as the
+*                required step-length estimate, whenever SRCHC returns
+*                INFORM = 1 or 2 (and possibly 3).
+*
+*  FBEST, GBEST  will be the corresponding values of F, G.
+*
+*
+*  The following parameters retain information between entries
+*  -----------------------------------------------------------
+*
+*  ALFUZZ        is such that, if the final ALFA lies in the interval
+*                (0,ALFUZZ)  and  ABS( F(ALFA)-OLDF ).LE.EPSAF,  ALFA
+*                cannot be guaranteed to be a point of sufficient
+*                decrease.
+*
+*  BRAKTD        is false if F and G have not been evaluated at
+*                the far end of the interval of uncertainty.  In this
+*                case, the point B will be at ALFMAX + TOL(ALFMAX).
+*
+*  CRAMPD        is true if ALFMAX is very small (le TOLABS).  If the
+*                search fails, this indicates that a zero step should be
+*                taken.
+*
+*  EXTRAP        is true if XW lies outside the interval of uncertainty.
+*                In this case, extra safeguards are applied to allow for
+*                instability in the polynomial fit.
+*
+*  MOVED         is true if a better point has been found (ALFBST GT 0).
+*
+*  WSET          records whether a second-best point has been determined
+*                It will always be true when convergence is tested.
+*
+*  NSAMEA        is the number of consecutive times that the left-hand
+*                end of the interval of uncertainty has remained the
+*                same.
+*
+*  NSAMEB        similarly for the right-hand end.
+*
+*  A, B, ALFBST  define the current interval of uncertainty.
+*                The required minimum lies somewhere within the
+*                closed interval  (ALFBST + A, ALFBST + B).
+*
+*  ALFBST        is the best point so far.  It is always at one end of
+*                the interval of uncertainty.  Hence we have
+*                either  A lt 0,  B = 0  or  A = 0,  B gt 0.
+*
+*  FBEST, GBEST  are the values of F, G at the point ALFBST.
+*
+*  FACTOR        controls the rate at which extrapolated estimates of
+*                ALFA may expand into the interval of uncertainty.
+*                FACTOR is not used if the minimum has been bracketed
+*                (i.e., when the variable BRAKTD is true).
+*
+*  FW, GW        are the values of F, G at the point ALFBST + XW.
+*                They are not defined until WSET is true.
+*
+*  XTRY          is the trial point within the shifted interval (A, B).
+*
+*  XW            is such that  ALFBST + XW  is the second-best point.
+*                It is not defined until  WSET  is true.
+*                In some cases,  XW  will replace a previous  XW  that
+*                has a lower function but has just been excluded from
+*                the interval of uncertainty.
+*
+*  RMU           controls what is meant by a significant decrease in F.
+*                The final F(ALFBST)  should lie on or below the line
+*                      L(ALFA)  =  OLDF + ALFA*RMU*OLDG.
+*                RMU  should be in the open interval (0, 1/2).
+*                The value  RMU = 1.0E-4  is good for most purposes.
+*
+*  RTMIN         is used to avoid floating-point underflow.  It should
+*                be reasonably close to the square root of the smallest
+*                representable positive number.
+*
+*
+*  Systems Optimization Laboratory, Stanford University, California.
+*  Original version February 1982.  Rev. May 1983.
+*  Original F77 version 22-August-1985.
+*  This version of SRCHC dated 29-June-1986.
+************************************************************************
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      SAVE      /SOLMCH/
+      COMMON    /SOL1CM/ NOUT
+
+      EXTERNAL           DNORM
+      INTRINSIC          ABS   , SQRT
+      LOGICAL            BRAKTD, CRAMPD, EXTRAP, MOVED , WSET
+      SAVE               BRAKTD, CRAMPD, EXTRAP, MOVED , WSET
+
+      SAVE               NFSRCH, NSAMEA, NSAMEB
+      SAVE               A     , B     , ALFUZZ, FACTOR, RTMIN
+      SAVE               XW    , FW    , GW    , TOLMAX
+
+      LOGICAL            CLOSEF, CONV1 , CONV2 , CONVRG
+      LOGICAL            FITOK , SETXW , SIGDEC
+
+      PARAMETER        ( ZERO  =0.0D+0, POINT1 =0.1D+0, HALF   =0.5D+0 )
+      PARAMETER        ( ONE   =1.0D+0, TWO    =2.0D+0, THREE  =3.0D+0 )
+      PARAMETER        ( FIVE  =5.0D+0, TEN    =1.0D+1, ELEVEN =1.1D+1 )
+      PARAMETER        ( RMU   =1.0D-4, MFSRCH =15                     )
+
+*     ------------------------------------------------------------------
+*     Local variables
+*     ===============
+*
+*     CLOSEF     is true if the new function FTRY is within EPSAF of
+*                FBEST (up or down).
+*
+*     CONVRG     will be set to true if at least one of the convergence
+*                conditions holds at ALFBST.
+*
+*     SIGDEC     says whether FBEST represents a significant decrease in
+*                the function, compared to the initial value OLDF.
+*  ---------------------------------------------------------------------
+
+      IMPRVD = .FALSE.
+      IF (FIRST) THEN
+*        ---------------------------------------------------------------
+*        First entry.  Initialize various quantities, check input data
+*        and prepare to evaluate the function at the initial step ALFA.
+*        ---------------------------------------------------------------
+         FIRST  = .FALSE.
+         RTMIN  = WMACH(6)
+
+         NFSRCH = 0
+         ALFBST = ZERO
+         FBEST  = OLDF
+         GBEST  = OLDG
+         CRAMPD = ALFMAX .LE. TOLABS
+         DONE   = ALFMAX .LE. TOLTNY  .OR.  OLDG .GE. ZERO
+         MOVED  = .FALSE.
+
+         IF (.NOT. DONE) THEN
+            BRAKTD = .FALSE.
+            EXTRAP = .FALSE.
+            WSET   = .FALSE.
+            NSAMEA = 0
+            NSAMEB = 0
+            ALFUZZ = ALFMAX
+            IF (TWO*EPSAF .LT. - OLDG*RMU*ALFMAX)
+     $         ALFUZZ = - TWO*EPSAF/(RMU*OLDG)
+
+            TOLMAX = TOLABS + TOLREL*ALFMAX
+            A      = ZERO
+            B      = ALFMAX + TOLMAX
+            FACTOR = FIVE
+            TOL    = TOLABS
+            XTRY   = ALFA
+            IF (DEBUG)
+     $         WRITE (NOUT, 1000) ALFMAX, OLDF , OLDG  , TOLABS,
+     $                            ALFUZZ, EPSAF, TOLREL, CRAMPD
+         END IF
+      ELSE
+*        ---------------------------------------------------------------
+*        Subsequent entries. The function has just been evaluated at
+*        ALFA = ALFBST + XTRY,  giving FTRY and GTRY.
+*        ---------------------------------------------------------------
+         NFSRCH = NFSRCH + 1
+         NSAMEA = NSAMEA + 1
+         NSAMEB = NSAMEB + 1
+
+         IF (.NOT. BRAKTD) THEN
+            TOLMAX = TOLABS + TOLREL*ALFMAX
+            B      = ALFMAX - ALFBST + TOLMAX
+         END IF
+
+*        See if the new step is better.  If ALFA is large enough that
+*        FTRY can be distinguished numerically from OLDF,  the function
+*        is required to be sufficiently decreased.
+
+         IF (ALFA .LE. ALFUZZ) THEN
+            SIGDEC = FTRY - OLDF                 .LE. EPSAF
+         ELSE
+            SIGDEC = FTRY - OLDF - ALFA*RMU*OLDG .LE. EPSAF
+         END IF
+         CLOSEF = ABS( FTRY - FBEST ) .LE.    EPSAF
+         IMPRVD =    ( FTRY - FBEST ) .LE. (- EPSAF)
+         IF (CLOSEF) IMPRVD = ABS( GTRY ) .LE. ABS( GBEST )
+         IMPRVD = IMPRVD  .AND.  SIGDEC
+
+         IF (DEBUG) WRITE (NOUT, 1100)
+     $      ALFA, FTRY, GTRY, FTRY - OLDF - ALFA*RMU*OLDG
+
+         IF (IMPRVD) THEN
+
+*           We seem to have an improvement.  The new point becomes the
+*           origin and other points are shifted accordingly.
+
+            FW     = FBEST
+            FBEST  = FTRY
+            GW     = GBEST
+            GBEST  = GTRY
+            ALFBST = ALFA
+            MOVED  = .TRUE.
+
+            A      = A    - XTRY
+            B      = B    - XTRY
+            XW     = ZERO - XTRY
+            WSET   = .TRUE.
+            EXTRAP =       XW .LT. ZERO  .AND.  GBEST .LT. ZERO
+     $               .OR.  XW .GT. ZERO  .AND.  GBEST .GT. ZERO
+
+*           Decrease the length of the interval of uncertainty.
+
+            IF (GTRY .LE. ZERO) THEN
+               A      = ZERO
+               NSAMEA = 0
+            ELSE
+               B      = ZERO
+               NSAMEB = 0
+               BRAKTD = .TRUE.
+            END IF
+         ELSE
+
+*           The new function value is not better than the best point so
+*           far.  The origin remains unchanged but the new point may
+*           qualify as XW.  XTRY must be a new bound on the best point.
+
+            IF (XTRY .LE. ZERO) THEN
+               A      = XTRY
+               NSAMEA = 0
+            ELSE
+               B      = XTRY
+               NSAMEB = 0
+               BRAKTD = .TRUE.
+            END IF
+
+*           If XW has not been set or FTRY is better than FW, update the
+*           points accordingly.
+
+            SETXW = .TRUE.
+            IF (WSET)
+     $         SETXW = FTRY .LE. FW + EPSAF  .OR.  .NOT. EXTRAP
+
+            IF (SETXW) THEN
+               XW     = XTRY
+               FW     = FTRY
+               GW     = GTRY
+               WSET   = .TRUE.
+               EXTRAP = .FALSE.
+            END IF
+         END IF
+
+*        ---------------------------------------------------------------
+*        Check the termination criteria.  WSET will always be true.
+*        ---------------------------------------------------------------
+         TOL    = TOLABS + TOLREL*ALFBST
+
+         IF (ALFBST .LE. ALFUZZ) THEN
+            SIGDEC = FBEST - OLDF                   .LE. EPSAF
+         ELSE
+            SIGDEC = FBEST - OLDF - ALFBST*RMU*OLDG .LE. EPSAF
+         END IF
+
+         CONV1  = (B - A) .LE. (TOL + TOL)
+         CONV2  = MOVED  .AND.  SIGDEC
+     $                   .AND.  ABS(GBEST) .LE. ETA*ABS(OLDG)
+         CONVRG = CONV1  .OR.   CONV2
+
+         IF (DEBUG) WRITE (NOUT, 1200)
+     $      ALFBST + A, ALFBST + B, B - A, TOL,
+     $      NSAMEA, NSAMEB, BRAKTD, CLOSEF,
+     $      IMPRVD, CONV1 , CONV2 , EXTRAP,
+     $      ALFBST, FBEST , GBEST , FBEST - OLDF - ALFBST*RMU*OLDG,
+     $      ALFBST + XW, FW, GW
+
+         IF (NFSRCH .GE. MFSRCH) THEN
+            DONE = .TRUE.
+         ELSE IF (CONVRG) THEN
+            IF (MOVED) THEN
+               DONE = .TRUE.
+            ELSE
+
+*              A better point has not yet been found (the step XW is no
+*              better than step zero).  Check that the change in F is
+*              consistent with an X-perturbation of TOL,  the minimum
+*              spacing estimate.  If not, the value of TOL is reduced.
+*              F is larger than EPSAF, the value of TOL is reduced.
+
+               TOL    = TOL/TEN
+               TOLABS = TOL
+               IF (ABS(FW - OLDF) .LE. EPSAF  .OR.  TOL .LE. TOLTNY)
+     $            DONE = .TRUE.
+            END IF
+         END IF
+
+*        ---------------------------------------------------------------
+*        Proceed with the computation of a trial step length.
+*        The choices are...
+*        1. Parabolic fit using gradients only, if the F values are
+*           close.
+*        2. Cubic fit for a minimum, using both function and gradients.
+*        3. Damped cubic or parabolic fit if the regular fit appears to
+*           be consistently over-estimating the distance to the minimum.
+*        4. Bisection, geometric bisection, or a step of  TOL  if
+*           choices 2 or 3 are unsatisfactory.
+*        ---------------------------------------------------------------
+         IF (.NOT. DONE) THEN
+            XMIDPT = HALF*(A + B)
+            S      = ZERO
+            Q      = ZERO
+
+            IF (CLOSEF) THEN
+*              ---------------------------------------------------------
+*              Fit a parabola to the two best gradient values.
+*              ---------------------------------------------------------
+               S      = GBEST
+               Q      = GBEST - GW
+               IF (DEBUG) WRITE (NOUT, 2200)
+            ELSE
+*              ---------------------------------------------------------
+*              Fit cubic through  FBEST  and  FW.
+*              ---------------------------------------------------------
+               IF (DEBUG) WRITE (NOUT, 2100)
+               FITOK  = .TRUE.
+               R      = THREE*(FBEST - FW)/XW + GBEST + GW
+               ABSR   = ABS( R )
+               S      = SQRT( ABS( GBEST ) ) * SQRT( ABS( GW ) )
+               IF (S .LE. RTMIN) THEN
+                  Q   = ABSR
+               ELSE
+
+*                 Compute  Q =  the square root of  R*R - GBEST*GW.
+*                 The method avoids unnecessary underflow and overflow.
+
+                  IF ((GW .LT. ZERO  .AND.  GBEST .GT. ZERO) .OR.
+     $                (GW .GT. ZERO  .AND.  GBEST .LT. ZERO)) THEN
+                     SUMSQ  = ONE
+                     IF (ABSR .LT. S) THEN
+                        IF (ABSR .GE. S*RTMIN) SUMSQ = ONE + (ABSR/S)**2
+                        SCALE  = S
+                     ELSE
+                        IF (S .GE. ABSR*RTMIN) SUMSQ = ONE + (S/ABSR)**2
+                        SCALE  = ABSR
+                     END IF
+                     Q     = DNORM ( SCALE, SUMSQ )
+                  ELSE IF (ABSR .GE. S) THEN
+                     Q     = SQRT(ABSR + S)*SQRT(ABSR - S)
+                  ELSE
+                     FITOK  = .FALSE.
+                  END IF
+
+               END IF
+
+               IF (FITOK) THEN
+
+*                 Compute the minimum of the fitted cubic.
+
+                  IF (XW .LT. ZERO) Q = - Q
+                  S  = GBEST -  R - Q
+                  Q  = GBEST - GW - Q - Q
+               END IF
+            END IF
+
+*           ------------------------------------------------------------
+*           Construct an artificial interval  (ARTIFA, ARTIFB)  in which
+*           the new estimate of the step length must lie.  Set a default
+*           value of XTRY that will be used if the polynomial fit fails.
+*           ------------------------------------------------------------
+            ARTIFA = A
+            ARTIFB = B
+            IF (.NOT. BRAKTD) THEN
+
+*              The minimum has not been bracketed.  Set an artificial
+*              upper bound by expanding the interval  XW  by a suitable
+*              FACTOR.
+
+               XTRY   = - FACTOR*XW
+               ARTIFB =   XTRY
+               IF (ALFBST + XTRY .LT. ALFMAX) FACTOR = FIVE*FACTOR
+
+            ELSE IF (EXTRAP) THEN
+
+*              The points are configured for an extrapolation.
+*              Set a default value of  XTRY  in the interval  (A,B)
+*              that will be used if the polynomial fit is rejected.  In
+*              the following,  DTRY  and  DAUX  denote the lengths of
+*              the intervals  (A,B)  and  (0,XW)  (or  (XW,0),  if
+*              appropriate).  The value of  XTRY is the point at which
+*              the exponents of  DTRY  and  DAUX  are approximately
+*              bisected.
+
+               DAUX = ABS( XW )
+               DTRY = B - A
+               IF (DAUX .GE. DTRY) THEN
+                  XTRY = FIVE*DTRY*(POINT1 + DTRY/DAUX)/ELEVEN
+               ELSE
+                  XTRY = HALF * SQRT( DAUX ) * SQRT( DTRY )
+               END IF
+               IF (XW .GT. ZERO)   XTRY = - XTRY
+               IF (DEBUG) WRITE (NOUT, 2400) XTRY, DAUX, DTRY
+
+*              Reset the artificial bounds.  If the point computed by
+*              extrapolation is rejected,  XTRY will remain at the
+*              relevant artificial bound.
+
+               IF (XTRY .LE. ZERO) ARTIFA = XTRY
+               IF (XTRY .GT. ZERO) ARTIFB = XTRY
+            ELSE
+
+*              The points are configured for an interpolation.  The
+*              default value XTRY bisects the interval of uncertainty.
+*              The artificial interval is just (A,B).
+
+               XTRY   = XMIDPT
+               IF (DEBUG) WRITE (NOUT, 2300) XTRY
+               IF (NSAMEA .GE. 3  .OR.  NSAMEB .GE. 3) THEN
+
+*                 If the interpolation appears to be over-estimating the
+*                 distance to the minimum,  damp the interpolation step.
+
+                  FACTOR = FACTOR / FIVE
+                  S      = FACTOR * S
+               ELSE
+                  FACTOR = ONE
+               END IF
+            END IF
+
+*           ------------------------------------------------------------
+*           The polynomial fits give  (S/Q)*XW  as the new step.
+*           Reject this step if it lies outside  (ARTIFA, ARTIFB).
+*           ------------------------------------------------------------
+            IF (Q .NE. ZERO) THEN
+               IF (Q .LT. ZERO) S = - S
+               IF (Q .LT. ZERO) Q = - Q
+               IF (S*XW .GE. Q*ARTIFA  .AND.  S*XW .LE. Q*ARTIFB) THEN
+
+*                 Accept the polynomial fit.
+
+                  XTRY = ZERO
+                  IF (ABS( S*XW ) .GE. Q*TOL) XTRY = (S/Q)*XW
+                  IF (DEBUG) WRITE (NOUT, 2500) XTRY
+               END IF
+            END IF
+         END IF
+      END IF
+
+*     ==================================================================
+
+      IF (.NOT. DONE) THEN
+         ALFA  = ALFBST + XTRY
+         IF (BRAKTD  .OR.  ALFA .LT. ALFMAX - TOLMAX) THEN
+
+*           The function must not be evaluated too close to A or B.
+*           (It has already been evaluated at both those points.)
+
+            IF (XTRY .LE. A + TOL  .OR.  XTRY .GE. B - TOL) THEN
+               XTRY = TOL
+               IF (HALF*(A + B) .LE. ZERO) XTRY = - TOL
+               ALFA = ALFBST + XTRY
+            END IF
+
+         ELSE
+
+*           The step is close to or larger than ALFMAX, replace it by
+*           ALFMAX to force evaluation of the function at the boundary.
+
+            BRAKTD = .TRUE.
+            XTRY   = ALFMAX - ALFBST
+            ALFA   = ALFMAX
+
+         END IF
+      END IF
+
+*     ------------------------------------------------------------------
+*     Exit.
+*     ------------------------------------------------------------------
+      IF (DONE) THEN
+         IF (MOVED) THEN
+            IF (CONVRG) THEN
+               INFORM = 1
+               IF (ALFA .EQ. ALFMAX) INFORM = 2
+            ELSE
+               INFORM = 3
+            END IF
+         ELSE IF (OLDG .GE. ZERO  .OR.  ALFMAX .LT. TOLTNY) THEN
+            INFORM = 7
+         ELSE
+            INFORM = 6
+            IF (CRAMPD) INFORM = 4
+         END IF
+      END IF
+
+
+      IF (DEBUG) WRITE (NOUT, 3000)
+      RETURN
+
+ 1000 FORMAT(/' ALFMAX  OLDF    OLDG    TOLABS', 1P2E22.14,   1P2E16.8
+     $       /' ALFUZZ  EPSAF           TOLREL', 1P2E22.14,16X,1PE16.8
+     $       /' CRAMPD                        ',  L6)
+ 1100 FORMAT(/' ALFA    FTRY    GTRY    CTRY  ', 1P2E22.14,   1P2E16.8)
+ 1200 FORMAT(/' A       B       B - A   TOL   ', 1P2E22.14,   1P2E16.8
+     $       /' NSAMEA  NSAMEB  BRAKTD  CLOSEF', 2I3, 2L6
+     $       /' IMPRVD  CONVRG  EXTRAP        ',  L6, 3X, 2L1, L6
+     $       /' ALFBST  FBEST   GBEST   CBEST ', 1P2E22.14,   1P2E16.8
+     $       /' ALFAW   FW      GW            ', 1P2E22.14,    1PE16.8/)
+ 2100 FORMAT( ' Cubic.   ')
+ 2200 FORMAT( ' Parabola.')
+ 2300 FORMAT( ' Bisection.              XMIDPT', 1P1E22.14)
+ 2400 FORMAT( ' Geo. bisection. XTRY,DAUX,DTRY', 1P3E22.14)
+ 2500 FORMAT( ' Polynomial fit accepted.  XTRY', 1P1E22.14)
+ 3000 FORMAT( ' ----------------------------------------------------'/)
+
+*     End of  SRCHC .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/npsol/srchq.f
@@ -0,0 +1,669 @@
+*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      SUBROUTINE SRCHQ ( DEBUG, DONE, FIRST, IMPRVD, INFORM,
+     $                   ALFMAX, ALFSML, EPSAF, ETA,
+     $                   XTRY, FTRY, OLDF, OLDG,
+     $                   TOLABS, TOLREL, TOLTNY,
+     $                   ALFA, ALFBST, FBEST )
+
+      IMPLICIT           DOUBLE PRECISION(A-H,O-Z)
+      LOGICAL            DEBUG , DONE  , FIRST , IMPRVD
+
+************************************************************************
+*  SRCHQ  is a step-length algorithm for minimizing a function of one
+*  variable.  It will be called repeatedly by a search routine whose
+*  purpose is to estimate a point ALFA = ALFBST that minimizes some
+*  function F(ALFA) over the closed interval (0, ALFMAX).
+*
+*  SRCHQ  requires the function F(ALFA) (but not its gradient) to be
+*  evaluated at various points within the interval.  New steplength
+*  estimates are computed using quadratic interpolation with safeguards.
+*
+*  Reverse communication is used to allow the calling program to
+*  evaluate F.  Some of the parameters must be set or tested by the
+*  calling program.  The remainder would ordinarily be local variables.
+*
+*
+*  Input parameters (relevant to the calling program)
+*  --------------------------------------------------
+*
+*  DEBUG         specifies whether detailed output is wanted.
+*
+*  FIRST         must be .TRUE. on the first entry. It is subsequently
+*                altered by SRCHQ.
+*
+*  MFSRCH        is an upper limit on the number of times SRCHQ is to be
+*                entered consecutively with DONE = .FALSE. (following
+*                an initial entry with FIRST = .TRUE.).
+*
+*  ALFA          is the first estimate of the steplength.  ALFA is
+*                subsequently altered by SRCHQ (see below).
+*
+*  ALFMAX        is the upper limit of the interval to be searched.
+*
+*  ALFSML        is intended to prevent inefficiency when the optimum
+*                step is very small, for cases where the calling program
+*                would prefer to re-define F(ALFA).  ALFSML is allowed
+*                to be zero. Early termination will occur if SRCHQ
+*                determines that the optimum step lies somewhere in the
+*                interval (0, ALFSML) (but not if ALFMAX .LE. ALFSML).
+*
+*  EPSAF         is an estimate of the absolute precision in the
+*                computed value of F.
+*
+*  ETA           controls the accuracy of the search.  It must lie
+*                in the range  0 .LE. ETA .LT. 1.  Decreasing ETA tends
+*                to increase the accuracy of the search.
+*
+*  FTRY          the value of F at the new point ALFA = ALFBST + XTRY.
+*
+*  OLDF, OLDG    are the values of F(0) and G(0). OLDG must be negative.
+*
+*  TOLABS,TOLREL define a function  TOL(ALFA) = TOLREL*ALFA + TOLABS
+*                such that if F has already been evaluated at step ALFA,
+*                then it will not be evaluated at any point closer than
+*                TOL(ALFA).  These values may be reduced by SRCHQ if
+*                they seem to be too large.
+*
+*  TOLTNY        is the smallest value that TOLABS is allowed to be
+*                reduced to.
+*
+*
+*  Output parameters (relevant to the calling program)
+*  ---------------------------------------------------
+*
+*  IMPRVD        is true if the previous step ALFA was the best point
+*                so far.  Any related quantities should be saved by the
+*                calling program (e.g., arrays) before paying attention
+*                to DONE.
+*
+*  DONE = FALSE  means the calling program should evaluate FTRY for the
+*                new trial step ALFA, and then re-enter SRCHQ.
+*
+*  DONE = TRUE   means that no new steplength was calculated.  The value
+*                of INFORM gives the result of the linesearch as follows
+*
+*                INFORM = 1 means the search has terminated successfully
+*                           with ALFBST less than ALFMAX.
+*
+*                INFORM = 2 means the search has terminated successfully
+*                           with ALFBST = ALFMAX.
+*
+*                INFORM = 3 means that the search failed to find a point
+*                           of sufficient decrease in MFSRCH functions,
+*                           but an improved point was found.
+*
+*                INFORM = 4 means ALFMAX is so small that a search
+*                           should not have been attempted.
+*
+*                INFORM = 5 means that the search was terminated because
+*                           of ALFSML (see above).
+*
+*                INFORM = 6 means the search has failed to find a useful
+*                           step.  If the function has been programmed
+*                           correctly, this will usually occur if the
+*                           minimum lies very close to ALFA = 0.
+*
+*  NFSRCH        counts the number of times SRCHQ has been entered
+*                consecutively with DONE = FALSE (i.e., with a new
+*                function value FTRY).
+*
+*  ALFA          is the step at which the next function FTRY must be
+*                computed.
+*
+*  ALFBST        should be accepted by the calling program as the
+*                required steplength estimate, whenever SRCHQ returns
+*                INFORM = 1, 2 or 3.
+*
+*  FBEST         will be the corresponding value of F.
+*
+*
+*  The following parameters retain information between entries
+*  -----------------------------------------------------------
+*
+*  ALFUZZ        is such that, if the final ALFA lies in the interval
+*                (0,ALFUZZ) and ABS( F(ALFA)-OLDF ) .LE. EPSAF,  ALFA
+*                cannot be guaranteed to be a point of sufficient
+*                decrease.
+*
+*  BRAKTD        is false if F has not been evaluated at the far end
+*                of the interval of uncertainty.  In this case, the
+*                point B will be at ALFMAX + TOL(ALFMAX).
+*
+*  CRAMPD        is true if ALFMAX is very small (.LE. TOLABS).  If the
+*                search fails, this indicates that a zero step should
+*                be taken.
+*
+*  EXTRAP        is true if ALFBST has moved at least once and XV lies
+*                outside the interval of uncertainty.  In this case,
+*                extra safeguards are applied to allow for instability
+*                in the polynomial fit.
+*
+*  MOVED         is true if a better point has been found (ALFBST GT 0).
+*
+*  VSET          records whether a third-best point has been defined.
+*
+*  WSET          records whether a second-best point has been defined.
+*                It will always be true by the time the convergence
+*                test is applied.
+*
+*  NSAMEA        is the number of consecutive times that the left-hand
+*                end of the interval of uncertainty has remained the
+*                same.
+*
+*  NSAMEB        similarly for the right-hand end.
+*
+*  A, B, ALFBST  define the current interval of uncertainty.
+*                The required minimum lies somewhere within the
+*                closed interval  (ALFBST + A, ALFBST + B).
+*
+*  ALFBST        is the best point so far.  it is strictly within the
+*                the interval of uncertainty except when it lies at the
+*                left-hand end when ALFBST has not been moved.
+*                Hence we have A .LE. 0 and B .GT. 0.
+*
+*  FBEST         is the value of F at the point ALFBST.
+*
+*  FA            is the value of F at the point ALFBST + A.
+*
+*  FACTOR        controls the rate at which extrapolated estimates of
+*                ALFA  may expand into the interval of uncertainty.
+*                FACTOR is not used if the minimum has been bracketed
+*                (i.e., when the variable BRAKTD is true).
+*
+*  FV, FW        are the values of F at the points ALFBST + XV,
+*                ALFBST + XW.  They are not defined until VSET or WSET
+*                are true.
+*
+*  XTRY          is the trial point within the shifted interval (A, B).
+*                The new trial function value must be computed at the
+*                point ALFA = ALFBST + XTRY.
+*
+*  XV            is such that ALFBST + XV is the third-best point. It is
+*                not defined until VSET is true.
+*
+*  XW            is such that ALFBST + XW is the second-best point. It
+*                is not defined until WSET is true.  In some cases, XW
+*                will replace a previous XW that has a lower function
+*                but has just been excluded from (A,B).
+*
+*  RMU           controls what is meant by a significant decrease in F.
+*                The final F(ALFBST)  should lie on or below the line
+*                      L(ALFA)  =  OLDF + ALFA*RMU*OLDG.
+*                RMU  should be in the open interval (0, 1/2).
+*                The value  RMU = 1.0E-4  is good for most purposes.
+*
+*
+*  Systems Optimization Laboratory, Stanford University, California.
+*  Original version February 1982.  Rev. May 1983.
+*  Original F77 version 22-August-1985.
+*  This version of SRCHQ dated 30-July-1986.
+************************************************************************
+      COMMON    /SOL1CM/ NOUT
+
+      LOGICAL            BRAKTD, CRAMPD, EXTRAP, MOVED , VSET  , WSET
+      SAVE               BRAKTD, CRAMPD, EXTRAP, MOVED , VSET  , WSET
+
+      SAVE               NFSRCH, NSAMEA, NSAMEB
+      SAVE               A     , B     , FA    , ALFUZZ, FACTOR
+      SAVE               XW    , FW    , XV    , FV    , TOLMAX
+
+      LOGICAL            CLOSEF, CONV1 , CONV2 , CONV3 , CONVRG
+      LOGICAL            SETXV , SIGDEC, XINXW
+      INTRINSIC          ABS   , SQRT
+
+      PARAMETER        ( ZERO  =0.0D+0, POINT1 =0.1D+0, HALF   =0.5D+0 )
+      PARAMETER        ( ONE   =1.0D+0, TWO    =2.0D+0, FIVE   =5.0D+0 )
+      PARAMETER        ( TEN   =1.0D+1, ELEVEN =1.1D+1                 )
+      PARAMETER        ( RMU   =1.0D-4, MFSRCH =15                     )
+
+*     ------------------------------------------------------------------
+*     Local variables
+*     ===============
+*
+*     CLOSEF     is true if the worst function FV is within EPSAF of
+*                FBEST (up or down).
+*
+*     CONVRG     will be set to true if at least one of the convergence
+*                conditions holds at ALFBST.
+*
+*     SIGDEC     says whether FBEST represents a significant decrease
+*             in the function, compared to the initial value OLDF.
+*
+*     XINXW      is true if XTRY is in (XW,0) or (0,XW).
+*     ------------------------------------------------------------------
+
+      IMPRVD = .FALSE.
+      IF (FIRST) THEN
+*        ---------------------------------------------------------------
+*        First entry.  Initialize various quantities, check input data
+*        and prepare to evaluate the function at the initial step ALFA.
+*        ---------------------------------------------------------------
+         FIRST  = .FALSE.
+         NFSRCH = 0
+         ALFBST = ZERO
+         FBEST  = OLDF
+         CRAMPD = ALFMAX .LE. TOLABS
+         DONE   = ALFMAX .LE. TOLTNY  .OR.  OLDG .GE. ZERO
+         MOVED  = .FALSE.
+
+         IF (.NOT. DONE) THEN
+            BRAKTD = .FALSE.
+            CRAMPD = ALFMAX .LE. TOLABS
+            EXTRAP = .FALSE.
+            VSET   = .FALSE.
+            WSET   = .FALSE.
+            NSAMEA = 0
+            NSAMEB = 0
+            ALFUZZ = ALFMAX
+            IF (TWO*EPSAF .LT. - OLDG*RMU*ALFMAX)
+     $         ALFUZZ = - TWO*EPSAF/(RMU*OLDG)
+
+            TOLMAX = TOLREL*ALFMAX + TOLABS
+            A      = ZERO
+            B      = ALFMAX + TOLMAX
+            FA     = OLDF
+            FACTOR = FIVE
+            TOL    = TOLABS
+            XTRY   = ALFA
+            IF (DEBUG)
+     $         WRITE (NOUT, 1000) ALFMAX, OLDF , OLDG  , TOLABS,
+     $                            ALFUZZ,         EPSAF, TOLREL,
+     $                            CRAMPD
+         END IF
+      ELSE
+*        ---------------------------------------------------------------
+*        Subsequent entries.  The function has just been evaluated at
+*        ALFA = ALFBST + XTRY,  giving FTRY.
+*        ---------------------------------------------------------------
+         NFSRCH = NFSRCH + 1
+         NSAMEA = NSAMEA + 1
+         NSAMEB = NSAMEB + 1
+
+         IF (.NOT. BRAKTD) THEN
+            TOLMAX = TOLABS + TOLREL*ALFMAX
+            B      = ALFMAX - ALFBST + TOLMAX
+         END IF
+
+*        Check if XTRY is in the interval (XW,0) or (0,XW).
+
+         XINXW  = .FALSE.
+         IF (WSET) XINXW =       ZERO .LT. XTRY  .AND.  XTRY .LE. XW
+     $                     .OR.    XW .LE. XTRY  .AND.  XTRY .LT. ZERO
+
+*        See if the new step is better.
+
+         IF (ALFA .LE. ALFUZZ) THEN
+            SIGDEC = FTRY - OLDF                 .LE. (- EPSAF)
+         ELSE
+            SIGDEC = FTRY - OLDF - ALFA*RMU*OLDG .LE.    EPSAF
+         END IF
+         IMPRVD = SIGDEC  .AND.  (FTRY .LE. FBEST - EPSAF)
+
+         IF (DEBUG) WRITE (NOUT, 1100)
+     $      ALFA, FTRY, FTRY - OLDF - ALFA*RMU*OLDG
+
+         IF (IMPRVD) THEN
+
+*           We seem to have an improvement.  The new point becomes the
+*           origin and other points are shifted accordingly.
+
+            IF (WSET) THEN
+               XV     = XW - XTRY
+               FV     = FW
+               VSET   = .TRUE.
+            END IF
+
+            XW     = ZERO - XTRY
+            FW     = FBEST
+            WSET   = .TRUE.
+            FBEST  = FTRY
+            ALFBST = ALFA
+            MOVED  = .TRUE.
+
+            A      = A    - XTRY
+            B      = B    - XTRY
+            EXTRAP = .NOT. XINXW
+
+*           Decrease the length of (A,B).
+
+            IF (XTRY .GE. ZERO) THEN
+               A      = XW
+               FA     = FW
+               NSAMEA = 0
+            ELSE
+               B      = XW
+               NSAMEB = 0
+               BRAKTD = .TRUE.
+            END IF
+         ELSE
+
+*           The new function value is no better than the current best
+*           point.  XTRY must an end point of the new (A,B).
+
+            IF (XTRY .LT. ZERO) THEN
+               A      = XTRY
+               FA     = FTRY
+               NSAMEA = 0
+            ELSE
+               B      = XTRY
+               NSAMEB = 0
+               BRAKTD = .TRUE.
+            END IF
+
+*           The origin remains unchanged but XTRY may qualify as XW.
+
+            IF (WSET) THEN
+               IF (FTRY .LE. FW + EPSAF) THEN
+                  XV     = XW
+                  FV     = FW
+                  VSET   = .TRUE.
+
+                  XW     = XTRY
+                  FW     = FTRY
+                  IF (MOVED) EXTRAP = XINXW
+               ELSE IF (MOVED) THEN
+                  SETXV = .TRUE.
+                  IF (VSET)
+     $               SETXV = FTRY .LE. FV + EPSAF  .OR.  .NOT. EXTRAP
+
+                  IF (SETXV) THEN
+                     IF (VSET  .AND.  XINXW) THEN
+                        XW = XV
+                        FW = FV
+                     END IF
+                     XV = XTRY
+                     FV = FTRY
+                     VSET = .TRUE.
+                  END IF
+               ELSE
+                  XW = XTRY
+                  FW = FTRY
+               END IF
+            ELSE
+               XW     = XTRY
+               FW     = FTRY
+               WSET   = .TRUE.
+            END IF
+         END IF
+
+*        ---------------------------------------------------------------
+*        Check the termination criteria.
+*        ---------------------------------------------------------------
+         TOL    = TOLABS + TOLREL*ALFBST
+
+         IF (ALFBST .LE. ALFUZZ) THEN
+            SIGDEC = FBEST - OLDF                   .LE. (- EPSAF)
+         ELSE
+            SIGDEC = FBEST - OLDF - ALFBST*RMU*OLDG .LE.    EPSAF
+         END IF
+         CLOSEF = .FALSE.
+         IF (VSET) CLOSEF = ABS( FBEST - FV ) .LE. EPSAF
+
+         CONV1  =  MAX( ABS( A ), B )  .LE.  (TOL + TOL)
+         CONV2  =  MOVED  .AND.  SIGDEC
+     $                    .AND.  ABS( FA - FBEST )  .LE.  A*ETA*OLDG
+         CONV3  = CLOSEF  .AND.  (SIGDEC  .OR.
+     $                           (.NOT. MOVED)  .AND.  (B .LE. ALFUZZ))
+         CONVRG = CONV1  .OR.  CONV2  .OR.  CONV3
+
+         IF (DEBUG) THEN
+            WRITE (NOUT, 1200) ALFBST + A, ALFBST + B, B - A, TOL,
+     $         NSAMEA, NSAMEB, BRAKTD, CLOSEF,
+     $         IMPRVD, CONV1, CONV2, CONV3, EXTRAP,
+     $         ALFBST, FBEST,  FBEST - OLDF - ALFBST*RMU*OLDG,
+     $         ALFBST + XW, FW
+            IF (VSET)
+     $         WRITE (NOUT, 1300) ALFBST + XV, FV
+         END IF
+
+         IF (NFSRCH .GE. MFSRCH  .OR.  ALFBST + B .LE. ALFSML) THEN
+            DONE = .TRUE.
+         ELSE IF (CONVRG) THEN
+            IF (MOVED) THEN
+               DONE = .TRUE.
+            ELSE
+
+*              A better point has not yet been found (the step XW is no
+*              better than step zero).  Check that the change in F is
+*              consistent with an X-perturbation of TOL,  the minimum
+*              spacing estimate.  If not, the value of TOL is reduced.
+
+               TOL    = TOL/TEN
+               TOLABS = TOL
+               IF (ABS(FW - OLDF) .LE. EPSAF  .OR.  TOL .LE. TOLTNY)
+     $            DONE = .TRUE.
+            END IF
+         END IF
+
+*        ---------------------------------------------------------------
+*        Proceed with the computation of a trial step length.
+*        The choices are...
+*        1. Parabolic fit using function values only.
+*        2. Damped parabolic fit if the regular fit appears to be
+*           consistently over-estimating the distance to the minimum.
+*        3. Bisection, geometric bisection, or a step of TOL if the
+*           parabolic fit is unsatisfactory.
+*        ---------------------------------------------------------------
+         XMIDPT = HALF*(A + B)
+         S      = ZERO
+         Q      = ZERO
+
+*        ===============================================================
+*        Fit a parabola.
+*        ===============================================================
+*        Check if there are two or three points for the parabolic fit.
+
+         GW = (FW - FBEST)/XW
+         IF (VSET  .AND.  MOVED) THEN
+
+*           Three points available.  Use FBEST, FW and FV.
+
+            GV = (FV - FBEST)/XV
+            S  = GV - (XV/XW)*GW
+            Q  = TWO*(GV - GW)
+            IF (DEBUG) WRITE (NOUT, 2200)
+         ELSE
+
+*           Only two points available.  Use FBEST, FW and OLDG.
+
+            IF (MOVED) THEN
+               S  = OLDG - TWO*GW
+            ELSE
+               S  = OLDG
+            END IF
+            Q = TWO*(OLDG - GW)
+            IF (DEBUG) WRITE (NOUT, 2100)
+         END IF
+
+*        ---------------------------------------------------------------
+*        Construct an artificial interval (ARTIFA, ARTIFB) in which the
+*        new estimate of the steplength must lie.  Set a default value
+*        of XTRY that will be used if the polynomial fit is rejected.
+*        In the following, the interval (A,B) is considered the sum of
+*        two intervals of lengths DTRY and DAUX, with common end point
+*        the best point (zero).  DTRY is the length of the interval into
+*        which the default XTRY will be placed and ENDPNT denotes its
+*        non-zero end point.  The magnitude of XTRY is computed so that
+*        the exponents of DTRY and DAUX are approximately bisected.
+*        ---------------------------------------------------------------
+         ARTIFA = A
+         ARTIFB = B
+         IF (.NOT. BRAKTD) THEN
+
+*           The minimum has not been bracketed.  Set an artificial upper
+*           bound by expanding the interval XW by a suitable factor.
+
+            XTRY   = - FACTOR*XW
+            ARTIFB =   XTRY
+            IF (ALFBST + XTRY .LT. ALFMAX) FACTOR = FIVE*FACTOR
+         ELSE IF (VSET .AND. MOVED) THEN
+
+*           Three points exist in the interval of uncertainty.
+*           Check if the points are configured for an extrapolation
+*           or an interpolation.
+
+            IF (EXTRAP) THEN
+
+*              The points are configured for an extrapolation.
+
+               IF (XW .LT. ZERO) ENDPNT = B
+               IF (XW .GT. ZERO) ENDPNT = A
+            ELSE
+
+*              If the interpolation appears to be over-estimating the
+*              distance to the minimum,  damp the interpolation step.
+
+               IF (NSAMEA .GE. 3  .OR.   NSAMEB .GE. 3) THEN
+                  FACTOR = FACTOR / FIVE
+                  S      = FACTOR * S
+               ELSE
+                  FACTOR = ONE
+               END IF
+
+*              The points are configured for an interpolation.  The
+*              artificial interval will be just (A,B).  Set ENDPNT so
+*              that XTRY lies in the larger of the intervals (A,B) and
+*              (0,B).
+
+               ENDPNT = A
+               IF (XMIDPT .GT. ZERO) ENDPNT = B
+
+*              If a bound has remained the same for three iterations,
+*              set ENDPNT so that  XTRY  is likely to replace the
+*              offending bound.
+
+               IF (NSAMEA .GE. 3) ENDPNT = A
+               IF (NSAMEB .GE. 3) ENDPNT = B
+            END IF
+
+*           Compute the default value of  XTRY.
+
+            DTRY = ABS( ENDPNT )
+            DAUX = B - A - DTRY
+            IF (DAUX .GE. DTRY) THEN
+               XTRY = FIVE*DTRY*(POINT1 + DTRY/DAUX)/ELEVEN
+            ELSE
+               XTRY = HALF*SQRT( DAUX )*SQRT( DTRY )
+            END IF
+            IF (ENDPNT .LT. ZERO) XTRY = - XTRY
+            IF (DEBUG) WRITE (NOUT, 2500) XTRY, DAUX, DTRY
+
+*           If the points are configured for an extrapolation set the
+*           artificial bounds so that the artificial interval lies
+*           within (A,B).  If the polynomial fit is rejected,  XTRY will
+*           remain at the relevant artificial bound.
+
+            IF (EXTRAP) THEN
+               IF (XTRY .LE. ZERO) THEN
+                  ARTIFA = XTRY
+               ELSE
+                  ARTIFB = XTRY
+               END IF
+            END IF
+         ELSE
+
+*           The gradient at the origin is being used for the polynomial
+*           fit.  Set the default XTRY to one tenth XW.
+
+            XTRY   = XW/TEN
+            IF (EXTRAP) XTRY = - XW
+            IF (DEBUG) WRITE (NOUT, 2400) XTRY
+         END IF
+
+*        ---------------------------------------------------------------
+*        The polynomial fits give (S/Q)*XW as the new step.  Reject this
+*        step if it lies outside (ARTIFA, ARTIFB).
+*        ---------------------------------------------------------------
+         IF (Q .NE. ZERO) THEN
+            IF (Q .LT. ZERO) S = - S
+            IF (Q .LT. ZERO) Q = - Q
+            IF (S*XW .GE. Q*ARTIFA   .AND.   S*XW .LE. Q*ARTIFB) THEN
+
+*              Accept the polynomial fit.
+
+               XTRY = ZERO
+               IF (ABS( S*XW ) .GE. Q*TOL) XTRY = (S/Q)*XW
+               IF (DEBUG) WRITE (NOUT, 2600) XTRY
+            END IF
+         END IF
+      END IF
+
+*     ==================================================================
+
+      IF (.NOT. DONE) THEN
+         ALFA  = ALFBST + XTRY
+         IF (BRAKTD  .OR.  ALFA .LT. ALFMAX - TOLMAX) THEN
+
+*           The function must not be evaluated too close to A or B.
+*           (It has already been evaluated at both those points.)
+
+            XMIDPT = HALF*(A + B)
+            IF (XTRY .LE. A + TOL  .OR.  XTRY .GE. B - TOL) THEN
+               XTRY = TOL
+               IF (XMIDPT .LE. ZERO) XTRY = - TOL
+            END IF
+
+            IF (ABS( XTRY ) .LT. TOL) THEN
+               XTRY = TOL
+               IF (XMIDPT .LE. ZERO) XTRY = - TOL
+            END IF
+            ALFA  = ALFBST + XTRY
+         ELSE
+
+*           The step is close to or larger than ALFMAX, replace it by
+*           ALFMAX to force evaluation of the function at the boundary.
+
+            BRAKTD = .TRUE.
+            XTRY   = ALFMAX - ALFBST
+            ALFA   = ALFMAX
+         END IF
+      END IF
+
+*     ------------------------------------------------------------------
+*     Exit.
+*     ------------------------------------------------------------------
+      IF (DONE) THEN
+         IF (MOVED) THEN
+            IF (CONVRG) THEN
+               INFORM = 1
+               IF (ALFA .EQ. ALFMAX) INFORM = 2
+            ELSE IF (ALFBST + B .LT. ALFSML) THEN
+               INFORM = 5
+            ELSE
+               INFORM = 3
+            END IF
+         ELSE IF (OLDG .GE. ZERO  .OR.  ALFMAX .LT. TOLTNY) THEN
+            INFORM = 7
+         ELSE IF (CRAMPD) THEN
+            INFORM = 4
+         ELSE IF (ALFBST + B .LT. ALFSML) THEN
+            INFORM = 5
+         ELSE
+            INFORM = 6
+         END IF
+      END IF
+
+      IF (DEBUG) WRITE (NOUT, 3000)
+      RETURN
+
+ 1000 FORMAT(/' ALFMAX  OLDF    OLDG    TOLABS', 1P2E22.14,   1P2E16.8
+     $       /' ALFUZZ  EPSAF           TOLREL', 1P2E22.14,16X,1PE16.8
+     $       /' CRAMPD                        ',  L6)
+ 1100 FORMAT(/' ALFA    FTRY    CTRY          ', 1P2E22.14,   1P1E16.8)
+ 1200 FORMAT(/' A       B       B - A   TOL   ', 1P2E22.14,   1P2E16.8
+     $       /' NSAMEA  NSAMEB  BRAKTD  CLOSEF', 2I3, 2L6
+     $       /' IMPRVD  CONVRG  EXTRAP        ',  L6, 3X, 3L1, L6
+     $       /' ALFBST  FBEST   CBEST         ', 1P2E22.14,   1P1E16.8
+     $       /' ALFAW   FW                    ', 1P2E22.14)
+ 1300 FORMAT( ' ALFAV   FV                    ', 1P2E22.14 /)
+ 2100 FORMAT( ' Parabolic fit,    two points. ')
+ 2200 FORMAT( ' Parabolic fit,  three points. ')
+ 2400 FORMAT( ' Exponent reduced.  Trial point', 1P1E22.14)
+ 2500 FORMAT( ' Geo. bisection. XTRY,DAUX,DTRY', 1P3E22.14)
+ 2600 FORMAT( ' Polynomial fit accepted.  XTRY', 1P1E22.14)
+ 3000 FORMAT( ' ----------------------------------------------------'/)
+
+*     End of  SRCHQ .
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/odepack/cfode.f
@@ -0,0 +1,112 @@
+      SUBROUTINE CFODE (METH, ELCO, TESCO)
+CLLL. OPTIMIZE
+      INTEGER METH
+      INTEGER I, IB, NQ, NQM1, NQP1
+      DOUBLE PRECISION ELCO, TESCO
+      DOUBLE PRECISION AGAMQ, FNQ, FNQM1, PC, PINT, RAGQ,
+     1   RQFAC, RQ1FAC, TSIGN, XPIN
+      DIMENSION ELCO(13,12), TESCO(3,12)
+C-----------------------------------------------------------------------
+C CFODE IS CALLED BY THE INTEGRATOR ROUTINE TO SET COEFFICIENTS
+C NEEDED THERE.  THE COEFFICIENTS FOR THE CURRENT METHOD, AS
+C GIVEN BY THE VALUE OF METH, ARE SET FOR ALL ORDERS AND SAVED.
+C THE MAXIMUM ORDER ASSUMED HERE IS 12 IF METH = 1 AND 5 IF METH = 2. 
+C (A SMALLER VALUE OF THE MAXIMUM ORDER IS ALSO ALLOWED.)
+C CFODE IS CALLED ONCE AT THE BEGINNING OF THE PROBLEM,
+C AND IS NOT CALLED AGAIN UNLESS AND UNTIL METH IS CHANGED. 
+C
+C THE ELCO ARRAY CONTAINS THE BASIC METHOD COEFFICIENTS.
+C THE COEFFICIENTS EL(I), 1 .LE. I .LE. NQ+1, FOR THE METHOD OF
+C ORDER NQ ARE STORED IN ELCO(I,NQ).  THEY ARE GIVEN BY A GENETRATING 
+C POLYNOMIAL, I.E., 
+C     L(X) = EL(1) + EL(2)*X + ... + EL(NQ+1)*X**NQ.
+C FOR THE IMPLICIT ADAMS METHODS, L(X) IS GIVEN BY
+C     DL/DX = (X+1)*(X+2)*...*(X+NQ-1)/FACTORIAL(NQ-1),    L(-1) = 0. 
+C FOR THE BDF METHODS, L(X) IS GIVEN BY 
+C     L(X) = (X+1)*(X+2)* ... *(X+NQ)/K,
+C WHERE         K = FACTORIAL(NQ)*(1 + 1/2 + ... + 1/NQ).
+C
+C THE TESCO ARRAY CONTAINS TEST CONSTANTS USED FOR THE
+C LOCAL ERROR TEST AND THE SELECTION OF STEP SIZE AND/OR ORDER.
+C AT ORDER NQ, TESCO(K,NQ) IS USED FOR THE SELECTION OF STEP
+C SIZE AT ORDER NQ - 1 IF K = 1, AT ORDER NQ IF K = 2, AND AT ORDER
+C NQ + 1 IF K = 3.
+C-----------------------------------------------------------------------
+      DIMENSION PC(12)
+C
+      GO TO (100, 200), METH
+C
+ 100  ELCO(1,1) = 1.0D0
+      ELCO(2,1) = 1.0D0
+      TESCO(1,1) = 0.0D0
+      TESCO(2,1) = 2.0D0
+      TESCO(1,2) = 1.0D0
+      TESCO(3,12) = 0.0D0
+      PC(1) = 1.0D0 
+      RQFAC = 1.0D0 
+      DO 140 NQ = 2,12
+C-----------------------------------------------------------------------
+C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL
+C     P(X) = (X+1)*(X+2)*...*(X+NQ-1).
+C INITIALLY, P(X) = 1.
+C-----------------------------------------------------------------------
+        RQ1FAC = RQFAC
+        RQFAC = RQFAC/DBLE(NQ)
+        NQM1 = NQ - 1
+        FNQM1 = DBLE(NQM1)  
+        NQP1 = NQ + 1
+C FORM COEFFICIENTS OF P(X)*(X+NQ-1). ----------------------------------
+        PC(NQ) = 0.0D0
+        DO 110 IB = 1,NQM1
+          I = NQP1 - IB
+ 110      PC(I) = PC(I-1) + FNQM1*PC(I) 
+        PC(1) = FNQM1*PC(1)
+C COMPUTE INTEGRAL, -1 TO 0, OF P(X) AND X*P(X). -----------------------
+        PINT = PC(1)
+        XPIN = PC(1)/2.0D0
+        TSIGN = 1.0D0
+        DO 120 I = 2,NQ
+          TSIGN = -TSIGN
+          PINT = PINT + TSIGN*PC(I)/DBLE(I)     
+ 120      XPIN = XPIN + TSIGN*PC(I)/DBLE(I+1)   
+C STORE COEFFICIENTS IN ELCO AND TESCO. --------------------------------
+        ELCO(1,NQ) = PINT*RQ1FAC
+        ELCO(2,NQ) = 1.0D0
+        DO 130 I = 2,NQ
+ 130      ELCO(I+1,NQ) = RQ1FAC*PC(I)/DBLE(I)   
+        AGAMQ = RQFAC*XPIN
+        RAGQ = 1.0D0/AGAMQ
+        TESCO(2,NQ) = RAGQ
+        IF (NQ .LT. 12) TESCO(1,NQP1) = RAGQ*RQFAC/DBLE(NQP1)       
+        TESCO(3,NQM1) = RAGQ
+ 140    CONTINUE
+      RETURN
+C
+ 200  PC(1) = 1.0D0 
+      RQ1FAC = 1.0D0
+      DO 230 NQ = 1,5
+C-----------------------------------------------------------------------
+C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL
+C     P(X) = (X+1)*(X+2)*...*(X+NQ).
+C INITIALLY, P(X) = 1.
+C-----------------------------------------------------------------------
+        FNQ = DBLE(NQ)      
+        NQP1 = NQ + 1
+C FORM COEFFICIENTS OF P(X)*(X+NQ). ------------------------------------
+        PC(NQP1) = 0.0D0
+        DO 210 IB = 1,NQ
+          I = NQ + 2 - IB
+ 210      PC(I) = PC(I-1) + FNQ*PC(I)
+        PC(1) = FNQ*PC(1)
+C STORE COEFFICIENTS IN ELCO AND TESCO. --------------------------------
+        DO 220 I = 1,NQP1
+ 220      ELCO(I,NQ) = PC(I)/PC(2)
+        ELCO(2,NQ) = 1.0D0
+        TESCO(1,NQ) = RQ1FAC
+        TESCO(2,NQ) = DBLE(NQP1)/ELCO(1,NQ)     
+        TESCO(3,NQ) = DBLE(NQ+2)/ELCO(1,NQ)     
+        RQ1FAC = RQ1FAC/FNQ
+ 230    CONTINUE
+      RETURN
+C----------------------- END OF SUBROUTINE CFODE -----------------------
+      END 
new file mode 100644
--- /dev/null
+++ b/libcruft/odepack/ewset.f
@@ -0,0 +1,32 @@
+      SUBROUTINE EWSET (N, ITOL, RTOL, ATOL, YCUR, EWT)
+CLLL. OPTIMIZE
+C-----------------------------------------------------------------------
+C THIS SUBROUTINE SETS THE ERROR WEIGHT VECTOR EWT ACCORDING TO
+C     EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(I),  I = 1,...,N,
+C WITH THE SUBSCRIPT ON RTOL AND/OR ATOL POSSIBLY REPLACED BY 1 ABOVE,
+C DEPENDING ON THE VALUE OF ITOL.
+C-----------------------------------------------------------------------
+      INTEGER N, ITOL
+      INTEGER I
+      DOUBLE PRECISION RTOL, ATOL, YCUR, EWT
+      DIMENSION RTOL(1), ATOL(1), YCUR(N), EWT(N) 
+C
+      GO TO (10, 20, 30, 40), ITOL
+ 10   CONTINUE
+      DO 15 I = 1,N 
+ 15     EWT(I) = RTOL(1)*DABS(YCUR(I)) + ATOL(1)
+      RETURN
+ 20   CONTINUE
+      DO 25 I = 1,N 
+ 25     EWT(I) = RTOL(1)*DABS(YCUR(I)) + ATOL(I)
+      RETURN
+ 30   CONTINUE
+      DO 35 I = 1,N 
+ 35     EWT(I) = RTOL(I)*DABS(YCUR(I)) + ATOL(1)
+      RETURN
+ 40   CONTINUE
+      DO 45 I = 1,N 
+ 45     EWT(I) = RTOL(I)*DABS(YCUR(I)) + ATOL(I)
+      RETURN
+C----------------------- END OF SUBROUTINE EWSET -----------------------
+      END 
new file mode 100644
--- /dev/null
+++ b/libcruft/odepack/intdy.f
@@ -0,0 +1,84 @@
+      SUBROUTINE INTDY (T, K, YH, NYH, DKY, IFLAG)
+CLLL. OPTIMIZE
+      INTEGER K, NYH, IFLAG
+      INTEGER IOWND, IOWNS,
+     1   ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER,
+     2   MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU
+      INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1
+      DOUBLE PRECISION T, YH, DKY
+      DOUBLE PRECISION ROWNS, 
+     1   CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND
+      DOUBLE PRECISION C, R, S, TP
+      DIMENSION YH(NYH,1), DKY(1)
+      COMMON /LS0001/ ROWNS(209),
+     2   CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND,
+     3   IOWND(14), IOWNS(6), 
+     4   ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER,
+     5   MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU
+C-----------------------------------------------------------------------
+C INTDY COMPUTES INTERPOLATED VALUES OF THE K-TH DERIVATIVE OF THE
+C DEPENDENT VARIABLE VECTOR Y, AND STORES IT IN DKY.  THIS ROUTINE
+C IS CALLED WITHIN THE PACKAGE WITH K = 0 AND T = TOUT, BUT MAY
+C ALSO BE CALLED BY THE USER FOR ANY K UP TO THE CURRENT ORDER.
+C (SEE DETAILED INSTRUCTIONS IN THE USAGE DOCUMENTATION.)
+C-----------------------------------------------------------------------
+C THE COMPUTED VALUES IN DKY ARE GOTTEN BY INTERPOLATION USING THE
+C NORDSIECK HISTORY ARRAY YH.  THIS ARRAY CORRESPONDS UNIQUELY TO A
+C VECTOR-VALUED POLYNOMIAL OF DEGREE NQCUR OR LESS, AND DKY IS SET
+C TO THE K-TH DERIVATIVE OF THIS POLYNOMIAL AT T. 
+C THE FORMULA FOR DKY IS..
+C              Q
+C  DKY(I)  =  SUM  C(J,K) * (T - TN)**(J-K) * H**(-J) * YH(I,J+1)
+C             J=K
+C WHERE  C(J,K) = J*(J-1)*...*(J-K+1), Q = NQCUR, TN = TCUR, H = HCUR.
+C THE QUANTITIES  NQ = NQCUR, L = NQ+1, N = NEQ, TN, AND H ARE
+C COMMUNICATED BY COMMON.  THE ABOVE SUM IS DONE IN REVERSE ORDER.
+C IFLAG IS RETURNED NEGATIVE IF EITHER K OR T IS OUT OF BOUNDS.
+C-----------------------------------------------------------------------
+      IFLAG = 0
+      IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80
+      TP = TN - HU -  100.0D0*UROUND*(TN + HU)
+      IF ((T-TP)*(T-TN) .GT. 0.0D0) GO TO 90
+C
+      S = (T - TN)/H
+      IC = 1
+      IF (K .EQ. 0) GO TO 15
+      JJ1 = L - K
+      DO 10 JJ = JJ1,NQ
+ 10     IC = IC*JJ
+ 15   C = DBLE(IC)
+      DO 20 I = 1,N 
+ 20     DKY(I) = C*YH(I,L)
+      IF (K .EQ. NQ) GO TO 55 
+      JB2 = NQ - K
+      DO 50 JB = 1,JB2
+        J = NQ - JB 
+        JP1 = J + 1 
+        IC = 1
+        IF (K .EQ. 0) GO TO 35
+        JJ1 = JP1 - K
+        DO 30 JJ = JJ1,J
+ 30       IC = IC*JJ
+ 35     C = DBLE(IC)
+        DO 40 I = 1,N
+ 40       DKY(I) = C*YH(I,JP1) + S*DKY(I)
+ 50     CONTINUE
+      IF (K .EQ. 0) RETURN
+ 55   R = H**(-K)
+      DO 60 I = 1,N 
+ 60     DKY(I) = R*DKY(I)
+      RETURN
+C
+ 80   CALL XERRWV(30HINTDY--  K (=I1) ILLEGAL      ,
+     1   30, 51, 0, 1, K, 0, 0, 0.0D0, 0.0D0)
+      IFLAG = -1
+      RETURN
+ 90   CALL XERRWV(30HINTDY--  T (=R1) ILLEGAL      ,
+     1   30, 52, 0, 0, 0, 0, 1, T, 0.0D0)
+      CALL XERRWV(
+     1  60H      T NOT IN INTERVAL TCUR - HU (= R1) TO TCUR (=R2)      ,
+     1   60, 52, 0, 0, 0, 0, 2, TP, TN) 
+      IFLAG = -2
+      RETURN
+C----------------------- END OF SUBROUTINE INTDY -----------------------
+      END 
new file mode 100644
--- /dev/null
+++ b/libcruft/odepack/lsode.f
@@ -0,0 +1,1523 @@
+      SUBROUTINE LSODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK,
+     1            ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF)
+      EXTERNAL F, JAC
+      INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF
+      DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK
+      DIMENSION NEQ(1), Y(1), RTOL(1), ATOL(1), RWORK(LRW), IWORK(LIW)
+C-----------------------------------------------------------------------
+C THIS IS THE MARCH 30, 1987 VERSION OF 
+C LSODE.. LIVERMORE SOLVER FOR ORDINARY DIFFERENTIAL EQUATIONS.
+C THIS VERSION IS IN DOUBLE PRECISION.
+C
+C LSODE SOLVES THE INITIAL VALUE PROBLEM FOR STIFF OR NONSTIFF
+C SYSTEMS OF FIRST ORDER ODE-S,
+C     DY/DT = F(T,Y) ,  OR, IN COMPONENT FORM,
+C     DY(I)/DT = F(I) = F(I,T,Y(1),Y(2),...,Y(NEQ)) (I = 1,...,NEQ).
+C LSODE IS A PACKAGE BASED ON THE GEAR AND GEARB PACKAGES, AND ON THE 
+C OCTOBER 23, 1978 VERSION OF THE TENTATIVE ODEPACK USER INTERFACE
+C STANDARD, WITH MINOR MODIFICATIONS.
+C-----------------------------------------------------------------------
+C REFERENCE..
+C     ALAN C. HINDMARSH,  ODEPACK, A SYSTEMATIZED COLLECTION OF ODE
+C     SOLVERS, IN SCIENTIFIC COMPUTING, R. S. STEPLEMAN ET AL. (EDS.),
+C     NORTH-HOLLAND, AMSTERDAM, 1983, PP. 55-64.
+C-----------------------------------------------------------------------
+C AUTHOR AND CONTACT.. ALAN C. HINDMARSH,
+C                      COMPUTING AND MATHEMATICS RESEARCH DIV., L-316 
+C                      LAWRENCE LIVERMORE NATIONAL LABORATORY
+C                      LIVERMORE, CA 94550.
+C-----------------------------------------------------------------------
+C SUMMARY OF USAGE. 
+C
+C COMMUNICATION BETWEEN THE USER AND THE LSODE PACKAGE, FOR NORMAL
+C SITUATIONS, IS SUMMARIZED HERE.  THIS SUMMARY DESCRIBES ONLY A SUBSET
+C OF THE FULL SET OF OPTIONS AVAILABLE.  SEE THE FULL DESCRIPTION FOR 
+C DETAILS, INCLUDING OPTIONAL COMMUNICATION, NONSTANDARD OPTIONS,
+C AND INSTRUCTIONS FOR SPECIAL SITUATIONS.  SEE ALSO THE EXAMPLE
+C PROBLEM (WITH PROGRAM AND OUTPUT) FOLLOWING THIS SUMMARY. 
+C
+C A. FIRST PROVIDE A SUBROUTINE OF THE FORM..
+C               SUBROUTINE F (NEQ, T, Y, YDOT, IERR)
+C               DIMENSION Y(NEQ), YDOT(NEQ)
+C WHICH SUPPLIES THE VECTOR FUNCTION F BY LOADING YDOT(I) WITH F(I).
+C
+C B. NEXT DETERMINE (OR GUESS) WHETHER OR NOT THE PROBLEM IS STIFF.
+C STIFFNESS OCCURS WHEN THE JACOBIAN MATRIX DF/DY HAS AN EIGENVALUE
+C WHOSE REAL PART IS NEGATIVE AND LARGE IN MAGNITUDE, COMPARED TO THE 
+C RECIPROCAL OF THE T SPAN OF INTEREST.  IF THE PROBLEM IS NONSTIFF,
+C USE A METHOD FLAG MF = 10.  IF IT IS STIFF, THERE ARE FOUR STANDARD 
+C CHOICES FOR MF, AND LSODE REQUIRES THE JACOBIAN MATRIX IN SOME FORM.
+C THIS MATRIX IS REGARDED EITHER AS FULL (MF = 21 OR 22),
+C OR BANDED (MF = 24 OR 25).  IN THE BANDED CASE, LSODE REQUIRES TWO
+C HALF-BANDWIDTH PARAMETERS ML AND MU.  THESE ARE, RESPECTIVELY, THE
+C WIDTHS OF THE LOWER AND UPPER PARTS OF THE BAND, EXCLUDING THE MAIN 
+C DIAGONAL.  THUS THE BAND CONSISTS OF THE LOCATIONS (I,J) WITH
+C I-ML .LE. J .LE. I+MU, AND THE FULL BANDWIDTH IS ML+MU+1. 
+C
+C C. IF THE PROBLEM IS STIFF, YOU ARE ENCOURAGED TO SUPPLY THE JACOBIAN
+C DIRECTLY (MF = 21 OR 24), BUT IF THIS IS NOT FEASIBLE, LSODE WILL
+C COMPUTE IT INTERNALLY BY DIFFERENCE QUOTIENTS (MF = 22 OR 25).
+C IF YOU ARE SUPPLYING THE JACOBIAN, PROVIDE A SUBROUTINE OF THE FORM..
+C               SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD)
+C               DIMENSION Y(NEQ), PD(NROWPD,NEQ)
+C WHICH SUPPLIES DF/DY BY LOADING PD AS FOLLOWS.. 
+C     FOR A FULL JACOBIAN (MF = 21), LOAD PD(I,J) WITH DF(I)/DY(J),
+C THE PARTIAL DERIVATIVE OF F(I) WITH RESPECT TO Y(J).  (IGNORE THE
+C ML AND MU ARGUMENTS IN THIS CASE.)
+C     FOR A BANDED JACOBIAN (MF = 24), LOAD PD(I-J+MU+1,J) WITH
+C DF(I)/DY(J), I.E. LOAD THE DIAGONAL LINES OF DF/DY INTO THE ROWS OF 
+C PD FROM THE TOP DOWN.
+C     IN EITHER CASE, ONLY NONZERO ELEMENTS NEED BE LOADED. 
+C
+C D. WRITE A MAIN PROGRAM WHICH CALLS SUBROUTINE LSODE ONCE FOR
+C EACH POINT AT WHICH ANSWERS ARE DESIRED.  THIS SHOULD ALSO PROVIDE
+C FOR POSSIBLE USE OF LOGICAL UNIT 6 FOR OUTPUT OF ERROR MESSAGES
+C BY LSODE.  ON THE FIRST CALL TO LSODE, SUPPLY ARGUMENTS AS FOLLOWS..
+C F      = NAME OF SUBROUTINE FOR RIGHT-HAND SIDE VECTOR F. 
+C          THIS NAME MUST BE DECLARED EXTERNAL IN CALLING PROGRAM.
+C NEQ    = NUMBER OF FIRST ORDER ODE-S. 
+C Y      = ARRAY OF INITIAL VALUES, OF LENGTH NEQ.
+C T      = THE INITIAL VALUE OF THE INDEPENDENT VARIABLE.
+C TOUT   = FIRST POINT WHERE OUTPUT IS DESIRED (.NE. T).
+C ITOL   = 1 OR 2 ACCORDING AS ATOL (BELOW) IS A SCALAR OR ARRAY.
+C RTOL   = RELATIVE TOLERANCE PARAMETER (SCALAR). 
+C ATOL   = ABSOLUTE TOLERANCE PARAMETER (SCALAR OR ARRAY).
+C          THE ESTIMATED LOCAL ERROR IN Y(I) WILL BE CONTROLLED SO AS 
+C          TO BE ROUGHLY LESS (IN MAGNITUDE) THAN 
+C             EWT(I) = RTOL*ABS(Y(I)) + ATOL     IF ITOL = 1, OR
+C             EWT(I) = RTOL*ABS(Y(I)) + ATOL(I)  IF ITOL = 2.
+C          THUS THE LOCAL ERROR TEST PASSES IF, IN EACH COMPONENT,
+C          EITHER THE ABSOLUTE ERROR IS LESS THAN ATOL (OR ATOL(I)),
+C          OR THE RELATIVE ERROR IS LESS THAN RTOL.
+C          USE RTOL = 0.0 FOR PURE ABSOLUTE ERROR CONTROL, AND
+C          USE ATOL = 0.0 (OR ATOL(I) = 0.0) FOR PURE RELATIVE ERROR
+C          CONTROL.  CAUTION.. ACTUAL (GLOBAL) ERRORS MAY EXCEED THESE
+C          LOCAL TOLERANCES, SO CHOOSE THEM CONSERVATIVELY. 
+C ITASK  = 1 FOR NORMAL COMPUTATION OF OUTPUT VALUES OF Y AT T = TOUT.
+C ISTATE = INTEGER FLAG (INPUT AND OUTPUT).  SET ISTATE = 1.
+C IOPT   = 0 TO INDICATE NO OPTIONAL INPUTS USED. 
+C RWORK  = REAL WORK ARRAY OF LENGTH AT LEAST..
+C             20 + 16*NEQ                    FOR MF = 10,
+C             22 +  9*NEQ + NEQ**2           FOR MF = 21 OR 22,
+C             22 + 10*NEQ + (2*ML + MU)*NEQ  FOR MF = 24 OR 25.
+C LRW    = DECLARED LENGTH OF RWORK (IN USER-S DIMENSION).
+C IWORK  = INTEGER WORK ARRAY OF LENGTH AT LEAST..
+C             20        FOR MF = 10,
+C             20 + NEQ  FOR MF = 21, 22, 24, OR 25.
+C          IF MF = 24 OR 25, INPUT IN IWORK(1),IWORK(2) THE LOWER
+C          AND UPPER HALF-BANDWIDTHS ML,MU.
+C LIW    = DECLARED LENGTH OF IWORK (IN USER-S DIMENSION).
+C JAC    = NAME OF SUBROUTINE FOR JACOBIAN MATRIX (MF = 21 OR 24).
+C          IF USED, THIS NAME MUST BE DECLARED EXTERNAL IN CALLING
+C          PROGRAM.  IF NOT USED, PASS A DUMMY NAME.
+C MF     = METHOD FLAG.  STANDARD VALUES ARE..
+C          10 FOR NONSTIFF (ADAMS) METHOD, NO JACOBIAN USED.
+C          21 FOR STIFF (BDF) METHOD, USER-SUPPLIED FULL JACOBIAN.
+C          22 FOR STIFF METHOD, INTERNALLY GENERATED FULL JACOBIAN.
+C          24 FOR STIFF METHOD, USER-SUPPLIED BANDED JACOBIAN.
+C          25 FOR STIFF METHOD, INTERNALLY GENERATED BANDED JACOBIAN. 
+C NOTE THAT THE MAIN PROGRAM MUST DECLARE ARRAYS Y, RWORK, IWORK,
+C AND POSSIBLY ATOL.
+C
+C E. THE OUTPUT FROM THE FIRST CALL (OR ANY CALL) IS..
+C      Y = ARRAY OF COMPUTED VALUES OF Y(T) VECTOR.
+C      T = CORRESPONDING VALUE OF INDEPENDENT VARIABLE (NORMALLY TOUT).
+C ISTATE = 2  IF LSODE WAS SUCCESSFUL, NEGATIVE OTHERWISE.
+C          -1 MEANS EXCESS WORK DONE ON THIS CALL (PERHAPS WRONG MF). 
+C          -2 MEANS EXCESS ACCURACY REQUESTED (TOLERANCES TOO SMALL). 
+C          -3 MEANS ILLEGAL INPUT DETECTED (SEE PRINTED MESSAGE).
+C          -4 MEANS REPEATED ERROR TEST FAILURES (CHECK ALL INPUTS).
+C          -5 MEANS REPEATED CONVERGENCE FAILURES (PERHAPS BAD JACOBIAN
+C             SUPPLIED OR WRONG CHOICE OF MF OR TOLERANCES).
+C          -6 MEANS ERROR WEIGHT BECAME ZERO DURING PROBLEM. (SOLUTION
+C             COMPONENT I VANISHED, AND ATOL OR ATOL(I) = 0.)
+C         -13 MEANS EXIT REQUESTED IN USER-SUPPLIED FUNCTION.
+C
+C F. TO CONTINUE THE INTEGRATION AFTER A SUCCESSFUL RETURN, SIMPLY
+C RESET TOUT AND CALL LSODE AGAIN.  NO OTHER PARAMETERS NEED BE RESET.
+C
+C-----------------------------------------------------------------------
+C EXAMPLE PROBLEM.
+C
+C THE FOLLOWING IS A SIMPLE EXAMPLE PROBLEM, WITH THE CODING
+C NEEDED FOR ITS SOLUTION BY LSODE.  THE PROBLEM IS FROM CHEMICAL
+C KINETICS, AND CONSISTS OF THE FOLLOWING THREE RATE EQUATIONS..
+C     DY1/DT = -.04*Y1 + 1.E4*Y2*Y3
+C     DY2/DT = .04*Y1 - 1.E4*Y2*Y3 - 3.E7*Y2**2
+C     DY3/DT = 3.E7*Y2**2
+C ON THE INTERVAL FROM T = 0.0 TO T = 4.E10, WITH INITIAL CONDITIONS
+C Y1 = 1.0, Y2 = Y3 = 0.  THE PROBLEM IS STIFF.
+C
+C THE FOLLOWING CODING SOLVES THIS PROBLEM WITH LSODE, USING MF = 21
+C AND PRINTING RESULTS AT T = .4, 4., ..., 4.E10.  IT USES
+C ITOL = 2 AND ATOL MUCH SMALLER FOR Y2 THAN Y1 OR Y3 BECAUSE
+C Y2 HAS MUCH SMALLER VALUES. 
+C AT THE END OF THE RUN, STATISTICAL QUANTITIES OF INTEREST ARE
+C PRINTED (SEE OPTIONAL OUTPUTS IN THE FULL DESCRIPTION BELOW).
+C
+C     EXTERNAL FEX, JEX
+C     DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y
+C     DIMENSION Y(3), ATOL(3), RWORK(58), IWORK(23)
+C     NEQ = 3
+C     Y(1) = 1.D0
+C     Y(2) = 0.D0
+C     Y(3) = 0.D0
+C     T = 0.D0
+C     TOUT = .4D0
+C     ITOL = 2
+C     RTOL = 1.D-4
+C     ATOL(1) = 1.D-6
+C     ATOL(2) = 1.D-10
+C     ATOL(3) = 1.D-6
+C     ITASK = 1
+C     ISTATE = 1
+C     IOPT = 0
+C     LRW = 58
+C     LIW = 23
+C     MF = 21
+C     DO 40 IOUT = 1,12
+C       CALL LSODE(FEX,NEQ,Y,T,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE,
+C    1     IOPT,RWORK,LRW,IWORK,LIW,JEX,MF)
+C       WRITE(6,20)T,Y(1),Y(2),Y(3)
+C 20    FORMAT(7H AT T =,E12.4,6H   Y =,3E14.6)
+C       IF (ISTATE .LT. 0) GO TO 80
+C 40    TOUT = TOUT*10.D0
+C     WRITE(6,60)IWORK(11),IWORK(12),IWORK(13)
+C 60  FORMAT(/12H NO. STEPS =,I4,11H  NO. F-S =,I4,11H  NO. J-S =,I4) 
+C     STOP
+C 80  WRITE(6,90)ISTATE
+C 90  FORMAT(///22H ERROR HALT.. ISTATE =,I3)
+C     STOP
+C     END 
+C
+C     SUBROUTINE FEX (NEQ, T, Y, YDOT)
+C     DOUBLE PRECISION T, Y, YDOT
+C     DIMENSION Y(3), YDOT(3) 
+C     YDOT(1) = -.04D0*Y(1) + 1.D4*Y(2)*Y(3)
+C     YDOT(3) = 3.D7*Y(2)*Y(2)
+C     YDOT(2) = -YDOT(1) - YDOT(3)
+C     RETURN
+C     END 
+C
+C     SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD)
+C     DOUBLE PRECISION PD, T, Y
+C     DIMENSION Y(3), PD(NRPD,3)
+C     PD(1,1) = -.04D0
+C     PD(1,2) = 1.D4*Y(3)
+C     PD(1,3) = 1.D4*Y(2)
+C     PD(2,1) = .04D0
+C     PD(2,3) = -PD(1,3)
+C     PD(3,2) = 6.D7*Y(2)
+C     PD(2,2) = -PD(1,2) - PD(3,2)
+C     RETURN
+C     END 
+C
+C THE OUTPUT OF THIS PROGRAM (ON A CDC-7600 IN SINGLE PRECISION)
+C IS AS FOLLOWS..
+C
+C   AT T =  4.0000E-01   Y =  9.851726E-01  3.386406E-05  1.479357E-02
+C   AT T =  4.0000E+00   Y =  9.055142E-01  2.240418E-05  9.446344E-02
+C   AT T =  4.0000E+01   Y =  7.158050E-01  9.184616E-06  2.841858E-01
+C   AT T =  4.0000E+02   Y =  4.504846E-01  3.222434E-06  5.495122E-01
+C   AT T =  4.0000E+03   Y =  1.831701E-01  8.940379E-07  8.168290E-01
+C   AT T =  4.0000E+04   Y =  3.897016E-02  1.621193E-07  9.610297E-01
+C   AT T =  4.0000E+05   Y =  4.935213E-03  1.983756E-08  9.950648E-01
+C   AT T =  4.0000E+06   Y =  5.159269E-04  2.064759E-09  9.994841E-01
+C   AT T =  4.0000E+07   Y =  5.306413E-05  2.122677E-10  9.999469E-01
+C   AT T =  4.0000E+08   Y =  5.494529E-06  2.197824E-11  9.999945E-01
+C   AT T =  4.0000E+09   Y =  5.129458E-07  2.051784E-12  9.999995E-01
+C   AT T =  4.0000E+10   Y = -7.170586E-08 -2.868234E-13  1.000000E+00
+C
+C   NO. STEPS = 330  NO. F-S = 405  NO. J-S =  69 
+C-----------------------------------------------------------------------
+C FULL DESCRIPTION OF USER INTERFACE TO LSODE.
+C
+C THE USER INTERFACE TO LSODE CONSISTS OF THE FOLLOWING PARTS.
+C
+C I.   THE CALL SEQUENCE TO SUBROUTINE LSODE, WHICH IS A DRIVER
+C      ROUTINE FOR THE SOLVER.  THIS INCLUDES DESCRIPTIONS OF BOTH
+C      THE CALL SEQUENCE ARGUMENTS AND OF USER-SUPPLIED ROUTINES.
+C      FOLLOWING THESE DESCRIPTIONS IS A DESCRIPTION OF
+C      OPTIONAL INPUTS AVAILABLE THROUGH THE CALL SEQUENCE, AND THEN
+C      A DESCRIPTION OF OPTIONAL OUTPUTS (IN THE WORK ARRAYS).
+C
+C II.  DESCRIPTIONS OF OTHER ROUTINES IN THE LSODE PACKAGE THAT MAY BE
+C      (OPTIONALLY) CALLED BY THE USER.  THESE PROVIDE THE ABILITY TO 
+C      ALTER ERROR MESSAGE HANDLING, SAVE AND RESTORE THE INTERNAL
+C      COMMON, AND OBTAIN SPECIFIED DERIVATIVES OF THE SOLUTION Y(T). 
+C
+C III. DESCRIPTIONS OF COMMON BLOCKS TO BE DECLARED IN OVERLAY
+C      OR SIMILAR ENVIRONMENTS, OR TO BE SAVED WHEN DOING AN INTERRUPT
+C      OF THE PROBLEM AND CONTINUED SOLUTION LATER.
+C
+C IV.  DESCRIPTION OF TWO ROUTINES IN THE LSODE PACKAGE, EITHER OF
+C      WHICH THE USER MAY REPLACE WITH HIS OWN VERSION, IF DESIRED.
+C      THESE RELATE TO THE MEASUREMENT OF ERRORS. 
+C
+C-----------------------------------------------------------------------
+C PART I.  CALL SEQUENCE.
+C
+C THE CALL SEQUENCE PARAMETERS USED FOR INPUT ONLY ARE
+C     F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, MF, 
+C AND THOSE USED FOR BOTH INPUT AND OUTPUT ARE
+C     Y, T, ISTATE. 
+C THE WORK ARRAYS RWORK AND IWORK ARE ALSO USED FOR CONDITIONAL AND
+C OPTIONAL INPUTS AND OPTIONAL OUTPUTS.  (THE TERM OUTPUT HERE REFERS 
+C TO THE RETURN FROM SUBROUTINE LSODE TO THE USER-S CALLING PROGRAM.) 
+C
+C THE LEGALITY OF INPUT PARAMETERS WILL BE THOROUGHLY CHECKED ON THE
+C INITIAL CALL FOR THE PROBLEM, BUT NOT CHECKED THEREAFTER UNLESS A
+C CHANGE IN INPUT PARAMETERS IS FLAGGED BY ISTATE = 3 ON INPUT.
+C
+C THE DESCRIPTIONS OF THE CALL ARGUMENTS ARE AS FOLLOWS.
+C
+C F      = THE NAME OF THE USER-SUPPLIED SUBROUTINE DEFINING THE
+C          ODE SYSTEM.  THE SYSTEM MUST BE PUT IN THE FIRST-ORDER
+C          FORM DY/DT = F(T,Y), WHERE F IS A VECTOR-VALUED FUNCTION
+C          OF THE SCALAR T AND THE VECTOR Y.  SUBROUTINE F IS TO
+C          COMPUTE THE FUNCTION F.  IT IS TO HAVE THE FORM
+C               SUBROUTINE F (NEQ, T, Y, YDOT)
+C               DIMENSION Y(1), YDOT(1) 
+C          WHERE NEQ, T, AND Y ARE INPUT, AND THE ARRAY YDOT = F(T,Y) 
+C          IS OUTPUT.  Y AND YDOT ARE ARRAYS OF LENGTH NEQ. 
+C          (IN THE DIMENSION STATEMENT ABOVE, 1 IS A DUMMY
+C          DIMENSION.. IT CAN BE REPLACED BY ANY VALUE.)
+C          SUBROUTINE F SHOULD NOT ALTER Y(1),...,Y(NEQ).
+C          F MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM.
+C
+C          SUBROUTINE F MAY ACCESS USER-DEFINED QUANTITIES IN
+C          NEQ(2),... AND/OR IN Y(NEQ(1)+1),... IF NEQ IS AN ARRAY
+C          (DIMENSIONED IN F) AND/OR Y HAS LENGTH EXCEEDING NEQ(1).
+C          SEE THE DESCRIPTIONS OF NEQ AND Y BELOW.
+C
+C          IF QUANTITIES COMPUTED IN THE F ROUTINE ARE NEEDED
+C          EXTERNALLY TO LSODE, AN EXTRA CALL TO F SHOULD BE MADE
+C          FOR THIS PURPOSE, FOR CONSISTENT AND ACCURATE RESULTS.
+C          IF ONLY THE DERIVATIVE DY/DT IS NEEDED, USE INTDY INSTEAD. 
+C
+C NEQ    = THE SIZE OF THE ODE SYSTEM (NUMBER OF FIRST ORDER
+C          ORDINARY DIFFERENTIAL EQUATIONS).  USED ONLY FOR INPUT.
+C          NEQ MAY BE DECREASED, BUT NOT INCREASED, DURING THE PROBLEM.
+C          IF NEQ IS DECREASED (WITH ISTATE = 3 ON INPUT), THE
+C          REMAINING COMPONENTS OF Y SHOULD BE LEFT UNDISTURBED, IF
+C          THESE ARE TO BE ACCESSED IN F AND/OR JAC.
+C
+C          NORMALLY, NEQ IS A SCALAR, AND IT IS GENERALLY REFERRED TO 
+C          AS A SCALAR IN THIS USER INTERFACE DESCRIPTION.  HOWEVER,
+C          NEQ MAY BE AN ARRAY, WITH NEQ(1) SET TO THE SYSTEM SIZE.
+C          (THE LSODE PACKAGE ACCESSES ONLY NEQ(1).)  IN EITHER CASE, 
+C          THIS PARAMETER IS PASSED AS THE NEQ ARGUMENT IN ALL CALLS
+C          TO F AND JAC.  HENCE, IF IT IS AN ARRAY, LOCATIONS
+C          NEQ(2),... MAY BE USED TO STORE OTHER INTEGER DATA AND PASS
+C          IT TO F AND/OR JAC.  SUBROUTINES F AND/OR JAC MUST INCLUDE 
+C          NEQ IN A DIMENSION STATEMENT IN THAT CASE.
+C
+C Y      = A REAL ARRAY FOR THE VECTOR OF DEPENDENT VARIABLES, OF
+C          LENGTH NEQ OR MORE.  USED FOR BOTH INPUT AND OUTPUT ON THE 
+C          FIRST CALL (ISTATE = 1), AND ONLY FOR OUTPUT ON OTHER CALLS.
+C          ON THE FIRST CALL, Y MUST CONTAIN THE VECTOR OF INITIAL
+C          VALUES.  ON OUTPUT, Y CONTAINS THE COMPUTED SOLUTION VECTOR,
+C          EVALUATED AT T.  IF DESIRED, THE Y ARRAY MAY BE USED
+C          FOR OTHER PURPOSES BETWEEN CALLS TO THE SOLVER.
+C
+C          THIS ARRAY IS PASSED AS THE Y ARGUMENT IN ALL CALLS TO
+C          F AND JAC.  HENCE ITS LENGTH MAY EXCEED NEQ, AND LOCATIONS 
+C          Y(NEQ+1),... MAY BE USED TO STORE OTHER REAL DATA AND
+C          PASS IT TO F AND/OR JAC.  (THE LSODE PACKAGE ACCESSES ONLY 
+C          Y(1),...,Y(NEQ).)
+C
+C T      = THE INDEPENDENT VARIABLE.  ON INPUT, T IS USED ONLY ON THE 
+C          FIRST CALL, AS THE INITIAL POINT OF THE INTEGRATION.
+C          ON OUTPUT, AFTER EACH CALL, T IS THE VALUE AT WHICH A
+C          COMPUTED SOLUTION Y IS EVALUATED (USUALLY THE SAME AS TOUT).
+C          ON AN ERROR RETURN, T IS THE FARTHEST POINT REACHED.
+C
+C TOUT   = THE NEXT VALUE OF T AT WHICH A COMPUTED SOLUTION IS DESIRED.
+C          USED ONLY FOR INPUT.
+C
+C          WHEN STARTING THE PROBLEM (ISTATE = 1), TOUT MAY BE EQUAL
+C          TO T FOR ONE CALL, THEN SHOULD .NE. T FOR THE NEXT CALL.
+C          FOR THE INITIAL T, AN INPUT VALUE OF TOUT .NE. T IS USED
+C          IN ORDER TO DETERMINE THE DIRECTION OF THE INTEGRATION
+C          (I.E. THE ALGEBRAIC SIGN OF THE STEP SIZES) AND THE ROUGH
+C          SCALE OF THE PROBLEM.  INTEGRATION IN EITHER DIRECTION
+C          (FORWARD OR BACKWARD IN T) IS PERMITTED.
+C
+C          IF ITASK = 2 OR 5 (ONE-STEP MODES), TOUT IS IGNORED AFTER
+C          THE FIRST CALL (I.E. THE FIRST CALL WITH TOUT .NE. T).
+C          OTHERWISE, TOUT IS REQUIRED ON EVERY CALL.
+C
+C          IF ITASK = 1, 3, OR 4, THE VALUES OF TOUT NEED NOT BE
+C          MONOTONE, BUT A VALUE OF TOUT WHICH BACKS UP IS LIMITED
+C          TO THE CURRENT INTERNAL T INTERVAL, WHOSE ENDPOINTS ARE
+C          TCUR - HU AND TCUR (SEE OPTIONAL OUTPUTS, BELOW, FOR
+C          TCUR AND HU).
+C
+C ITOL   = AN INDICATOR FOR THE TYPE OF ERROR CONTROL.  SEE 
+C          DESCRIPTION BELOW UNDER ATOL.  USED ONLY FOR INPUT.
+C
+C RTOL   = A RELATIVE ERROR TOLERANCE PARAMETER, EITHER A SCALAR OR
+C          AN ARRAY OF LENGTH NEQ.  SEE DESCRIPTION BELOW UNDER ATOL. 
+C          INPUT ONLY.
+C
+C ATOL   = AN ABSOLUTE ERROR TOLERANCE PARAMETER, EITHER A SCALAR OR
+C          AN ARRAY OF LENGTH NEQ.  INPUT ONLY.
+C
+C             THE INPUT PARAMETERS ITOL, RTOL, AND ATOL DETERMINE
+C          THE ERROR CONTROL PERFORMED BY THE SOLVER.  THE SOLVER WILL
+C          CONTROL THE VECTOR E = (E(I)) OF ESTIMATED LOCAL ERRORS
+C          IN Y, ACCORDING TO AN INEQUALITY OF THE FORM
+C                      RMS-NORM OF ( E(I)/EWT(I) )   .LE.   1,
+C          WHERE       EWT(I) = RTOL(I)*ABS(Y(I)) + ATOL(I),
+C          AND THE RMS-NORM (ROOT-MEAN-SQUARE NORM) HERE IS 
+C          RMS-NORM(V) = SQRT(SUM V(I)**2 / NEQ).  HERE EWT = (EWT(I))
+C          IS A VECTOR OF WEIGHTS WHICH MUST ALWAYS BE POSITIVE, AND
+C          THE VALUES OF RTOL AND ATOL SHOULD ALL BE NON-NEGATIVE.
+C          THE FOLLOWING TABLE GIVES THE TYPES (SCALAR/ARRAY) OF
+C          RTOL AND ATOL, AND THE CORRESPONDING FORM OF EWT(I).
+C
+C             ITOL    RTOL       ATOL          EWT(I)
+C              1     SCALAR     SCALAR     RTOL*ABS(Y(I)) + ATOL
+C              2     SCALAR     ARRAY      RTOL*ABS(Y(I)) + ATOL(I)
+C              3     ARRAY      SCALAR     RTOL(I)*ABS(Y(I)) + ATOL
+C              4     ARRAY      ARRAY      RTOL(I)*ABS(Y(I)) + ATOL(I)
+C
+C          WHEN EITHER OF THESE PARAMETERS IS A SCALAR, IT NEED NOT
+C          BE DIMENSIONED IN THE USER-S CALLING PROGRAM.
+C
+C          IF NONE OF THE ABOVE CHOICES (WITH ITOL, RTOL, AND ATOL
+C          FIXED THROUGHOUT THE PROBLEM) IS SUITABLE, MORE GENERAL
+C          ERROR CONTROLS CAN BE OBTAINED BY SUBSTITUTING
+C          USER-SUPPLIED ROUTINES FOR THE SETTING OF EWT AND/OR FOR
+C          THE NORM CALCULATION.  SEE PART IV BELOW.
+C
+C          IF GLOBAL ERRORS ARE TO BE ESTIMATED BY MAKING A REPEATED
+C          RUN ON THE SAME PROBLEM WITH SMALLER TOLERANCES, THEN ALL
+C          COMPONENTS OF RTOL AND ATOL (I.E. OF EWT) SHOULD BE SCALED 
+C          DOWN UNIFORMLY.
+C
+C ITASK  = AN INDEX SPECIFYING THE TASK TO BE PERFORMED.
+C          INPUT ONLY.  ITASK HAS THE FOLLOWING VALUES AND MEANINGS.
+C          1  MEANS NORMAL COMPUTATION OF OUTPUT VALUES OF Y(T) AT
+C             T = TOUT (BY OVERSHOOTING AND INTERPOLATING). 
+C          2  MEANS TAKE ONE STEP ONLY AND RETURN.
+C          3  MEANS STOP AT THE FIRST INTERNAL MESH POINT AT OR
+C             BEYOND T = TOUT AND RETURN.
+C          4  MEANS NORMAL COMPUTATION OF OUTPUT VALUES OF Y(T) AT
+C             T = TOUT BUT WITHOUT OVERSHOOTING T = TCRIT.
+C             TCRIT MUST BE INPUT AS RWORK(1).  TCRIT MAY BE EQUAL TO 
+C             OR BEYOND TOUT, BUT NOT BEHIND IT IN THE DIRECTION OF
+C             INTEGRATION.  THIS OPTION IS USEFUL IF THE PROBLEM
+C             HAS A SINGULARITY AT OR BEYOND T = TCRIT.
+C          5  MEANS TAKE ONE STEP, WITHOUT PASSING TCRIT, AND RETURN. 
+C             TCRIT MUST BE INPUT AS RWORK(1).
+C
+C          NOTE..  IF ITASK = 4 OR 5 AND THE SOLVER REACHES TCRIT
+C          (WITHIN ROUNDOFF), IT WILL RETURN T = TCRIT (EXACTLY) TO
+C          INDICATE THIS (UNLESS ITASK = 4 AND TOUT COMES BEFORE TCRIT,
+C          IN WHICH CASE ANSWERS AT T = TOUT ARE RETURNED FIRST).
+C
+C ISTATE = AN INDEX USED FOR INPUT AND OUTPUT TO SPECIFY THE
+C          THE STATE OF THE CALCULATION.
+C
+C          ON INPUT, THE VALUES OF ISTATE ARE AS FOLLOWS.
+C          1  MEANS THIS IS THE FIRST CALL FOR THE PROBLEM
+C             (INITIALIZATIONS WILL BE DONE).  SEE NOTE BELOW.
+C          2  MEANS THIS IS NOT THE FIRST CALL, AND THE CALCULATION
+C             IS TO CONTINUE NORMALLY, WITH NO CHANGE IN ANY INPUT
+C             PARAMETERS EXCEPT POSSIBLY TOUT AND ITASK.
+C             (IF ITOL, RTOL, AND/OR ATOL ARE CHANGED BETWEEN CALLS
+C             WITH ISTATE = 2, THE NEW VALUES WILL BE USED BUT NOT
+C             TESTED FOR LEGALITY.)
+C          3  MEANS THIS IS NOT THE FIRST CALL, AND THE
+C             CALCULATION IS TO CONTINUE NORMALLY, BUT WITH 
+C             A CHANGE IN INPUT PARAMETERS OTHER THAN
+C             TOUT AND ITASK.  CHANGES ARE ALLOWED IN
+C             NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, ML, MU,
+C             AND ANY OF THE OPTIONAL INPUTS EXCEPT H0.
+C             (SEE IWORK DESCRIPTION FOR ML AND MU.)
+C          NOTE..  A PRELIMINARY CALL WITH TOUT = T IS NOT COUNTED
+C          AS A FIRST CALL HERE, AS NO INITIALIZATION OR CHECKING OF
+C          INPUT IS DONE.  (SUCH A CALL IS SOMETIMES USEFUL FOR THE
+C          PURPOSE OF OUTPUTTING THE INITIAL CONDITIONS.)
+C          THUS THE FIRST CALL FOR WHICH TOUT .NE. T REQUIRES
+C          ISTATE = 1 ON INPUT.
+C
+C          ON OUTPUT, ISTATE HAS THE FOLLOWING VALUES AND MEANINGS.
+C           1  MEANS NOTHING WAS DONE, AS TOUT WAS EQUAL TO T WITH
+C              ISTATE = 1 ON INPUT.  (HOWEVER, AN INTERNAL COUNTER WAS
+C              SET TO DETECT AND PREVENT REPEATED CALLS OF THIS TYPE.)
+C           2  MEANS THE INTEGRATION WAS PERFORMED SUCCESSFULLY.
+C          -1  MEANS AN EXCESSIVE AMOUNT OF WORK (MORE THAN MXSTEP
+C              STEPS) WAS DONE ON THIS CALL, BEFORE COMPLETING THE
+C              REQUESTED TASK, BUT THE INTEGRATION WAS OTHERWISE
+C              SUCCESSFUL AS FAR AS T.  (MXSTEP IS AN OPTIONAL INPUT
+C              AND IS NORMALLY 500.)  TO CONTINUE, THE USER MAY
+C              SIMPLY RESET ISTATE TO A VALUE .GT. 1 AND CALL AGAIN
+C              (THE EXCESS WORK STEP COUNTER WILL BE RESET TO 0).
+C              IN ADDITION, THE USER MAY INCREASE MXSTEP TO AVOID
+C              THIS ERROR RETURN (SEE BELOW ON OPTIONAL INPUTS).
+C          -2  MEANS TOO MUCH ACCURACY WAS REQUESTED FOR THE PRECISION
+C              OF THE MACHINE BEING USED.  THIS WAS DETECTED BEFORE
+C              COMPLETING THE REQUESTED TASK, BUT THE INTEGRATION
+C              WAS SUCCESSFUL AS FAR AS T.  TO CONTINUE, THE TOLERANCE
+C              PARAMETERS MUST BE RESET, AND ISTATE MUST BE SET
+C              TO 3.  THE OPTIONAL OUTPUT TOLSF MAY BE USED FOR THIS
+C              PURPOSE.  (NOTE.. IF THIS CONDITION IS DETECTED BEFORE 
+C              TAKING ANY STEPS, THEN AN ILLEGAL INPUT RETURN
+C              (ISTATE = -3) OCCURS INSTEAD.)
+C          -3  MEANS ILLEGAL INPUT WAS DETECTED, BEFORE TAKING ANY
+C              INTEGRATION STEPS.  SEE WRITTEN MESSAGE FOR DETAILS.
+C              NOTE..  IF THE SOLVER DETECTS AN INFINITE LOOP OF CALLS
+C              TO THE SOLVER WITH ILLEGAL INPUT, IT WILL CAUSE
+C              THE RUN TO STOP.
+C          -4  MEANS THERE WERE REPEATED ERROR TEST FAILURES ON
+C              ONE ATTEMPTED STEP, BEFORE COMPLETING THE REQUESTED
+C              TASK, BUT THE INTEGRATION WAS SUCCESSFUL AS FAR AS T.
+C              THE PROBLEM MAY HAVE A SINGULARITY, OR THE INPUT
+C              MAY BE INAPPROPRIATE.
+C          -5  MEANS THERE WERE REPEATED CONVERGENCE TEST FAILURES ON 
+C              ONE ATTEMPTED STEP, BEFORE COMPLETING THE REQUESTED
+C              TASK, BUT THE INTEGRATION WAS SUCCESSFUL AS FAR AS T.
+C              THIS MAY BE CAUSED BY AN INACCURATE JACOBIAN MATRIX,
+C              IF ONE IS BEING USED.
+C          -6  MEANS EWT(I) BECAME ZERO FOR SOME I DURING THE
+C              INTEGRATION.  PURE RELATIVE ERROR CONTROL (ATOL(I)=0.0)
+C              WAS REQUESTED ON A VARIABLE WHICH HAS NOW VANISHED.
+C              THE INTEGRATION WAS SUCCESSFUL AS FAR AS T.
+C
+C          NOTE..  SINCE THE NORMAL OUTPUT VALUE OF ISTATE IS 2,
+C          IT DOES NOT NEED TO BE RESET FOR NORMAL CONTINUATION.
+C          ALSO, SINCE A NEGATIVE INPUT VALUE OF ISTATE WILL BE
+C          REGARDED AS ILLEGAL, A NEGATIVE OUTPUT VALUE REQUIRES THE
+C          USER TO CHANGE IT, AND POSSIBLY OTHER INPUTS, BEFORE
+C          CALLING THE SOLVER AGAIN.
+C
+C IOPT   = AN INTEGER FLAG TO SPECIFY WHETHER OR NOT ANY OPTIONAL
+C          INPUTS ARE BEING USED ON THIS CALL.  INPUT ONLY. 
+C          THE OPTIONAL INPUTS ARE LISTED SEPARATELY BELOW. 
+C          IOPT = 0 MEANS NO OPTIONAL INPUTS ARE BEING USED.
+C                   DEFAULT VALUES WILL BE USED IN ALL CASES.
+C          IOPT = 1 MEANS ONE OR MORE OPTIONAL INPUTS ARE BEING USED. 
+C
+C RWORK  = A REAL WORKING ARRAY (DOUBLE PRECISION).
+C          THE LENGTH OF RWORK MUST BE AT LEAST
+C             20 + NYH*(MAXORD + 1) + 3*NEQ + LWM    WHERE
+C          NYH    = THE INITIAL VALUE OF NEQ,
+C          MAXORD = 12 (IF METH = 1) OR 5 (IF METH = 2) (UNLESS A
+C                   SMALLER VALUE IS GIVEN AS AN OPTIONAL INPUT),
+C          LWM   = 0             IF MITER = 0,
+C          LWM   = NEQ**2 + 2    IF MITER IS 1 OR 2,
+C          LWM   = NEQ + 2       IF MITER = 3, AND
+C          LWM   = (2*ML+MU+1)*NEQ + 2 IF MITER IS 4 OR 5.
+C          (SEE THE MF DESCRIPTION FOR METH AND MITER.)
+C          THUS IF MAXORD HAS ITS DEFAULT VALUE AND NEQ IS CONSTANT,
+C          THIS LENGTH IS..
+C             20 + 16*NEQ                  FOR MF = 10,
+C             22 + 16*NEQ + NEQ**2         FOR MF = 11 OR 12,
+C             22 + 17*NEQ                  FOR MF = 13,
+C             22 + 17*NEQ + (2*ML+MU)*NEQ  FOR MF = 14 OR 15,
+C             20 +  9*NEQ                  FOR MF = 20,
+C             22 +  9*NEQ + NEQ**2         FOR MF = 21 OR 22,
+C             22 + 10*NEQ                  FOR MF = 23,
+C             22 + 10*NEQ + (2*ML+MU)*NEQ  FOR MF = 24 OR 25.
+C          THE FIRST 20 WORDS OF RWORK ARE RESERVED FOR CONDITIONAL
+C          AND OPTIONAL INPUTS AND OPTIONAL OUTPUTS.
+C
+C          THE FOLLOWING WORD IN RWORK IS A CONDITIONAL INPUT..
+C            RWORK(1) = TCRIT = CRITICAL VALUE OF T WHICH THE SOLVER
+C                       IS NOT TO OVERSHOOT.  REQUIRED IF ITASK IS
+C                       4 OR 5, AND IGNORED OTHERWISE.  (SEE ITASK.)
+C
+C LRW    = THE LENGTH OF THE ARRAY RWORK, AS DECLARED BY THE USER.
+C          (THIS WILL BE CHECKED BY THE SOLVER.)
+C
+C IWORK  = AN INTEGER WORK ARRAY.  THE LENGTH OF IWORK MUST BE AT LEAST
+C             20        IF MITER = 0 OR 3 (MF = 10, 13, 20, 23), OR
+C             20 + NEQ  OTHERWISE (MF = 11, 12, 14, 15, 21, 22, 24, 25).
+C          THE FIRST FEW WORDS OF IWORK ARE USED FOR CONDITIONAL AND
+C          OPTIONAL INPUTS AND OPTIONAL OUTPUTS.
+C
+C          THE FOLLOWING 2 WORDS IN IWORK ARE CONDITIONAL INPUTS..
+C            IWORK(1) = ML     THESE ARE THE LOWER AND UPPER
+C            IWORK(2) = MU     HALF-BANDWIDTHS, RESPECTIVELY, OF THE
+C                       BANDED JACOBIAN, EXCLUDING THE MAIN DIAGONAL. 
+C                       THE BAND IS DEFINED BY THE MATRIX LOCATIONS
+C                       (I,J) WITH I-ML .LE. J .LE. I+MU.  ML AND MU
+C                       MUST SATISFY  0 .LE.  ML,MU  .LE. NEQ-1.
+C                       THESE ARE REQUIRED IF MITER IS 4 OR 5, AND
+C                       IGNORED OTHERWISE.  ML AND MU MAY IN FACT BE
+C                       THE BAND PARAMETERS FOR A MATRIX TO WHICH
+C                       DF/DY IS ONLY APPROXIMATELY EQUAL.
+C
+C LIW    = THE LENGTH OF THE ARRAY IWORK, AS DECLARED BY THE USER.
+C          (THIS WILL BE CHECKED BY THE SOLVER.)
+C
+C NOTE..  THE WORK ARRAYS MUST NOT BE ALTERED BETWEEN CALLS TO LSODE
+C FOR THE SAME PROBLEM, EXCEPT POSSIBLY FOR THE CONDITIONAL AND
+C OPTIONAL INPUTS, AND EXCEPT FOR THE LAST 3*NEQ WORDS OF RWORK.
+C THE LATTER SPACE IS USED FOR INTERNAL SCRATCH SPACE, AND SO IS
+C AVAILABLE FOR USE BY THE USER OUTSIDE LSODE BETWEEN CALLS, IF
+C DESIRED (BUT NOT FOR USE BY F OR JAC).
+C
+C JAC    = THE NAME OF THE USER-SUPPLIED ROUTINE (MITER = 1 OR 4) TO
+C          COMPUTE THE JACOBIAN MATRIX, DF/DY, AS A FUNCTION OF
+C          THE SCALAR T AND THE VECTOR Y.  IT IS TO HAVE THE FORM
+C               SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD)
+C               DIMENSION Y(1), PD(NROWPD,1)
+C          WHERE NEQ, T, Y, ML, MU, AND NROWPD ARE INPUT AND THE ARRAY
+C          PD IS TO BE LOADED WITH PARTIAL DERIVATIVES (ELEMENTS OF
+C          THE JACOBIAN MATRIX) ON OUTPUT.  PD MUST BE GIVEN A FIRST
+C          DIMENSION OF NROWPD.  T AND Y HAVE THE SAME MEANING AS IN
+C          SUBROUTINE F.  (IN THE DIMENSION STATEMENT ABOVE, 1 IS A
+C          DUMMY DIMENSION.. IT CAN BE REPLACED BY ANY VALUE.)
+C               IN THE FULL MATRIX CASE (MITER = 1), ML AND MU ARE
+C          IGNORED, AND THE JACOBIAN IS TO BE LOADED INTO PD IN
+C          COLUMNWISE MANNER, WITH DF(I)/DY(J) LOADED INTO PD(I,J).
+C               IN THE BAND MATRIX CASE (MITER = 4), THE ELEMENTS
+C          WITHIN THE BAND ARE TO BE LOADED INTO PD IN COLUMNWISE
+C          MANNER, WITH DIAGONAL LINES OF DF/DY LOADED INTO THE ROWS
+C          OF PD.  THUS DF(I)/DY(J) IS TO BE LOADED INTO PD(I-J+MU+1,J).
+C          ML AND MU ARE THE HALF-BANDWIDTH PARAMETERS (SEE IWORK).
+C          THE LOCATIONS IN PD IN THE TWO TRIANGULAR AREAS WHICH
+C          CORRESPOND TO NONEXISTENT MATRIX ELEMENTS CAN BE IGNORED
+C          OR LOADED ARBITRARILY, AS THEY ARE OVERWRITTEN BY LSODE.
+C               JAC NEED NOT PROVIDE DF/DY EXACTLY.  A CRUDE
+C          APPROXIMATION (POSSIBLY WITH A SMALLER BANDWIDTH) WILL DO. 
+C               IN EITHER CASE, PD IS PRESET TO ZERO BY THE SOLVER,
+C          SO THAT ONLY THE NONZERO ELEMENTS NEED BE LOADED BY JAC.
+C          EACH CALL TO JAC IS PRECEDED BY A CALL TO F WITH THE SAME
+C          ARGUMENTS NEQ, T, AND Y.  THUS TO GAIN SOME EFFICIENCY,
+C          INTERMEDIATE QUANTITIES SHARED BY BOTH CALCULATIONS MAY BE 
+C          SAVED IN A USER COMMON BLOCK BY F AND NOT RECOMPUTED BY JAC,
+C          IF DESIRED.  ALSO, JAC MAY ALTER THE Y ARRAY, IF DESIRED.
+C          JAC MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM.
+C               SUBROUTINE JAC MAY ACCESS USER-DEFINED QUANTITIES IN
+C          NEQ(2),... AND/OR IN Y(NEQ(1)+1),... IF NEQ IS AN ARRAY
+C          (DIMENSIONED IN JAC) AND/OR Y HAS LENGTH EXCEEDING NEQ(1). 
+C          SEE THE DESCRIPTIONS OF NEQ AND Y ABOVE.
+C
+C MF     = THE METHOD FLAG.  USED ONLY FOR INPUT.  THE LEGAL VALUES OF
+C          MF ARE 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, AND 25. 
+C          MF HAS DECIMAL DIGITS METH AND MITER.. MF = 10*METH + MITER.
+C          METH INDICATES THE BASIC LINEAR MULTISTEP METHOD..
+C            METH = 1 MEANS THE IMPLICIT ADAMS METHOD.
+C            METH = 2 MEANS THE METHOD BASED ON BACKWARD
+C                     DIFFERENTIATION FORMULAS (BDF-S).
+C          MITER INDICATES THE CORRECTOR ITERATION METHOD.. 
+C            MITER = 0 MEANS FUNCTIONAL ITERATION (NO JACOBIAN MATRIX 
+C                      IS INVOLVED).
+C            MITER = 1 MEANS CHORD ITERATION WITH A USER-SUPPLIED
+C                      FULL (NEQ BY NEQ) JACOBIAN.
+C            MITER = 2 MEANS CHORD ITERATION WITH AN INTERNALLY
+C                      GENERATED (DIFFERENCE QUOTIENT) FULL JACOBIAN
+C                      (USING NEQ EXTRA CALLS TO F PER DF/DY VALUE).
+C            MITER = 3 MEANS CHORD ITERATION WITH AN INTERNALLY
+C                      GENERATED DIAGONAL JACOBIAN APPROXIMATION.
+C                      (USING 1 EXTRA CALL TO F PER DF/DY EVALUATION).
+C            MITER = 4 MEANS CHORD ITERATION WITH A USER-SUPPLIED
+C                      BANDED JACOBIAN. 
+C            MITER = 5 MEANS CHORD ITERATION WITH AN INTERNALLY
+C                      GENERATED BANDED JACOBIAN (USING ML+MU+1 EXTRA 
+C                      CALLS TO F PER DF/DY EVALUATION).
+C          IF MITER = 1 OR 4, THE USER MUST SUPPLY A SUBROUTINE JAC
+C          (THE NAME IS ARBITRARY) AS DESCRIBED ABOVE UNDER JAC.
+C          FOR OTHER VALUES OF MITER, A DUMMY ARGUMENT CAN BE USED.
+C-----------------------------------------------------------------------
+C OPTIONAL INPUTS.
+C
+C THE FOLLOWING IS A LIST OF THE OPTIONAL INPUTS PROVIDED FOR IN THE
+C CALL SEQUENCE.  (SEE ALSO PART II.)  FOR EACH SUCH INPUT VARIABLE,
+C THIS TABLE LISTS ITS NAME AS USED IN THIS DOCUMENTATION, ITS
+C LOCATION IN THE CALL SEQUENCE, ITS MEANING, AND THE DEFAULT VALUE.
+C THE USE OF ANY OF THESE INPUTS REQUIRES IOPT = 1, AND IN THAT
+C CASE ALL OF THESE INPUTS ARE EXAMINED.  A VALUE OF ZERO FOR ANY
+C OF THESE OPTIONAL INPUTS WILL CAUSE THE DEFAULT VALUE TO BE USED.
+C THUS TO USE A SUBSET OF THE OPTIONAL INPUTS, SIMPLY PRELOAD
+C LOCATIONS 5 TO 10 IN RWORK AND IWORK TO 0.0 AND 0 RESPECTIVELY, AND 
+C THEN SET THOSE OF INTEREST TO NONZERO VALUES.
+C
+C NAME    LOCATION      MEANING AND DEFAULT VALUE 
+C
+C H0      RWORK(5)  THE STEP SIZE TO BE ATTEMPTED ON THE FIRST STEP.
+C                   THE DEFAULT VALUE IS DETERMINED BY THE SOLVER.
+C
+C HMAX    RWORK(6)  THE MAXIMUM ABSOLUTE STEP SIZE ALLOWED. 
+C                   THE DEFAULT VALUE IS INFINITE.
+C
+C HMIN    RWORK(7)  THE MINIMUM ABSOLUTE STEP SIZE ALLOWED. 
+C                   THE DEFAULT VALUE IS 0.  (THIS LOWER BOUND IS NOT 
+C                   ENFORCED ON THE FINAL STEP BEFORE REACHING TCRIT
+C                   WHEN ITASK = 4 OR 5.)
+C
+C MAXORD  IWORK(5)  THE MAXIMUM ORDER TO BE ALLOWED.  THE DEFAULT
+C                   VALUE IS 12 IF METH = 1, AND 5 IF METH = 2.
+C                   IF MAXORD EXCEEDS THE DEFAULT VALUE, IT WILL
+C                   BE REDUCED TO THE DEFAULT VALUE.
+C                   IF MAXORD IS CHANGED DURING THE PROBLEM, IT MAY
+C                   CAUSE THE CURRENT ORDER TO BE REDUCED.
+C
+C MXSTEP  IWORK(6)  MAXIMUM NUMBER OF (INTERNALLY DEFINED) STEPS
+C                   ALLOWED DURING ONE CALL TO THE SOLVER.
+C                   THE DEFAULT VALUE IS 500.
+C
+C MXHNIL  IWORK(7)  MAXIMUM NUMBER OF MESSAGES PRINTED (PER PROBLEM)
+C                   WARNING THAT T + H = T ON A STEP (H = STEP SIZE). 
+C                   THIS MUST BE POSITIVE TO RESULT IN A NON-DEFAULT
+C                   VALUE.  THE DEFAULT VALUE IS 10.
+C-----------------------------------------------------------------------
+C OPTIONAL OUTPUTS. 
+C
+C AS OPTIONAL ADDITIONAL OUTPUT FROM LSODE, THE VARIABLES LISTED
+C BELOW ARE QUANTITIES RELATED TO THE PERFORMANCE OF LSODE
+C WHICH ARE AVAILABLE TO THE USER.  THESE ARE COMMUNICATED BY WAY OF
+C THE WORK ARRAYS, BUT ALSO HAVE INTERNAL MNEMONIC NAMES AS SHOWN.
+C EXCEPT WHERE STATED OTHERWISE, ALL OF THESE OUTPUTS ARE DEFINED
+C ON ANY SUCCESSFUL RETURN FROM LSODE, AND ON ANY RETURN WITH
+C ISTATE = -1, -2, -4, -5, OR -6.  ON AN ILLEGAL INPUT RETURN
+C (ISTATE = -3), THEY WILL BE UNCHANGED FROM THEIR EXISTING VALUES
+C (IF ANY), EXCEPT POSSIBLY FOR TOLSF, LENRW, AND LENIW.
+C ON ANY ERROR RETURN, OUTPUTS RELEVANT TO THE ERROR WILL BE DEFINED, 
+C AS NOTED BELOW.
+C
+C NAME    LOCATION      MEANING
+C
+C HU      RWORK(11) THE STEP SIZE IN T LAST USED (SUCCESSFULLY).
+C
+C HCUR    RWORK(12) THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP.
+C
+C TCUR    RWORK(13) THE CURRENT VALUE OF THE INDEPENDENT VARIABLE
+C                   WHICH THE SOLVER HAS ACTUALLY REACHED, I.E. THE
+C                   CURRENT INTERNAL MESH POINT IN T.  ON OUTPUT, TCUR
+C                   WILL ALWAYS BE AT LEAST AS FAR AS THE ARGUMENT
+C                   T, BUT MAY BE FARTHER (IF INTERPOLATION WAS DONE).
+C
+C TOLSF   RWORK(14) A TOLERANCE SCALE FACTOR, GREATER THAN 1.0,
+C                   COMPUTED WHEN A REQUEST FOR TOO MUCH ACCURACY WAS 
+C                   DETECTED (ISTATE = -3 IF DETECTED AT THE START OF 
+C                   THE PROBLEM, ISTATE = -2 OTHERWISE).  IF ITOL IS
+C                   LEFT UNALTERED BUT RTOL AND ATOL ARE UNIFORMLY
+C                   SCALED UP BY A FACTOR OF TOLSF FOR THE NEXT CALL, 
+C                   THEN THE SOLVER IS DEEMED LIKELY TO SUCCEED.
+C                   (THE USER MAY ALSO IGNORE TOLSF AND ALTER THE
+C                   TOLERANCE PARAMETERS IN ANY OTHER WAY APPROPRIATE.)
+C
+C NST     IWORK(11) THE NUMBER OF STEPS TAKEN FOR THE PROBLEM SO FAR. 
+C
+C NFE     IWORK(12) THE NUMBER OF F EVALUATIONS FOR THE PROBLEM SO FAR.
+C
+C NJE     IWORK(13) THE NUMBER OF JACOBIAN EVALUATIONS (AND OF MATRIX 
+C                   LU DECOMPOSITIONS) FOR THE PROBLEM SO FAR.
+C
+C NQU     IWORK(14) THE METHOD ORDER LAST USED (SUCCESSFULLY).
+C
+C NQCUR   IWORK(15) THE ORDER TO BE ATTEMPTED ON THE NEXT STEP.
+C
+C IMXER   IWORK(16) THE INDEX OF THE COMPONENT OF LARGEST MAGNITUDE IN
+C                   THE WEIGHTED LOCAL ERROR VECTOR ( E(I)/EWT(I) ),
+C                   ON AN ERROR RETURN WITH ISTATE = -4 OR -5.
+C
+C LENRW   IWORK(17) THE LENGTH OF RWORK ACTUALLY REQUIRED.
+C                   THIS IS DEFINED ON NORMAL RETURNS AND ON AN ILLEGAL
+C                   INPUT RETURN FOR INSUFFICIENT STORAGE.
+C
+C LENIW   IWORK(18) THE LENGTH OF IWORK ACTUALLY REQUIRED.
+C                   THIS IS DEFINED ON NORMAL RETURNS AND ON AN ILLEGAL
+C                   INPUT RETURN FOR INSUFFICIENT STORAGE.
+C
+C THE FOLLOWING TWO ARRAYS ARE SEGMENTS OF THE RWORK ARRAY WHICH
+C MAY ALSO BE OF INTEREST TO THE USER AS OPTIONAL OUTPUTS.
+C FOR EACH ARRAY, THE TABLE BELOW GIVES ITS INTERNAL NAME,
+C ITS BASE ADDRESS IN RWORK, AND ITS DESCRIPTION. 
+C
+C NAME    BASE ADDRESS      DESCRIPTION 
+C
+C YH      21             THE NORDSIECK HISTORY ARRAY, OF SIZE NYH BY
+C                        (NQCUR + 1), WHERE NYH IS THE INITIAL VALUE
+C                        OF NEQ.  FOR J = 0,1,...,NQCUR, COLUMN J+1
+C                        OF YH CONTAINS HCUR**J/FACTORIAL(J) TIMES
+C                        THE J-TH DERIVATIVE OF THE INTERPOLATING
+C                        POLYNOMIAL CURRENTLY REPRESENTING THE SOLUTION,
+C                        EVALUATED AT T = TCUR.
+C
+C ACOR     LENRW-NEQ+1   ARRAY OF SIZE NEQ USED FOR THE ACCUMULATED
+C                        CORRECTIONS ON EACH STEP, SCALED ON OUTPUT
+C                        TO REPRESENT THE ESTIMATED LOCAL ERROR IN Y
+C                        ON THE LAST STEP.  THIS IS THE VECTOR E IN
+C                        THE DESCRIPTION OF THE ERROR CONTROL.  IT IS 
+C                        DEFINED ONLY ON A SUCCESSFUL RETURN FROM LSODE.
+C
+C-----------------------------------------------------------------------
+C PART II.  OTHER ROUTINES CALLABLE.
+C
+C THE FOLLOWING ARE OPTIONAL CALLS WHICH THE USER MAY MAKE TO
+C GAIN ADDITIONAL CAPABILITIES IN CONJUNCTION WITH LSODE.
+C (THE ROUTINES XSETUN AND XSETF ARE DESIGNED TO CONFORM TO THE
+C SLATEC ERROR HANDLING PACKAGE.)
+C
+C     FORM OF CALL                  FUNCTION
+C   CALL XSETUN(LUN)          SET THE LOGICAL UNIT NUMBER, LUN, FOR
+C                             OUTPUT OF MESSAGES FROM LSODE, IF
+C                             THE DEFAULT IS NOT DESIRED.
+C                             THE DEFAULT VALUE OF LUN IS 6.
+C
+C   CALL XSETF(MFLAG)         SET A FLAG TO CONTROL THE PRINTING OF
+C                             MESSAGES BY LSODE.
+C                             MFLAG = 0 MEANS DO NOT PRINT. (DANGER.. 
+C                             THIS RISKS LOSING VALUABLE INFORMATION.)
+C                             MFLAG = 1 MEANS PRINT (THE DEFAULT).
+C
+C                             EITHER OF THE ABOVE CALLS MAY BE MADE AT
+C                             ANY TIME AND WILL TAKE EFFECT IMMEDIATELY.
+C
+C   CALL SRCOM(RSAV,ISAV,JOB) SAVES AND RESTORES THE CONTENTS OF
+C                             THE INTERNAL COMMON BLOCKS USED BY
+C                             LSODE (SEE PART III BELOW).
+C                             RSAV MUST BE A REAL ARRAY OF LENGTH 218 
+C                             OR MORE, AND ISAV MUST BE AN INTEGER
+C                             ARRAY OF LENGTH 41 OR MORE.
+C                             JOB=1 MEANS SAVE COMMON INTO RSAV/ISAV. 
+C                             JOB=2 MEANS RESTORE COMMON FROM RSAV/ISAV.
+C                                SRCOM IS USEFUL IF ONE IS
+C                             INTERRUPTING A RUN AND RESTARTING
+C                             LATER, OR ALTERNATING BETWEEN TWO OR
+C                             MORE PROBLEMS SOLVED WITH LSODE.
+C
+C   CALL INTDY(,,,,,)         PROVIDE DERIVATIVES OF Y, OF VARIOUS
+C        (SEE BELOW)          ORDERS, AT A SPECIFIED POINT T, IF
+C                             DESIRED.  IT MAY BE CALLED ONLY AFTER
+C                             A SUCCESSFUL RETURN FROM LSODE.
+C
+C THE DETAILED INSTRUCTIONS FOR USING INTDY ARE AS FOLLOWS. 
+C THE FORM OF THE CALL IS..
+C
+C   CALL INTDY (T, K, RWORK(21), NYH, DKY, IFLAG) 
+C
+C THE INPUT PARAMETERS ARE..
+C
+C T         = VALUE OF INDEPENDENT VARIABLE WHERE ANSWERS ARE DESIRED 
+C             (NORMALLY THE SAME AS THE T LAST RETURNED BY LSODE).
+C             FOR VALID RESULTS, T MUST LIE BETWEEN TCUR - HU AND TCUR.
+C             (SEE OPTIONAL OUTPUTS FOR TCUR AND HU.)
+C K         = INTEGER ORDER OF THE DERIVATIVE DESIRED.  K MUST SATISFY
+C             0 .LE. K .LE. NQCUR, WHERE NQCUR IS THE CURRENT ORDER
+C             (SEE OPTIONAL OUTPUTS).  THE CAPABILITY CORRESPONDING
+C             TO K = 0, I.E. COMPUTING Y(T), IS ALREADY PROVIDED
+C             BY LSODE DIRECTLY.  SINCE NQCUR .GE. 1, THE FIRST
+C             DERIVATIVE DY/DT IS ALWAYS AVAILABLE WITH INTDY.
+C RWORK(21) = THE BASE ADDRESS OF THE HISTORY ARRAY YH.
+C NYH       = COLUMN LENGTH OF YH, EQUAL TO THE INITIAL VALUE OF NEQ. 
+C
+C THE OUTPUT PARAMETERS ARE.. 
+C
+C DKY       = A REAL ARRAY OF LENGTH NEQ CONTAINING THE COMPUTED VALUE
+C             OF THE K-TH DERIVATIVE OF Y(T).
+C IFLAG     = INTEGER FLAG, RETURNED AS 0 IF K AND T WERE LEGAL,
+C             -1 IF K WAS ILLEGAL, AND -2 IF T WAS ILLEGAL. 
+C             ON AN ERROR RETURN, A MESSAGE IS ALSO WRITTEN.
+C-----------------------------------------------------------------------
+C PART III.  COMMON BLOCKS.
+C
+C IF LSODE IS TO BE USED IN AN OVERLAY SITUATION, THE USER
+C MUST DECLARE, IN THE PRIMARY OVERLAY, THE VARIABLES IN..
+C   (1) THE CALL SEQUENCE TO LSODE,
+C   (2) THE TWO INTERNAL COMMON BLOCKS
+C         /LS0001/  OF LENGTH  257  (218 DOUBLE PRECISION WORDS
+C                         FOLLOWED BY 39 INTEGER WORDS),
+C         /EH0001/  OF LENGTH  2 (INTEGER WORDS). 
+C
+C IF LSODE IS USED ON A SYSTEM IN WHICH THE CONTENTS OF INTERNAL
+C COMMON BLOCKS ARE NOT PRESERVED BETWEEN CALLS, THE USER SHOULD
+C DECLARE THE ABOVE TWO COMMON BLOCKS IN HIS MAIN PROGRAM TO INSURE
+C THAT THEIR CONTENTS ARE PRESERVED.
+C
+C IF THE SOLUTION OF A GIVEN PROBLEM BY LSODE IS TO BE INTERRUPTED
+C AND THEN LATER CONTINUED, SUCH AS WHEN RESTARTING AN INTERRUPTED RUN
+C OR ALTERNATING BETWEEN TWO OR MORE PROBLEMS, THE USER SHOULD SAVE,
+C FOLLOWING THE RETURN FROM THE LAST LSODE CALL PRIOR TO THE
+C INTERRUPTION, THE CONTENTS OF THE CALL SEQUENCE VARIABLES AND THE
+C INTERNAL COMMON BLOCKS, AND LATER RESTORE THESE VALUES BEFORE THE
+C NEXT LSODE CALL FOR THAT PROBLEM.  TO SAVE AND RESTORE THE COMMON
+C BLOCKS, USE SUBROUTINE SRCOM (SEE PART II ABOVE).
+C
+C-----------------------------------------------------------------------
+C PART IV.  OPTIONALLY REPLACEABLE SOLVER ROUTINES.
+C
+C BELOW ARE DESCRIPTIONS OF TWO ROUTINES IN THE LSODE PACKAGE WHICH
+C RELATE TO THE MEASUREMENT OF ERRORS.  EITHER ROUTINE CAN BE
+C REPLACED BY A USER-SUPPLIED VERSION, IF DESIRED.  HOWEVER, SINCE SUCH
+C A REPLACEMENT MAY HAVE A MAJOR IMPACT ON PERFORMANCE, IT SHOULD BE
+C DONE ONLY WHEN ABSOLUTELY NECESSARY, AND ONLY WITH GREAT CAUTION.
+C (NOTE.. THE MEANS BY WHICH THE PACKAGE VERSION OF A ROUTINE IS
+C SUPERSEDED BY THE USER-S VERSION MAY BE SYSTEM-DEPENDENT.)
+C
+C (A) EWSET.
+C THE FOLLOWING SUBROUTINE IS CALLED JUST BEFORE EACH INTERNAL
+C INTEGRATION STEP, AND SETS THE ARRAY OF ERROR WEIGHTS, EWT, AS
+C DESCRIBED UNDER ITOL/RTOL/ATOL ABOVE..
+C     SUBROUTINE EWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT)
+C WHERE NEQ, ITOL, RTOL, AND ATOL ARE AS IN THE LSODE CALL SEQUENCE,
+C YCUR CONTAINS THE CURRENT DEPENDENT VARIABLE VECTOR, AND
+C EWT IS THE ARRAY OF WEIGHTS SET BY EWSET.
+C
+C IF THE USER SUPPLIES THIS SUBROUTINE, IT MUST RETURN IN EWT(I)
+C (I = 1,...,NEQ) A POSITIVE QUANTITY SUITABLE FOR COMPARING ERRORS
+C IN Y(I) TO.  THE EWT ARRAY RETURNED BY EWSET IS PASSED TO THE
+C VNORM ROUTINE (SEE BELOW), AND ALSO USED BY LSODE IN THE COMPUTATION
+C OF THE OPTIONAL OUTPUT IMXER, THE DIAGONAL JACOBIAN APPROXIMATION,
+C AND THE INCREMENTS FOR DIFFERENCE QUOTIENT JACOBIANS.
+C
+C IN THE USER-SUPPLIED VERSION OF EWSET, IT MAY BE DESIRABLE TO USE
+C THE CURRENT VALUES OF DERIVATIVES OF Y.  DERIVATIVES UP TO ORDER NQ 
+C ARE AVAILABLE FROM THE HISTORY ARRAY YH, DESCRIBED ABOVE UNDER
+C OPTIONAL OUTPUTS.  IN EWSET, YH IS IDENTICAL TO THE YCUR ARRAY,
+C EXTENDED TO NQ + 1 COLUMNS WITH A COLUMN LENGTH OF NYH AND SCALE
+C FACTORS OF H**J/FACTORIAL(J).  ON THE FIRST CALL FOR THE PROBLEM,
+C GIVEN BY NST = 0, NQ IS 1 AND H IS TEMPORARILY SET TO 1.0.
+C THE QUANTITIES NQ, NYH, H, AND NST CAN BE OBTAINED BY INCLUDING
+C IN EWSET THE STATEMENTS..
+C     DOUBLE PRECISION H, RLS 
+C     COMMON /LS0001/ RLS(218),ILS(39)
+C     NQ = ILS(35)
+C     NYH = ILS(14) 
+C     NST = ILS(36) 
+C     H = RLS(212)
+C THUS, FOR EXAMPLE, THE CURRENT VALUE OF DY/DT CAN BE OBTAINED AS
+C YCUR(NYH+I)/H  (I=1,...,NEQ)  (AND THE DIVISION BY H IS
+C UNNECESSARY WHEN NST = 0).
+C
+C (B) VNORM.
+C THE FOLLOWING IS A REAL FUNCTION ROUTINE WHICH COMPUTES THE WEIGHTED
+C ROOT-MEAN-SQUARE NORM OF A VECTOR V.. 
+C     D = VNORM (N, V, W)
+C WHERE.. 
+C   N = THE LENGTH OF THE VECTOR,
+C   V = REAL ARRAY OF LENGTH N CONTAINING THE VECTOR,
+C   W = REAL ARRAY OF LENGTH N CONTAINING WEIGHTS,
+C   D = SQRT( (1/N) * SUM(V(I)*W(I))**2 ).
+C VNORM IS CALLED WITH N = NEQ AND WITH W(I) = 1.0/EWT(I), WHERE
+C EWT IS AS SET BY SUBROUTINE EWSET.
+C
+C IF THE USER SUPPLIES THIS FUNCTION, IT SHOULD RETURN A NON-NEGATIVE 
+C VALUE OF VNORM SUITABLE FOR USE IN THE ERROR CONTROL IN LSODE.
+C NONE OF THE ARGUMENTS SHOULD BE ALTERED BY VNORM.
+C FOR EXAMPLE, A USER-SUPPLIED VNORM ROUTINE MIGHT..
+C   -SUBSTITUTE A MAX-NORM OF (V(I)*W(I)) FOR THE RMS-NORM, OR
+C   -IGNORE SOME COMPONENTS OF V IN THE NORM, WITH THE EFFECT OF
+C    SUPPRESSING THE ERROR CONTROL ON THOSE COMPONENTS OF Y.
+C-----------------------------------------------------------------------
+C-----------------------------------------------------------------------
+C OTHER ROUTINES IN THE LSODE PACKAGE.
+C
+C IN ADDITION TO SUBROUTINE LSODE, THE LSODE PACKAGE INCLUDES THE
+C FOLLOWING SUBROUTINES AND FUNCTION ROUTINES..
+C  INTDY    COMPUTES AN INTERPOLATED VALUE OF THE Y VECTOR AT T = TOUT.
+C  STODE    IS THE CORE INTEGRATOR, WHICH DOES ONE STEP OF THE
+C           INTEGRATION AND THE ASSOCIATED ERROR CONTROL.
+C  CFODE    SETS ALL METHOD COEFFICIENTS AND TEST CONSTANTS.
+C  PREPJ    COMPUTES AND PREPROCESSES THE JACOBIAN MATRIX J = DF/DY
+C           AND THE NEWTON ITERATION MATRIX P = I - H*L0*J. 
+C  SOLSY    MANAGES SOLUTION OF LINEAR SYSTEM IN CHORD ITERATION.
+C  EWSET    SETS THE ERROR WEIGHT VECTOR EWT BEFORE EACH STEP.
+C  VNORM    COMPUTES THE WEIGHTED R.M.S. NORM OF A VECTOR.
+C  SRCOM    IS A USER-CALLABLE ROUTINE TO SAVE AND RESTORE
+C           THE CONTENTS OF THE INTERNAL COMMON BLOCKS.
+C  DGEFA AND DGESL   ARE ROUTINES FROM LINPACK FOR SOLVING FULL
+C           SYSTEMS OF LINEAR ALGEBRAIC EQUATIONS.
+C  DGBFA AND DGBSL   ARE ROUTINES FROM LINPACK FOR SOLVING BANDED
+C           LINEAR SYSTEMS.
+C  DAXPY, DSCAL, IDAMAX, AND DDOT   ARE BASIC LINEAR ALGEBRA MODULES
+C           (BLAS) USED BY THE ABOVE LINPACK ROUTINES.
+C  D1MACH   COMPUTES THE UNIT ROUNDOFF IN A MACHINE-INDEPENDENT MANNER.
+C  XERRWV, XSETUN, AND XSETF   HANDLE THE PRINTING OF ALL ERROR
+C           MESSAGES AND WARNINGS.  XERRWV IS MACHINE-DEPENDENT.
+C NOTE..  VNORM, IDAMAX, DDOT, AND D1MACH ARE FUNCTION ROUTINES.
+C ALL THE OTHERS ARE SUBROUTINES.
+C
+C THE INTRINSIC AND EXTERNAL ROUTINES USED BY LSODE ARE..
+C DABS, DMAX1, DMIN1, DBLE, MAX0, MIN0, MOD, DSIGN, DSQRT, AND WRITE. 
+C
+C A BLOCK DATA SUBPROGRAM IS ALSO INCLUDED WITH THE PACKAGE,
+C FOR LOADING SOME OF THE VARIABLES IN INTERNAL COMMON.
+C
+C-----------------------------------------------------------------------
+C THE FOLLOWING CARD IS FOR OPTIMIZED COMPILATION ON LLNL COMPILERS.
+CLLL. OPTIMIZE
+C-----------------------------------------------------------------------
+      EXTERNAL PREPJ, SOLSY
+      INTEGER ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM,
+     1   MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, NYH, IOWNS
+      INTEGER ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER, 
+     1   MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU
+      INTEGER I, I1, I2, IFLAG, IMXER, KGO, LF0,
+     1   LENIW, LENRW, LENWM, ML, MORD, MU, MXHNL0, MXSTP0
+      DOUBLE PRECISION ROWNS, 
+     1   CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND
+      DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI,
+     1   TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0,
+     2   D1MACH, VNORM
+      DIMENSION MORD(2)
+      LOGICAL IHIT
+C-----------------------------------------------------------------------
+C THE FOLLOWING INTERNAL COMMON BLOCK CONTAINS
+C (A) VARIABLES WHICH ARE LOCAL TO ANY SUBROUTINE BUT WHOSE VALUES MUST
+C     BE PRESERVED BETWEEN CALLS TO THE ROUTINE (OWN VARIABLES), AND
+C (B) VARIABLES WHICH ARE COMMUNICATED BETWEEN SUBROUTINES. 
+C THE STRUCTURE OF THE BLOCK IS AS FOLLOWS..  ALL REAL VARIABLES ARE
+C LISTED FIRST, FOLLOWED BY ALL INTEGERS.  WITHIN EACH TYPE, THE
+C VARIABLES ARE GROUPED WITH THOSE LOCAL TO SUBROUTINE LSODE FIRST,
+C THEN THOSE LOCAL TO SUBROUTINE STODE, AND FINALLY THOSE USED
+C FOR COMMUNICATION.  THE BLOCK IS DECLARED IN SUBROUTINES
+C LSODE, INTDY, STODE, PREPJ, AND SOLSY.  GROUPS OF VARIABLES ARE
+C REPLACED BY DUMMY ARRAYS IN THE COMMON DECLARATIONS IN ROUTINES
+C WHERE THOSE VARIABLES ARE NOT USED.
+C-----------------------------------------------------------------------
+      COMMON /LS0001/ ROWNS(209),
+     1   CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND,
+     2   ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM,
+     3   MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, NYH, IOWNS(6),
+     4   ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, MITER,
+     5   MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU
+C
+      DATA  MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/
+C-----------------------------------------------------------------------
+C BLOCK A.
+C THIS CODE BLOCK IS EXECUTED ON EVERY CALL.
+C IT TESTS ISTATE AND ITASK FOR LEGALITY AND BRANCHES APPROPRIATELY.
+C IF ISTATE .GT. 1 BUT THE FLAG INIT SHOWS THAT INITIALIZATION HAS
+C NOT YET BEEN DONE, AN ERROR RETURN OCCURS.
+C IF ISTATE = 1 AND TOUT = T, JUMP TO BLOCK G AND RETURN IMMEDIATELY. 
+C-----------------------------------------------------------------------
+      IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601
+      IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602
+      IF (ISTATE .EQ. 1) GO TO 10
+      IF (INIT .EQ. 0) GO TO 603
+      IF (ISTATE .EQ. 2) GO TO 200
+      GO TO 20
+ 10   INIT = 0
+      IF (TOUT .EQ. T) GO TO 430
+ 20   NTREP = 0
+C-----------------------------------------------------------------------
+C BLOCK B.
+C THE NEXT CODE BLOCK IS EXECUTED FOR THE INITIAL CALL (ISTATE = 1),
+C OR FOR A CONTINUATION CALL WITH PARAMETER CHANGES (ISTATE = 3).
+C IT CONTAINS CHECKING OF ALL INPUTS AND VARIOUS INITIALIZATIONS.
+C
+C FIRST CHECK LEGALITY OF THE NON-OPTIONAL INPUTS NEQ, ITOL, IOPT,
+C MF, ML, AND MU.
+C-----------------------------------------------------------------------
+      IF (NEQ(1) .LE. 0) GO TO 604
+      IF (ISTATE .EQ. 1) GO TO 25
+      IF (NEQ(1) .GT. N) GO TO 605
+ 25   N = NEQ(1)
+      IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 
+      IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 
+      METH = MF/10
+      MITER = MF - 10*METH
+      IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 
+      IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608
+      IF (MITER .LE. 3) GO TO 30
+      ML = IWORK(1) 
+      MU = IWORK(2) 
+      IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609
+      IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610
+ 30   CONTINUE
+C NEXT PROCESS AND CHECK THE OPTIONAL INPUTS. --------------------------
+      IF (IOPT .EQ. 1) GO TO 40
+      MAXORD = MORD(METH)
+      MXSTEP = MXSTP0
+      MXHNIL = MXHNL0
+      IF (ISTATE .EQ. 1) H0 = 0.0D0
+      HMXI = 0.0D0
+      HMIN = 0.0D0
+      GO TO 60
+ 40   MAXORD = IWORK(5)
+      IF (MAXORD .LT. 0) GO TO 611
+      IF (MAXORD .EQ. 0) MAXORD = 100
+      MAXORD = MIN0(MAXORD,MORD(METH))
+      MXSTEP = IWORK(6)
+      IF (MXSTEP .LT. 0) GO TO 612
+      IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0
+      MXHNIL = IWORK(7)
+      IF (MXHNIL .LT. 0) GO TO 613
+      IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0
+      IF (ISTATE .NE. 1) GO TO 50
+      H0 = RWORK(5) 
+      IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614
+ 50   HMAX = RWORK(6)
+      IF (HMAX .LT. 0.0D0) GO TO 615
+      HMXI = 0.0D0
+      IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX
+      HMIN = RWORK(7)
+      IF (HMIN .LT. 0.0D0) GO TO 616
+C-----------------------------------------------------------------------
+C SET WORK ARRAY POINTERS AND CHECK LENGTHS LRW AND LIW.
+C POINTERS TO SEGMENTS OF RWORK AND IWORK ARE NAMED BY PREFIXING L TO 
+C THE NAME OF THE SEGMENT.  E.G., THE SEGMENT YH STARTS AT RWORK(LYH).
+C SEGMENTS OF RWORK (IN ORDER) ARE DENOTED  YH, WM, EWT, SAVF, ACOR.
+C-----------------------------------------------------------------------
+ 60   LYH = 21
+      IF (ISTATE .EQ. 1) NYH = N
+      LWM = LYH + (MAXORD + 1)*NYH
+      IF (MITER .EQ. 0) LENWM = 0
+      IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENWM = N*N + 2
+      IF (MITER .EQ. 3) LENWM = N + 2
+      IF (MITER .GE. 4) LENWM = (2*ML + MU + 1)*N + 2
+      LEWT = LWM + LENWM
+      LSAVF = LEWT + N
+      LACOR = LSAVF + N
+      LENRW = LACOR + N - 1
+      IWORK(17) = LENRW
+      LIWM = 1
+      LENIW = 20 + N
+      IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 20
+      IWORK(18) = LENIW
+      IF (LENRW .GT. LRW) GO TO 617
+      IF (LENIW .GT. LIW) GO TO 618
+C CHECK RTOL AND ATOL FOR LEGALITY. ------------------------------------
+      RTOLI = RTOL(1)
+      ATOLI = ATOL(1)
+      DO 70 I = 1,N 
+        IF (ITOL .GE. 3) RTOLI = RTOL(I)
+        IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I)
+        IF (RTOLI .LT. 0.0D0) GO TO 619 
+        IF (ATOLI .LT. 0.0D0) GO TO 620 
+ 70     CONTINUE
+      IF (ISTATE .EQ. 1) GO TO 100
+C IF ISTATE = 3, SET FLAG TO SIGNAL PARAMETER CHANGES TO STODE. --------
+      JSTART = -1
+      IF (NQ .LE. MAXORD) GO TO 90
+C MAXORD WAS REDUCED BELOW NQ.  COPY YH(*,MAXORD+2) INTO SAVF. ---------
+      DO 80 I = 1,N 
+ 80     RWORK(I+LSAVF-1) = RWORK(I+LWM-1)
+C RELOAD WM(1) = RWORK(LWM), SINCE LWM MAY HAVE CHANGED. ---------------
+ 90   IF (MITER .GT. 0) RWORK(LWM) = DSQRT(UROUND)
+      IF (N .EQ. NYH) GO TO 200
+C NEQ WAS REDUCED.  ZERO PART OF YH TO AVOID UNDEFINED REFERENCES. -----
+      I1 = LYH + L*NYH
+      I2 = LYH + (MAXORD + 1)*NYH - 1
+      IF (I1 .GT. I2) GO TO 200
+      DO 95 I = I1,I2
+ 95     RWORK(I) = 0.0D0
+      GO TO 200
+C-----------------------------------------------------------------------
+C BLOCK C.
+C THE NEXT BLOCK IS FOR THE INITIAL CALL ONLY (ISTATE = 1). 
+C IT CONTAINS ALL REMAINING INITIALIZATIONS, THE INITIAL CALL TO F,
+C AND THE CALCULATION OF THE INITIAL STEP SIZE.
+C THE ERROR WEIGHTS IN EWT ARE INVERTED AFTER BEING LOADED. 
+C-----------------------------------------------------------------------
+ 100  UROUND = D1MACH(4)
+      TN = T
+      IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110
+      TCRIT = RWORK(1)
+      IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625
+      IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0)
+     1   H0 = TCRIT - T
+ 110  JSTART = 0
+      IF (MITER .GT. 0) RWORK(LWM) = DSQRT(UROUND)
+      NHNIL = 0
+      NST = 0
+      NJE = 0
+      NSLAST = 0
+      HU = 0.0D0
+      NQU = 0
+      CCMAX = 0.3D0 
+      MAXCOR = 3
+      MSBP = 20
+      MXNCF = 10
+C INITIAL CALL TO F.  (LF0 POINTS TO YH(*,2).) -------------------------
+      LF0 = LYH + NYH
+      IERR = 0
+      CALL F (NEQ, T, Y, RWORK(LF0), IERR)
+      IF (IERR .LT. 0) THEN
+        ISTATE = -13
+        RETURN
+      ENDIF
+      NFE = 1
+C LOAD THE INITIAL VALUE VECTOR IN YH. ---------------------------------
+      DO 115 I = 1,N
+ 115    RWORK(I+LYH-1) = Y(I) 
+C LOAD AND INVERT THE EWT ARRAY.  (H IS TEMPORARILY SET TO 1.0.) -------
+      NQ = 1
+      H = 1.0D0
+      CALL EWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT))
+      DO 120 I = 1,N
+        IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 
+ 120    RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1)
+C-----------------------------------------------------------------------
+C THE CODING BELOW COMPUTES THE STEP SIZE, H0, TO BE ATTEMPTED ON THE 
+C FIRST STEP, UNLESS THE USER HAS SUPPLIED A VALUE FOR THIS.
+C FIRST CHECK THAT TOUT - T DIFFERS SIGNIFICANTLY FROM ZERO.
+C A SCALAR TOLERANCE QUANTITY TOL IS COMPUTED, AS MAX(RTOL(I))
+C IF THIS IS POSITIVE, OR MAX(ATOL(I)/ABS(Y(I))) OTHERWISE, ADJUSTED
+C SO AS TO BE BETWEEN 100*UROUND AND 1.0E-3.
+C THEN THE COMPUTED VALUE H0 IS GIVEN BY..
+C                                      NEQ
+C   H0**2 = TOL / ( W0**-2 + (1/NEQ) * SUM ( F(I)/YWT(I) )**2  )
+C                                       1
+C WHERE   W0     = MAX ( ABS(T), ABS(TOUT) ),
+C         F(I)   = I-TH COMPONENT OF INITIAL VALUE OF F,
+C         YWT(I) = EWT(I)/TOL  (A WEIGHT FOR Y(I)).
+C THE SIGN OF H0 IS INFERRED FROM THE INITIAL VALUES OF TOUT AND T.
+C-----------------------------------------------------------------------
+      IF (H0 .NE. 0.0D0) GO TO 180
+      TDIST = DABS(TOUT - T)
+      W0 = DMAX1(DABS(T),DABS(TOUT))
+      IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622
+      TOL = RTOL(1) 
+      IF (ITOL .LE. 2) GO TO 140
+      DO 130 I = 1,N
+ 130    TOL = DMAX1(TOL,RTOL(I))
+ 140  IF (TOL .GT. 0.0D0) GO TO 160
+      ATOLI = ATOL(1)
+      DO 150 I = 1,N
+        IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I)
+        AYI = DABS(Y(I))
+        IF (AYI .NE. 0.0D0) TOL = DMAX1(TOL,ATOLI/AYI)
+ 150    CONTINUE
+ 160  TOL = DMAX1(TOL,100.0D0*UROUND)
+      TOL = DMIN1(TOL,0.001D0)
+      SUM = VNORM (N, RWORK(LF0), RWORK(LEWT))
+      SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2
+      H0 = 1.0D0/DSQRT(SUM)
+      H0 = DMIN1(H0,TDIST)
+      H0 = DSIGN(H0,TOUT-T)
+C ADJUST H0 IF NECESSARY TO MEET HMAX BOUND. ---------------------------
+ 180  RH = DABS(H0)*HMXI
+      IF (RH .GT. 1.0D0) H0 = H0/RH
+C LOAD H WITH H0 AND SCALE YH(*,2) BY H0. ------------------------------
+      H = H0
+      DO 190 I = 1,N
+ 190    RWORK(I+LF0-1) = H0*RWORK(I+LF0-1)
+      GO TO 270
+C-----------------------------------------------------------------------
+C BLOCK D.
+C THE NEXT CODE BLOCK IS FOR CONTINUATION CALLS ONLY (ISTATE = 2 OR 3)
+C AND IS TO CHECK STOP CONDITIONS BEFORE TAKING A STEP.
+C-----------------------------------------------------------------------
+ 200  NSLAST = NST
+      GO TO (210, 250, 220, 230, 240), ITASK
+ 210  IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250
+      CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG)
+      IF (IFLAG .NE. 0) GO TO 627
+      T = TOUT
+      GO TO 420
+ 220  TP = TN - HU*(1.0D0 + 100.0D0*UROUND)
+      IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623
+      IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250
+      GO TO 400
+ 230  TCRIT = RWORK(1)
+      IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624
+      IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625
+      IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245
+      CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG)
+      IF (IFLAG .NE. 0) GO TO 627
+      T = TOUT
+      GO TO 420
+ 240  TCRIT = RWORK(1)
+      IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624
+ 245  HMX = DABS(TN) + DABS(H)
+      IHIT = DABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX
+      IF (IHIT) GO TO 400
+      TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND)
+      IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 
+      H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND)
+      IF (ISTATE .EQ. 2) JSTART = -2
+C-----------------------------------------------------------------------
+C BLOCK E.
+C THE NEXT BLOCK IS NORMALLY EXECUTED FOR ALL CALLS AND CONTAINS
+C THE CALL TO THE ONE-STEP CORE INTEGRATOR STODE. 
+C
+C THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS.
+C
+C FIRST CHECK FOR TOO MANY STEPS BEING TAKEN, UPDATE EWT (IF NOT AT
+C START OF PROBLEM), CHECK FOR TOO MUCH ACCURACY BEING REQUESTED, AND 
+C CHECK FOR H BELOW THE ROUNDOFF LEVEL IN T.
+C-----------------------------------------------------------------------
+ 250  CONTINUE
+      IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500
+      CALL EWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT))
+      DO 260 I = 1,N
+        IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 
+ 260    RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1)
+ 270  TOLSF = UROUND*VNORM (N, RWORK(LYH), RWORK(LEWT))
+      IF (TOLSF .LE. 1.0D0) GO TO 280
+      TOLSF = TOLSF*2.0D0
+      IF (NST .EQ. 0) GO TO 626
+      GO TO 520
+ 280  IF ((TN + H) .NE. TN) GO TO 290
+      NHNIL = NHNIL + 1
+      IF (NHNIL .GT. MXHNIL) GO TO 290
+      CALL XERRWV(50HLSODE--  WARNING..INTERNAL T (=R1) AND H (=R2) ARE,
+     1   50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0)
+      CALL XERRWV(
+     1  60H      SUCH THAT IN THE MACHINE, T + H = T ON THE NEXT STEP  ,
+     1   60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0)
+      CALL XERRWV(50H      (H = STEP SIZE). SOLVER WILL CONTINUE ANYWAY,
+     1   50, 101, 0, 0, 0, 0, 2, TN, H) 
+      IF (NHNIL .LT. MXHNIL) GO TO 290
+      CALL XERRWV(50HLSODE--  ABOVE WARNING HAS BEEN ISSUED I1 TIMES.  ,
+     1   50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0)
+      CALL XERRWV(50H      IT WILL NOT BE ISSUED AGAIN FOR THIS PROBLEM,
+     1   50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0)
+ 290  CONTINUE
+C-----------------------------------------------------------------------
+C     CALL STODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,PREPJ,SOLSY)
+C-----------------------------------------------------------------------
+      IERR = 0
+      CALL STODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT),
+     1   RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWORK(LIWM),
+     2   F, JAC, PREPJ, SOLSY, IERR)
+      IF (IERR .LT. 0) THEN
+        ISTATE = -13
+        RETURN
+      ENDIF
+      KGO = 1 - KFLAG
+      GO TO (300, 530, 540), KGO
+C-----------------------------------------------------------------------
+C BLOCK F.
+C THE FOLLOWING BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN FROM THE
+C CORE INTEGRATOR (KFLAG = 0).  TEST FOR STOP CONDITIONS.
+C-----------------------------------------------------------------------
+ 300  INIT = 1
+      GO TO (310, 400, 330, 340, 350), ITASK
+C ITASK = 1.  IF TOUT HAS BEEN REACHED, INTERPOLATE. -------------------
+ 310  IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250
+      CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG)
+      T = TOUT
+      GO TO 420
+C ITASK = 3.  JUMP TO EXIT IF TOUT WAS REACHED. ------------------------
+ 330  IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400
+      GO TO 250
+C ITASK = 4.  SEE IF TOUT OR TCRIT WAS REACHED.  ADJUST H IF NECESSARY.
+ 340  IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345
+      CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG)
+      T = TOUT
+      GO TO 420
+ 345  HMX = DABS(TN) + DABS(H)
+      IHIT = DABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX
+      IF (IHIT) GO TO 400
+      TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND)
+      IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 
+      H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND)
+      JSTART = -2
+      GO TO 250
+C ITASK = 5.  SEE IF TCRIT WAS REACHED AND JUMP TO EXIT. ---------------
+ 350  HMX = DABS(TN) + DABS(H)
+      IHIT = DABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX
+C-----------------------------------------------------------------------
+C BLOCK G.
+C THE FOLLOWING BLOCK HANDLES ALL SUCCESSFUL RETURNS FROM LSODE.
+C IF ITASK .NE. 1, Y IS LOADED FROM YH AND T IS SET ACCORDINGLY.
+C ISTATE IS SET TO 2, THE ILLEGAL INPUT COUNTER IS ZEROED, AND THE
+C OPTIONAL OUTPUTS ARE LOADED INTO THE WORK ARRAYS BEFORE RETURNING.
+C IF ISTATE = 1 AND TOUT = T, THERE IS A RETURN WITH NO ACTION TAKEN, 
+C EXCEPT THAT IF THIS HAS HAPPENED REPEATEDLY, THE RUN IS TERMINATED. 
+C-----------------------------------------------------------------------
+ 400  DO 410 I = 1,N
+ 410    Y(I) = RWORK(I+LYH-1) 
+      T = TN
+      IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420
+      IF (IHIT) T = TCRIT
+ 420  ISTATE = 2
+      ILLIN = 0
+      RWORK(11) = HU
+      RWORK(12) = H 
+      RWORK(13) = TN
+      IWORK(11) = NST
+      IWORK(12) = NFE
+      IWORK(13) = NJE
+      IWORK(14) = NQU
+      IWORK(15) = NQ
+      RETURN
+C
+ 430  NTREP = NTREP + 1
+      IF (NTREP .LT. 5) RETURN
+      CALL XERRWV(
+     1  60HLSODE--  REPEATED CALLS WITH ISTATE = 1 AND TOUT = T (=R1)  ,
+     1   60, 301, 0, 0, 0, 0, 1, T, 0.0D0)
+      GO TO 800
+C-----------------------------------------------------------------------
+C BLOCK H.
+C THE FOLLOWING BLOCK HANDLES ALL UNSUCCESSFUL RETURNS OTHER THAN
+C THOSE FOR ILLEGAL INPUT.  FIRST THE ERROR MESSAGE ROUTINE IS CALLED.
+C IF THERE WAS AN ERROR TEST OR CONVERGENCE TEST FAILURE, IMXER IS SET.
+C THEN Y IS LOADED FROM YH, T IS SET TO TN, AND THE ILLEGAL INPUT
+C COUNTER ILLIN IS SET TO 0.  THE OPTIONAL OUTPUTS ARE LOADED INTO
+C THE WORK ARRAYS BEFORE RETURNING.
+C-----------------------------------------------------------------------
+C THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE REACHING TOUT. ----------
+ 500  CALL XERRWV(50HLSODE--  AT CURRENT T (=R1), MXSTEP (=I1) STEPS   ,
+     1   50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0)
+      CALL XERRWV(50H      TAKEN ON THIS CALL BEFORE REACHING TOUT     ,
+     1   50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0)
+      ISTATE = -1
+      GO TO 580
+C EWT(I) .LE. 0.0 FOR SOME I (NOT AT START OF PROBLEM). ----------------
+ 510  EWTI = RWORK(LEWT+I-1)
+      CALL XERRWV(50HLSODE--  AT T (=R1), EWT(I1) HAS BECOME R2 .LE. 0.,
+     1   50, 202, 0, 1, I, 0, 2, TN, EWTI)
+      ISTATE = -6
+      GO TO 580
+C TOO MUCH ACCURACY REQUESTED FOR MACHINE PRECISION. -------------------
+ 520  CALL XERRWV(50HLSODE--  AT T (=R1), TOO MUCH ACCURACY REQUESTED  ,
+     1   50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0)
+      CALL XERRWV(50H      FOR PRECISION OF MACHINE..  SEE TOLSF (=R2) ,
+     1   50, 203, 0, 0, 0, 0, 2, TN, TOLSF)
+      RWORK(14) = TOLSF
+      ISTATE = -2
+      GO TO 580
+C KFLAG = -1.  ERROR TEST FAILED REPEATEDLY OR WITH ABS(H) = HMIN. -----
+ 530  CALL XERRWV(50HLSODE--  AT T(=R1) AND STEP SIZE H(=R2), THE ERROR,
+     1   50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0)
+      CALL XERRWV(50H      TEST FAILED REPEATEDLY OR WITH ABS(H) = HMIN,
+     1   50, 204, 0, 0, 0, 0, 2, TN, H) 
+      ISTATE = -4
+      GO TO 560
+C KFLAG = -2.  CONVERGENCE FAILED REPEATEDLY OR WITH ABS(H) = HMIN. ----
+ 540  CALL XERRWV(50HLSODE--  AT T (=R1) AND STEP SIZE H (=R2), THE    ,
+     1   50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0)
+      CALL XERRWV(50H      CORRECTOR CONVERGENCE FAILED REPEATEDLY     ,
+     1   50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0)
+      CALL XERRWV(30H      OR WITH ABS(H) = HMIN   ,
+     1   30, 205, 0, 0, 0, 0, 2, TN, H) 
+      ISTATE = -5
+C COMPUTE IMXER IF RELEVANT. -------------------------------------------
+ 560  BIG = 0.0D0
+      IMXER = 1
+      DO 570 I = 1,N
+        SIZE = DABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1))
+        IF (BIG .GE. SIZE) GO TO 570
+        BIG = SIZE
+        IMXER = I
+ 570    CONTINUE
+      IWORK(16) = IMXER
+C SET Y VECTOR, T, ILLIN, AND OPTIONAL OUTPUTS. ------------------------
+ 580  DO 590 I = 1,N
+ 590    Y(I) = RWORK(I+LYH-1) 
+      T = TN
+      ILLIN = 0
+      RWORK(11) = HU
+      RWORK(12) = H 
+      RWORK(13) = TN
+      IWORK(11) = NST
+      IWORK(12) = NFE
+      IWORK(13) = NJE
+      IWORK(14) = NQU
+      IWORK(15) = NQ
+      RETURN
+C-----------------------------------------------------------------------
+C BLOCK I.
+C THE FOLLOWING BLOCK HANDLES ALL ERROR RETURNS DUE TO ILLEGAL INPUT
+C (ISTATE = -3), AS DETECTED BEFORE CALLING THE CORE INTEGRATOR.
+C FIRST THE ERROR MESSAGE ROUTINE IS CALLED.  THEN IF THERE HAVE BEEN 
+C 5 CONSECUTIVE SUCH RETURNS JUST BEFORE THIS CALL TO THE SOLVER,
+C THE RUN IS HALTED.
+C-----------------------------------------------------------------------
+ 601  CALL XERRWV(30HLSODE--  ISTATE (=I1) ILLEGAL ,
+     1   30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) 
+      GO TO 700
+ 602  CALL XERRWV(30HLSODE--  ITASK (=I1) ILLEGAL  ,
+     1   30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0)
+      GO TO 700
+ 603  CALL XERRWV(50HLSODE--  ISTATE .GT. 1 BUT LSODE NOT INITIALIZED  ,
+     1   50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0)
+      GO TO 700
+ 604  CALL XERRWV(30HLSODE--  NEQ (=I1) .LT. 1     ,
+     1   30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) 
+      GO TO 700
+ 605  CALL XERRWV(50HLSODE--  ISTATE = 3 AND NEQ INCREASED (I1 TO I2)  ,
+     1   50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) 
+      GO TO 700
+ 606  CALL XERRWV(30HLSODE--  ITOL (=I1) ILLEGAL   ,
+     1   30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0)
+      GO TO 700
+ 607  CALL XERRWV(30HLSODE--  IOPT (=I1) ILLEGAL   ,
+     1   30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0)
+      GO TO 700
+ 608  CALL XERRWV(30HLSODE--  MF (=I1) ILLEGAL     ,
+     1   30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0)
+      GO TO 700
+ 609  CALL XERRWV(50HLSODE--  ML (=I1) ILLEGAL.. .LT.0 OR .GE.NEQ (=I2),
+     1   50, 9, 0, 2, ML, NEQ(1), 0, 0.0D0, 0.0D0)
+      GO TO 700
+ 610  CALL XERRWV(50HLSODE--  MU (=I1) ILLEGAL.. .LT.0 OR .GE.NEQ (=I2),
+     1   50, 10, 0, 2, MU, NEQ(1), 0, 0.0D0, 0.0D0)
+      GO TO 700
+ 611  CALL XERRWV(30HLSODE--  MAXORD (=I1) .LT. 0  ,
+     1   30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0)
+      GO TO 700
+ 612  CALL XERRWV(30HLSODE--  MXSTEP (=I1) .LT. 0  ,
+     1   30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0)
+      GO TO 700
+ 613  CALL XERRWV(30HLSODE--  MXHNIL (=I1) .LT. 0  ,
+     1   30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0)
+      GO TO 700
+ 614  CALL XERRWV(40HLSODE--  TOUT (=R1) BEHIND T (=R2)      ,
+     1   40, 14, 0, 0, 0, 0, 2, TOUT, T)
+      CALL XERRWV(50H      INTEGRATION DIRECTION IS GIVEN BY H0 (=R1)  ,
+     1   50, 14, 0, 0, 0, 0, 1, H0, 0.0D0)
+      GO TO 700
+ 615  CALL XERRWV(30HLSODE--  HMAX (=R1) .LT. 0.0  ,
+     1   30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0)
+      GO TO 700
+ 616  CALL XERRWV(30HLSODE--  HMIN (=R1) .LT. 0.0  ,
+     1   30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0)
+      GO TO 700
+ 617  CALL XERRWV(
+     1  60HLSODE--  RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS LRW (=I2),
+     1   60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0)
+      GO TO 700
+ 618  CALL XERRWV(
+     1  60HLSODE--  IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS LIW (=I2),
+     1   60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0)
+      GO TO 700
+ 619  CALL XERRWV(40HLSODE--  RTOL(I1) IS R1 .LT. 0.0        ,
+     1   40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0)
+      GO TO 700
+ 620  CALL XERRWV(40HLSODE--  ATOL(I1) IS R1 .LT. 0.0        ,
+     1   40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0)
+      GO TO 700
+ 621  EWTI = RWORK(LEWT+I-1)
+      CALL XERRWV(40HLSODE--  EWT(I1) IS R1 .LE. 0.0         ,
+     1   40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0)
+      GO TO 700
+ 622  CALL XERRWV(
+     1  60HLSODE--  TOUT (=R1) TOO CLOSE TO T(=R2) TO START INTEGRATION,
+     1   60, 22, 0, 0, 0, 0, 2, TOUT, T)
+      GO TO 700
+ 623  CALL XERRWV(
+     1  60HLSODE--  ITASK = I1 AND TOUT (=R1) BEHIND TCUR - HU (= R2)  ,
+     1   60, 23, 0, 1, ITASK, 0, 2, TOUT, TP)
+      GO TO 700
+ 624  CALL XERRWV(
+     1  60HLSODE--  ITASK = 4 OR 5 AND TCRIT (=R1) BEHIND TCUR (=R2)   ,
+     1   60, 24, 0, 0, 0, 0, 2, TCRIT, TN)
+      GO TO 700
+ 625  CALL XERRWV(
+     1  60HLSODE--  ITASK = 4 OR 5 AND TCRIT (=R1) BEHIND TOUT (=R2)   ,
+     1   60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT)
+      GO TO 700
+ 626  CALL XERRWV(50HLSODE--  AT START OF PROBLEM, TOO MUCH ACCURACY   ,
+     1   50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0)
+      CALL XERRWV(
+     1  60H      REQUESTED FOR PRECISION OF MACHINE..  SEE TOLSF (=R1) ,
+     1   60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0)
+      RWORK(14) = TOLSF
+      GO TO 700
+ 627  CALL XERRWV(50HLSODE--  TROUBLE FROM INTDY. ITASK = I1, TOUT = R1,
+     1   50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0)
+C
+ 700  IF (ILLIN .EQ. 5) GO TO 710
+      ILLIN = ILLIN + 1
+      ISTATE = -3
+      RETURN
+ 710  CALL XERRWV(50HLSODE--  REPEATED OCCURRENCES OF ILLEGAL INPUT    ,
+     1   50, 302, 0, 0, 0, 0, 0, 0.0D0, 0.0D0)
+C
+ 800  CALL XERRWV(50HLSODE--  RUN ABORTED.. APPARENT INFINITE LOOP     ,
+     1   50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0)
+      RETURN
+C----------------------- END OF SUBROUTINE LSODE -----------------------
+      END 
new file mode 100644
--- /dev/null
+++ b/libcruft/odepack/vnorm.f
@@ -0,0 +1,18 @@
+      DOUBLE PRECISION FUNCTION VNORM (N, V, W)
+CLLL. OPTIMIZE
+C-----------------------------------------------------------------------
+C THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED ROOT-MEAN-SQUARE NORM
+C OF THE VECTOR OF LENGTH N CONTAINED IN THE ARRAY V, WITH WEIGHTS
+C CONTAINED IN THE ARRAY W OF LENGTH N..
+C   VNORM = SQRT( (1/N) * SUM( V(I)*W(I) )**2 )
+C-----------------------------------------------------------------------
+      INTEGER N,   I
+      DOUBLE PRECISION V, W,   SUM
+      DIMENSION V(N), W(N)
+      SUM = 0.0D0
+      DO 10 I = 1,N 
+ 10     SUM = SUM + (V(I)*W(I))**2
+      VNORM = DSQRT(SUM/DBLE(N))      
+      RETURN
+C----------------------- END OF FUNCTION VNORM -------------------------
+      END 
new file mode 100644
--- /dev/null
+++ b/libcruft/odepack/xerrwv.f
@@ -0,0 +1,114 @@
+      SUBROUTINE XERRWV (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2)
+      INTEGER MSG, NMES, NERR, LEVEL, NI, I1, I2, NR,
+     1   I, LUN, LUNIT, MESFLG, NCPW, NCH, NWDS
+      DOUBLE PRECISION R1, R2 
+      DIMENSION MSG(NMES)
+C-----------------------------------------------------------------------
+C SUBROUTINES XERRWV, XSETF, AND XSETUN, AS GIVEN HERE, CONSTITUTE
+C A SIMPLIFIED VERSION OF THE SLATEC ERROR HANDLING PACKAGE.
+C WRITTEN BY A. C. HINDMARSH AT LLNL.  VERSION OF MARCH 30, 1987.
+C THIS VERSION IS IN DOUBLE PRECISION.
+C
+C ALL ARGUMENTS ARE INPUT ARGUMENTS.
+C
+C MSG    = THE MESSAGE (HOLLERITH LITERAL OR INTEGER ARRAY).
+C NMES   = THE LENGTH OF MSG (NUMBER OF CHARACTERS).
+C NERR   = THE ERROR NUMBER (NOT USED). 
+C LEVEL  = THE ERROR LEVEL..
+C          0 OR 1 MEANS RECOVERABLE (CONTROL RETURNS TO CALLER).
+C          2 MEANS FATAL (RUN IS ABORTED--SEE NOTE BELOW).
+C NI     = NUMBER OF INTEGERS (0, 1, OR 2) TO BE PRINTED WITH MESSAGE.
+C I1,I2  = INTEGERS TO BE PRINTED, DEPENDING ON NI.
+C NR     = NUMBER OF REALS (0, 1, OR 2) TO BE PRINTED WITH MESSAGE.
+C R1,R2  = REALS TO BE PRINTED, DEPENDING ON NR.
+C
+C NOTE..  THIS ROUTINE IS MACHINE-DEPENDENT AND SPECIALIZED FOR USE
+C IN LIMITED CONTEXT, IN THE FOLLOWING WAYS..
+C 1. THE NUMBER OF HOLLERITH CHARACTERS STORED PER WORD, DENOTED
+C    BY NCPW BELOW, IS A DATA-LOADED CONSTANT.
+C 2. THE VALUE OF NMES IS ASSUMED TO BE AT MOST 60.
+C    (MULTI-LINE MESSAGES ARE GENERATED BY REPEATED CALLS.) 
+C 3. IF LEVEL = 2, CONTROL PASSES TO THE STATEMENT   STOP
+C    TO ABORT THE RUN.  THIS STATEMENT MAY BE MACHINE-DEPENDENT.
+C 4. R1 AND R2 ARE ASSUMED TO BE IN DOUBLE PRECISION AND ARE PRINTED
+C    IN D21.13 FORMAT.
+C 5. THE COMMON BLOCK /EH0001/ BELOW IS DATA-LOADED (A MACHINE-
+C    DEPENDENT FEATURE) WITH DEFAULT VALUES.
+C    THIS BLOCK IS NEEDED FOR PROPER RETENTION OF PARAMETERS USED BY
+C    THIS ROUTINE WHICH THE USER CAN RESET BY CALLING XSETF OR XSETUN.
+C    THE VARIABLES IN THIS BLOCK ARE AS FOLLOWS.. 
+C       MESFLG = PRINT CONTROL FLAG..
+C                1 MEANS PRINT ALL MESSAGES (THE DEFAULT).
+C                0 MEANS NO PRINTING.
+C       LUNIT  = LOGICAL UNIT NUMBER FOR MESSAGES.
+C                THE DEFAULT IS 6 (MACHINE-DEPENDENT).
+C-----------------------------------------------------------------------
+C THE FOLLOWING ARE INSTRUCTIONS FOR INSTALLING THIS ROUTINE
+C IN DIFFERENT MACHINE ENVIRONMENTS.
+C
+C TO CHANGE THE DEFAULT OUTPUT UNIT, CHANGE THE DATA STATEMENT
+C IN THE BLOCK DATA SUBPROGRAM BELOW.
+C
+C FOR A DIFFERENT NUMBER OF CHARACTERS PER WORD, CHANGE THE 
+C DATA STATEMENT SETTING NCPW BELOW, AND FORMAT 10.  ALTERNATIVES FOR 
+C VARIOUS COMPUTERS ARE SHOWN IN COMMENT CARDS.
+C
+C FOR A DIFFERENT RUN-ABORT COMMAND, CHANGE THE STATEMENT FOLLOWING
+C STATEMENT 100 AT THE END.
+C-----------------------------------------------------------------------
+      COMMON /EH0001/ MESFLG, LUNIT
+C-----------------------------------------------------------------------
+C THE FOLLOWING DATA-LOADED VALUE OF NCPW IS VALID FOR THE CDC-6600
+C AND CDC-7600 COMPUTERS.
+C     DATA NCPW/10/ 
+C THE FOLLOWING IS VALID FOR THE CRAY-1 COMPUTER. 
+C     DATA NCPW/8/
+C THE FOLLOWING IS VALID FOR THE BURROUGHS 6700 AND 7800 COMPUTERS.
+C     DATA NCPW/6/
+C THE FOLLOWING IS VALID FOR THE PDP-10 COMPUTER. 
+C     DATA NCPW/5/
+C THE FOLLOWING IS VALID FOR THE VAX COMPUTER WITH 4 BYTES PER INTEGER,
+C AND FOR THE IBM-360, IBM-370, IBM-303X, AND IBM-43XX COMPUTERS.
+      DATA NCPW/4/
+C THE FOLLOWING IS VALID FOR THE PDP-11, OR VAX WITH 2-BYTE INTEGERS. 
+C     DATA NCPW/2/
+C-----------------------------------------------------------------------
+      IF (MESFLG .EQ. 0) GO TO 100
+C GET LOGICAL UNIT NUMBER. ---------------------------------------------
+      LUN = LUNIT
+C GET NUMBER OF WORDS IN MESSAGE. --------------------------------------
+      NCH = MIN0(NMES,60)
+      NWDS = NCH/NCPW
+      IF (NCH .NE. NWDS*NCPW) NWDS = NWDS + 1
+C WRITE THE MESSAGE. ---------------------------------------------------
+      WRITE (LUN, 10) (MSG(I),I=1,NWDS) 
+C-----------------------------------------------------------------------
+C THE FOLLOWING FORMAT STATEMENT IS TO HAVE THE FORM
+C 10  FORMAT(1X,MMANN)
+C WHERE NN = NCPW AND MM IS THE SMALLEST INTEGER .GE. 60/NCPW.
+C THE FOLLOWING IS VALID FOR NCPW = 10. 
+C 10  FORMAT(1X,6A10)
+C THE FOLLOWING IS VALID FOR NCPW = 8.
+C 10  FORMAT(1X,8A8)
+C THE FOLLOWING IS VALID FOR NCPW = 6.
+C 10  FORMAT(1X,10A6)
+C THE FOLLOWING IS VALID FOR NCPW = 5.
+C 10  FORMAT(1X,12A5)
+C THE FOLLOWING IS VALID FOR NCPW = 4.
+  10  FORMAT(1X,15A4)
+C THE FOLLOWING IS VALID FOR NCPW = 2.
+C 10  FORMAT(1X,30A2)
+C-----------------------------------------------------------------------
+      IF (NI .EQ. 1) WRITE (LUN, 20) I1 
+ 20   FORMAT(6X,23HIN ABOVE MESSAGE,  I1 =,I10)
+      IF (NI .EQ. 2) WRITE (LUN, 30) I1,I2
+ 30   FORMAT(6X,23HIN ABOVE MESSAGE,  I1 =,I10,3X,4HI2 =,I10)
+      IF (NR .EQ. 1) WRITE (LUN, 40) R1 
+ 40   FORMAT(6X,23HIN ABOVE MESSAGE,  R1 =,D21.13)
+      IF (NR .EQ. 2) WRITE (LUN, 50) R1,R2
+ 50   FORMAT(6X,15HIN ABOVE,  R1 =,D21.13,3X,4HR2 =,D21.13) 
+C ABORT THE RUN IF LEVEL = 2. ------------------------------------------
+ 100  IF (LEVEL .NE. 2) RETURN
+      CALL XSTOPX (' ')
+C----------------------- END OF SUBROUTINE XERRWV ----------------------
+      END 
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/addcon.f
@@ -0,0 +1,372 @@
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C     FILE CMSUBS66 FORTRAN
+C
+C     ADDCON   ALLOC    BDPERT   BNDALF   CHKDAT   DELCON
+C     FINDP    GETLAM   PRTSOL   RSOLVE   TQADD    TSOLVE   ZYPROD
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+      SUBROUTINE ADDCON( MODFYG, MODFYR, ORTHOG, UNITQ, INFORM,
+     *                   IFIX, IADD, JADD, NACTIV, NCOLR, NCOLZ, NFREE,
+     *                   N, NQ, NROWA, NROWRT, NCOLRT, KFREE,
+     *                   CONDMX, CSLAST, SNLAST,
+     *                   A, QTG, RT, ZY, WRK1, WRK2 )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      LOGICAL            MODFYG, MODFYR, ORTHOG, UNITQ
+      INTEGER            INFORM, IFIX, IADD, JADD, NACTIV, NCOLR,
+     *                   NCOLZ, NFREE, N, NQ, NROWA, NROWRT, NCOLRT
+      INTEGER            KFREE(N)
+      DOUBLE PRECISION   CONDMX, CSLAST, SNLAST
+      DOUBLE PRECISION   A(NROWA,N), QTG(N), RT(NROWRT,NCOLRT),
+     *                   ZY(NQ,NQ), WRK1(N), WRK2(N)
+C
+      INTEGER            NOUT, MSG, ISTART
+      DOUBLE PRECISION   ASIZE, DTMAX, DTMIN
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+      COMMON    /SOL5CM/ ASIZE, DTMAX, DTMIN
+C
+C  *********************************************************************
+C  ADDCON  UPDATES THE FACTORIZATION OF THE MATRIX OF
+C  CONSTRAINTS IN THE WORKING SET,  A(FREE) * (Z Y) = (0 T).
+C  IF THE LOGICAL VARIABLE  MODFYR  IS TRUE, THE CHOLESKY FACTORIZATION
+C  OF THE PROJECTED HESSIAN, R(T)*R, IS UPDATED ALSO.
+C
+C  THERE ARE THREE SEPARATE CASES TO CONSIDER (ALTHOUGH EACH CASE
+C  SHARES CODE WITH ANOTHER)...
+C
+C  (1) A FREE VARIABLE BECOMES FIXED ON ONE OF ITS BOUNDS WHEN THERE
+C      ARE ALREADY SOME GENERAL CONSTRAINTS IN THE WORKING SET.
+C
+C  (2) A FREE VARIABLE BECOMES FIXED ON ONE OF ITS BOUNDS WHEN THERE
+C      ARE ONLY BOUND CONSTRAINTS IN THE WORKING SET.
+C
+C  (3) A GENERAL CONSTRAINT (CORRESPONDING TO ROW  IADD  OF  A) IS
+C      ADDED TO THE WORKING SET.
+C
+C      IN CASES (1) AND (2), WE ASSUME THAT  KFREE(IFIX) = JADD.
+C  IN ALL CASES,  JADD  IS THE INDEX OF THE CONSTRAINT BEING ADDED.
+C
+C  IF THERE ARE NO GENERAL CONSTRAINTS IN THE WORKING SET,  THE
+C  MATRIX  Q = (Z Y)  IS THE IDENTITY AND WILL NOT BE TOUCHED.
+C
+C  IF  MODFYR  IS TRUE AND  NCOLZ IS GREATER THAN ONE ON ENTRY,
+C  CSLAST AND SNLAST CONTAIN THE LAST OF THE SEQUENCE OF GIVENS
+C  ROTATIONS USED TO REDUCE THE INTERMEDIATE UPPER-HESSENBERG MATRIX
+C  TO UPPER-TRIANGULAR FORM.  THESE ELEMENTS ARE NEEDED BY QPCORE.
+C
+C  IF  MODFYG  IS TRUE ON ENTRY, THE COLUMN TRANSFORMATIONS ARE
+C  APPLIED TO THE VECTOR  Q(T)GRAD,  STORED IN  QTG.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION OF JANUARY 1982.  REV. OCT. 1982.  MARCH 1983.
+C  MARCH 1983.  HOUSEHOLDER REFLECTION USED TO ADD GENERAL CONSTRAINT.
+C  APRIL 1983.  ELIMINATIONS ADDED AS AN OPTION.
+C  *********************************************************************
+C
+      INTEGER            I, INCT, ISWAP, ITRANS, J, K, KP1, LDIAG, LENQ,
+     *                   LENRT, LROWA, LROWR, NACT1, NCOLZ1, NELM,NFREE1
+      DOUBLE PRECISION   BETA, COND, CONDBD, CS, D, DELTA, DTNEW,
+     *                   EPSMCH, ONE, POINT9, SN, TDTMAX, TDTMIN,
+     *                   ZERO
+      DOUBLE PRECISION   DOT, QUOTNT, V2NORM
+      DOUBLE PRECISION   DMAX1, DMIN1
+      DATA               ZERO  , POINT9, ONE
+     *                  /0.0D+0, 0.9D+0, 1.0D+0/
+C
+      EPSMCH = WMACH(3)
+C
+C  IF THE CONDITION ESTIMATOR OF THE UPDATED FACTORS IS GREATER THAN
+C  CONDBD,  A WARNING MESSAGE IS PRINTED.
+C
+      CONDBD = EPSMCH**(- POINT9)
+      LENQ   = NQ   *(NQ - 1) + 1
+      LROWA  = NROWA*(N  - 1) + 1
+      NCOLZ1 = NCOLZ - 1
+      IF (JADD .GT. N) GO TO 200
+C
+C  ---------------------------------------------------------------------
+C  A SIMPLE BOUND HAS ENTERED THE WORKING SET.  IADD  IS NOT USED.
+C  ---------------------------------------------------------------------
+      IF (MSG .GE. 80)
+     *WRITE (NOUT, 1010) NACTIV, NCOLZ, NFREE, IFIX, JADD, UNITQ
+C
+C  SET  WRK1 = APPROPRIATE ROW OF  Q.
+C  REORDER THE ELEMENTS OF  KFREE (THIS REQUIRES REORDERING THE
+C  CORRESPONDING ROWS OF  Q).
+C
+      NFREE1 = NFREE - 1
+      NACT1  = NACTIV
+      IF (UNITQ) GO TO 120
+C
+C  Q  IS STORED EXPLICITLY.  INTERCHANGE COMPONENTS  IFIX  AND  NFREE
+C  OF  KFREE  AND SWAP THE CORRESPONDING ROWS OF  Q.
+C
+      CALL COPYVC( NFREE, ZY(IFIX,1), LENQ, NQ, WRK1, N, 1 )
+      IF (IFIX .EQ. NFREE) GO TO 400
+      KFREE(IFIX) = KFREE(NFREE)
+      CALL COPYVC( NFREE, ZY(NFREE,1), LENQ, NQ, ZY(IFIX,1), LENQ, NQ )
+      GO TO 400
+C
+C  Q  IS NOT STORED, BUT  KFREE  DEFINES AN ORDERING OF THE COLUMNS
+C  OF THE IDENTITY MATRIX THAT IMPLICITLY DEFINE  Z.
+C  REORDER  KFREE  SO THAT VARIABLES  IFIX+1,...,NFREE  ARE MOVED ONE
+C  POSITION TO THE LEFT.
+C
+  120 CALL ZEROVC( NFREE, WRK1, N, 1 )
+      WRK1(IFIX) = ONE
+      IF (IFIX .EQ. NFREE) GO TO 400
+      DO 130 I = IFIX, NFREE1
+         KFREE(I) = KFREE(I+1)
+  130 CONTINUE
+      GO TO 400
+C
+C  ---------------------------------------------------------------------
+C  A GENERAL CONSTRAINT HAS ENTERED THE WORKING SET.  IFIX IS NOT USED.
+C  ---------------------------------------------------------------------
+  200 IF (MSG .GE. 80)
+     *WRITE (NOUT, 1020) NACTIV, NCOLZ, NFREE, IADD, JADD, UNITQ
+C
+      NACT1  = NACTIV + 1
+C
+C  TRANSFORM THE INCOMING ROW OF  A  BY  Q(T).
+C
+      CALL COPYVC( N, A(IADD,1), LROWA, NROWA, WRK1, N, 1 )
+      CALL ZYPROD( 8, N, NACTIV, NCOLZ, NFREE, NQ, UNITQ,
+     *             KFREE, KFREE, WRK1, ZY, WRK2 )
+C
+      IF (.NOT. UNITQ) GO TO 250
+C
+C  THIS IS THE FIRST GENERAL CONSTRAINT TO BE ADDED  --  SET  Q = I.
+C
+      DO 220 J = 1, NFREE
+         CALL ZEROVC( NFREE, ZY(1,J), NFREE, 1 )
+         ZY(J,J) = ONE
+  220 CONTINUE
+      UNITQ  = .FALSE.
+C
+C  CHECK THAT THE INCOMING ROW IS NOT DEPENDENT UPON THOSE
+C  ALREADY IN THE WORKING SET.
+C
+  250 DTNEW  = V2NORM( NCOLZ, WRK1, NCOLZ, 1 )
+      IF (NACT1 .GT. 1) GO TO 300
+C
+C  THIS IS THE ONLY GENERAL CONSTRAINT IN THE WORKING SET.
+C
+      COND   = QUOTNT( ASIZE, DTNEW )
+      IF (COND .GE. CONDMX) GO TO 910
+      IF (COND .GE. CONDBD) WRITE (NOUT, 2000) JADD
+      DTMAX  = DTNEW
+      DTMIN  = DTNEW
+      GO TO 400
+C
+C  THERE ARE ALREADY SOME GENERAL CONSTRAINTS IN THE WORKING SET.
+C  UPDATE THE ESTIMATE OF THE CONDITION NUMBER.
+C
+  300 TDTMAX = DMAX1( DTNEW, DTMAX )
+      TDTMIN = DMIN1( DTNEW, DTMIN )
+      COND   = QUOTNT( TDTMAX, TDTMIN )
+      IF (COND .GE. CONDMX) GO TO 910
+      IF (COND .GE. CONDBD) WRITE (NOUT, 2000) JADD
+      DTMAX  = TDTMAX
+      DTMIN  = TDTMIN
+C
+C  ---------------------------------------------------------------------
+C  USE ONE OR MORE COLUMN TRANSFORMATIONS TO REDUCE THE FIRST  NCOLZ1
+C  ELEMENTS OF  WRK1  TO ZERO.  THIS AFFECTS  ZY,  EXCEPT IF (UNITQ).
+C  THE TRANSFORMATIONS MAY ALSO BE APPLIED TO  QTG  AND  R.
+C  ---------------------------------------------------------------------
+C
+  400 IF (NCOLZ1 .EQ. 0    ) GO TO 600
+      IF (MODFYR .OR. UNITQ) GO TO 500
+C
+C  ---------------------------------------------------------------------
+C  THERE IS NO  R.  USE A SINGLE ELIMINATION OR HOUSEHOLDER MATRIX.
+C  ---------------------------------------------------------------------
+      IF (ORTHOG) GO TO 440
+C
+C  *********************************************************************
+C  ELIMINATION.
+C  WE USE   ELM( ..., ZERO, ZERO )   TO PERFORM AN INTERCHANGE.
+C  *********************************************************************
+      CALL ETAGEN( NCOLZ1, WRK1(NCOLZ), WRK1, NCOLZ1, 1, ISWAP, ITRANS )
+      IF (ISWAP .GT. 0)
+     *   CALL ELM   ( ORTHOG, NFREE, ZY(1,NCOLZ), NFREE, 1,
+     *                               ZY(1,ISWAP), NFREE, 1, ZERO, ZERO )
+C
+      IF (ITRANS .EQ. 0) GO TO 420
+C
+      DO 410 J = 1, NCOLZ1
+         D     = WRK1(J)
+         IF (D .EQ. ZERO) GO TO 410
+         CALL AXPY( NFREE, D, ZY(1,NCOLZ), NFREE, 1, ZY(1,J), NFREE, 1 )
+  410 CONTINUE
+C
+  420 IF (.NOT. MODFYG) GO TO 600
+      IF (ISWAP .GT. 0)
+     *   CALL ELM   ( ORTHOG, 1, QTG(NCOLZ), 1, 1,
+     *                           QTG(ISWAP), 1, 1, ZERO, ZERO )
+C
+      IF (ITRANS .GT. 0)
+     *   CALL AXPY( NCOLZ1, QTG(NCOLZ), WRK1, NCOLZ1, 1,
+     *                                  QTG , NCOLZ1, 1 )
+      GO TO 600
+C
+C  *********************************************************************
+C  ORTHOGONAL TRANSFORMATION.
+C  WE USE A HOUSEHOLDER REFLECTION,   I  -  1/BETA  V V(T).
+C
+C  THERE ARE TWO WAYS OF APPLYING THE REFLECTION.  THE UPDATE TO  Z
+C  IS DONE VIA   W  =  Z * V,   Z  =  Z  -  1/BETA  W V(T),
+C  WHERE  V = WRK1 (FROM HOUSEHOLDER), AND  W = WRK2 (WORKSPACE).
+C
+C  THE UPDATE TO  QTG  IS THE MORE USUAL  D =  - QTG(T)*V / BETA,
+C  QTG  =  QTG  +  D * V.
+C
+C  NOTE THAT  DELTA  HAS TO BE STORED AFTER THE REFLECTION IS USED.
+C  *********************************************************************
+  440 CALL REFGEN( NCOLZ1, WRK1(NCOLZ), WRK1, NCOLZ1, 1, BETA, DELTA )
+      IF (BETA .LE. ZERO) GO TO 600
+      CALL ZEROVC( NFREE, WRK2, NFREE, 1 )
+C
+      DO 450 J = 1, NCOLZ
+         D     = WRK1(J)
+         IF (D .EQ. ZERO) GO TO 450
+         CALL AXPY( NFREE, D, ZY(1,J), NFREE, 1, WRK2, NFREE, 1 )
+  450 CONTINUE
+C
+      DO 460 J = 1, NCOLZ
+         D     = WRK1(J)
+         IF (D .EQ. ZERO) GO TO 460
+         D     = - D/BETA
+         CALL AXPY( NFREE, D, WRK2, NFREE, 1, ZY(1,J), NFREE, 1 )
+  460 CONTINUE
+C
+      IF (.NOT. MODFYG) GO TO 470
+      D      = DOT( NCOLZ, WRK1, NCOLZ, 1, QTG, NCOLZ, 1 )
+      D      = - D/BETA
+      CALL AXPY( NCOLZ, D, WRK1, NCOLZ, 1, QTG, NCOLZ, 1 )
+C
+  470 WRK1(NCOLZ) = DELTA
+      GO TO 600
+C
+C  ---------------------------------------------------------------------
+C  R  HAS TO BE MODIFIED.  USE A SEQUENCE OF 2*2 TRANSFORMATIONS.
+C  ---------------------------------------------------------------------
+  500 LROWR  = NCOLR
+C
+      DO 510 K = 1, NCOLZ1
+C
+C        COMPUTE THE TRANSFORMATION THAT REDUCES WRK1(K) TO ZERO,
+C        THEN APPLY IT TO THE RELEVANT COLUMNS OF  Z  AND  GRAD(T)Q.
+C
+         KP1    = K + 1
+         CALL ELMGEN( ORTHOG, WRK1(KP1), WRK1(K), CS, SN )
+         IF (.NOT. UNITQ)
+     *   CALL ELM   ( ORTHOG, NFREE, ZY(1,KP1), NFREE, 1,
+     *                               ZY(1,K  ), NFREE, 1, CS, SN )
+         IF (MODFYG)
+     *   CALL ELM   ( ORTHOG, 1, QTG(KP1), 1, 1, QTG(K), 1, 1, CS, SN )
+C
+C        APPLY THE SAME TRANSFORMATION TO THE COLS OF  R  IF RELEVANT.
+C        THIS GENERATES A SUBDIAGONAL ELEMENT IN  R  WHICH MUST BE
+C        ELIMINATED BY A ROW ROTATION.  THE LAST SUCH ROW ROTATION
+C        IS NEEDED BY  QPCORE.
+C
+         IF (.NOT. (MODFYR  .AND.  K .LT. NCOLR)) GO TO 510
+         RT(KP1,K) = ZERO
+         CALL ELM   ( ORTHOG, KP1, RT(1,KP1), KP1, 1,
+     *                             RT(1,K  ), KP1, 1, CS, SN )
+         CALL ROTGEN( RT(K,K), RT(KP1,K), CSLAST, SNLAST )
+         LROWR  = LROWR - 1
+         LENRT  = NROWRT*(LROWR - 1) + 1
+         CALL ROT3  ( LROWR, RT(K,KP1), LENRT, NROWRT,
+     *                     RT(KP1,KP1), LENRT, NROWRT, CSLAST, SNLAST )
+  510 CONTINUE
+C
+C  ---------------------------------------------------------------------
+C  IF ADDING A GENERAL CONSTRAINT, INSERT THE NEW ROW OF  T  AND EXIT.
+C  ---------------------------------------------------------------------
+  600 IF (JADD .LE. N) GO TO 700
+      LENRT  = NROWRT*NACTIV + 1
+      CALL COPYVC( NACT1, WRK1(NCOLZ), NACT1, 1,
+     *                RT(NACT1,NCOLZ), LENRT, NROWRT )
+      GO TO 900
+C
+C  ---------------------------------------------------------------------
+C  WE ARE ADDING A BOUND.  CONTINUE REDUCING THE ELEMENTS OF  WRK1
+C  TO ZERO.  THIS AFFECTS  Y,  T  AND  QTG.
+C  ---------------------------------------------------------------------
+C  FIRST, SET THE SUPER-DIAGONAL ELEMENTS OF T TO ZERO.
+C
+  700 IF (NACTIV .EQ. 0) GO TO 790
+      LENRT = NROWRT*(NACTIV - 1) + 1
+      CALL ZEROVC( NACTIV, RT(NACTIV,NCOLZ), LENRT, (NROWRT - 1) )
+      NELM   = 1
+      LDIAG  = NACTIV
+C
+      DO 710 K = NCOLZ, NFREE1
+         CALL ELMGEN( ORTHOG, WRK1(K+1), WRK1(K), CS, SN )
+         CALL ELM   ( ORTHOG, NFREE, ZY(1,K+1), NQ, 1,
+     *                               ZY(1,K  ), NQ, 1, CS, SN )
+         CALL ELM   ( ORTHOG, NELM, RT(LDIAG,K+1), NROWRT, 1,
+     *                              RT(LDIAG,K  ), NROWRT, 1, CS, SN )
+         IF (MODFYG)
+     *   CALL ELM   ( ORTHOG, 1, QTG(K+1), 1, 1, QTG(K), 1, 1, CS, SN )
+         NELM  = NELM  + 1
+         LDIAG = LDIAG - 1
+  710 CONTINUE
+C
+C  ---------------------------------------------------------------------
+C  THE DIAGONALS OF  T  HAVE BEEN ALTERED.  RECOMPUTE THE LARGEST AND
+C  SMALLEST VALUES.
+C  ---------------------------------------------------------------------
+      LENRT  = NROWRT*(NACTIV - 1) + 1
+      INCT   = NROWRT - 1
+      CALL CONDVC( NACTIV, RT(NACTIV,NCOLZ1+1), LENRT, INCT,
+     *             DTMAX, DTMIN )
+      IF ((DTMIN/DTMAX)*CONDMX .LT. ONE) GO TO 910
+      IF ((DTMIN/DTMAX)*CONDBD .LT. ONE) WRITE (NOUT, 2000) JADD
+C
+C  THE LAST ROW OF  ZY  HAS BEEN TRANSFORMED TO A MULTIPLE OF THE
+C  UNIT VECTOR  E(NFREE).  IF ORTHOGONAL TRANSFORMATIONS HAVE BEEN
+C  USED THROUGHOUT, THE LAST COLUMN OF  ZY  IS THE SAME.   WE CAN
+C  THEREFORE RESURRECT THE GRADIENT ELEMENT OF THE NEWLY-FIXED VARIABLE.
+C
+  790 IF (ORTHOG .AND. MODFYG)
+     *QTG(NFREE) = QTG(NFREE)/WRK1(NFREE)
+C
+C  ---------------------------------------------------------------------
+C  THE FACTORIZATION HAS BEEN SUCCESSFULLY UPDATED.
+C  ---------------------------------------------------------------------
+  900 INFORM = 0
+      RETURN
+C
+C  THE PROPOSED WORKING SET APPEARS TO BE LINEARLY DEPENDENT.
+C
+  910 INFORM = 1
+      IF (.NOT. MSG .GE. 80) RETURN
+C
+      WRITE (NOUT, 3000)
+      IF (JADD .LE. N) WRITE (NOUT, 3010) ASIZE, DTMAX, DTMIN
+      IF (JADD .GT. N) WRITE (NOUT, 3020) ASIZE, DTMAX, DTMIN, DTNEW
+      RETURN
+C
+ 1010 FORMAT(/ 32H //ADDCON//  SIMPLE BOUND ADDED.
+     *       / 49H //ADDCON//  NACTIV NCOLZ NFREE  IFIX  JADD UNITQ
+     *       / 13H //ADDCON//  , 5I6, L6 )
+ 1020 FORMAT(/ 38H //ADDCON//  GENERAL CONSTRAINT ADDED.
+     *       / 49H //ADDCON//  NACTIV NCOLZ NFREE  IADD  JADD UNITQ
+     *       / 13H //ADDCON//  , 5I6, L6 )
+ 2000 FORMAT(/ 12H *** WARNING
+     *       / 48H *** SERIOUS ILL-CONDITIONING IN THE WORKING SET,
+     *         25H AFTER ADDING CONSTRAINT ,  I5
+     *       / 48H *** OVERFLOW MAY OCCUR IN SUBSEQUENT ITERATIONS //)
+ 3000 FORMAT(/ 42H //ADDCON//  DEPENDENT CONSTRAINT REJECTED )
+ 3010 FORMAT(/ 41H //ADDCON//     ASIZE     DTMAX     DTMIN
+     *       / 11H //ADDCON//, 1P3E10.2 )
+ 3020 FORMAT(/ 51H //ADDCON//     ASIZE     DTMAX     DTMIN     DTNEW
+     *       / 11H //ADDCON//, 1P4E10.2 )
+C
+C  END OF ADDCON
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/alloc.f
@@ -0,0 +1,220 @@
+      SUBROUTINE ALLOC ( NALG, N, NCLIN, NCNLN, NCTOTL, NROWA, NROWJ,
+     *                   LITOTL, LWTOTL )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      INTEGER            NALG, N, NCLIN, NCNLN, NCTOTL, NROWA, NROWJ,
+     *                   LITOTL, LWTOTL
+C
+      LOGICAL            SCALED
+      INTEGER            NOUT, MSG, ISTART, LENNAM, NROWRT,
+     *                   NCOLRT, NQ, NCQP, NROWQP
+      DOUBLE PRECISION   PARM
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+      COMMON    /SOL3CM/ LENNAM, NROWRT, NCOLRT, NQ
+      COMMON    /SOL4CM/ PARM(10)
+C
+      INTEGER            LOCLP
+      COMMON    /SOL1LP/ LOCLP(15)
+C
+      INTEGER            LOCNP
+      COMMON    /SOL1NP/ LOCNP(30)
+      COMMON    /SOL2NP/ NCQP, NROWQP
+C
+      INTEGER            LOCLC
+      COMMON    /SOL1LC/ LOCLC(15)
+C
+C  *********************************************************************
+C  ALLOC  ALLOCATES THE ADDRESSES OF THE WORK ARRAYS FOR LPCORE, QPCORE
+C  LCCORE  AND  NPCORE.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  ORIGINAL VERSION              JANUARY  1983.
+C           VERSION 0.0  LCCORE  MAY      1983.
+C           VERSION 2.0  NPCORE  APRIL    1984.
+C  *********************************************************************
+C
+      INTEGER            MAX0
+C
+      GO TO (100, 100, 300, 400), NALG
+C
+C  ---------------------------------------------------------------------
+C  ALLOCATE THE ADDRESSES FOR  LPCORE  AND  QPCORE.
+C  ---------------------------------------------------------------------
+  100 LKACTV    = LITOTL + 1
+      LKFREE    = LKACTV + N
+      LITOTL    = LKFREE + N - 1
+C
+      LANORM    = LWTOTL + 1
+      LAP       = LANORM + NCLIN
+      LPX       = LAP    + NCLIN
+      LQTG      = LPX    + N
+      LRLAM     = LQTG   + N
+      LRT       = LRLAM  + N
+      LZY       = LRT    + NROWRT*NCOLRT
+      LWRK      = LZY    + NQ*NQ
+      LWTOTL    = LWRK   + N - 1
+C
+      LOCLP( 2) = LKACTV
+      LOCLP( 3) = LKFREE
+      LOCLP( 4) = LANORM
+      LOCLP( 5) = LAP
+      LOCLP( 6) = LPX
+      LOCLP( 7) = LQTG
+      LOCLP( 8) = LRLAM
+      LOCLP( 9) = LRT
+      LOCLP(10) = LZY
+      LOCLP(11) = LWRK
+C
+      GO TO 900
+C
+C  ---------------------------------------------------------------------
+C  ALLOCATE THE ADDRESSES FOR NPCORE.
+C  ---------------------------------------------------------------------
+  300 LKACTV    = LITOTL + 1
+      LKFREE    = LKACTV + N
+      LIQPST    = LKFREE + N
+      LITOTL    = LIQPST + NCTOTL - 1
+C
+C  VARIABLES USED NOT ONLY BY  NPCORE,  BUT ALSO  LPCORE AND  QPCORE.
+C
+      LANORM    = LWTOTL + 1
+      LQTG      = LANORM + NROWQP
+      LRLAM     = LQTG   + N
+      LRT       = LRLAM  + N
+      LZY       = LRT    + NROWRT*NCOLRT
+C
+      LOCLP( 2) = LKACTV
+      LOCLP( 3) = LKFREE
+      LOCLP( 4) = LANORM
+      LOCLP( 7) = LQTG
+      LOCLP( 8) = LRLAM
+      LOCLP( 9) = LRT
+      LOCLP(10) = LZY
+C
+C  ASSIGN THE ADDRESSES FOR THE WORKSPACE ARRAYS USED BY  NPIQP.
+C
+      LQPADX    = LZY    + NQ*NQ
+      LQPDX     = LQPADX + NROWQP
+      LQPWRK    = LQPDX  + N
+C
+      LOCLP( 5) = LQPADX
+      LOCLP( 6) = LQPDX
+      LOCLP(11) = LQPWRK
+C
+C  ASSIGN THE ADDRESSES FOR ARRAYS USED IN  NPCORE.
+C
+      IF (NCNLN .EQ. 0) LENAQP = 0
+      IF (NCNLN .GT. 0) LENAQP = NROWQP*N
+C
+      LAQP      = LQPWRK + N
+      LADX      = LAQP   + LENAQP
+      LBL       = LADX   + NROWQP
+      LBU       = LBL    + NCTOTL
+      LDX       = LBU    + NCTOTL
+      LG1       = LDX    + N
+      LG2       = LG1    + N
+      LQPTOL    = LG2    + N
+      LX1       = LQPTOL + NCTOTL
+      LNPWRK    = LX1    + N
+C
+      LOCNP( 1) = LIQPST
+      LOCNP( 2) = LAQP
+      LOCNP( 3) = LADX
+      LOCNP( 4) = LBL
+      LOCNP( 5) = LBU
+      LOCNP( 6) = LDX
+      LOCNP( 7) = LG1
+      LOCNP( 8) = LG2
+      LOCNP( 9) = LQPTOL
+      LOCNP(10) = LX1
+      LOCNP(11) = LNPWRK
+C
+      LCS1      = LNPWRK + NCTOTL
+      LCS2      = LCS1   + NCNLN
+      LCSL1     = LCS2   + NCNLN
+      LCSLAM    = LCSL1  + NCNLN
+      LCJDX     = LCSLAM + NCNLN
+      LDLAM     = LCJDX  + NCNLN
+      LDSLK     = LDLAM  + NCNLN
+      LRHO      = LDSLK  + NCNLN
+      LSIGMA    = LRHO   + NCNLN
+      LSLK1     = LSIGMA + NCNLN
+      LSLK      = LSLK1  + NCNLN
+C
+      LOCNP(12) = LCS1
+      LOCNP(13) = LCS2
+      LOCNP(14) = LCSL1
+      LOCNP(15) = LCSLAM
+      LOCNP(16) = LCJDX
+      LOCNP(17) = LDLAM
+      LOCNP(18) = LDSLK
+      LOCNP(19) = LRHO
+      LOCNP(20) = LSIGMA
+      LOCNP(21) = LSLK1
+      LOCNP(22) = LSLK
+C
+      LWTOTL    = LSLK   + NCNLN  - 1
+C
+      GO TO 900
+C
+C  ---------------------------------------------------------------------
+C  ALLOCATE THE ADDRESSES FOR  LCCORE.
+C  ---------------------------------------------------------------------
+  400 LKACTV    = LITOTL + 1
+      LKFREE    = LKACTV + N
+      LITOTL    = LKFREE + N - 1
+C
+      LZTG2     = LWTOTL + 1
+C
+      LOCLC( 1) = LZTG2
+C
+C  ARRAYS USED NOT ONLY BY  LCCORE,  BUT ALSO  LPCORE.
+C
+      LANORM    = LZTG2  + N
+      LAP       = LANORM + NCLIN
+      LPX       = LAP    + NCLIN
+      LQTG      = LPX    + N
+      LRLAM     = LQTG   + N
+      LRT       = LRLAM  + N
+      LZY       = LRT    + NROWRT*NCOLRT
+      LWRK      = LZY    + NQ*NQ
+C
+      LOCLP( 2) = LKACTV
+      LOCLP( 3) = LKFREE
+      LOCLP( 4) = LANORM
+      LOCLP( 5) = LAP
+      LOCLP( 6) = LPX
+      LOCLP( 7) = LQTG
+      LOCLP( 8) = LRLAM
+      LOCLP( 9) = LRT
+      LOCLP(10) = LZY
+      LOCLP(11) = LWRK
+C
+      LSHARE    = LWRK   + N
+C
+C  ASSIGN THE ADDRESSES OF THE WORKSPACE USED BY  LCSRCH.
+C  THIS WORKSPACE IS SHARED BY  LCAPPG.
+C
+      LX2       = LSHARE
+      LGRAD2    = LX2    + N
+      LMAX1     = LGRAD2 + N      - 1
+C
+C  ASSIGN THE ADDRESSES OF THE WORKSPACE USED BY  LCAPPG.
+C  THIS WORKSPACE IS SHARED BY  LCSRCH.
+C
+      LXFWD     = LSHARE
+      LXBWD     = LXFWD   + N
+      LMAX2     = LXBWD   + N     - 1
+C
+      LWTOTL    = MAX0( LMAX1, LMAX2 )
+C
+      LOCLC( 2) = LX2
+      LOCLC( 3) = LGRAD2
+C
+      LOCLC( 4) = LXFWD
+      LOCLC( 5) = LXBWD
+C
+  900 RETURN
+C
+C  END OF ALLOC
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/axpy.f
@@ -0,0 +1,74 @@
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C     FILE BLAS66 FORTRAN
+C
+C     AXPY     CONDVC   COPYMX   COPYVC   DOT      DSCALE   ELM
+C     ELMGEN   ETAGEN   QUOTNT   REFGEN   ROTGEN   ROT3     SSCALE
+C     V2NORM   ZEROVC
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+      SUBROUTINE AXPY  ( N, A, X, LENX, INCX, Y, LENY, INCY )
+C
+      INTEGER            N, LENX, INCX, LENY, INCY
+      DOUBLE PRECISION   A, X(LENX), Y(LENY)
+C
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+C
+C  AXPY  REPLACES  Y  BY  A*X + Y.
+C
+      INTEGER            I, IX, IY, NINCX
+      DOUBLE PRECISION   FLMIN, ONE, TINY, UNDFLW, U, V, ZERO
+      DOUBLE PRECISION   ABSA, ABSX, DU, DV
+      DOUBLE PRECISION   DABS
+      DATA               ZERO/0.0D+0/, ONE/1.0D+0/
+C
+      IF (N .LT.    1) RETURN
+      IF (A .EQ. ZERO) RETURN
+      IX = 1
+      IY = 1
+      UNDFLW = WMACH(9)
+      IF (UNDFLW .GT. ZERO) GO TO 110
+C
+C  NO UNDERFLOW TEST REQUIRED.
+C  DO THE MOST COMMON CASE SPECIALLY (INCX = INCY).
+C
+      IF (INCX .NE. INCY) GO TO 50
+      NINCX  = N * INCX
+      DO 40 I = 1, NINCX, INCX
+         Y(I) = A * X(I) + Y(I)
+   40 CONTINUE
+      RETURN
+C
+   50 DO 100 I = 1, N
+         Y(IY) = A * X(IX) + Y(IY)
+         IX    = IX + INCX
+         IY    = IY + INCY
+  100 CONTINUE
+      RETURN
+C
+C  UNDERFLOW TEST REQUIRED.
+C
+  110 FLMIN  = WMACH(5)
+      ABSA   = DABS( A )
+      TINY   = FLMIN
+      IF (ABSA .LT. ONE) TINY = FLMIN / ABSA
+      DO 160 I = 1, N
+         ABSX   = DABS( X(IX) )
+         IF (ABSX .LT. TINY) GO TO 150
+         U      = Y(IY)
+         DU     = DABS( U )
+         V      = A * X(IX)
+         DV     = DABS( V )
+         IF (U .GE. ZERO) GO TO 120
+         IF (V .LT. ZERO) GO TO 140
+         GO TO 130
+  120    IF (V .GE. ZERO) GO TO 140
+  130    Y(IY) = ZERO
+         IF (DU .LE. FLMIN + DV  .AND.  DV .LE. FLMIN + DU) GO TO 150
+  140    Y(IY)  = V  + U
+  150    IX     = IX + INCX
+         IY     = IY + INCY
+  160 CONTINUE
+         RETURN
+C
+C  END OF AXPY
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/bdpert.f
@@ -0,0 +1,146 @@
+      SUBROUTINE BDPERT( FIRSTV, NEGSTP, BIGALF, BIGBND, PNORM,
+     *                   JADD1, JADD2, PALFA1, PALFA2,
+     *                   ISTATE, N, NCLIN0, NROWA, NCTOTL,
+     *                   ANORM, AP, AX, BL, BU, FEATOL, P, X )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      LOGICAL            FIRSTV, NEGSTP
+      INTEGER            JADD1, JADD2, N, NCLIN0, NCTOTL, NROWA
+      INTEGER            ISTATE(NCTOTL)
+      DOUBLE PRECISION   BIGALF, BIGBND, PALFA1, PALFA2, PNORM
+      DOUBLE PRECISION   AP(NCLIN0), AX(NROWA), BL(NCTOTL), BU(NCTOTL),
+     *                   FEATOL(NCTOTL), P(N), X(N), ANORM(NCLIN0)
+C
+      DOUBLE PRECISION   PARM
+      INTEGER            NOUT, MSG, ISTART
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+      COMMON    /SOL4CM/ PARM(10)
+C
+C  *********************************************************************
+C  BDPERT  FINDS STEPS  PALFA1, PALFA2  SUCH THAT
+C     THE POINT  X + PALFA1*P  REACHES A LINEAR CONSTRAINT THAT IS
+C                              CURRENTLY NOT IN THE WORKING SET BUT IS
+C                              SATISFIED,
+C     THE POINT  X + PALFA2*P  REACHES A LINEAR CONSTRAINT THAT IS
+C                              CURRENTLY NOT IN THE WORKING SET BUT IS
+C                              VIOLATED.
+C  THE CONSTRAINTS ARE PERTURBED BY AN AMOUNT  FEATOL, SO THAT
+C  PALFA1  IS SLIGHTLY LARGER THAN IT SHOULD BE, AND
+C  PALFA2  IS SLIGHTLY SMALLER THAN IT SHOULD BE.  THIS GIVES
+C  SOME LEEWAY LATER WHEN THE EXACT STEPS ARE COMPUTED BY BNDALF.
+C
+C  CONSTRAINTS IN THE WORKING SET ARE IGNORED  (ISTATE(J) GE 1).
+C
+C  IF  NEGSTP  IS TRUE, THE SEARCH DIRECTION WILL BE TAKEN TO BE  - P.
+C
+C
+C  VALUES OF ISTATE(J)....
+C
+C     - 2         - 1         0           1          2         3
+C  A*X LT BL   A*X GT BU   A*X FREE   A*X = BL   A*X = BU   BL = BU
+C
+C  THE VALUES -2 AND -1 DO NOT OCCUR ONCE LPCORE FINDS A FEASIBLE POINT.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION OF MAY 1982.  REV. OCT. 1982.  JUNE 1986.
+C  *********************************************************************
+C
+      LOGICAL            LASTV, NOLOW, NOUPP
+      INTEGER            I, J, JS
+      DOUBLE PRECISION   ABSATP, ATP, ATX, EPSPT9, ONE, RES, ROWNRM,
+     *                   ZERO
+      DOUBLE PRECISION   DABS
+      DATA               ZERO/0.0D+0/, ONE/1.0D+0/
+C
+      EPSPT9 = PARM(4)
+      IF (MSG .EQ. 99) WRITE (NOUT, 1100)
+      LASTV  = .NOT. FIRSTV
+      JADD1  = 0
+      JADD2  = 0
+      PALFA1 = BIGALF
+      PALFA2 = ZERO
+      IF (FIRSTV) PALFA2 = BIGALF
+C
+      DO 200 J = 1, NCTOTL
+         JS     = ISTATE(J)
+         IF (JS .GT. 0) GO TO 200
+         IF (J  .GT. N) GO TO 120
+C
+C        BOUND CONSTRAINT.
+C
+         ATX    = X(J)
+         ATP    = P(J)
+         ROWNRM = ONE
+         GO TO 130
+C
+C        GENERAL LINEAR CONSTRAINT.
+C
+  120    I      = J - N
+         ATX    = AX(I)
+         ATP    = AP(I)
+         ROWNRM = ONE + ANORM(I)
+C
+  130    IF (NEGSTP) ATP = - ATP
+         IF (DABS(ATP) .GT. EPSPT9*ROWNRM*PNORM) GO TO 135
+         RES    = - ONE
+         GO TO 190
+C
+  135    IF (ATP .GT. ZERO) GO TO 150
+C
+C        AX  IS DECREASING.
+C        TEST FOR SMALLER PALFA1 IF LOWER BOUND IS SATISFIED.
+C
+         IF (JS .EQ. (- 2)) GO TO 190
+         ABSATP = - ATP
+         NOLOW  = BL(J) .LE. (- BIGBND)
+         IF (NOLOW) GO TO 140
+         RES    = ATX - BL(J) + FEATOL(J)
+         IF (BIGALF*ABSATP .LE. DABS( RES )) GO TO 140
+         IF (PALFA1*ABSATP .LE.       RES  ) GO TO 140
+         PALFA1 = RES/ABSATP
+         JADD1  = J
+C
+C        TEST FOR DIFFERENT PALFA2 IF UPPER BOUND IS VIOLATED.
+C
+  140    IF (JS .NE. (- 1)) GO TO 190
+         RES    = ATX - BU(J) - FEATOL(J)
+         IF (BIGALF*ABSATP .LE. DABS( RES )) GO TO 190
+         IF (LASTV   .AND.  PALFA2*ABSATP .GE. RES) GO TO 190
+         IF (FIRSTV  .AND.  PALFA2*ABSATP .LE. RES) GO TO 190
+         PALFA2 = RES/ABSATP
+         JADD2  = J
+         GO TO 190
+C
+C        AX  IS INCREASING.
+C        TEST FOR SMALLER PALFA1 IF UPPER BOUND IS SATISFIED.
+C
+  150    IF (JS .EQ. (- 1)) GO TO 190
+         NOUPP  = BU(J) .GE.   BIGBND
+         IF (NOUPP) GO TO 160
+         RES    = BU(J) - ATX + FEATOL(J)
+         IF (BIGALF*ATP .LE. DABS( RES )) GO TO 160
+         IF (PALFA1*ATP .LE.       RES  ) GO TO 160
+         PALFA1 = RES/ATP
+         JADD1  = J
+C
+C        TEST FOR DIFFERENT PALFA2 IF LOWER BOUND IS VIOLATED.
+C
+  160    IF (JS .NE. (- 2)) GO TO 190
+         RES    = BL(J) - ATX - FEATOL(J)
+         IF (BIGALF*ATP .LE. DABS( RES )) GO TO 190
+         IF (LASTV   .AND.  PALFA2*ATP .GE. RES) GO TO 190
+         IF (FIRSTV  .AND.  PALFA2*ATP .LE. RES) GO TO 190
+         PALFA2 = RES/ATP
+         JADD2  = J
+C
+  190    IF (MSG .EQ. 99) WRITE (NOUT, 1200) J, JS, FEATOL(J), ATX,
+     *      ATP, JADD1, PALFA1, JADD2, PALFA2
+  200 CONTINUE
+      RETURN
+C
+ 1100 FORMAT(/ 50H    J  JS         FEATOL         AX             AP,
+     *   46H     JADD1       PALFA1     JADD2       PALFA2 /)
+ 1200 FORMAT(I5, I4, 3G15.5, 2(I6, G17.7))
+C
+C  END OF BDPERT
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/bndalf.f
@@ -0,0 +1,278 @@
+      SUBROUTINE BNDALF( FIRSTV, HITLOW, ISTATE, INFORM, JADD,
+     *                   N, NROWA, NCLIN, NCLIN0, NCTOTL, NUMINF,
+     *                   ALFA, PALFA, ATPHIT, BIGALF, BIGBND, PNORM,
+     *                   ANORM, AP, AX, BL, BU, FEATOL, P, X )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      INTEGER            INFORM, JADD, N, NROWA, NCLIN, NCLIN0, NCTOTL,
+     *                   NUMINF
+      INTEGER            ISTATE(NCTOTL)
+      DOUBLE PRECISION   ALFA, PALFA, ATPHIT, BIGALF, BIGBND, PNORM
+      DOUBLE PRECISION   ANORM(NCLIN0), AP(NCLIN0), AX(NROWA),
+     *                   BL(NCTOTL), BU(NCTOTL), FEATOL(NCTOTL),
+     *                   P(N), X(N)
+      LOGICAL            FIRSTV, HITLOW
+C
+      INTEGER            NOUT, MSG, ISTART
+      DOUBLE PRECISION   PARM
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+      COMMON    /SOL4CM/ PARM(10)
+C
+C  *********************************************************************
+C  BNDALF  FINDS A STEP  ALFA  SUCH THAT THE POINT  X + ALFA*P  REACHES
+C  ONE OF THE LINEAR CONSTRAINTS (INCLUDING BOUNDS).  TWO POSSIBLE STEPS
+C  ARE DEFINED AS FOLLOWS...
+C
+C  ALFA1   IS THE MAXIMUM STEP THAT CAN BE TAKEN WITHOUT VIOLATING
+C          ONE OF THE LINEAR CONSTRAINTS THAT IS CURRENTLY SATISFIED.
+C  ALFA2   REACHES A LINEAR CONSTRAINT THAT IS CURRENTLY VIOLATED.
+C          USUALLY THIS WILL BE THE FURTHEST SUCH CONSTRAINT ALONG  P,
+C          BUT IF  FIRSTV = .TRUE.  IT WILL BE THE FIRST ONE ALONG  P.
+C          THIS IS USED ONLY BY  LPCORE  WHEN THE PROBLEM HAS BEEN
+C          DETERMINED TO BE INFEASIBLE, AND WE ARE NOW MINIMIZING THE
+C          SUM OF INFEASIBILITIES.
+C          (ALFA2  IS NOT DEFINED IF NUMINF = 0.)
+C
+C  ALFA  WILL USUALLY BE THE MINIMUM OF  ALFA1  AND  ALFA2.
+C  ALFA  COULD BE NEGATIVE (SINCE WE ALLOW INACTIVE CONSTRAINTS
+C  TO BE VIOLATED BY AS MUCH AS  FEATOL).  IN SUCH CASES, A
+C  THIRD POSSIBLE STEP IS COMPUTED, TO FIND THE NEAREST SATISFIED
+C  CONSTRAINT (PERTURBED BY  FEATOL) ALONG THE DIRECTION  - P.
+C  ALFA  WILL BE RESET TO THIS STEP IF IT IS SHORTER.  THIS IS THE
+C  ONLY CASE FOR WHICH THE FINAL STEP  ALFA  DOES NOT MOVE  X  EXACTLY
+C  ONTO A CONSTRAINT (THE ONE DENOTED BY  JADD).
+C
+C  CONSTRAINTS IN THE WORKING SET ARE IGNORED  (ISTATE(J) GE 1).
+C
+C  JADD    DENOTES WHICH LINEAR CONSTRAINT IS REACHED.
+C
+C  HITLOW  INDICATES WHETHER IT IS THE LOWER OR UPPER BOUND THAT
+C          HAS RESTRICTED  ALFA.
+C
+C  VALUES OF ISTATE(J)....
+C
+C     - 2         - 1         0           1          2         3
+C  A*X LT BL   A*X GT BU   A*X FREE   A*X = BL   A*X = BU   BL = BU
+C
+C  THE VALUES -2 AND -1 DO NOT OCCUR ONCE LPCORE FINDS A FEASIBLE POINT.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION OF MAY 1982.  REV. OCT. 1982.  FEB. 1984. JUNE 1986.
+C  *********************************************************************
+C
+      INTEGER            I, IADD, J, JS, JSAVE1, JSAVE2, JADD1, JADD2
+      DOUBLE PRECISION   ABSATP, ALFA1, ALFA2, APMAX1, APMAX2, ATP,
+     *                   ATP1, ATP2, ATX, EPSPT9, PALFA1, PALFA2, RES,
+     *                   ROWNRM
+      DOUBLE PRECISION   ZERO, ONE
+      DOUBLE PRECISION   DABS, DMIN1
+      LOGICAL            HLOW1, HLOW2, LASTV, NEGSTP, NOLOW, NOUPP,
+     *                   STEP2
+      DATA               ZERO, ONE /0.0D+0, 1.0D+0/
+C
+      EPSPT9 = PARM(4)
+C
+      INFORM = 0
+C
+C  ---------------------------------------------------------------------
+C  FIRST PASS -- FIND STEPS TO PERTURBED CONSTRAINTS, SO THAT
+C  PALFA1  WILL BE SLIGHTLY LARGER THAN THE TRUE STEP, AND
+C  PALFA2  WILL BE SLIGHTLY SMALLER THAN IT SHOULD BE.  IN DEGENERATE
+C  CASES, THIS STRATEGY GIVES US SOME FREEDOM IN THE SECOND PASS.
+C  THE GENERAL IDEA FOLLOWS THAT DESCRIBED BY P.M.J. HARRIS, P.21 OF
+C  MATHEMATICAL PROGRAMMING 5, 1 (1973), 1--28.
+C  ---------------------------------------------------------------------
+C
+      NEGSTP = .FALSE.
+      CALL BDPERT( FIRSTV, NEGSTP, BIGALF, BIGBND, PNORM,
+     *             JADD1, JADD2, PALFA1, PALFA2,
+     *             ISTATE, N, NCLIN0, NROWA, NCTOTL,
+     *             ANORM, AP, AX, BL, BU, FEATOL, P, X )
+C
+      JSAVE1 = JADD1
+      JSAVE2 = JADD2
+C
+C  ---------------------------------------------------------------------
+C  SECOND PASS -- RECOMPUTE STEP-LENGTHS WITHOUT PERTURBATION.
+C  AMONGST CONSTRAINTS THAT ARE CLOSE TO THE PERTURBED STEPS,
+C  CHOOSE THE ONE (OF EACH TYPE) THAT MAKES THE LARGEST ANGLE
+C  WITH THE SEARCH DIRECTION.
+C  ---------------------------------------------------------------------
+      IF (MSG .EQ. 99) WRITE (NOUT, 1000)
+      ALFA1  = BIGALF
+      ALFA2  = ZERO
+      IF (FIRSTV) ALFA2 = BIGALF
+C
+      APMAX1 = ZERO
+      APMAX2 = ZERO
+      ATP1   = ZERO
+      ATP2   = ZERO
+      HLOW1  = .FALSE.
+      HLOW2  = .FALSE.
+      LASTV  = .NOT. FIRSTV
+C
+      DO 400 J  = 1, NCTOTL
+         JS     = ISTATE(J)
+         IF (JS .GT. 0) GO TO 400
+         IF (J  .GT. N) GO TO 320
+C
+C        BOUND CONSTRAINT.
+C
+         ATX    = X(J)
+         ATP    = P(J)
+         ROWNRM = ONE
+         GO TO 330
+C
+C        GENERAL LINEAR CONSTRAINT.
+C
+  320    I      = J - N
+         ATX    = AX(I)
+         ATP    = AP(I)
+         ROWNRM = ANORM(I) + ONE
+C
+  330    IF (DABS(ATP) .GT. EPSPT9*ROWNRM*PNORM) GO TO 335
+         RES    = - ONE
+         GO TO 390
+C
+  335    IF (ATP .GT. ZERO) GO TO 350
+C
+C        ATX IS DECREASING.
+C        TEST FOR SMALLER ALFA1 IF LOWER BOUND IS SATISFIED.
+C
+         IF (JS .EQ. (- 2)) GO TO 390
+         ABSATP = - ATP
+         NOLOW  = BL(J) .LE. (- BIGBND)
+         IF (NOLOW) GO TO 340
+         RES    = ATX - BL(J)
+         IF (PALFA1*ABSATP .LT. RES  .AND.  J .NE. JSAVE1) GO TO 340
+         IF (APMAX1*ROWNRM*PNORM              .GE. ABSATP) GO TO 340
+         APMAX1 = ABSATP/(ROWNRM*PNORM)
+         ALFA1  = RES/ABSATP
+         JADD1  = J
+         ATP1   = ATP
+         HLOW1  = .TRUE.
+C
+C        TEST FOR BIGGER ALFA2 IF UPPER BOUND IS VIOLATED.
+C
+  340    IF (JS .NE. (- 1)) GO TO 390
+         RES    = ATX - BU(J)
+         IF (LASTV  .AND.  PALFA2*ABSATP .GT. RES  .AND.  J .NE. JSAVE2)
+     *      GO TO 390
+         IF (FIRSTV .AND.  PALFA2*ABSATP .LT. RES  .AND.  J .NE. JSAVE2)
+     *      GO TO 390
+         IF (APMAX2*ROWNRM*PNORM   .GE.   ABSATP) GO TO 390
+         APMAX2 = ABSATP/(ROWNRM*PNORM)
+         ALFA2  = BIGALF
+         IF (ABSATP .LT. ONE) GO TO 342
+         ALFA2  = RES/ABSATP
+         GO TO 345
+  342    IF (RES .LT. BIGALF*ABSATP) ALFA2 = RES/ABSATP
+C
+  345    JADD2  = J
+         ATP2   = ATP
+         HLOW2  = .FALSE.
+         GO TO 390
+C
+C        ATX IS INCREASING.
+C        TEST FOR SMALLER ALFA1 IF UPPER BOUND IS SATISFIED.
+C
+  350    IF (JS .EQ. (- 1)) GO TO 390
+         NOUPP  = BU(J) .GE.   BIGBND
+         IF (NOUPP) GO TO 360
+         RES    = BU(J) - ATX
+         IF (PALFA1*ATP .LT. RES  .AND.  J .NE. JSAVE1) GO TO 360
+         IF (APMAX1*ROWNRM*PNORM           .GE. ATP   ) GO TO 360
+         APMAX1 = ATP/(ROWNRM*PNORM)
+         ALFA1  = RES/ATP
+         JADD1  = J
+         ATP1   = ATP
+         HLOW1  = .FALSE.
+C
+C        TEST FOR BIGGER ALFA2 IF LOWER BOUND IS VIOLATED.
+C
+  360    IF (JS .NE. (- 2)) GO TO 390
+         RES    = BL(J) - ATX
+         IF (LASTV   .AND.  PALFA2*ATP .GT. RES  .AND.  J .NE. JSAVE2)
+     *      GO TO 390
+         IF (FIRSTV  .AND.  PALFA2*ATP .LT. RES  .AND.  J .NE. JSAVE2)
+     *      GO TO 390
+         IF (APMAX2*ROWNRM*PNORM    .GE.  ATP) GO TO 390
+         APMAX2 = ATP/(ROWNRM*PNORM)
+         ALFA2  = BIGALF
+         IF (ATP .LT. ONE) GO TO 363
+         ALFA2  = RES/ATP
+         GO TO 365
+  363    IF (RES .LT. BIGALF*ATP) ALFA2 = RES/ATP
+C
+  365    JADD2  = J
+         ATP2   = ATP
+         HLOW2  = .TRUE.
+C
+  390    IF (MSG .EQ. 99) WRITE (NOUT, 1200) J, JS, FEATOL(J), ATX,
+     *      ATP, JADD1, ALFA1, JADD2, ALFA2
+  400 CONTINUE
+C
+C  ---------------------------------------------------------------------
+C  IF FEASIBLE, ONLY ALFA1 WILL HAVE BEEN SET.
+C  ---------------------------------------------------------------------
+      ALFA   = ALFA1
+      PALFA  = PALFA1
+      JADD   = JADD1
+      ATPHIT = ATP1
+      HITLOW = HLOW1
+      IF (NUMINF .EQ. 0) GO TO 500
+      IF (JADD2  .EQ. 0) GO TO 500
+C
+C  INFEASIBLE -- SEE IF WE STEP TO THE FURTHEST VIOLATED CONSTRAINT.
+C  BE PREPARED TO STEP IN THE RANGE  (ALFA1, PALFA1)  IF THE VIOLATED
+C  CONSTRAINT HAS A LARGER VALUE OF  AP.
+C
+      STEP2  =  ALFA2 .LT. ALFA1   .OR.
+     *         (ALFA2 .LE. PALFA1  .AND.  APMAX2 .GE. APMAX1)
+      IF (.NOT. STEP2) GO TO 500
+      ALFA   = ALFA2
+      JADD   = JADD2
+      ATPHIT = ATP2
+      HITLOW = HLOW2
+      GO TO 900
+C
+C  TEST FOR NEGATIVE STEP.
+C  JADD  WILL RETAIN ITS CURRENT VALUE, BUT WE MAY SHORTEN  ALFA
+C  TO BE  - PALFA1,  THE STEP TO THE NEAREST PERTURBED SATISFIED
+C  CONSTRAINT ALONG THE DIRECTION  - P.
+C
+  500 NEGSTP = ALFA .LT. ZERO
+      IF (.NOT. NEGSTP) GO TO 900
+C
+      CALL BDPERT( FIRSTV, NEGSTP, BIGALF, BIGBND, PNORM,
+     *             JADD1, JADD2, PALFA1, PALFA2,
+     *             ISTATE, N, NCLIN0, NROWA, NCTOTL,
+     *             ANORM, AP, AX, BL, BU, FEATOL, P, X )
+C
+      IF (MSG .GE. 80) WRITE (NOUT, 9000) ALFA, PALFA1
+      ALFA = - DMIN1( DABS(ALFA), PALFA1 )
+C
+C  TEST FOR UNDEFINED OR INFINITE STEP.  THIS SHOULD MEAN THAT THE
+C  SOLUTION IS UNBOUNDED.
+C
+  900 IF (JADD .EQ. 0)      ALFA   = BIGALF
+      IF (JADD .EQ. 0)      PALFA  = BIGALF
+      IF (JADD .EQ. 0)      INFORM = 2
+      IF (ALFA .GE. BIGALF) INFORM = 3
+      IF (MSG .GE. 80  .AND.  INFORM .GT. 0)
+     *WRITE (NOUT, 9010) JADD, ALFA
+      RETURN
+C
+ 1000 FORMAT(/ 15H BNDALF ENTERED
+     *       / 50H    J  JS         FEATOL         AX             AP,
+     *         46H     JADD1        ALFA1     JADD2        ALFA2 /)
+ 1200 FORMAT(I5, I4, 3G15.5, 2(I6, G17.7))
+ 9000 FORMAT(/ 27H //BNDALF//  NEGATIVE STEP.
+     *       / 41H //BNDALF//           ALFA          PALFA
+     *       / 11H //BNDALF//, 2G15.4 )
+ 9010 FORMAT(/ 28H //BNDALF//  UNBOUNDED STEP.
+     *       / 32H //BNDALF//  JADD           ALFA
+     *       / 13H //BNDALF//  , I4, G15.4 )
+C
+C  END OF BNDALF
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/chkdat.f
@@ -0,0 +1,122 @@
+      SUBROUTINE CHKDAT( NERROR, LIWORK, LWORK, LITOTL, LWTOTL,
+     *                   NROWA, N, NCLIN, NCNLN, NCTOTL,
+     *                   ISTATE, KACTIV,
+     *                   LCRASH, NAMED, NAMES, LENNAM,
+     *                   BIGBND, A, BL, BU, FEATOL, X )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      INTEGER            NERROR, LIWORK, LWORK, LITOTL, LWTOTL, NROWA,
+     *                   N, NCLIN, NCNLN, NCTOTL, LCRASH,
+     *                   LENNAM
+      INTEGER            ISTATE(NCTOTL), KACTIV(N), NAMES(4,LENNAM)
+      DOUBLE PRECISION   BIGBND
+      DOUBLE PRECISION   A(NROWA,N), BL(NCTOTL), BU(NCTOTL),
+     *                   FEATOL(NCTOTL), X(N)
+      LOGICAL            NAMED
+C
+      INTEGER            NOUT, MSG, ISTART
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+C
+C  *********************************************************************
+C  CHKDAT  CHECKS THE DATA INPUT TO THE VARIOUS OPTIMIZERS.
+C
+C  THE FOLLOWING QUANTITIES ARE NOT CHECKED...
+C     NROWA, N, NCLIN, NCTOTL
+C     KACTIV
+C     A, X
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION OF APRIL 1982.  REV. OCT. 1982.
+C  *********************************************************************
+C
+      INTEGER            IS, J, K, L, L1, L2, NPLIN
+      INTEGER            ID(9)
+      DOUBLE PRECISION   B1, B2, FTOL, ONE, TEST, ZERO
+      LOGICAL            OK
+      DATA               ID(1), ID(2), ID(3), ID(4), ID(5)
+     *                  / 2HVA,  2HRB,  2HL ,  2HLN,  2HCO/
+      DATA               ID(6), ID(7), ID(8), ID(9)
+     *                  / 2HN ,  2HNL,  2HCO,  2HN /
+      DATA               ONE/1.0D+0/, ZERO/0.0D+0/
+C
+      NERROR = 0
+C
+C  ---------------------------------------------------------------------
+C  CHECK THAT THERE IS ENOUGH WORKSPACE TO SOLVE THE PROBLEM.
+C  ---------------------------------------------------------------------
+      OK     = LITOTL .LE. LIWORK  .AND.  LWTOTL .LE. LWORK
+      IF (OK  .AND.  MSG .LE. 0) GO TO 100
+      WRITE (NOUT, 1000) LIWORK, LWORK, LITOTL, LWTOTL
+      IF (OK) GO TO 100
+      NERROR = NERROR + 1
+      WRITE (NOUT, 1010)
+C
+C  ---------------------------------------------------------------------
+C  CHECK THE BOUNDS ON ALL VARIABLES AND CONSTRAINTS.
+C  ---------------------------------------------------------------------
+  100 DO 200 J = 1, NCTOTL
+         B1     = BL(J)
+         B2     = BU(J)
+         OK     = B1 .LE. B2
+         IF (OK) GO TO 200
+         NERROR = NERROR + 1
+         K      = J
+         L1     = 1
+         IF (J .GT. N)         K  = J - N
+         IF (J .GT. N)         L1 = 4
+         IF (J .GT. N + NCLIN) K  = K - NCLIN
+         IF (J .GT. N + NCLIN) L1 = 7
+         L2     = L1 + 2
+         IF (.NOT. NAMED) WRITE (NOUT, 1100) (ID(L), L=L1,L2), K, B1,B2
+         IF (      NAMED) WRITE (NOUT, 1200) (NAMES(L,J), L=1,4), B1,B2
+  200 CONTINUE
+C
+C  ---------------------------------------------------------------------
+C  CHECK  BIGBND  AND  FEATOL.
+C  ---------------------------------------------------------------------
+      OK     = BIGBND .GT. ZERO
+      IF (OK) GO TO 300
+      NERROR = NERROR + 1
+      WRITE (NOUT, 1300) BIGBND
+C
+  300 DO 320 J = 1, NCTOTL
+         FTOL   = FEATOL(J)
+         TEST   = ONE + FTOL
+         OK     = TEST .GT. ONE
+         IF (OK) GO TO 320
+         WRITE (NOUT, 1400) J, FTOL
+  320 CONTINUE
+C
+C  ---------------------------------------------------------------------
+C  IF WARM START, CHECK  ISTATE.
+C  ---------------------------------------------------------------------
+  400 IF (LCRASH .EQ. 0) GO TO 900
+      NPLIN  = N + NCLIN
+C
+      DO 420 J = 1, NPLIN
+         IS     = ISTATE(J)
+         OK     = IS .GE. (- 2)   .AND.   IS .LE. 4
+         IF (OK) GO TO 420
+         NERROR = NERROR + 1
+         WRITE (NOUT, 1500) J, IS
+  420 CONTINUE
+C
+  900 RETURN
+C
+ 1000 FORMAT(/ 30H WORKSPACE PROVIDED IS     IW(, I6,
+     *   6H),  W(, I6, 2H).
+     *       / 30H TO SOLVE PROBLEM WE NEED  IW(, I6,
+     *   6H),  W(, I6, 2H).)
+ 1010 FORMAT(/ 44H XXX  NOT ENOUGH WORKSPACE TO SOLVE PROBLEM.)
+ 1100 FORMAT(/ 21H XXX  THE BOUNDS ON  , 2A2, A1, I3,
+     *   26H  ARE INCONSISTENT.   BL =, G16.7, 7H   BU =, G16.7)
+ 1200 FORMAT(/ 21H XXX  THE BOUNDS ON  , 4A2,
+     *   26H  ARE INCONSISTENT.   BL =, G16.7, 7H   BU =, G16.7)
+ 1300 FORMAT(/ 32H XXX  BIGBND  IS NOT POSITIVE..., G16.6)
+ 1400 FORMAT(/ 24H ***  WARNING -- FEATOL(, I4, 16H )  IS LESS THAN,
+     *   21H MACHINE PRECISION..., G16.6)
+ 1500 FORMAT(/ 15H XXX  COMPONENT, I5, 23H  OF  ISTATE  IS OUT OF,
+     *   9H RANGE..., I10)
+C
+C  END OF CHKDAT
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/condvc.f
@@ -0,0 +1,27 @@
+      SUBROUTINE CONDVC( N, X, LENX, INCX, XMAX, XMIN )
+C
+      INTEGER            N, LENX, INCX
+      DOUBLE PRECISION   XMAX, XMIN
+      DOUBLE PRECISION   X(LENX)
+C
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+C
+C  CONDVC  FINDS THE BIGGEST AND SMALLEST COMPONENTS OF N ELEMENTS OF X.
+C
+      INTEGER            I, IX
+      DOUBLE PRECISION   DABS, DMAX1, DMIN1
+C
+      XMAX = 0.0D+0
+      XMIN = WMACH(8)
+      IF (N .LT. 1) RETURN
+      IX   = 1
+      DO 100 I = 1, N
+         XMAX = DMAX1( XMAX, DABS(X(IX)) )
+         XMIN = DMIN1( XMIN, DABS(X(IX)) )
+         IX   = IX + INCX
+  100 CONTINUE
+      RETURN
+C
+C  END OF CONDVC
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/copymx.f
@@ -0,0 +1,18 @@
+      SUBROUTINE COPYMX( NROWS, N, IROWX, X, LROWX, IROWY, Y, LROWY )
+C
+      INTEGER            NROWS, N, IROWX, LROWX, IROWY, LROWY
+      DOUBLE PRECISION   X(LROWX,N), Y(LROWY,N)
+C
+C  LOAD  NROWS  FROM THE MATRIX  X  INTO THE MATRIX  Y.
+C  THE ROWS CONCERNED ARE ROWS  IROWX, IROWX+1,...  OF  X  AND ROWS
+C  IROWY, IROWY+1,...  OF THE ARRAY  Y.
+C
+      INTEGER            J
+      DO 100 J = 1, N
+         CALL COPYVC( NROWS, X(IROWX,J), NROWS, 1, Y(IROWY,J), NROWS, 1)
+  100 CONTINUE
+C
+      RETURN
+C
+C  END OF COPYMX
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/copyvc.f
@@ -0,0 +1,27 @@
+      SUBROUTINE COPYVC( N, X, LENX, INCX, Y, LENY, INCY )
+C
+      INTEGER            N, LENX, INCX, LENY, INCY
+      DOUBLE PRECISION   X(LENX), Y(LENY)
+C
+C  COPY THE FIRST N ELEMENTS OF X INTO Y.
+C
+      INTEGER            I, IX, IY
+C
+      IF (N .LT. 1) RETURN
+      IF (INCX .EQ. 1  .AND.  INCY .EQ. 1) GO TO 50
+      IX = 1
+      IY = 1
+      DO 10 I = 1, N
+         Y(IY) = X(IX)
+         IX = IX + INCX
+         IY = IY + INCY
+   10 CONTINUE
+      RETURN
+C
+   50 DO 60 I = 1, N
+         Y(I) = X(I)
+   60 CONTINUE
+      RETURN
+C
+C  END OF COPYVC
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/delcon.f
@@ -0,0 +1,159 @@
+      SUBROUTINE DELCON( MODFYG, ORTHOG, UNITQ,
+     *                   JDEL, KDEL, NACTIV, NCOLZ, NFREE,
+     *                   N, NQ, NROWA, NROWRT, NCOLRT,
+     *                   KACTIV, KFREE,
+     *                   A, QTG, RT, ZY )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      LOGICAL            MODFYG, ORTHOG, UNITQ
+      INTEGER            JDEL, KDEL, NACTIV, NCOLZ, NFREE, N, NQ,
+     *                   NROWA, NROWRT, NCOLRT
+      INTEGER            KACTIV(N), KFREE(N)
+      DOUBLE PRECISION   ASIZE, DTMAX, DTMIN
+      DOUBLE PRECISION   A(NROWA,N), RT(NROWRT,NCOLRT), QTG(N),
+     *                   ZY(NQ,NQ)
+C
+      INTEGER            NOUT, MSG, ISTART
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+      COMMON    /SOL5CM/ ASIZE, DTMAX, DTMIN
+C
+C  *********************************************************************
+C  DELCON  UPDATES THE FACTORIZATION OF THE MATRIX OF
+C  CONSTRAINTS IN THE WORKING SET,  A(FREE) * (Z Y) = (0 T).
+C
+C  IF THERE ARE NO GENERAL CONSTRAINTS IN THE WORKING SET AND THE
+C  MATRIX  Q = (Z Y)  IS THE IDENTITY,  Q  WILL NOT BE
+C  TOUCHED.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION OF DECEMBER 1981.  REV. OCT. 1982.
+C  *********************************************************************
+C
+      INTEGER            I, IBEGIN, IFREED, INCT, ISTORE, K, KA,
+     *                   KB, L, LDIAG, LENQ, LENRT, NACTPI, NACTP1,
+     *                   NACTV1, NCOLZ1, NFIXD1, NFREEI, NFREE1
+      DOUBLE PRECISION   CS, ONE, SN, STORE
+      DOUBLE PRECISION   DMAX1
+      DATA               ONE/1.0D+0/
+C
+      LENQ   = NQ*(NQ - 1) + 1
+      IF (JDEL .GT. N) GO TO 200
+C
+C  ------------------------------------------------------------------
+C  A SIMPLE BOUND IS BEING DELETED FROM THE WORKING SET.
+C  ------------------------------------------------------------------
+      IFREED = KDEL - NACTIV
+      IF (MSG .GE. 80)
+     *WRITE (NOUT, 1010) NACTIV, NCOLZ, NFREE,IFREED,JDEL, UNITQ
+      NACTV1 = NACTIV
+      NFREE1 = NFREE + 1
+      IBEGIN = 1
+      KFREE(NFREE1) = JDEL
+C
+C  ADD THE GRADIENT CORRESPONDING TO THE NEWLY-FREED VARIABLE TO THE
+C  END OF  Q(FREE)(T)G(FREE).  THIS IS DONE BY INTERCHANGING THE
+C  APPROPRIATE ELEMENTS OF  QTG  AND  KACTIV.
+C
+      IF (.NOT. MODFYG)  GO TO 120
+      IF (IFREED .EQ. 1) GO TO 120
+      NFREEI = NFREE  + IFREED
+      NACTP1 = NACTIV + 1
+      NACTPI = NACTIV + IFREED
+      STORE          = QTG(NFREE1)
+      QTG(NFREE1)    = QTG(NFREEI)
+      QTG(NFREEI)    = STORE
+      ISTORE         = KACTIV(NACTP1)
+      KACTIV(NACTP1) = KACTIV(NACTPI)
+      KACTIV(NACTPI) = ISTORE
+C
+C  COPY THE INCOMING COLUMN OF  A  INTO THE END OF  T.
+C
+  120 IF (UNITQ        ) GO TO 400
+      IF (NACTIV .EQ. 0) GO TO 150
+C
+      DO 130 KA = 1, NACTIV
+         I = KACTIV(KA)
+         RT(KA,NFREE1) = A(I,JDEL)
+  130 CONTINUE
+C
+C  EXPAND  Q  BY ADDING A UNIT ROW AND COLUMN.
+C
+  150 CALL ZEROVC( NFREE, ZY(NFREE1,1), LENQ, NQ )
+      CALL ZEROVC( NFREE, ZY(1,NFREE1), NQ, 1 )
+      ZY(NFREE1,NFREE1) = ONE
+      GO TO 400
+C
+C  ------------------------------------------------------------------
+C  A GENERAL CONSTRAINT IS BEING DELETED FROM THE WORKING SET.
+C  ------------------------------------------------------------------
+  200 IF (MSG .GE. 80)
+     *WRITE (NOUT, 1020) NACTIV, NCOLZ, NFREE, KDEL, JDEL, UNITQ
+      NACTV1 = NACTIV - 1
+      NFREE1 = NFREE
+      IBEGIN = KDEL
+      IF (KDEL .GT. NACTV1) GO TO 400
+C
+C  DELETE A ROW OF  T  AND MOVE THE ONES BELOW IT UP.
+C
+      DO 220 I = KDEL, NACTV1
+         KACTIV(I) = KACTIV(I+1)
+         LENRT     = NROWRT*I + 1
+         LDIAG     = NFREE - I
+         CALL COPYVC( I+1, RT(I+1,LDIAG), LENRT, NROWRT,
+     *                       RT(I,LDIAG), LENRT, NROWRT )
+  220 CONTINUE
+C
+C  ------------------------------------------------------------------
+C  ELIMINATE THE SUPER-DIAGONAL ELEMENTS OF  T,
+C  USING A BACKWARD SWEEP OF 2*2 TRANFORMATIONS.
+C  ------------------------------------------------------------------
+  400 IF (IBEGIN .GT. NACTV1) GO TO 800
+      K = NFREE1 - IBEGIN
+      L = NACTV1 - IBEGIN
+C
+      DO 420 I = IBEGIN, NACTV1
+         CALL ELMGEN( ORTHOG, RT(I,K+1), RT(I,K), CS, SN )
+         IF (L .GT. 0)
+     *   CALL ELM   ( ORTHOG, L, RT(I+1,K+1), L, 1,
+     *                           RT(I+1,K  ), L, 1, CS, SN )
+         IF (NACTV1 .GT. 0)
+     *   CALL ELM   ( ORTHOG, NFREE1, ZY(1,K+1), NQ, 1,
+     *                                ZY(1,K  ), NQ, 1, CS, SN )
+         IF (MODFYG)
+     *   CALL ELM   ( ORTHOG, 1, QTG(K+1), 1, 1, QTG(K), 1, 1, CS, SN )
+         K = K - 1
+         L = L - 1
+  420 CONTINUE
+C
+C  ------------------------------------------------------------------
+C  COMPRESS THE ELEMENTS OF  KACTIV  CORRESPONDING TO FIXED VARIABLES.
+C  ------------------------------------------------------------------
+  800 NFIXD1 = N - NFREE1
+      KB     = NACTV1 + 1
+      IF (NFIXD1 .EQ. 0) GO TO 900
+      DO 810 K = 1, NFIXD1
+         KACTIV(KB) = KACTIV(KB+1)
+         KB         = KB + 1
+  810 CONTINUE
+C
+C  ------------------------------------------------------------------
+C  ESTIMATE THE CONDITION NUMBER OF  T.
+C  ------------------------------------------------------------------
+  900 NCOLZ1 = NCOLZ + 1
+      LENRT  = NROWRT*(NACTV1 - 1) + 1
+      INCT   = NROWRT - 1
+      IF (NACTV1 .GT. 0)
+     *   CALL CONDVC( NACTV1, RT(NACTV1,NCOLZ1+1), LENRT, INCT,
+     *                DTMAX, DTMIN )
+C
+      RETURN
+C
+ 1010 FORMAT(/ 34H //DELCON//  SIMPLE BOUND DELETED.
+     *       / 49H //DELCON//  NACTIV NCOLZ NFREE IFREED JDEL UNITQ
+     *       / 13H //DELCON//  , 3I6, I7, I5, L6 )
+ 1020 FORMAT(/ 40H //DELCON//  GENERAL CONSTRAINT DELETED.
+     *       / 49H //DELCON//  NACTIV NCOLZ NFREE  KDEL  JDEL UNITQ
+     *       / 13H //DELCON//  , 5I6, L6 )
+C
+C  END OF DELCON
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/dot.f
@@ -0,0 +1,56 @@
+      DOUBLE PRECISION FUNCTION DOT( N, X, LENX, INCX, Y, LENY, INCY )
+C
+      INTEGER            N, LENX, INCX, LENY, INCY
+      DOUBLE PRECISION   X(LENX), Y(LENY)
+C
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+C
+C  DOT  RETURNS THE INNER PRODUCT OF X AND Y.
+C  VERSION OF FEBRUARY 1981.  SIMPLE CASE ADDED MARCH 1983.
+C
+      INTEGER            I, IX, IY, NINCX
+      DOUBLE PRECISION   ABSXI, FLMIN, ONE, UNDFLW, ZERO
+      DOUBLE PRECISION   DABS
+      DATA               ZERO, ONE/0.0D+0, 1.0D+0/
+C
+      DOT = ZERO
+      IF (N .LT. 1) RETURN
+      IX = 1
+      IY = 1
+      UNDFLW = WMACH(9)
+      IF (UNDFLW .GT. ZERO) GO TO 110
+C
+C  NO UNDERFLOW TEST REQUIRED.
+C  DO THE MOST COMMON CASE SPECIALLY (INCX = INCY).
+C
+      IF (INCX .NE. INCY) GO TO 50
+      NINCX  = N * INCX
+      DO 40 I = 1, NINCX, INCX
+         DOT  = DOT + X(I)*Y(I)
+   40 CONTINUE
+      RETURN
+C
+   50 DO 100 I = 1, N
+         DOT = DOT + X(IX)*Y(IY)
+         IX  = IX + INCX
+         IY  = IY + INCY
+  100 CONTINUE
+      RETURN
+C
+C  GUARD AGAINST UNDERFLOW.
+C
+  110 FLMIN = WMACH(5)
+      DO 140 I = 1, N
+         ABSXI = DABS(X(IX))
+         IF (ABSXI .EQ. ZERO) GO TO 130
+         IF (ABSXI .GE. ONE)  GO TO 120
+         IF (DABS(Y(IY)) .LT. FLMIN/ABSXI) GO TO 130
+  120    DOT = DOT + X(IX)*Y(IY)
+  130    IX  = IX + INCX
+         IY  = IY + INCY
+  140 CONTINUE
+      RETURN
+C
+C  END OF DOT
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/dscale.f
@@ -0,0 +1,22 @@
+      SUBROUTINE DSCALE( N, D, LEND, INCD, X, LENX, INCX )
+C
+      INTEGER            N, LEND, INCD, LENX, INCX
+      DOUBLE PRECISION   D(LEND), X(LENX)
+C
+C  DSCALE  PERFORMS DIAGONAL SCALING ON THE VECTOR  X,
+C  REPLACING  X(I)  BY  D(I)*X(I)  FOR  N  VALUES OF  I.
+C
+      INTEGER            I, ID, IX
+C
+      IF (N .LT. 1) RETURN
+      ID = 1
+      IX = 1
+      DO 100 I = 1, N
+         X(IX) = D(ID)*X(IX)
+         ID    = ID + INCD
+         IX    = IX + INCX
+  100 CONTINUE
+      RETURN
+C
+C  END OF DSCALE
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/elm.f
@@ -0,0 +1,62 @@
+      SUBROUTINE ELM   ( ORTHOG, N, X, LENX, INCX, Y, LENY, INCY,
+     *                   CS, SN )
+C
+      LOGICAL            ORTHOG
+      INTEGER            N, LENX, INCX, LENY, INCY
+      DOUBLE PRECISION   CS, SN
+      DOUBLE PRECISION   X(LENX), Y(LENY)
+C
+C  *********************************************************************
+C  IF  ORTHOG  IS TRUE,  ELM  APPLIES A PLANE ROTATION.  OTHERWISE,
+C  ELM  COMPUTES THE TRANSFORMATION  (X Y)*E  AND RETURNS THE RESULT
+C  IN  (X Y),  WHERE THE 2 BY 2 MATRIX  E  IS DEFINED BY  CS  AND  SN
+C  AS FOLLOWS...
+C
+C     E  =  ( 1  SN )  IF  CS .GT. ZERO,    E  =  (     1 )  OTHERWISE.
+C           (     1 )                             ( 1  SN )
+C
+C  VERSION 1, APRIL 5 1983.
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  *********************************************************************
+C
+      INTEGER            I, IX, IY
+      DOUBLE PRECISION   XI, YI, ZERO
+C
+      IF (ORTHOG) GO TO 800
+      ZERO   = 0.0
+      IF (CS .LE. ZERO) GO TO 200
+      IF (SN .EQ. ZERO) RETURN
+      CALL AXPY  ( N, SN, X, LENX, INCX, Y, LENY, INCY )
+      RETURN
+C
+  200 IX     = 1
+      IY     = 1
+      IF (SN .EQ. ZERO) GO TO 300
+C
+      DO 210 I = 1, N
+         XI    = X(IX)
+         YI    = Y(IY)
+         X(IX) = YI
+         Y(IY) = XI + YI*SN
+         IX    = IX + INCX
+         IY    = IY + INCY
+  210 CONTINUE
+      RETURN
+C
+C  TREAT AN INTERCHANGE SPECIALLY.
+C
+  300 DO 310 I = 1, N
+         XI    = X(IX)
+         X(IX) = Y(IY)
+         Y(IY) = XI
+         IX    = IX + INCX
+         IY    = IY + INCY
+  310 CONTINUE
+      RETURN
+C
+C
+  800 CALL ROT3  ( N, X, LENX, INCX, Y, LENY, INCY, CS, SN )
+      RETURN
+C
+C  END OF ELM
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/elmgen.f
@@ -0,0 +1,40 @@
+      SUBROUTINE ELMGEN( ORTHOG, X, Y, CS, SN )
+C
+      LOGICAL            ORTHOG
+      DOUBLE PRECISION   X, Y, CS, SN
+C
+C  *********************************************************************
+C  IF  ORTHOG  IS TRUE,  ELMGEN  GENERATES A PLANE ROTATION.  OTHERWISE,
+C  ELMGEN  GENERATES AN ELIMINATION TRANSFORMATION  E  SUCH THAT
+C  (X Y)*E  =  (X  0)   OR   (Y  0),  DEPENDING ON THE RELATIVE
+C  SIZES OF  X  AND  Y.
+C
+C  VERSION 1, APRIL 5 1983.
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  *********************************************************************
+C
+      DOUBLE PRECISION   DABS
+      DOUBLE PRECISION   ZERO, ONE
+      DATA               ZERO, ONE /0.0D+0, 1.0D+0/
+C
+      IF (ORTHOG) GO TO 800
+      CS     = ONE
+      SN     = ZERO
+      IF (Y .EQ. ZERO) RETURN
+      IF (DABS(X) .LT. DABS(Y)) GO TO 200
+      SN     = - Y/X
+      GO TO 300
+C
+  200 CS     =   ZERO
+      SN     = - X/Y
+      X      =   Y
+C
+  300 Y      =   ZERO
+      RETURN
+C
+C
+  800 CALL ROTGEN( X, Y, CS, SN )
+      RETURN
+C
+C  END OF ELMGEN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/etagen.f
@@ -0,0 +1,97 @@
+      SUBROUTINE ETAGEN( N, ALPHA, X, LENX, INCX, ISWAP, ITRANS )
+C
+      INTEGER            N, LENX, INCX, ISWAP, ITRANS
+      DOUBLE PRECISION   ALPHA
+      DOUBLE PRECISION   X(LENX)
+C
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+C
+C  *********************************************************************
+C  ETAGEN  GENERATES AN ELIMINATION TRANSFORMATION  E  SUCH THAT
+C
+C     E ( ALPHA )  =  ( DELTA ) ,
+C       (   X   )     (   0   )
+C
+C  WHERE  E  HAS THE FORM
+C
+C     E  = ( 1    ) P
+C          ( Z  I )
+C
+C  FOR SOME N-VECTOR  Z  AND PERMUTATION MATRIX  P  OF ORDER  N + 1.
+C
+C  IN CERTAIN CIRCUMSTANCES ( X  VERY SMALL IN ABSOLUTE TERMS OR
+C  X  VERY SMALL COMPARED TO  ALPHA),  E  WILL BE THE IDENTITY MATRIX.
+C  ETAGEN  WILL THEN LEAVE  ALPHA  AND  X  UNALTERED, AND WILL RETURN
+C  ISWAP = 0,  ITRANS = 0.
+C
+C  MORE GENERALLY,  ISWAP  AND  ITRANS  INDICATE THE VARIOUS POSSIBLE
+C  FORMS OF  P  AND  Z  AS FOLLOWS.
+C
+C  IF  ISWAP  =  0,  P = I.
+C  IF  ISWAP  GT 0,  P  INTERCHANGES  ALPHA  AND  X(ISWAP).
+C
+C  IF  ITRANS =  0,  Z = 0  AND THE TRANSFORMATION IS JUST  E = P.
+C  IF  ITRANS GT 0,  Z  IS NONZERO.  ITS ELEMENTS ARE RETURNED IN  X.
+C
+C  ETAGEN  GUARDS AGAINST OVERFLOW AND UNDERFLOW.
+C  IT IS ASSUMED THAT  FLMIN .LT. EPSMCH**2  (I.E.  RTMIN .LT. EPSMCH).
+C
+C  VERSION 1, MARCH 31 1983.
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  *********************************************************************
+C
+      INTEGER            I, IMAX, NINCX, NZERO
+      DOUBLE PRECISION   ABSALF, EPSMCH, RTMIN, TOL, XMAX, ZERO
+      DOUBLE PRECISION   DABS
+      DATA               ZERO/0.0D+0/
+C
+      ISWAP  = 0
+      ITRANS = 0
+      IF (N .LT. 1) RETURN
+      EPSMCH = WMACH(3)
+      RTMIN  = WMACH(6)
+      ABSALF = DABS(ALPHA)
+      XMAX   = ZERO
+      NINCX  = N * INCX
+C
+      DO 10 I = 1, NINCX, INCX
+         IF (XMAX  .GE.  DABS( X(I) )) GO TO 10
+         XMAX   = DABS( X(I) )
+         IMAX   = I
+   10 CONTINUE
+C
+C  EXIT IF  X  IS VERY SMALL.
+C
+      IF (XMAX .LE. RTMIN) RETURN
+C
+C  SEE IF AN INTERCHANGE IS NEEDED FOR STABILITY.
+C
+      IF (ABSALF .LT. XMAX) ISWAP = IMAX
+      IF (ISWAP  .EQ.    0) GO TO 200
+      XMAX    = X(IMAX)
+      X(IMAX) = ALPHA
+      ALPHA   = XMAX
+C
+C  FORM THE MULTIPLIERS IN  X.  THEY WILL BE NO GREATER THAN ONE
+C  IN MAGNITUDE.  CHANGE NEGLIGIBLE MULTIPLIERS TO ZERO.
+C
+  200 TOL    = DABS( ALPHA ) * EPSMCH
+      NZERO  = 0
+C
+      DO 300 I = 1, NINCX, INCX
+         IF (DABS( X(I) ) .LE. TOL) GO TO 250
+         X(I)  = - X(I) / ALPHA
+         GO TO 300
+C
+  250    X(I)  = ZERO
+         NZERO = NZERO + 1
+  300 CONTINUE
+C
+C  Z  IS ZERO ONLY IF  NZERO = N.
+C
+      IF (NZERO .LT. N) ITRANS = 1
+      RETURN
+C
+C  END OF ETAGEN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/findp.f
@@ -0,0 +1,110 @@
+      SUBROUTINE FINDP ( NULLR, UNITPG, UNITQ,
+     *                   N, NCLIN, NCLIN0, NCTOTL, NQ,
+     *                   NROWA, NROWRT, NCOLRT, NCOLR, NCOLZ, NFREE,
+     *                   ISTATE, KFREE,
+     *                   DINKY, GTP, PNORM, RDLAST, ZTGNRM,
+     *                   A, AP, P, QTG, RT, V, ZY, WORK )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      LOGICAL            NULLR, UNITPG, UNITQ
+      INTEGER            N, NCLIN, NCLIN0, NCTOTL, NQ, NROWA,
+     *                   NROWRT, NCOLRT, NCOLR, NFREE
+      INTEGER            ISTATE(NCTOTL), KFREE(N)
+      DOUBLE PRECISION   DINKY, GTP, PNORM, RDLAST, ZTGNRM
+      DOUBLE PRECISION   A(NROWA,N), AP(NCLIN0), QTG(N), P(N),
+     *                   RT(NROWRT,NCOLRT), V(N), ZY(NQ,NQ)
+      DOUBLE PRECISION   WORK(N)
+C
+      INTEGER            NOUT, MSG, ISTART
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+C
+C  *********************************************************************
+C  FINDP   COMPUTES THE FOLLOWING QUANTITIES FOR  LPCORE,  QPCORE  AND
+C  LCCORE ...
+C
+C  (1) THE SEARCH DIRECTION  P  (AND ITS 2-NORM).
+C  (2) THE VECTOR  V  SUCH THAT  R(T)V = - Z(T)G(FREE).  THIS VECTOR IS
+C      REQUIRED BY  LCCORE  ONLY.
+C  (3) THE VECTOR  AP,  WHERE  A  IS THE MATRIX OF LINEAR CONSTRAINTS.
+C      AND, IF  NULLR  IS FALSE,
+C  (4) THE  (NCOLR)-TH DIAGONAL ELEMENT OF THE CHOLESKY FACTOR OF THE
+C      PROJECTED HESSIAN.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  ORIGINAL VERSION OF DECEMBER 1982. REV. MAY 1983.
+C  *********************************************************************
+C
+      INTEGER            I, J
+      DOUBLE PRECISION   ONE
+      DOUBLE PRECISION   DOT, V2NORM
+      DATA               ONE /1.0D+0/
+C
+      CALL COPYVC( NCOLR,          QTG, NCOLR, 1, P, NCOLR, 1 )
+      CALL SSCALE( NCOLR, (- ONE), P  , NCOLR, 1 )
+      IF (NULLR) GO TO 200
+      RDLAST   = RT(NCOLR,NCOLR)
+C  ***
+C  CORRECTION INSERTED BY MHW, 22 OCT 1985.
+C  THIS ENSURES A NON-ZERO SEARCH DIRECTION.
+C  ***
+      IF (NCOLR .LT. NCOLZ .AND. ZTGNRM .LE. DINKY)  P(NCOLR) = RDLAST
+C
+C  ---------------------------------------------------------------------
+C  SOLVE THE SYSTEM   R(T)R (PZ) = - Z(T)G(FREE).
+C  ---------------------------------------------------------------------
+      IF (UNITPG) GO TO 120
+C
+C  PERFORM THE FORWARD SUBSTITUTION  R(T)V = - Z(T)G(FREE).
+C
+      CALL RSOLVE( 2, NROWRT, NCOLR, RT, P )
+      GO TO 130
+C
+C  THE PROJECTED GRADIENT IS A MULTIPLE OF THE UNIT VECTOR, THE FORWARD
+C  SUBSTITUTION MAY BE AVOIDED.
+C
+  120 IF (ZTGNRM .LE. DINKY) P(NCOLR) = - ONE
+      IF (ZTGNRM .GT. DINKY) P(NCOLR) =   P(NCOLR) / RDLAST
+C
+C  PERFORM THE BACKWARD SUBSTITUTION   R(PZ) = P.
+C
+  130 CALL COPYVC( NCOLR, P, NCOLR, 1, V, NCOLR, 1 )
+      CALL RSOLVE( 1, NROWRT, NCOLR, RT, P )
+C
+C  ---------------------------------------------------------------------
+C  THE VECTOR  (PZ)  HAS BEEN COMPUTED.
+C  ---------------------------------------------------------------------
+C  COMPUTE THE DIRECTIONAL DERIVATIVE  G(T)P = (GZ)(T)(PZ).
+C
+  200 GTP    = DOT( NCOLR, QTG, NCOLR, 1, P, NCOLR, 1 )
+C
+C  ---------------------------------------------------------------------
+C  COMPUTE  P = Z * PZ.
+C  ---------------------------------------------------------------------
+C  NACTIV  AND  KACTIV  ARE NOT USED IN  ZYPROD.  N  AND  KFREE  SERVE
+C  AS ARGUMENTS FOR  NACTIV  AND  KACTIV.
+C
+      CALL ZYPROD( 1, N, N, NCOLR, NFREE, NQ, UNITQ,
+     *             KFREE, KFREE, P, ZY, WORK )
+C
+      PNORM = V2NORM( NFREE, WORK, NFREE, 1 )
+      IF (MSG .GE. 80) WRITE (NOUT, 1100) (P(J), J = 1, N)
+C
+C  ---------------------------------------------------------------------
+C  COMPUTE  AP.
+C  ---------------------------------------------------------------------
+      IF (NCLIN .EQ. 0) GO TO 900
+      CALL ZEROVC( NCLIN, AP, NCLIN, 1 )
+      DO 410 J = 1, N
+         IF (ISTATE(J) .GT. 0) GO TO 410
+         CALL AXPY( NCLIN, P(J), A(1,J), NCLIN, 1, AP, NCLIN, 1 )
+  410 CONTINUE
+      IF (MSG .GE. 80  .AND.  NCLIN .GT. 0)
+     *   WRITE (NOUT, 1000) (AP(I), I = 1, NCLIN)
+C
+  900 RETURN
+C
+ 1000 FORMAT(/ 20H //FINDP //  AP ...  / (1P5E15.5))
+ 1100 FORMAT(/ 20H //FINDP //   P ...  / (1P5E15.5))
+C
+C  END OF FINDP
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/getlam.f
@@ -0,0 +1,139 @@
+      SUBROUTINE GETLAM( LPROB, N, NCLIN0, NCTOTL,
+     *                   NACTIV, NCOLZ, NFREE, NROWA,
+     *                   NROWRT, NCOLRT, JSMLST, KSMLST, SMLLST,
+     *                   ISTATE, KACTIV,
+     *                   A, ANORM, QTG, RLAMDA, RT )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      INTEGER            LPROB, N, NCLIN0, NCTOTL, NACTIV, NCOLZ, NFREE,
+     *                   NROWA, NROWRT, NCOLRT, JSMLST, KSMLST
+      INTEGER            ISTATE(NCTOTL), KACTIV(N)
+      DOUBLE PRECISION   SMLLST
+      DOUBLE PRECISION   A(NROWA,N), ANORM(NCLIN0), RLAMDA(N), QTG(N),
+     *                   RT(NROWRT,NCOLRT)
+C
+      INTEGER            NOUT, MSG, ISTART
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+C
+C  *********************************************************************
+C  GETLAM  FIRST COMPUTES THE LAGRANGE MULTIPLIER ESTIMATES FOR THE
+C  GIVEN WORKING SET.  IT THEN DETERMINES THE VALUES AND INDICES OF
+C  CERTAIN SIGNIFICANT MULTIPLIERS.  IN THIS PROCESS, THE MULTIPLIERS
+C  FOR INEQUALITIES AT THEIR UPPER BOUNDS ARE ADJUSTED SO THAT A
+C  NEGATIVE MULTIPLIER FOR AN INEQUALITY CONSTRAINT INDICATES
+C  NON-OPTIMALITY.  IN THE FOLLOWING, THE TERM MINIMUM REFERS TO THE
+C  ORDERING OF NUMBERS ON THE REAL LINE, AND NOT TO THEIR MAGNITUDE.
+C
+C  SMLLST  IS THE MINIMUM AMONG THE INEQUALITY CONSTRAINTS OF THE
+C          (ADJUSTED) MULTIPLIERS SCALED BY THE 2-NORM OF THE
+C          ASSOCIATED CONSTRAINT ROW.
+C
+C  JSMLST  IS THE INDEX OF THE CONSTRAINT CORRESPONDING TO  SMLLST.
+C  KSMLST  MARKS ITS POSITION IN  KACTIV.
+C
+C
+C  ON EXIT,  ELEMENTS  1  THRU  NACTIV  OF  RLAMDA  CONTAIN THE
+C  (UNADJUSTED) MULTIPLIERS FOR THE GENERAL CONSTRAINTS.  ELEMENTS
+C  NACTIV  ONWARDS OF  RLAMDA  CONTAIN THE (UNADJUSTED) MULTIPLIERS FOR
+C  THE SIMPLE BOUNDS.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  ORIGINAL VERSION OCTOBER 1982.
+C  *********************************************************************
+C
+      INTEGER            I, IS, J, JGFXD, K, KA, KB, L, L1, L2,
+     *                   NFIXED, NLAM
+      DOUBLE PRECISION   ANORMJ, BLAM, FLMAX, RLAM
+      DOUBLE PRECISION   ONE
+      DOUBLE PRECISION   DABS
+      DATA               ONE / 1.0D+0 /
+C
+      FLMAX  = WMACH(7)
+C
+C  ---------------------------------------------------------------------
+C  FIRST, COMPUTE THE LAGRANGE MULTIPLIERS FOR THE GENERAL CONSTRAINTS
+C  IN THE WORKING SET, BY SOLVING  T(TRANSPOSE)*RLAMDA = Y(T)*GRAD.
+C  ---------------------------------------------------------------------
+      NFIXED = N      - NFREE
+      NLAM   = NFIXED + NACTIV
+      IF (NACTIV .EQ. 0) GO TO 120
+      CALL COPYVC( NACTIV, QTG(NCOLZ+1), NACTIV, 1, RLAMDA, NACTIV, 1 )
+      CALL TSOLVE( 2, NROWRT, NACTIV, RT(1,NCOLZ+1), RLAMDA )
+C
+C  ---------------------------------------------------------------------
+C  NOW SET ELEMENTS NACTIV, NACTIV+1,... OF RLAMDA EQUAL TO THE
+C  MULTIPLIERS FOR THE BOUND CONSTRAINTS IN THE WORKING SET.
+C  ---------------------------------------------------------------------
+  120 IF (NFIXED .EQ. 0) GO TO 300
+      DO 190 L = 1, NFIXED
+         KB    = NACTIV + L
+         J     = KACTIV(KB)
+         JGFXD = NFREE + L
+         BLAM  = QTG(JGFXD)
+         IF (NACTIV .EQ. 0) GO TO 180
+         DO 170 KA = 1, NACTIV
+            I    = KACTIV(KA)
+            BLAM = BLAM - A(I,J)*RLAMDA(KA)
+  170    CONTINUE
+  180    RLAMDA(KB) = BLAM
+  190 CONTINUE
+C
+C  ---------------------------------------------------------------------
+C  FIND  JSMLST,  KSMLST  AND  SMLLST.
+C  ---------------------------------------------------------------------
+  300 SMLLST =   FLMAX
+      JSMLST =   0
+      KSMLST =   0
+      IF (NLAM .EQ. 0) GO TO 400
+      DO 330 K = 1, NLAM
+         J    = KACTIV(K)
+         IF (K .LE. NACTIV) J = J + N
+C
+         IS   = ISTATE(J)
+         IF (IS .EQ. 3) GO TO 330
+C
+         I      = J - N
+         IF (J .LE. N) ANORMJ = ONE
+         IF (J .GT. N) ANORMJ = ANORM(I)
+C
+         RLAM = RLAMDA(K) * ANORMJ
+C
+C        CHANGE THE SIGN OF THE ESTIMATE IF THE CONSTRAINT IS IN THE
+C        WORKING SET (OR VIOLATED) AT ITS UPPER BOUND.
+C
+         IF (IS .EQ. 2) RLAM = - RLAM
+         IF (IS .EQ. 4) RLAM = - DABS( RLAM )
+C
+C        FIND THE SMALLEST MULTIPLIER FOR THE INEQUALITIES.
+C
+         IF (SMLLST .LE. RLAM) GO TO 330
+         SMLLST = RLAM
+         JSMLST = J
+         KSMLST = K
+  330 CONTINUE
+C
+C  ---------------------------------------------------------------------
+C  IF REQUIRED, PRINT THE MULTIPLIERS.
+C  ---------------------------------------------------------------------
+  400 IF (MSG .LT. 20) GO TO 900
+      IF (NACTIV .GT. 0)
+     *   WRITE (NOUT, 2000) LPROB, (KACTIV(K), RLAMDA(K), K=1,NACTIV)
+      L1 = NACTIV + 1
+      L2 = NLAM
+      IF (L1 .LE. L2)
+     *   WRITE (NOUT, 2100) LPROB, (KACTIV(K), RLAMDA(K), K=L1,L2)
+         IF (MSG .GE. 80) WRITE (NOUT, 2200) JSMLST, SMLLST, KSMLST
+C
+  900 RETURN
+C
+ 2000 FORMAT(/ 21H MULTIPLIERS FOR THE , A2, 15H CONSTRAINTS...
+     *       / 4(I5, 1PE11.2))
+ 2100 FORMAT(/ 21H MULTIPLIERS FOR THE , A2, 21H BOUND CONSTRAINTS...
+     *       / 4(I5, 1PE11.2))
+ 2200 FORMAT(/ 51H //GETLAM//  JSMLST     SMLLST     KSMLST  (SCALED)
+     *       / 13H //GETLAM//  , I6, 1PE11.2, 5X, I6 )
+C
+C  END OF GETLAM
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/lpbgst.f
@@ -0,0 +1,62 @@
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C     FILE LPSUBS66 FORTRAN
+C
+C     LPBGST   LPCORE   LPCRSH   LPDUMP   LPGRAD   LPPRT
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+      SUBROUTINE LPBGST( N, NACTIV, NCTOTL, NFREE, JBIGST, KBIGST,
+     *                   ISTATE, KACTIV,
+     *                   DINKY, FEAMIN, TRULAM, FEATOL, RLAMDA )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      INTEGER            N, NACTIV, NCTOTL, NFREE, JBIGST, KBIGST
+      INTEGER            ISTATE(NCTOTL), KACTIV(N)
+      DOUBLE PRECISION   DINKY, FEAMIN, TRULAM
+      DOUBLE PRECISION   FEATOL(NCTOTL), RLAMDA(N)
+C
+      INTEGER            NOUT, MSG, ISTART
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+C
+C  *********************************************************************
+C  FIND THE BIGGEST SCALED MULTIPLIER LARGER THAN UNITY.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  ORIGINAL VERSION DECEMBER 1982.
+C  *********************************************************************
+C
+      INTEGER            IS, J, K, NFIXED, NLAM
+      DOUBLE PRECISION   BIGGST, RLAM
+      DOUBLE PRECISION   ONE
+      DOUBLE PRECISION   DABS
+      DATA               ONE/1.0D+0/
+C
+      JBIGST = 0
+      NFIXED = N      - NFREE
+      NLAM   = NFIXED + NACTIV
+      IF (NLAM .EQ. 0) GO TO 900
+C
+      BIGGST = ONE + DINKY
+      DO 110 K = 1, NLAM
+         J      = KACTIV(K)
+         IF (K .LE. NACTIV) J = J + N
+         IS     = ISTATE(J)
+         IF (IS .LT. 1) GO TO 110
+         RLAM   = RLAMDA(K)
+         IF (IS .EQ. 2) RLAM =     - RLAM
+         IF (IS .EQ. 3) RLAM = DABS( RLAM )
+         RLAM   = (FEATOL(J)/FEAMIN)*RLAM
+C
+         IF (BIGGST .GE. RLAM) GO TO 110
+         BIGGST = RLAM
+         TRULAM = RLAMDA(K)
+         JBIGST = J
+         KBIGST = K
+  110 CONTINUE
+      IF (MSG .GE. 80) WRITE (NOUT, 9000) JBIGST, BIGGST
+C
+  900 RETURN
+C
+ 9000 FORMAT(/ 33H //LPBGST// JBIGST         BIGGST
+     *       / 13H //LPBGST//  , I5,         G15.4 )
+C
+C  END OF LPBGST
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/lpcore.f
@@ -0,0 +1,496 @@
+      SUBROUTINE LPCORE( LP, MINSUM, NAMED, ORTHOG, UNITQ, VERTEX,
+     *                   INFORM, ITER, ITMAX, LCRASH,
+     *                   N, NCLIN, NCTOTL, NROWA, NACTIV, NFREE, NUMINF,
+     *                   ISTATE, KACTIV, KFREE,
+     *                   OBJ, XNORM,
+     *                   A, AX, BL, BU, CLAMDA, CVEC, FEATOL, X,
+     *                   IW, LIW, W, LW )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      INTEGER            INFORM, ITER, ITMAX, LCRASH, N, NCLIN, NCTOTL,
+     *                   NROWA, NACTIV, NFREE, NUMINF, LIW, LW
+      INTEGER            ISTATE(NCTOTL), KACTIV(N), KFREE(N)
+      INTEGER            IW(LIW)
+      DOUBLE PRECISION   ASIZE, DTMAX, DTMIN, OBJ, XNORM
+      DOUBLE PRECISION   A(NROWA,N), AX(NROWA), BL(NCTOTL), BU(NCTOTL),
+     *                   CLAMDA(NCTOTL), CVEC(N), FEATOL(NCTOTL), X(N)
+      DOUBLE PRECISION   W(LW)
+      LOGICAL            LP, MINSUM, NAMED, ORTHOG, UNITQ, VERTEX
+C
+      INTEGER            NOUT, MSG, ISTART, LENNAM, NROWRT, NCOLRT, NQ
+      DOUBLE PRECISION   WMACH, PARM
+      COMMON    /SOLMCH/ WMACH(15)
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+      COMMON    /SOL3CM/ LENNAM, NROWRT, NCOLRT, NQ
+      COMMON    /SOL4CM/ PARM(10)
+      COMMON    /SOL5CM/ ASIZE, DTMAX, DTMIN
+C
+      INTEGER            LOCLP
+      COMMON    /SOL1LP/ LOCLP(15)
+C
+C  *********************************************************************
+C  LPCORE  FINDS A FEASIBLE POINT FOR THE GENERAL LINEAR CONSTRAINTS
+C  AND BOUNDS. THE SUM OF THE INFEASIBILITIES IS MINIMIZED USING
+C  A LINEAR PROGRAMMING ALGORITHM WHICH MAY PERFORM NON-SIMPLEX
+C  STEPS. AT EACH ITERATION THE DIRECTION OF SEARCH IS DEFINED AS
+C  THE PROJECTION OF THE STEEPEST-DESCENT DIRECTION. THIS
+C  PROJECTION IS COMPUTED USING AN ORTHOGONAL FACTORIZATION OF THE
+C  MATRIX OF CONSTRAINTS IN THE WORKING SET.
+C
+C  IF  LP = .TRUE.,  LPCORE  WILL SOLVE THE LINEAR PROGRAMMING PROBLEM
+C  DEFINED BY THE OBJECTIVE CVEC, THE CONSTRAINT MATRIX  A  AND THE
+C  BOUNDS  BL, BU.
+C
+C  VALUES OF ISTATE(J)....
+C
+C     - 2         - 1         0           1          2         3
+C  A*X LT BL   A*X GT BU   A*X FREE   A*X = BL   A*X = BU   BL = BU
+C
+C  IF  VERTEX = .TRUE.,  THE INITIAL POINT  X  WILL BE MADE INTO A
+C  VERTEX BY REGARDING SOME OF THE FREE VARIABLES  X(J)  AS BEING ON AN
+C  TEMPORARY BOUND.  SOME OF THESE VARIABLES MAY REMAIN ON THEIR
+C  TEMPORARY BOUNDS.  IF SO, THEIR STATE WILL BE  ISTATE(J) = 4 .
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION 1.0. DECEMBER 1981.
+C  VERSION 2.0.     JUNE 1982.
+C  VERSION 3.0.  OCTOBER 1982.
+C  VERSION 3.2.  APRIL   1984.
+C
+C  COPYRIGHT  1982  STANFORD UNIVERSITY.
+C
+C  THIS MATERIAL MAY BE REPRODUCED BY OR FOR THE U.S. GOVERNMENT PURSU-
+C  ANT TO THE COPYRIGHT LICENSE UNDER DAR CLAUSE 7-104.9(A) (1979 MAR).
+C
+C  THIS MATERIAL IS BASED UPON WORK PARTIALLY SUPPORTED BY THE NATIONAL
+C  SCIENCE FOUNDATION UNDER GRANTS MCS-7926009 AND ECS-8012974; THE
+C  DEPARTMENT OF ENERGY CONTRACT AM03-76SF00326, PA NO. DE-AT03-
+C  76ER72018; AND THE ARMY RESEARCH OFFICE CONTRACT DAA29-79-C-0110.
+C
+C  *********************************************************************
+C
+      INTEGER            IADD, IDUMMY, IFIX, IS, ISDEL, JADD, JBIGST,
+     *                   JDEL, JSMLST, KB, KBIGST, KDEL, KGFIX, KSMLST,
+     *                   LANORM, LAP, LNAMES, LPROB, LPX, LQTG, LRLAM,
+     *                   LROWA, LRT, LWRK, LZY, MSGLVL, MSTALL, NCLIN0,
+     *                   NCNLN, NCOLZ, NDEL, NFIXED, NROWJ, NSTALL
+      INTEGER            MAX0
+      DOUBLE PRECISION   ALFA, ANORM, ATPHIT, BIGALF, BIGBND, BIGDX,
+     *                   BND, CONDMX, CONDT, CSLAST, DINKY, EPSMCH,
+     *                   EPSPT9, FEAMAX, FEAMIN, FLMAX, GFNORM, GTP,
+     *                   OBJLP, OBJSIZ, PALFA, PNORM, RDLAST, SMLLST,
+     *                   SNLAST, SUMINF, TOLACT, TRULAM, WGFIX, ZTGNRM
+      DOUBLE PRECISION   ZERO, ONE
+      DOUBLE PRECISION   DOT, QUOTNT, V2NORM
+      DOUBLE PRECISION   DABS, DMAX1
+      LOGICAL            ADDED, DELETE, FIRSTV, HITLOW, MODFYG,
+     *                   NULLR, PRNT, STALL, UNITPG
+      DATA               ZERO, ONE /0.0D+0, 1.0D+0/
+      DATA               LPROB     / 2HLP /
+C
+C  SPECIFY MACHINE-DEPENDENT PARAMETERS.
+C
+      EPSMCH = WMACH(3)
+      FLMAX  = WMACH(7)
+C
+      LNAMES = LOCLP( 1)
+      LANORM = LOCLP( 4)
+      LAP    = LOCLP( 5)
+      LPX    = LOCLP( 6)
+      LQTG   = LOCLP( 7)
+      LRLAM  = LOCLP( 8)
+      LRT    = LOCLP( 9)
+      LZY    = LOCLP(10)
+      LWRK   = LOCLP(11)
+C
+C  INITIALIZE
+C
+      NCNLN  = 0
+      NCLIN0 = MAX0( NCLIN, 1 )
+      NROWJ  = 1
+C
+      INFORM = 0
+      ITER   = 0
+      JADD   = 0
+      JDEL   = 0
+      LROWA  = NROWA*(N - 1) + 1
+      NDEL   = 0
+      NSTALL = 0
+      NUMINF = 1
+C
+      MSGLVL = MSG
+      MSG    = 0
+      IF (ITER .GE. ISTART) MSG = MSGLVL
+C
+      BIGBND = PARM(1)
+      BIGDX  = PARM(2)
+      TOLACT = PARM(3)
+      EPSPT9 = PARM(4)
+C
+      ALFA   = ZERO
+      CONDMX = FLMAX
+      OBJLP  = ZERO
+C
+      ADDED  = .TRUE.
+      FIRSTV = .FALSE.
+      MODFYG = .TRUE.
+      NULLR  = .TRUE.
+      UNITPG = .FALSE.
+C
+      CALL CONDVC( NCTOTL, FEATOL, NCTOTL, 1, FEAMAX, FEAMIN )
+C
+C  ---------------------------------------------------------------------
+C  GIVEN AN INITIAL POINT  X, COMPUTE THE FOLLOWING.....
+C  (1) THE INITIAL WORKING SET.
+C  (2) THE  TQ  FACTORIZATION OF THE MATRIX OF CONSTRAINTS IN THE
+C      WORKING SET.
+C  (3) THE VALUE AND GRADIENT OF THE SUM OF INFEASIBILITIES AT THE POINT
+C      X.  IF  X  IS FEASIBLE AND THE SOLUTION OF AN LP IS REQUIRED, THE
+C      LINEAR OBJECTIVE FUNCTION AND GRADIENT IS COMPUTED.
+C
+C  THE ARRAY  RLAMDA  IS USED AS TEMPORARY WORK SPACE.
+C  ---------------------------------------------------------------------
+      CALL LPCRSH( ORTHOG, UNITQ, VERTEX, LCRASH, N, NCLIN, NCLIN0,
+     *             NCTOTL, NQ, NROWA, NROWRT, NCOLRT, NACTIV,
+     *             NCOLZ, NFREE, ISTATE, KACTIV, KFREE,
+     *             BIGBND, TOLACT, XNORM,
+     *             A, W(LANORM), AX, BL, BU, X,
+     *             W(LQTG), W(LRT), W(LZY), W(LPX), W(LWRK), W(LRLAM) )
+C
+      CALL LPGRAD( LP, N, NCTOTL, NROWA,
+     *             BIGBND, FEAMIN, NUMINF, SUMINF, ISTATE,
+     *             A, BL, BU, CVEC, FEATOL, W(LQTG), X )
+C
+      CALL ZYPROD( 6, N, NACTIV, NCOLZ, NFREE, NQ, UNITQ,
+     *             KACTIV, KFREE, W(LQTG), W(LZY), W(LWRK) )
+C
+      OBJ    = SUMINF
+      IF (LP) OBJLP = DOT( N, CVEC, N, 1, X, N, 1 )
+      IF (LP  .AND.  NUMINF .EQ. 0) OBJ = OBJLP
+C
+      IF (NUMINF .EQ. 0  .AND.  .NOT. LP) GO TO 900
+C
+C  .......................START OF THE MAIN LOOP........................
+C
+C  DEFINE SMALL QUANTITIES THAT REFLECT THE MAGNITUDE OF  C,  X,
+C  AND THE NORM OF THE CONSTRAINTS IN THE WORKING SET.
+C
+  100 OBJSIZ = (ONE    + DABS( OBJ )) / (ONE    + XNORM)
+      IF (NUMINF .EQ. 0)
+     *OBJSIZ = (EPSMCH + DABS( OBJ )) / (EPSMCH + XNORM)
+      ANORM  = ZERO
+      IF (NACTIV .GT. 0) ANORM = DABS( DTMAX )
+      DINKY  = EPSPT9 * DMAX1( ANORM, OBJSIZ )
+C
+C  COMPUTE THE NORMS OF THE PROJECTED GRADIENT AND THE GRADIENT WITH
+C  RESPECT TO THE FREE VARIABLES.
+C
+      ZTGNRM = ZERO
+      IF (NCOLZ .GT. 0) ZTGNRM = V2NORM( NCOLZ, W(LQTG), NCOLZ, 1 )
+      GFNORM = ZTGNRM
+      IF (NFREE .GT. 0  .AND.  NACTIV .GT. 0)
+     *                  GFNORM = V2NORM( NFREE, W(LQTG), NFREE, 1 )
+C
+      IF (MSG .GE. 80) WRITE (NOUT, 1100) ZTGNRM, DINKY
+      DELETE = ZTGNRM .LE. DINKY
+C
+C  PRINT THE DETAILS OF THIS ITERATION.
+C
+      PRNT   = ADDED  .OR.  NDEL .GT. 1
+      IF (.NOT. PRNT) GO TO 120
+C
+      CONDT  = QUOTNT( DTMAX, DTMIN )
+C
+      CALL LPPRT ( LP, NROWA, NROWRT, NCOLRT, N, NCLIN, NCLIN0, NCTOTL,
+     *             NFREE, ISDEL, NACTIV, NCOLZ, ITER, JADD, JDEL,
+     *             ALFA, CONDT, NUMINF, SUMINF, OBJLP,
+     *             ISTATE, KFREE,
+     *             A, W(LRT), X, W(LWRK), W(LAP) )
+C
+      ADDED  = .FALSE.
+      JADD   = 0
+      JDEL   = 0
+C
+  120 IF (NUMINF .EQ. 0  .AND.  .NOT. LP) GO TO 900
+      IF (.NOT. DELETE) GO TO 300
+C
+C  ---------------------------------------------------------------------
+C  THE PROJECTED GRADIENT IS NEGLIGIBLE.
+C  WE HAVE TO DELETE A CONSTRAINT BEFORE A MOVE CAN BE MADE.
+C  ---------------------------------------------------------------------
+      CALL GETLAM( LPROB, N, NCLIN0, NCTOTL,
+     *             NACTIV, NCOLZ, NFREE, NROWA,
+     *             NROWRT, NCOLRT, JSMLST, KSMLST, SMLLST,
+     *             ISTATE, KACTIV,
+     *             A, W(LANORM), W(LQTG), W(LRLAM), W(LRT) )
+C
+C  ---------------------------------------------------------------------
+C  TEST FOR CONVERGENCE.  IF THE LEAST (ADJUSTED) MULTIPLIER IS GREATER
+C  THAN A SMALL NEGATIVE QUANTITY, AN ADEQUATE  LP  SOLUTION HAS BEEN
+C  FOUND.
+C  ---------------------------------------------------------------------
+      IF (SMLLST .GE. ( - DINKY )) JSMLST = 0
+      IF (JSMLST .EQ. 0)               GO TO 200
+      IF (VERTEX  .AND.  NCOLZ .GE. 1) GO TO 200
+C
+C  PREPARE TO DELETE THE CONSTRAINT WITH INDEX  JSMLST.
+C
+      JDEL   = JSMLST
+      KDEL   = KSMLST
+      ISDEL  = ISTATE(JDEL)
+      ISTATE(JDEL) = 0
+      GO TO 220
+C
+C  ---------------------------------------------------------------------
+C  IF STILL INFEASIBLE, WE CAN REDUCE THE SUM OF INFEASIBILITIES
+C  IF THERE IS A MULTIPLIER GREATER THAN ONE.
+C  ---------------------------------------------------------------------
+C  INSTEAD OF LOOKING FOR THE LAST VIOLATED CONSTRAINT IN BNDALF,
+C  WE MUST NOW LOOK FOR THE FIRST VIOLATED CONSTRAINT ALONG  P.
+C  THIS WILL ENSURE THAT THE WEIGHTED SUM OF INFEASIBILITIES DECREASES.
+C
+  200 IF (NUMINF .EQ. 0  .OR.  .NOT. MINSUM) GO TO 800
+C
+C  FIND THE BIGGEST MULTIPLIER LARGER THAN UNITY.
+C  FOR THE PURPOSES OF THE TEST,  THE  J-TH  MULTIPLIER IS SCALED
+C  BY  FEATOL(J)/FEAMIN.  THIS FORCES CONSTRAINTS WITH LARGER  FEATOL
+C  VALUES TO BE DELETED FIRST.
+C
+      CALL LPBGST( N, NACTIV, NCTOTL, NFREE, JBIGST, KBIGST,
+     *             ISTATE, KACTIV,
+     *             DINKY, FEAMIN, TRULAM, FEATOL, W(LRLAM) )
+C
+      IF (JBIGST .EQ. 0) GO TO 800
+      JDEL   = JBIGST
+      KDEL   = KBIGST
+      ISDEL  = ISTATE(JBIGST)
+      IF (TRULAM .LE. ZERO) IS = - 1
+      IF (TRULAM .GT. ZERO) IS = - 2
+      ISTATE(JBIGST) = IS
+      FIRSTV = .TRUE.
+C
+C  ---------------------------------------------------------------------
+C  UPDATE THE  TQ  FACTORIZATION OF THE MATRIX OF CONSTRAINTS IN THE
+C  WORKING SET.
+C  ---------------------------------------------------------------------
+  220 NDEL   = NDEL + 1
+      CALL DELCON( MODFYG, ORTHOG, UNITQ,
+     *             JDEL, KDEL, NACTIV, NCOLZ, NFREE,
+     *             N, NQ, NROWA, NROWRT, NCOLRT,
+     *             KACTIV, KFREE,
+     *             A, W(LQTG), W(LRT), W(LZY) )
+C
+      NCOLZ  = NCOLZ + 1
+      IF (JDEL .LE. N) NFREE  = NFREE  + 1
+      IF (JDEL .GT. N) NACTIV = NACTIV - 1
+      GO TO 100
+C
+C  ---------------------------------------------------------------------
+C  COMPUTE THE SEARCH DIRECTION,  P = - Z*(PROJECTED GRADIENT).
+C  ---------------------------------------------------------------------
+  300 IF (ITER .GE. ITMAX) GO TO 940
+      ITER   = ITER + 1
+      IF (ITER .GE. ISTART) MSG = MSGLVL
+C
+      CALL FINDP ( NULLR, UNITPG, UNITQ,
+     *             N, NCLIN, NCLIN0, NCTOTL, NQ,
+     *             NROWA, NROWRT, NCOLRT, NCOLZ, NCOLZ, NFREE,
+     *             ISTATE, KFREE,
+     *             DINKY, GTP, PNORM, RDLAST, ZTGNRM,
+     *             A, W(LAP), W(LPX), W(LQTG), W(LRT), W(LWRK),
+     *             W(LZY), W(LWRK) )
+C
+C  ---------------------------------------------------------------------
+C  FIND THE CONSTRAINT WE BUMP INTO ALONG  P.
+C  UPDATE  X  AND  AX  IF THE STEP  ALFA  IS NONZERO.
+C  ---------------------------------------------------------------------
+C
+C  ALFA  IS INITIALIZED TO  BIGALF.  IF IT REMAINS THAT WAY AFTER
+C  THE CALL TO BNDALF, IT WILL BE REGARDED AS INFINITE.
+C
+      BIGALF = QUOTNT( BIGDX, PNORM )
+C
+      CALL BNDALF( FIRSTV, HITLOW, ISTATE, INFORM, JADD,
+     *             N, NROWA, NCLIN, NCLIN0, NCTOTL, NUMINF,
+     *             ALFA, PALFA, ATPHIT, BIGALF, BIGBND, PNORM,
+     *             W(LANORM), W(LAP), AX, BL, BU, FEATOL, W(LPX), X )
+C
+      IF (INFORM .NE. 0  .OR.  JADD .EQ. 0) GO TO 820
+C
+C  TEST IF  ALFA*PNORM  IS NEGLIGIBLE.
+C
+      STALL  = DABS( ALFA*PNORM ) .LE. EPSPT9*XNORM
+      IF (.NOT. STALL) GO TO 410
+C
+C  TAKE A ZERO STEP.
+C  IF A NON-ORTHOGONAL  TQ  FACTORIZATION IS BEING RECURRED AND  X  IS
+C  NOT YET FEASIBLE,  THE GRADIENT OF THE SUM OF INFEASIBILITIES MUST BE
+C  RECOMPUTED.
+C
+      ALFA   = ZERO
+      NSTALL = NSTALL + 1
+      MSTALL = 50
+      IF (NSTALL .LE. MSTALL  .AND.        ORTHOG) GO TO 500
+      IF (NSTALL .LE. MSTALL  .AND.  .NOT. ORTHOG) GO TO 420
+      GO TO 930
+C
+C  CHANGE  X  TO  X + ALFA*P.  UPDATE  AX  ALSO.
+C
+  410 NSTALL = 0
+C
+      CALL AXPY  ( N    , ALFA, W(LPX), N    , 1, X , N    , 1 )
+      IF (NCLIN .GT. 0)
+     *CALL AXPY  ( NCLIN, ALFA, W(LAP), NCLIN, 1, AX, NCLIN, 1 )
+C
+      XNORM  = V2NORM( N, X, N, 1 )
+C
+      IF (LP) OBJLP = DOT( N, CVEC, N, 1, X, N, 1 )
+C
+C  IF  X  IS NOT YET FEASIBLE,  COMPUTE  OBJ  AND  GRAD  AS THE VALUE
+C  AND GRADIENT OF THE SUM OF INFEASIBILITIES (IF  X  IS FEASIBLE, THE
+C  VECTOR  QTG  IS UPDATED AND  GRAD  NEED NOT BE COMPUTED).
+C
+  420 IF (NUMINF .EQ. 0) GO TO 500
+C
+      CALL LPGRAD( LP, N, NCTOTL, NROWA,
+     *             BIGBND, FEAMIN, NUMINF, SUMINF,
+     *             ISTATE, A, BL, BU, CVEC, FEATOL, W(LQTG), X )
+C
+      KGFIX = LQTG + JADD - 1
+      IF (.NOT. ORTHOG .AND. JADD .LE. N)  WGFIX = W(KGFIX)
+C
+      CALL ZYPROD( 6, N, NACTIV, NCOLZ, NFREE, NQ, UNITQ,
+     *             KACTIV, KFREE, W(LQTG), W(LZY), W(LWRK) )
+C
+      OBJ    = SUMINF
+C
+C  ---------------------------------------------------------------------
+C  ADD A CONSTRAINT TO THE WORKING SET.
+C  ---------------------------------------------------------------------
+C  UPDATE  ISTATE.
+C
+  500 IF (LP  .AND.  NUMINF .EQ. 0) OBJ = OBJLP
+      IF (      HITLOW)           ISTATE(JADD) = 1
+      IF (.NOT. HITLOW)           ISTATE(JADD) = 2
+      IF (BL(JADD) .EQ. BU(JADD)) ISTATE(JADD) = 3
+C
+C  IF A BOUND IS TO BE ADDED, MOVE  X  EXACTLY ONTO IT, EXCEPT WHEN
+C  A NEGATIVE STEP WAS TAKEN.  (BNDALF  MAY HAVE HAD TO MOVE TO SOME
+C  OTHER CLOSER CONSTRAINT.)
+C
+      IADD = JADD - N
+      IF (JADD .GT. N) GO TO 520
+      IF (      HITLOW) BND = BL(JADD)
+      IF (.NOT. HITLOW) BND = BU(JADD)
+      IF (ALFA .GE. ZERO) X(JADD) = BND
+C
+      DO 510 IFIX = 1, NFREE
+         IF (KFREE(IFIX) .EQ. JADD) GO TO 520
+  510 CONTINUE
+C
+C  UPDATE THE  TQ  FACTORS OF THE MATRIX OF CONSTRAINTS IN THE WORKING
+C  SET.  USE THE ARRAY  P  AS WORK SPACE.
+C
+  520 ADDED  = .TRUE.
+      NDEL   = 0
+      CALL ADDCON( MODFYG, .FALSE., ORTHOG, UNITQ, INFORM,
+     *             IFIX, IADD, JADD, NACTIV, NCOLZ, NCOLZ, NFREE,
+     *             N, NQ, NROWA, NROWRT, NCOLRT, KFREE,
+     *             CONDMX, CSLAST, SNLAST,
+     *             A, W(LQTG), W(LRT), W(LZY), W(LWRK), W(LPX) )
+C
+      NCOLZ  = NCOLZ - 1
+      NFIXED = N - NFREE
+      IF (NFIXED .EQ. 0) GO TO 540
+      KB     = NACTIV + NFIXED
+      DO 530 IDUMMY = 1, NFIXED
+         KACTIV(KB+1) = KACTIV(KB)
+         KB           = KB - 1
+  530 CONTINUE
+  540 IF (JADD .GT. N) GO TO 550
+C
+C  ADD A BOUND.  IF STABILIZED ELIMINATIONS ARE BEING USED TO UPDATE
+C  THE  TQ  FACTORIZATION,  RECOMPUTE THE COMPONENT OF THE GRADIENT
+C  CORRESPONDING TO THE NEWLY FIXED VARIABLE.
+C
+      NFREE  = NFREE  - 1
+      KACTIV(NACTIV+1) = JADD
+      IF (ORTHOG) GO TO 100
+C
+      KGFIX    = LQTG + NFREE
+      IF (LP  .AND.  NUMINF .EQ. 0)  W(KGFIX) = CVEC(JADD)
+      IF (           NUMINF .GT. 0)  W(KGFIX) = WGFIX
+      GO TO 100
+C
+C  ADD A GENERAL LINEAR CONSTRAINT.
+C
+  550 NACTIV = NACTIV + 1
+      KACTIV(NACTIV)   = IADD
+      GO TO 100
+C
+C  .........................END OF MAIN LOOP............................
+C
+C
+C  NO CONSTRAINTS TO DROP.
+C
+  800 IF (NUMINF .GT. 0) GO TO 910
+      GO TO 900
+C
+C  ERROR IN  BNDALF  --  PROBABLY UNBOUNDED LP.
+C
+  820 IF (NUMINF .EQ. 0) GO TO 920
+      GO TO 910
+C
+C  FEASIBLE SOLUTION FOUND, OR OPTIMAL LP SOLUTION.
+C
+  900 INFORM = 0
+      GO TO 950
+C
+C  THE LINEAR CONSTRAINTS AND BOUNDS APPEAR TO BE INFEASIBLE.
+C
+  910 INFORM = 1
+      GO TO 950
+C
+C  UNBOUNDED LP.
+C
+  920 INFORM = 2
+      GO TO 950
+C
+C  TOO MANY ITERATIONS WITHOUT CHANGING  X.
+C
+  930 INFORM = 3
+      GO TO 950
+C
+C  TOO MANY ITERATIONS.
+C
+  940 INFORM = 4
+C
+C  ---------------------------------------------------------------------
+C  PRINT FULL SOLUTION.  IF NECESSARY, RECOMPUTE THE MULTIPLIERS.
+C  ---------------------------------------------------------------------
+  950 MSG    = MSGLVL
+      IF (MSG .GE. 1) WRITE (NOUT, 2000) INFORM, ITER
+C
+      IF (INFORM .GT. 0)
+     *CALL GETLAM( LPROB, N, NCLIN0, NCTOTL,
+     *             NACTIV, NCOLZ, NFREE, NROWA,
+     *             NROWRT, NCOLRT, JSMLST, KSMLST, SMLLST,
+     *             ISTATE, KACTIV,
+     *             A, W(LANORM), W(LQTG), W(LRLAM), W(LRT) )
+      IF (.NOT. LP  .AND.  INFORM .EQ. 0)
+     *             CALL ZEROVC( N, W(LRLAM), N, 1 )
+C
+      CALL PRTSOL( NFREE, NROWA, NROWJ,
+     *             N, NCLIN, NCNLN, NCTOTL, BIGBND,
+     *             NAMED, IW(LNAMES), LENNAM,
+     *             NACTIV, ISTATE, KACTIV,
+     *             A, BL, BU, X, CLAMDA, W(LRLAM), X )
+C
+      RETURN
+C
+ 1100 FORMAT(/ 34H //LPCORE//      ZTGNRM      DINKY
+     *       / 11H //LPCORE//, 1P2E11.2 )
+ 2000 FORMAT(/ 26H EXIT LP PHASE.   INFORM =, I3, 9H   ITER =, I4)
+C
+C  END OF LPCORE
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/lpcrsh.f
@@ -0,0 +1,374 @@
+      SUBROUTINE LPCRSH( ORTHOG, UNITQ, VERTEX, LCRASH, N, NCLIN,NCLIN0,
+     *                   NCTOTL, NQ, NROWA, NROWRT, NCOLRT, NACTIV,
+     *                   NCOLZ, NFREE, ISTATE, KACTIV, KFREE,
+     *                   BIGBND, TOLACT, XNORM,
+     *                   A, ANORM, AX, BL, BU, X,
+     *                   QTG, RT, ZY, P, WRK1, WRK2 )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      INTEGER            LCRASH, N, NCLIN, NCLIN0, NCTOTL, NQ, NROWA,
+     *                   NROWRT, NCOLRT, NACTIV, NCOLZ, NFREE
+      INTEGER            ISTATE(NCTOTL), KACTIV(N), KFREE(N)
+      DOUBLE PRECISION   ASIZE, DTMAX, DTMIN, BIGBND, TOLACT, XNORM
+      DOUBLE PRECISION   A(NROWA,N), ANORM(NCLIN0), AX(NROWA),
+     *                   BL(NCTOTL), BU(NCTOTL), QTG(N),
+     *                   RT(NROWRT,NCOLRT), ZY(NQ,NQ), P(N), X(N)
+      DOUBLE PRECISION   WRK1(N), WRK2(N)
+      LOGICAL            ORTHOG, UNITQ, VERTEX
+C
+      INTEGER            NOUT, MSG, ISTART
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+      COMMON    /SOL5CM/ ASIZE, DTMAX, DTMIN
+C
+C  *********************************************************************
+C  LPCRSH  COMPUTES DETAILS ASSOCIATED WITH THE WORKING SET AT A POINT
+C  X.  THE COMPUTATION DEPENDS UPON THE VALUE OF THE INPUT PARAMETER
+C  LCRASH.   AS  FOLLOWS ...
+C
+C  LCRASH = 0  MEANS THAT  LPCRSH  SHOULD FIND (1) AN INITIAL WORKING
+C              SET, (2) THE  TQ  FACTORS OF THE CONSTRAINT COEFFICIENTS
+C              FOR THE WORKING SET, AND (3) THE POINT CLOSEST TO  X
+C              THAT LIES ON THE WORKING SET.
+C  LCRASH = 1  MEANS THAT  LPCRSH  SHOULD COMPUTE (1) THE  TQ  FACTORS
+C              OF A WORKING SET SPECIFIED BY THE INTEGER ARRAY  ISTATE,
+C              AND (2) THE POINT CLOSEST TO  X  THAT SATISFIES THE
+C              WORKING SET.
+C  LCRASH = 2  MEANS THAT  LPCRSH  ESSENTIALLY DOES NOTHING BUT COMPUTE
+C              AUXILIARY INFORMATION ABOUT THE POINT  X  THAT LIES ON
+C              THE CONSTRAINTS IN THE GIVEN WORKING SET.
+C
+C  VALUES OF ISTATE(J)....
+C
+C     - 2         - 1         0           1          2         3
+C  A*X LT BL   A*X GT BU   A*X FREE   A*X = BL   A*X = BU   BL = BU
+C
+C     ISTATE(J) = 4  MEANS THAT X(J) IS ON A TEMPORARY BOUND.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION OF JANUARY 1982.  REV. NOV. 1982.  APR. 1984.
+C  *********************************************************************
+C
+      INTEGER            I, IADD, IDUMMY, IFIX, IMIN, INFORM, IS, J,
+     *                   JADD, JMIN, K, KB, LENQ, LROWA, NACT1, NARTIF,
+     *                   NCOLZ1, NFIXED
+      DOUBLE PRECISION   AMIN, BND, B1, B2, COLMIN, COLSIZ, CONDMX,
+     *                   CSLAST, FLMAX, RES, RESL, RESMIN, RESU, RNORM,
+     *                   ROWMAX, RTEPS, SNLAST, TOOBIG
+      DOUBLE PRECISION   ZERO, ONE
+      DOUBLE PRECISION   DOT, V2NORM
+      DOUBLE PRECISION   DABS, DMIN1
+      LOGICAL            NOLOW, NOUPP
+      DATA               ZERO  , ONE
+     *                  /0.0D+0, 1.0D+0/
+C
+      RTEPS  = WMACH(4)
+      FLMAX  = WMACH(7)
+C
+      LROWA  = NROWA*(N - 1) + 1
+C
+C  SET THE MAXIMUM ALLOWABLE CONDITION ESTIMATOR OF THE CONSTRAINTS
+C  IN THE WORKING SET.  NOTE THAT THE CONSERVATIVE VALUE USED IN  LPCRSH
+C  IS SMALLER THAN THAT USED WHEN A CONSTRAINT IS ADDED TO THE WORKING
+C  SET DURING A TYPICAL ITERATION.
+C
+      CONDMX = ONE/RTEPS
+C
+      IF (MSG .GE. 80) WRITE (NOUT, 1210) LCRASH, NCLIN, NCTOTL
+      IF (MSG .GE. 80) WRITE (NOUT, 1010) (X(J), J = 1, N)
+      NFIXED = 0
+      NACTIV = 0
+      NARTIF = 0
+C
+C  IF A COLD START IS BEING MADE, INITIALIZE  ISTATE.
+C  IF  BL(J) = BU(J),  SET  ISTATE(J)=3  FOR ALL VARIABLES AND LINEAR
+C  CONSTRAINTS.
+C
+      IF (LCRASH .GT. 0) GO TO 140
+      DO  130 J = 1, NCTOTL
+         ISTATE(J) = 0
+         IF (BL(J) .EQ. BU(J)) ISTATE(J) = 3
+  130 CONTINUE
+C
+C  INITIALIZE  NFIXED,  NACTIV  AND  KACTIV.
+C  ENSURE THAT THE NUMBER OF BOUNDS AND GENERAL CONSTRAINTS IN THE
+C  WORKING SET DOES NOT EXCEED  N.
+C
+  140 DO 200 J = 1, NCTOTL
+         IF (NFIXED + NACTIV .EQ. N) ISTATE(J) = 0
+         IF (ISTATE(J) .LE. 0) GO TO 200
+         IF (J .GT. N) GO TO 160
+         NFIXED = NFIXED + 1
+         IF (ISTATE(J) .EQ. 1) X(J) = BL(J)
+         IF (ISTATE(J) .GE. 2) X(J) = BU(J)
+         GO TO 200
+  160    NACTIV = NACTIV + 1
+         IF (LCRASH .LT. 2) KACTIV(NACTIV) = J - N
+  200 CONTINUE
+C
+      NFREE  = N      - NFIXED
+      NCOLZ  = NFREE  - NACTIV
+C
+C  IF A HOT START IS REQUIRED, THE  TQ  FACTORIZATION IS ALREADY KNOWN.
+C
+      IF (LCRASH .GT. 1) GO TO 700
+      DTMAX  = ONE
+      DTMIN  = ONE
+      UNITQ  = .TRUE.
+C
+C  COMPUTE THE 2-NORMS OF THE CONSTRAINT ROWS.
+C
+      ASIZE  = ONE
+      IF (NCLIN .EQ. 0) GO TO 215
+      DO 210 J = 1, NCLIN
+         ANORM(J) = V2NORM( N, A(J,1), LROWA, NROWA )
+  210 CONTINUE
+      CALL CONDVC( NCLIN, ANORM, NCLIN, 1, ASIZE, AMIN )
+C
+  215 IF (LCRASH .GT. 0) GO TO 400
+C
+C  ---------------------------------------------------------------------
+C  IF A COLD START IS REQUIRED, AN ATTEMPT IS MADE TO ADD AS MANY
+C  CONSTRAINTS AS POSSIBLE TO THE WORKING SET.
+C  ---------------------------------------------------------------------
+      IF (NFIXED + NACTIV .EQ. N) GO TO 500
+C
+C  SEE IF ANY VARIABLES ARE OUTSIDE THEIR BOUNDS.
+C
+      DO 250 J = 1, N
+         IF (ISTATE(J) .NE. 0) GO TO 250
+         B1     = BL(J)
+         B2     = BU(J)
+         NOLOW  = B1 .LE. (- BIGBND)
+         NOUPP  = B2 .GE.    BIGBND
+         IS     = 0
+         IF (NOLOW) GO TO 220
+         IF (X(J) - B1 .LE. (ONE + DABS( B1 ))*TOLACT) IS = 1
+  220    IF (NOUPP) GO TO 240
+         IF (B2 - X(J) .LE. (ONE + DABS( B2 ))*TOLACT) IS = 2
+  240    IF (IS .EQ. 0) GO TO 250
+C
+C        SET VARIABLE EQUAL TO ITS BOUND.
+C
+         ISTATE(J) = IS
+         IF (IS .EQ. 1) X(J) = B1
+         IF (IS .EQ. 2) X(J) = B2
+         NFIXED = NFIXED + 1
+         IF (NFIXED + NACTIV .EQ. N) GO TO 500
+  250 CONTINUE
+C
+C  ---------------------------------------------------------------------
+C  THE FOLLOWING LOOP FINDS THE LINEAR CONSTRAINT THAT IS CLOSEST
+C  TO BEING SATISFIED.  IF IT IS SUFFICIENTLY CLOSE, IT WILL BE ADDED
+C  TO THE WORKING SET AND THE PROCESS WILL BE REPEATED.
+C  ---------------------------------------------------------------------
+C  FIRST, COMPUTE  AX  FOR INEQUALITY LINEAR CONSTRAINTS.
+C
+      IF (NCLIN .EQ. 0) GO TO 400
+      DO 280 I = 1, NCLIN
+         J     = N + I
+         IF (ISTATE(J) .GT. 0) GO TO 280
+         AX(I) = DOT(N, A(I,1), LROWA, NROWA, X, N, 1 )
+  280 CONTINUE
+C
+         TOOBIG = TOLACT + TOLACT
+C
+      DO 350 IDUMMY = 1, N
+         RESMIN = TOOBIG
+         IS     = 0
+C
+         DO 340 I = 1, NCLIN
+            J      = N + I
+            IF (ISTATE(J) .GT. 0) GO TO 340
+            B1     = BL(J)
+            B2     = BU(J)
+            NOLOW  = B1 .LE. (- BIGBND)
+            NOUPP  = B2 .GE.    BIGBND
+            RESL   = TOOBIG
+            RESU   = TOOBIG
+            IF (NOLOW) GO TO 320
+            RESL   = DABS( AX(I) - B1 ) / (ONE + DABS( B1 ))
+  320       IF (NOUPP) GO TO 330
+            RESU   = DABS( AX(I) - B2 ) / (ONE + DABS( B2 ))
+  330       RES    = DMIN1( RESL, RESU )
+            IF (RES .GE. TOLACT) GO TO 340
+            IF (RES .GE. RESMIN) GO TO 340
+            RESMIN = RES
+            IMIN   = I
+            IS     = 1
+            IF (RESL .GT. RESU) IS = 2
+  340    CONTINUE
+C
+         IF (IS .EQ. 0) GO TO 400
+         NACTIV = NACTIV + 1
+         KACTIV(NACTIV) = IMIN
+         J         = N + IMIN
+         ISTATE(J) = IS
+         IF (NFIXED + NACTIV .EQ. N) GO TO 500
+  350 CONTINUE
+C
+C  ---------------------------------------------------------------------
+C  IF NECESSARY, ADD TEMPORARY BOUNDS TO MAKE A VERTEX.
+C  ---------------------------------------------------------------------
+  400 NCOLZ = N - NFIXED - NACTIV
+      IF (.NOT. VERTEX  .OR.  NCOLZ .EQ. 0) GO TO 500
+C
+C  COMPUTE LENGTHS OF COLUMNS OF SELECTED LINEAR CONSTRAINTS
+C  (JUST THE ONES CORRESPONDING TO FREE VARIABLES).
+C
+      DO 440 J = 1, N
+         IF (ISTATE(J) .NE. 0) GO TO 440
+         COLSIZ = ZERO
+         IF (NCLIN .EQ. 0) GO TO 430
+         DO 420 K = 1, NCLIN
+            I = N + K
+            IF (ISTATE(I) .GT. 0) COLSIZ = COLSIZ + DABS( A(K,J) )
+  420    CONTINUE
+  430    WRK1(J) = COLSIZ
+  440 CONTINUE
+C
+C  FIND THE  NARTIF  SMALLEST SUCH COLUMNS.
+C  THIS IS AN EXPENSIVE LOOP.  LATER WE CAN REPLACE IT
+C  BY A 4-PASS PROCESS (SAY), ACCEPTING THE FIRST COL THAT
+C  IS WITHIN  T  OF  COLMIN, WHERE  T = 0.0, 0.001, 0.01, 0.1 (SAY).
+C
+      DO 480 IDUMMY = 1, NCOLZ
+         COLMIN = FLMAX
+         DO 470 J = 1, N
+            IF (ISTATE(J) .NE. 0) GO TO 470
+            IF (NCLIN .EQ. 0) GO TO 475
+            COLSIZ = WRK1(J)
+            IF (COLMIN .LE. COLSIZ) GO TO 470
+            COLMIN = COLSIZ
+            JMIN   = J
+  470    CONTINUE
+         J = JMIN
+  475    ISTATE(J) = 4
+         NARTIF = NARTIF + 1
+  480 CONTINUE
+C
+C  ---------------------------------------------------------------------
+C  A TRIAL WORKING SET HAS NOW BEEN SELECTED.
+C  ---------------------------------------------------------------------
+C  SET  KFREE  TO POINT TO THE FREE VARIABLES.
+C
+  500 NFREE = 0
+      DO 520 J = 1, N
+         IF (ISTATE(J) .NE. 0) GO TO 520
+         NFREE = NFREE + 1
+         KFREE(NFREE) = J
+  520 CONTINUE
+C
+C  COMPUTE THE TQ FACTORIZATION FOR THE SELECTED LINEAR CONSTRAINTS.
+C  FIRST, THE COLUMNS CORRESPONDING TO SIMPLE BOUNDS IN THE WORKING SET
+C  ARE REMOVED. THE RESULTING  NACTIV BY NFREE  MATRIX (NACTIV LE NFREE)
+C  IS FACTORIZED BY ADDING THE CONSTRAINTS ONE AT A TIME AND UPDATING
+C  USING PLANE ROTATIONS OR STABILIZED ELIMINATIONS. THE  NACTIV BY
+C  NACTIV  TRIANGULAR MATRIX  T  AND THE NFREE BY NFREE MATRIX  Q
+C  ARE STORED IN THE ARRAYS  RT  AND  ZY.
+C
+      NCOLZ = NFREE
+      IF (NACTIV .EQ. 0) GO TO 550
+      NACT1  = NACTIV
+      NACTIV = 0
+      CALL TQADD ( ORTHOG, UNITQ,
+     *             INFORM, 1, NACT1, NACTIV, NCOLZ, NFREE,
+     *             N, NCTOTL, NQ, NROWA, NROWRT, NCOLRT,
+     *             ISTATE, KACTIV, KFREE,
+     *             CONDMX,
+     *             A, QTG, RT, ZY, WRK1, WRK2 )
+C
+C  IF A VERTEX IS REQUIRED BUT  TQADD  WAS UNABLE TO ADD ALL OF THE
+C  SELECTED GENERAL CONSTRAINTS, ADD MORE TEMPORARY BOUNDS.
+C
+      IF (.NOT. VERTEX  .OR.  NCOLZ .EQ. 0) GO TO 550
+      LENQ   = NQ*(NQ - 1) + 1
+      NCOLZ1 = NCOLZ
+      DO 540 IDUMMY = 1, NCOLZ1
+         ROWMAX = ZERO
+         DO 530 I = 1, NFREE
+            RNORM = V2NORM( NCOLZ, ZY(I,1), LENQ, NQ )
+            IF (ROWMAX .GE. RNORM) GO TO 530
+            ROWMAX = RNORM
+            IFIX   = I
+  530    CONTINUE
+         JADD = KFREE(IFIX)
+         CALL ADDCON( .FALSE., .FALSE., ORTHOG, UNITQ, INFORM,
+     *                IFIX, IADD, JADD, NACTIV, NCOLZ, NCOLZ, NFREE,
+     *                N, NQ, NROWA, NROWRT, NCOLRT, KFREE,
+     *                CONDMX, CSLAST, SNLAST,
+     *                A, QTG, RT, ZY, WRK1, WRK2 )
+C
+         NFREE  = NFREE  - 1
+         NCOLZ  = NCOLZ  - 1
+         NARTIF = NARTIF + 1
+         ISTATE(JADD) = 4
+  540 CONTINUE
+C
+C  SET ELEMENTS  NACTIV + 1, ......, NACTIV + NFIXED  OF  KACTIV TO
+C  POINT TO THE FIXED VARIABLES.
+C
+  550 KB = NACTIV
+      DO 560 J = 1, N
+         IF (ISTATE(J) .EQ. 0) GO TO 560
+         KB         = KB + 1
+         KACTIV(KB) = J
+  560 CONTINUE
+C
+C  ---------------------------------------------------------------------
+C  THE TQ FACTORIZATION HAS BEEN COMPUTED.  FIND THE POINT CLOSEST TO
+C  THE USER-SUPPLIED  X  THAT LIES ON THE INITIAL WORKING SET.
+C  ---------------------------------------------------------------------
+C  SET WRK1 = RESIDUALS FOR CONSTRAINTS IN THE WORKING SET.
+C
+      IF (NACTIV .EQ. 0) GO TO 700
+      DO 610 I = 1, NACTIV
+         K   = KACTIV(I)
+         J   = N + K
+         BND = BL(J)
+         IF (ISTATE(J) .GT. 1) BND = BU(J)
+         WRK1(I) = BND - DOT( N, A(K,1), LROWA, NROWA, X, N, 1 )
+  610 CONTINUE
+C
+C  SOLVE FOR P, THE SMALLEST CORRECTION TO X THAT GIVES A POINT
+C  ON THE CONSTRAINTS IN THE WORKING SET.
+C  FIRST SOLVE  T*WRK1 = RESIDUALS, THEN GET  P = Y*WRK1.
+C
+      CALL TSOLVE( 1, NROWRT, NACTIV, RT(1,NCOLZ+1), WRK1 )
+      CALL ZEROVC( N, P, N, 1 )
+      CALL COPYVC( NACTIV, WRK1, NACTIV, 1, P(NCOLZ + 1), NACTIV, 1 )
+      CALL ZYPROD( 2, N, NACTIV, NCOLZ, NFREE, NQ, UNITQ,
+     *             KACTIV, KFREE, P, ZY, WRK1 )
+      CALL AXPY  ( N, ONE, P, N, 1, X, N, 1 )
+C
+C  ---------------------------------------------------------------------
+C  COMPUTE THE 2-NORM OF  X.
+C  INITIALIZE  AX  FOR ALL GENERAL CONSTRAINTS.
+C  ---------------------------------------------------------------------
+  700 XNORM  = V2NORM( N, X, N, 1 )
+      IF (NCLIN .EQ. 0) GO TO 800
+      CALL ZEROVC( NCLIN, AX, NCLIN, 1 )
+      DO 720 J = 1, N
+         IF (X(J) .NE. ZERO)
+     *   CALL AXPY( NCLIN, X(J), A(1,J), NCLIN, 1, AX, NCLIN, 1 )
+  720 CONTINUE
+C
+C  A POINT THAT SATISFIES THE INITIAL WORKING SET HAS BEEN FOUND.
+C
+  800 NCOLZ  = NFREE - NACTIV
+      NFIXED = N     - NFREE
+      IF (MSG .GE. 80) WRITE (NOUT, 1000) NFIXED, NARTIF, NACTIV
+      IF (MSG .GE. 80) WRITE (NOUT, 1020) (X(J), J = 1, N)
+      RETURN
+C
+ 1000 FORMAT(/ 34H LPCRSH.  WORKING SET SELECTED ...
+     *       /  9H BOUNDS =, I5, 4X, 18HTEMPORARY BOUNDS =, I5,
+     *     4X, 16HGENERAL LINEAR =, I5)
+ 1010 FORMAT(/ 29H LP VARIABLES BEFORE CRASH... / (5G12.3))
+ 1020 FORMAT(/ 29H LP VARIABLES AFTER  CRASH... / (5G12.3))
+ 1210 FORMAT(/ 32H //LPCRSH//  LCRASH NCLIN NCTOTL
+     *       / 11H //LPCRSH//, 3I7 )
+C
+C  END OF LPCRSH
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/lpdump.f
@@ -0,0 +1,82 @@
+      SUBROUTINE LPDUMP( N, NCLIN, NCTOTL, NROWA,
+     *                   LCRASH, LP, MINSUM, NAMED, VERTEX,
+     *                   ISTATE, A, AX, BL, BU, CVEC, X )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      LOGICAL            LP, MINSUM, NAMED, VERTEX
+      INTEGER            N, NCLIN, NCTOTL, NROWA, LCRASH
+      INTEGER            ISTATE(NCTOTL)
+      DOUBLE PRECISION   A(NROWA,N), AX(NROWA), BL(NCTOTL), BU(NCTOTL)
+      DOUBLE PRECISION   CVEC(N), X(N)
+C
+      INTEGER            NOUT, MSG, ISTART
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+C
+C  *********************************************************************
+C  LPDUMP  PRINTS  A, BL, BU, CVEC, X, A*X,
+C                  COLD, LP, MINSUM, NAMED, VERTEX, AND POSSIBLY ISTATE.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION OF APRIL 1982.  REV. OCT. 1982.
+C  *********************************************************************
+C
+      INTEGER            I, J, K, LROWA
+      DOUBLE PRECISION   ATX, DOT
+C
+C  PRINT  WMACH  AND THE LOGICALS.
+C
+      WRITE (NOUT, 1000)
+      DO 10 I = 1, 11
+         WRITE (NOUT, 1100) I, WMACH(I)
+   10 CONTINUE
+      WRITE (NOUT, 1200) LCRASH, LP, MINSUM, NAMED, VERTEX
+C
+C  PRINT  A  BY ROWS AND COMPUTE  AX = A*X.
+C
+      IF (NCLIN .EQ. 0) GO TO 200
+      LROWA  = NROWA*(N - 1) + 1
+      DO 100 K = 1, NCLIN
+         WRITE (NOUT, 1500) K
+         WRITE (NOUT, 1600) (A(K,J), J=1,N)
+         AX(K) = DOT( N, A(K,1), LROWA, NROWA, X, N, 1 )
+  100 CONTINUE
+C
+C  PRINT  BL, BU  AND  X OR AX.
+C
+  200 WRITE (NOUT, 2000)
+      DO 300 J = 1, NCTOTL
+         IF (J .GT. N) GO TO 250
+         K      = J
+         ATX    = X(J)
+         GO TO 290
+C
+  250    K      = J - N
+         ATX    = AX(K)
+         IF (K .EQ. 1) WRITE (NOUT, 2100)
+C
+  290    WRITE (NOUT, 2200) K, BL(J), BU(J), ATX
+  300 CONTINUE
+C
+C  PRINT  CVEC, ISTATE.
+C
+      IF (LP           ) WRITE (NOUT, 3000) (CVEC(I)  , I=1,N)
+      IF (LCRASH .GT. 0) WRITE (NOUT, 3100) (ISTATE(J), J=1,NCTOTL)
+      RETURN
+C
+ 1000 FORMAT(1H1 / 19H OUTPUT FROM LPDUMP / 19H ******************)
+ 1100 FORMAT(/ 7H WMACH(, I2, 3H) =, G15.6)
+ 1200 FORMAT(/ 9H LCRASH =, I3, 4X, 9H LP     =, L3, 4X,
+     *         9H MINSUM =, L3, 4X, 9H NAMED  =, L3, 4X,
+     *         9H VERTEX =, L3)
+ 1500 FORMAT(/ 4H ROW, I6, 11H  OF  A ...)
+ 1600 FORMAT(5G15.6)
+ 2000 FORMAT(/ 14X, 42HJ      BL(J)          BU(J)           X(J))
+ 2100 FORMAT(/ 14X, 42HI    BL(N+I)        BU(N+I)         A(I)*X)
+ 2200 FORMAT(I15, 3G15.6)
+ 3000 FORMAT(/ 9H CVEC ... / (5G15.6))
+ 3100 FORMAT(/ 11H ISTATE ... / (10I4))
+C
+C  END OF LPDUMP
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/lpgrad.f
@@ -0,0 +1,93 @@
+      SUBROUTINE LPGRAD( LP, N, NCTOTL, NROWA,
+     *                   BIGBND, FEAMIN, NUMINF, SUMINF, ISTATE,
+     *                   A, BL, BU, CVEC, FEATOL, GRAD, X )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      INTEGER            N, NCTOTL, NROWA, NUMINF
+      INTEGER            ISTATE(NCTOTL)
+      DOUBLE PRECISION   BIGBND, FEAMIN, SUMINF
+      DOUBLE PRECISION   A(NROWA,N), BL(NCTOTL), BU(NCTOTL), CVEC(N),
+     *                   FEATOL(NCTOTL), GRAD(N), X(N)
+      LOGICAL            LP
+C
+C  *********************************************************************
+C  IF NUMINF .GT. 0,  LPGRAD  FINDS THE NUMBER AND WEIGHTED SUM OF
+C  INFEASIBILITIES FOR THE BOUNDS AND LINEAR CONSTRAINTS. AN
+C  APPROPRIATE GRADIENT VECTOR IS RETURNED IN  GRAD.
+C  IF NUMINF = 0,  AND IF AN LP PROBLEM IS BEING SOLVED,  GRAD  WILL BE
+C  LOADED WITH THE TRUE LINEAR OBJECTIVE.
+C
+C  POSITIVE VALUES OF  ISTATE(J)  WILL NOT BE ALTERED.  THESE MEAN
+C  THE FOLLOWING...
+C
+C            1          2         3
+C        A*X = BL   A*X = BU   BL = BU
+C
+C  OTHER VALUES OF  ISTATE(J)  WILL BE RESET AS FOLLOWS...
+C        A*X LT BL   A*X GT BU   A*X FREE
+C           - 2         - 1         0
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION OF SEPTEMBER 1981.  REV. OCT. 1982. JAN. 1983.
+C  *********************************************************************
+C
+      INTEGER            J, K, LROWA
+      DOUBLE PRECISION   ATX, FEASJ, S, WEIGHT, ZERO
+      DOUBLE PRECISION   DOT
+      DOUBLE PRECISION   DABS
+      LOGICAL            NOLOW, NOUPP
+      DATA               ZERO /0.0D+0/
+C
+      LROWA  = NROWA*(N - 1) + 1
+      IF (NUMINF .EQ. 0) GO TO 500
+      NUMINF = 0
+      SUMINF = ZERO
+      CALL ZEROVC( N, GRAD, N, 1 )
+C
+      DO 200 J = 1, NCTOTL
+C
+C        DO NOTHING IF THE VARIABLE OR CONSTRAINT IS AT A BOUND.
+C
+         IF (ISTATE(J) .GT. 0) GO TO 200
+         FEASJ  = FEATOL(J)
+         NOLOW  = BL(J) .LE. (- BIGBND)
+         NOUPP  = BU(J) .GE.    BIGBND
+         K      = J - N
+         IF (J .LE. N) ATX = X(J)
+         IF (J .GT. N) ATX = DOT( N, A(K,1), LROWA, NROWA, X, N, 1 )
+         ISTATE(J) = 0
+C
+C        SEE IF THE LOWER BOUND IS VIOLATED.
+C
+         IF (NOLOW) GO TO 150
+         S = BL(J) - ATX
+         IF (S .LE. FEASJ) GO TO 150
+         ISTATE(J) = - 2
+         WEIGHT    = - FEAMIN/FEASJ
+         GO TO 160
+C
+C        SEE IF THE UPPER BOUND IS VIOLATED.
+C
+  150    IF (NOUPP) GO TO 200
+         S = ATX - BU(J)
+         IF (S .LE. FEASJ) GO TO 200
+         ISTATE(J) = - 1
+         WEIGHT    =   FEAMIN/FEASJ
+C
+C        ADD THE INFEASIBILITY.
+C
+  160    NUMINF = NUMINF + 1
+         SUMINF = SUMINF + DABS( WEIGHT ) * S
+         IF (J .LE. N) GRAD(J) = WEIGHT
+         IF (J .GT. N)
+     *   CALL AXPY  ( N, WEIGHT, A(K,1), LROWA, NROWA, GRAD, N, 1 )
+  200 CONTINUE
+C
+C  IF FEASIBLE, INSTALL TRUE OBJECTIVE.
+C
+  500 IF (LP  .AND.  NUMINF .EQ. 0)
+     *CALL COPYVC( N, CVEC, N, 1, GRAD, N, 1 )
+      RETURN
+C
+C  END OF LPGRAD
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/lpprt.f
@@ -0,0 +1,135 @@
+      SUBROUTINE LPPRT ( LP, NROWA, NROWRT, NCOLRT,
+     *                   N, NCLIN, NCLIN0, NCTOTL,
+     *                   NFREE, ISDEL, NACTIV, NCOLZ, ITER, JADD, JDEL,
+     *                   ALFA, CONDT, NUMINF, SUMINF, OBJLP,
+     *                   ISTATE, KFREE,
+     *                   A, RT, X, WRK1, WRK2 )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      INTEGER            NROWA, NROWRT, NCOLRT, N, NCLIN, NCLIN0,
+     *                   NCTOTL, NFREE, ISDEL, NACTIV, NCOLZ, ITER,
+     *                   JADD, JDEL, NUMINF
+      INTEGER            ISTATE(NCTOTL), KFREE(N)
+      DOUBLE PRECISION   ALFA, CONDT, SUMINF, OBJLP
+      DOUBLE PRECISION   A(NROWA,N), RT(NROWRT,NCOLRT), X(N)
+      DOUBLE PRECISION   WRK1(N), WRK2(NCLIN0)
+      LOGICAL            LP
+C
+      INTEGER            NOUT, MSG, ISTART
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+C
+C  *********************************************************************
+C
+C  LPPRT  PRINTS VARIOUS LEVELS OF OUTPUT FOR  LPCORE.
+C
+C           MSG    CUMULATIVE RESULT
+C           ---    -----------------
+C
+C        LE   0    NO OUTPUT.
+C
+C        EQ   1    NOTHING NOW (BUT FULL OUTPUT LATER).
+C
+C        EQ   5    ONE TERSE LINE OF OUTPUT.
+C
+C        GE  10    SAME AS 5 (BUT FULL OUTPUT LATER).
+C
+C        GE  15    NOTHING MORE IF  ITER .LT. ISTART.
+C                  OTHERWISE,  X,  ISTATE  AND  KFREE.
+C
+C        GE  20    MULTIPLIERS (PRINTED OUTSIDE LPPRT).
+C                  THE ARRAY  AX.
+C
+C        GE  30    DIAGONALS OF  T.
+C
+C        GE  80    DEBUG OUTPUT.
+C
+C        EQ  99    A,  BL,  BU,  CVEC,  X  (CALLED FROM LPDUMP).
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION OF DECEMBER 1981.  REV. NOV. 1982.
+C  *********************************************************************
+C
+      INTEGER            INCT, J, K, LADD, LDEL, LENT, LROWA, L1, L2
+      INTEGER            LSTATE(5)
+      DOUBLE PRECISION   DOT
+      DATA               LSTATE(1), LSTATE(2) /      1H ,       1HL/
+      DATA               LSTATE(3), LSTATE(4) /      1HU,       1HE/
+      DATA               LSTATE(5)            /      1HT           /
+C
+      IF (MSG .LT. 5) GO TO 900
+C
+      LDEL   = 0
+      LADD   = 0
+      IF (JDEL .GT. 0) LDEL = ISDEL
+      IF (JADD .GT. 0) LADD = ISTATE(JADD)
+      LDEL   = LSTATE(LDEL + 1)
+      LADD   = LSTATE(LADD + 1)
+      IF (MSG .GE. 15) GO TO 100
+C
+C  ---------------------------------------------------------------------
+C  PRINT HEADING (POSSIBLY) AND TERSE LINE.
+C  ---------------------------------------------------------------------
+      IF (.NOT. LP  .AND.  ITER .EQ. 0) WRITE (NOUT, 1100)
+      IF (      LP  .AND.  ITER .EQ. 0) WRITE (NOUT, 1110)
+      IF (.NOT. LP) WRITE (NOUT, 1200) ITER, JDEL, LDEL, JADD, LADD,
+     *   ALFA, CONDT, NUMINF, SUMINF
+      IF (      LP) WRITE (NOUT, 1200) ITER, JDEL, LDEL, JADD, LADD,
+     *   ALFA, CONDT, NUMINF, SUMINF, OBJLP
+      GO TO 900
+C
+C  ---------------------------------------------------------------------
+C  PRINT TERSE LINE,  X,  ISTATE  AND  KFREE.
+C  ---------------------------------------------------------------------
+  100 WRITE (NOUT, 1000) ITER
+      IF (.NOT. LP) WRITE (NOUT, 1100)
+      IF (      LP) WRITE (NOUT, 1110)
+      IF (.NOT. LP) WRITE (NOUT, 1200) ITER, JDEL, LDEL, JADD, LADD,
+     *   ALFA, CONDT, NUMINF, SUMINF
+      IF (      LP) WRITE (NOUT, 1200) ITER, JDEL, LDEL, JADD, LADD,
+     *   ALFA, CONDT, NUMINF, SUMINF, OBJLP
+      WRITE (NOUT, 1300) (X(J)     , J=1,N)
+      WRITE (NOUT, 1600) (ISTATE(J), J=1,N)
+      L1 = N + 1
+      L2 = N + NCLIN
+      IF (L1     .LE. L2) WRITE (NOUT, 1610) (ISTATE(J), J=L1,L2)
+      IF (NFREE  .GT.  0) WRITE (NOUT, 1700) (KFREE(K), K=1,NFREE)
+C
+C  ---------------------------------------------------------------------
+C  COMPUTE AND PRINT  AX.  USE  WORK = AP  TO AVOID SIDE EFFECTS.
+C  ---------------------------------------------------------------------
+      IF (MSG .LT. 20) GO TO 900
+      IF (NCLIN .EQ. 0) GO TO 300
+      LROWA  = NROWA*(N - 1) + 1
+      DO 250 K = 1, NCLIN
+         WRK2(K) = DOT( N, A(K,1), LROWA, NROWA, X, N, 1 )
+  250 CONTINUE
+      WRITE (NOUT, 2000) (WRK2(K), K=1,NCLIN)
+C
+C  ---------------------------------------------------------------------
+C  PRINT THE DIAGONALS OF  T.
+C  ---------------------------------------------------------------------
+  300 IF (MSG .LT. 30) GO TO 900
+      LENT   = NROWRT*(NACTIV - 1) + 1
+      INCT   = NROWRT - 1
+      IF (NACTIV .NE. 0) CALL COPYVC( NACTIV, RT(NACTIV,NCOLZ+1),
+     *                                LENT, INCT, WRK1, NACTIV, 1 )
+      IF (NACTIV .NE. 0) WRITE (NOUT, 3000) (WRK1(J), J=1,NACTIV)
+C
+  900 RETURN
+C
+ 1000 FORMAT(/// 18H ================= / 13H LP ITERATION, I5
+     *         / 18H ================= )
+ 1100 FORMAT(// 5H  ITN, 12H JDEL  JADD , 6X, 4HSTEP, 10H    COND T,
+     *   7H NUMINF, 8X, 7H SUMINF)
+ 1110 FORMAT(// 5H  ITN, 12H JDEL  JADD , 6X, 4HSTEP, 10H    COND T,
+     *   7H NUMINF, 8X, 7H SUMINF, 9X, 6H LPOBJ)
+ 1200 FORMAT(I5, I5, A1, I5, A1, 1P2E10.2, I7, 1P2E15.6)
+ 1300 FORMAT(/ 13H LP VARIABLES                            / (1P5E15.6))
+ 1600 FORMAT(/ 37H STATUS OF THE LP BOUND   CONSTRAINTS    / (1X, 10I4))
+ 1610 FORMAT(/ 37H STATUS OF THE LP GENERAL CONSTRAINTS    / (1X, 10I4))
+ 1700 FORMAT(/ 26H LIST OF FREE LP VARIABLES               / (1X, 10I4))
+ 2000 FORMAT(/ 40H VALUES OF LP GENERAL LINEAR CONSTRAINTS / (1P5E15.6))
+ 3000 FORMAT(/ 40H DIAGONALS OF LP WORKING SET FACTOR  T   / (1P5E15.6))
+C
+C  END OF LPPRT
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/prtsol.f
@@ -0,0 +1,169 @@
+      SUBROUTINE PRTSOL( NFREE, NROWA, NROWJ,
+     *                   N, NCLIN, NCNLN, NCTOTL, BIGBND,
+     *                   NAMED, NAMES, LENNAM,
+     *                   NACTIV, ISTATE, KACTIV,
+     *                   A, BL, BU, C, CLAMDA, RLAMDA, X )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      LOGICAL            NAMED
+      INTEGER            NFREE, NROWA, NROWJ, N, NCLIN, NCNLN,
+     *                   NCTOTL, LENNAM, NACTIV
+      INTEGER            ISTATE(NCTOTL), KACTIV(N), NAMES(4,LENNAM)
+      DOUBLE PRECISION   BIGBND
+      DOUBLE PRECISION   A(NROWA,N), BL(NCTOTL), BU(NCTOTL), C(NROWJ),
+     *                   CLAMDA(NCTOTL), RLAMDA(N), X(N)
+C
+      INTEGER            NOUT, MSG, ISTART
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+C
+C  *********************************************************************
+C  PRTSOL  EXPANDS THE LAGRANGE MULTIPLIERS INTO  CLAMDA.
+C  IF  MSG .GE. 10  OR  MSG .EQ. 1,  PRTSOL  THEN PRINTS  X, A*X, C(X),
+C  THEIR BOUNDS,  THE MULTIPLIERS, AND THE RESIDUALS (DISTANCE TO THE
+C  NEAREST BOUND).
+C  PRTSOL  IS CALLED BY  LPCORE, QPCORE, LCCORE AND NPCORE  JUST BEFORE
+C  THEY EXIT.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION OF MARCH 1982. REV. OCT. 1982.
+C  *********************************************************************
+C
+      INTEGER            I, IP, IS, J, K, L, LROWA, LS,
+     *                   NFIXED, NLAM, NPLIN
+      INTEGER            ID(9), ID3(3), ID4(4), LSTATE(7)
+      DOUBLE PRECISION   B1, B2, RES, RES2, V, WLAM
+      DOUBLE PRECISION   DOT
+      DOUBLE PRECISION   DABS
+      DATA                ID(1), ID(2), ID(3), ID(4), ID(5)
+     *                   / 2HVA,  2HRB,  2HL ,  2HLN,  2HCO /
+      DATA                ID(6), ID(7), ID(8), ID(9)
+     *                   / 2HN ,  2HNL,  2HCO,  2HN /
+      DATA                LSTATE(1), LSTATE(2)
+     *                   /     2H--,      2H++/
+      DATA                LSTATE(3), LSTATE(4)
+     *                   /     2HFR,      2HLL /
+      DATA                LSTATE(5), LSTATE(6)
+     *                   /     2HUL,      2HEQ /
+      DATA                LSTATE(7)
+     *                   /     2HTB /
+C
+      NPLIN  = N + NCLIN
+      LROWA  = NROWA*(N - 1) + 1
+C
+C  EXPAND BOUND, LINEAR AND NONLINEAR MULTIPLIERS INTO  CLAMDA.
+C
+      CALL ZEROVC( NCTOTL, CLAMDA, NCTOTL, 1 )
+      NFIXED = N      - NFREE
+      NLAM   = NACTIV + NFIXED
+      IF (NLAM .EQ. 0) GO TO 180
+C
+      DO 150 K = 1, NLAM
+         J      = KACTIV(K)
+         IF (K .LE. NACTIV) J = J + N
+         CLAMDA(J) = RLAMDA(K)
+  150 CONTINUE
+C
+  180 IF (MSG .LT. 10  .AND.  MSG .NE. 1) RETURN
+C
+      WRITE (NOUT, 1100)
+      ID3(1) = ID(1)
+      ID3(2) = ID(2)
+      ID3(3) = ID(3)
+C
+      DO 500 J = 1, NCTOTL
+         B1     = BL(J)
+         B2     = BU(J)
+         WLAM   = CLAMDA(J)
+         IS     = ISTATE(J)
+         LS     = LSTATE(IS + 3)
+         IF (J .LE. N    ) GO TO 190
+         IF (J .LE. NPLIN) GO TO 200
+         GO TO 300
+C
+C
+C        SECTION 1 -- THE VARIABLES  X.
+C        ------------------------------
+  190    K      = J
+         V      = X(J)
+         GO TO 400
+C
+C
+C        SECTION 2 -- THE LINEAR CONSTRAINTS  A*X.
+C        -----------------------------------------
+  200    IF (J .NE. N + 1) GO TO 220
+         WRITE (NOUT, 1200)
+         ID3(1) = ID(4)
+         ID3(2) = ID(5)
+         ID3(3) = ID(6)
+C
+  220    K      = J - N
+         V      = DOT( N, A(K,1), LROWA, NROWA, X, N, 1 )
+         GO TO 400
+C
+C
+C        SECTION 3 -- THE NONLINEAR CONSTRAINTS  C(X).
+C        ---------------------------------------------
+C
+  300    IF (NCNLN .LE. 0) GO TO 500
+         IF (J .NE. NPLIN + 1) GO TO 320
+         WRITE (NOUT, 1300)
+         ID3(1) = ID(7)
+         ID3(2) = ID(8)
+         ID3(3) = ID(9)
+C
+  320    K      = J - NPLIN
+         V      = C(K)
+C
+C
+C        PRINT A LINE FOR THE J-TH VARIABLE OR CONSTRAINT.
+C        -------------------------------------------------
+  400    RES    = V - B1
+         RES2   = B2 - V
+         IF (DABS(RES) .GT. DABS(RES2)) RES = RES2
+         IP     = 1
+         IF (B1 .LE. ( - BIGBND )) IP = 2
+         IF (B2 .GE.     BIGBND  ) IP = IP + 2
+         IF (.NOT. NAMED) GO TO 490
+C
+         DO 450 L = 1, 4
+            ID4(L) = NAMES(L,J)
+  450    CONTINUE
+         IF (IP .EQ. 1) WRITE (NOUT, 2100) ID4,    LS, V,B1,B2,WLAM,RES
+         IF (IP .EQ. 2) WRITE (NOUT, 2200) ID4,    LS, V,   B2,WLAM,RES
+         IF (IP .EQ. 3) WRITE (NOUT, 2300) ID4,    LS, V,B1,   WLAM,RES
+         IF (IP .EQ. 4) WRITE (NOUT, 2400) ID4,    LS, V,      WLAM,RES
+         GO TO 500
+C
+  490    IF (IP .EQ. 1) WRITE (NOUT, 3100) ID3, K, LS, V,B1,B2,WLAM,RES
+         IF (IP .EQ. 2) WRITE (NOUT, 3200) ID3, K, LS, V,   B2,WLAM,RES
+         IF (IP .EQ. 3) WRITE (NOUT, 3300) ID3, K, LS, V,B1,   WLAM,RES
+         IF (IP .EQ. 4) WRITE (NOUT, 3400) ID3, K, LS, V,      WLAM,RES
+  500 CONTINUE
+C
+      RETURN
+C
+ 1100 FORMAT(// 22H VARIABLE        STATE, 5X, 6H VALUE,
+     *   6X, 12H LOWER BOUND, 4X, 12H UPPER BOUND,
+     *   17H  LAGR MULTIPLIER, 13H     RESIDUAL /)
+ 1200 FORMAT(// 22H LINEAR CONSTR   STATE, 5X, 6H VALUE,
+     *   6X, 12H LOWER BOUND, 4X, 12H UPPER BOUND,
+     *   17H  LAGR MULTIPLIER, 13H     RESIDUAL /)
+ 1300 FORMAT(// 22H NONLNR CONSTR   STATE, 5X, 6H VALUE,
+     *   6X, 12H LOWER BOUND, 4X, 12H UPPER BOUND,
+     *   17H  LAGR MULTIPLIER, 13H     RESIDUAL /)
+ 2100 FORMAT(1X, 4A2, 10X, A2, 3G16.7, G16.7, G16.4)
+ 2200 FORMAT(1X, 4A2, 10X, A2, G16.7, 5X, 5H NONE, 6X, G16.7,
+     *   G16.7, G16.4)
+ 2300 FORMAT(1X, 4A2, 10X, A2, 2G16.7, 5X, 5H NONE, 6X, G16.7, G16.4)
+ 2400 FORMAT(1X, 4A2, 10X, A2,  G16.7, 5X, 5H NONE, 11X, 5H NONE,
+     *   6X, G16.7, G16.4)
+ 3100 FORMAT(1X, 2A2, A1, I3, 10X, A2, 3G16.7, G16.7, G16.4)
+ 3200 FORMAT(1X, 2A2, A1, I3, 10X, A2,  G16.7,
+     *   5X, 5H NONE, 6X, G16.7, G16.7, G16.4)
+ 3300 FORMAT(1X, 2A2, A1, I3, 10X, A2, 2G16.7, 5X, 5H NONE, 6X,
+     *   G16.7, G16.4)
+ 3400 FORMAT(1X, 2A2, A1, I3, 10X, A2,  G16.7,
+     *   5X, 5H NONE, 11X, 5H NONE, 6X, G16.7, G16.4)
+C
+C  END OF PRTSOL
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/qpchkp.f
@@ -0,0 +1,55 @@
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C     FILE QPSUBS66 FORTRAN
+C
+C     QPCHKP   QPCOLR   QPCORE   QPCRSH   QPDUMP   QPGRAD   QPPRT
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+      SUBROUTINE QPCHKP( N, NCLIN, NCLIN0, ISSAVE, JDSAVE, AP, P )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      INTEGER            N, NCLIN, NCLIN0, ISSAVE, JDSAVE
+      DOUBLE PRECISION   AP(NCLIN0), P(N)
+C
+      INTEGER            NOUT, MSG, ISTART
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+C
+C  *********************************************************************
+C  QPCHKP  IS CALLED WHEN A CONSTRAINT HAS JUST BEEN DELETED AND THE
+C  SIGN OF THE SEARCH DIRECTION  P  MAY BE INCORRECT BECAUSE OF ROUNDING
+C  ERRORS IN THE COMPUTATION OF THE PROJECTED GRADIENT  ZTG.  THE SIGN
+C  OF THE SEARCH DIRECTION (AND THEREFORE THE PRODUCT  AP)  IS FIXED BY
+C  FORCING  P  TO SATISFY THE CONSTRAINT (WITH INDEX  JDSAVE)  THAT WAS
+C  JUST DELETED.  VARIABLES THAT WERE HELD TEMPORARILY FIXED (WITH
+C  ISTATE = 4)  ARE NOT CHECKED FOR FEASIBILITY.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  ORIGINAL VERSION DECEMBER 1982.
+C  *********************************************************************
+C
+      INTEGER            IDEL
+      DOUBLE PRECISION   ATP, ONE, ZERO
+      DATA               ZERO, ONE /0.0D+0, 1.0D+0/
+C
+      IF (ISSAVE .EQ. 4) GO TO 900
+C
+      IDEL = JDSAVE - N
+      IF (JDSAVE .LE. N) ATP =  P(JDSAVE)
+      IF (JDSAVE .GT. N) ATP = AP(IDEL)
+C
+      IF (MSG .GE. 80) WRITE (NOUT, 1000) JDSAVE, ISSAVE, ATP
+C
+      IF (      ISSAVE .EQ. 2  .AND.  ATP .LE. ZERO
+     *    .OR.  ISSAVE .EQ. 1  .AND.  ATP .GE. ZERO) GO TO 900
+C
+C  REVERSE THE DIRECTION OF  P  AND  AP.
+C
+      CALL SSCALE(     N, (- ONE),  P,     N, 1 )
+      IF (NCLIN .GT. 0)
+     *CALL SSCALE( NCLIN, (- ONE), AP, NCLIN, 1 )
+C
+  900 RETURN
+C
+ 1000 FORMAT(/ 42H //QPCHKP //  JDSAVE ISSAVE            ATP
+     *       / 13H //QPCHKP // , 2I7, G15.5 )
+C
+C  END OF QPCHKP
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/qpcolr.f
@@ -0,0 +1,197 @@
+      SUBROUTINE QPCOLR( NOCURV, POSDEF, RENEWR, UNITQ, QPHESS,
+     *                   N, NCOLR, NCTOTL, NFREE, NQ, NROWH, NCOLH,
+     *                   NROWRT, NCOLRT, NHESS, KFREE,
+     *                   CSLAST, SNLAST, DRMAX, EMAX, HSIZE, RDLAST,
+     *                   HESS, RT, SCALE, ZY, HZ, WRK )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      INTEGER            N, NCOLR, NCTOTL, NFREE, NQ, NROWH, NCOLH,
+     *                   NROWRT, NCOLRT, NHESS
+      INTEGER            KFREE(N)
+      DOUBLE PRECISION   CSLAST, SNLAST, DRMAX, EMAX, HSIZE, RDLAST
+      DOUBLE PRECISION   HESS(NROWH,NCOLH), RT(NROWRT,NCOLRT), HZ(N),
+     *                   SCALE(NCTOTL), ZY(NQ,NQ)
+      DOUBLE PRECISION   WRK(N)
+      LOGICAL            NOCURV, POSDEF, RENEWR, UNITQ
+      EXTERNAL           QPHESS
+C
+      INTEGER            NOUT, MSG, ISTART
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+C
+      LOGICAL            SCLDQP
+      COMMON    /SOL2LP/ SCLDQP
+C
+C  *********************************************************************
+C  QPCOLR  IS USED TO COMPUTE ELEMENTS OF THE  (NCOLR)-TH  COLUMN OF  R,
+C  THE CHOLESKY FACTOR OF THE PROJECTED HESSIAN.  IF  RENEWR  IS  TRUE
+C  ON ENTRY,  THE COMPLETE COLUMN IS TO BE COMPUTED.  OTHERWISE, ONLY
+C  THE LAST DIAGONAL ELEMENT IS REQUIRED.
+C  IF THE RESULTING PROJECTED HESSIAN IS SINGULAR OR INDEFINITE, ITS
+C  LAST DIAGONAL ELEMENT IS INCREASED BY AN AMOUNT  EMAX  THAT ENSURES
+C  POSITIVE DEFINITENESS.  THIS DIAGONAL MODIFICATION WILL ALTER THE
+C  SCALE OF THE QP SEARCH VECTOR  P, BUT NOT ITS DIRECTION.
+C
+C  ON EXIT,  QPCOLR WILL HAVE STORED THE  NCOLR  ELEMENTS OF THE NEW
+C  COLUMN OF  R  IN THE ARRAY  RT,  AND SET THE VARIABLES  NOCURV,
+C  POSDEF,  RENEWR,  DRMAX,  EMAX  AND  HSIZE.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  ORIGINAL VERSION MARCH 1982.  REV. APRIL 1982.
+C  *********************************************************************
+C
+      INTEGER            J, JTHCOL, K, NCOLR1
+      DOUBLE PRECISION   EPSMCH, RDSMAX, RDSMIN, RDSQ, RNORM, S, ZTHZ
+      DOUBLE PRECISION   ZERO, ONE, TWO, TEN
+      DOUBLE PRECISION   DSQRT, V2NORM
+      DOUBLE PRECISION   DABS, DMAX1
+      DATA               ZERO  , ONE   , TWO   , TEN
+     *                  /0.0D+0, 1.0D+0, 2.0D+0, 10.0D+0/
+C
+      EPSMCH = WMACH(3)
+C
+      IF (RENEWR) GO TO 300
+C
+C  ---------------------------------------------------------------------
+C  ONLY THE LAST ELEMENT OF THE NEW COLUMN OF  R  NEED BE COMPUTED.
+C  THIS SITUATION CAN ONLY OCCUR WHEN A CONSTRAINT IS ADDED TO THE
+C  WORKING SET WITH  ZTHZ  NOT POSITIVE DEFINITE.
+C  ---------------------------------------------------------------------
+C  THE LAST DIAGONAL ELEMENT OF  R  IS THAT OF  ZTHZ  PLUS A DIAGONAL
+C  MODIFICATION.  THE SQUARE OF THE TRUE DIAGONAL IS RECOVERED FROM THE
+C  ROTATIONS USED TO UPDATE  R  WHEN THE CONSTRAINT WAS ADDED TO THE
+C  WORKING SET.
+C
+      RDLAST = RT(NCOLR,NCOLR)
+      S      = DABS( SNLAST )
+      RDSQ   = ( (CSLAST - S)*RDLAST )*( (CSLAST + S)*RDLAST )
+      GO TO 600
+C
+C  ---------------------------------------------------------------------
+C  THE PROJECTED HESSIAN IS EXPANDED BY A ROW AND COLUMN.  COMPUTE THE
+C  FIRST  (NCOLR - 1)  ELEMENTS OF THE NEW COLUMN OF THE CHOLESKY FACTOR
+C  R.  ALSO, COMPUTE  RDSQ,  THE SQUARE OF THE LAST DIAGONAL ELEMENT.
+C  ---------------------------------------------------------------------
+  300 CALL ZEROVC( N, WRK, N, 1 )
+      IF (UNITQ) GO TO 320
+C
+C  EXPAND THE NEW COLUMN OF Z IN TO AN N-VECTOR.
+C
+      DO 310 K = 1, NFREE
+         J      = KFREE(K)
+         WRK(J) = ZY(K,NCOLR)
+  310 CONTINUE
+      IF (SCLDQP) CALL DSCALE( N, SCALE, N, 1, WRK, N, 1 )
+      JTHCOL = 0
+      GO TO 330
+C
+C  ONLY BOUNDS ARE IN THE WORKING SET (NFREE  IS EQUAL TO  NCOLZ).  THE
+C  (NCOLR)-TH  COLUMN OF  Z  IS JUST A COLUMN OF THE IDENTITY MATRIX.
+C
+  320 JTHCOL      = KFREE(NCOLR)
+      WRK(JTHCOL) = ONE
+C
+C  COMPUTE THE HESSIAN TIMES THE LAST COLUMN OF Z.
+C
+  330 CALL QPHESS( N, NROWH, NCOLH, JTHCOL, HESS, WRK, HZ )
+      NHESS  = NHESS + 1
+C
+      IF (UNITQ  .AND.  SCLDQP) CALL SSCALE( N, SCALE(JTHCOL), HZ, N,1 )
+      IF (              SCLDQP) CALL DSCALE( N, SCALE, N, 1,   HZ, N,1 )
+C
+C  COMPUTE THE  (NCOLR)-TH  COLUMN OF  Z(T)H Z.
+C
+      CALL ZYPROD( 4, N, NFREE, NCOLR, NFREE, NQ, UNITQ,
+     *             KFREE, KFREE, HZ, ZY, WRK )
+C
+      CALL COPYVC( NCOLR, HZ, NCOLR, 1, RT(1,NCOLR), NCOLR, 1 )
+C
+C  COMPUTE THE FIRST  (NCOLR - 1)  ELEMENTS OF THE LAST COLUMN OF  R.
+C
+      NCOLR1 = NCOLR - 1
+      ZTHZ   = RT(NCOLR,NCOLR)
+      RDSQ   = ZTHZ
+      IF (NCOLR1 .EQ. 0) GO TO 370
+      CALL RSOLVE( 2, NROWRT, NCOLR1, RT, RT(1,NCOLR) )
+      RNORM  = V2NORM( NCOLR1, RT(1,NCOLR), NCOLR1, 1 )
+C
+C  COMPUTE THE SQUARE OF THE LAST DIAGONAL ELEMENT OF  R.
+C
+      RDSQ   = ZTHZ - RNORM*RNORM
+C
+C  UPDATE THE ESTIMATE OF THE NORM OF THE HESSIAN.
+C
+  370 HSIZE  = DMAX1( HSIZE, DABS( ZTHZ ) )
+C
+C  ---------------------------------------------------------------------
+C  COMPUTE  RDLAST, THE LAST DIAGONAL OF  R.  THE VARIABLES POSDEF  AND
+C  NOCURV  ARE SET HERE.  THEY ARE USED TO INDICATE IF THE NEW PROJECTED
+C  HESSIAN IS POSITIVE DEFINITE OR SINGULAR.  IF  POSDEF  IS SET TO
+C  FALSE,  RDLAST  WILL BE THAT OF  ZTHZ  PLUS A DIAGONAL MODIFICATION.
+C  IF THE REQUIRED DIAGONAL MODIFICATION IS LARGE,  RENEWR  WILL BE SET
+C  TO BE  TRUE,  INDICATING THAT THE LAST ROW AND COLUMN OF  R  MUST BE
+C  RECOMPUTED WHEN A CONSTRAINT IS ADDED TO THE WORKING SET DURING THE
+C  NEXT ITERATION.
+C  ---------------------------------------------------------------------
+  600 NOCURV = .FALSE.
+      RENEWR = .FALSE.
+      EMAX   = ZERO
+C
+C  RDSMIN  IS THE SQUARE OF THE SMALLEST ALLOWABLE DIAGONAL ELEMENT
+C  FOR A POSITIVE-DEFINITE CHOLESKY FACTOR.  NOTE THAT THE TEST FOR A
+C  SINGULAR MATRIX IS SCALE DEPENDENT.
+C
+      IF (NCOLR .EQ. 1) RDSMIN =  EPSMCH*HSIZE
+      IF (NCOLR .GT. 1) RDSMIN = (EPSMCH*DRMAX) * DRMAX
+      POSDEF = RDSQ .GT. RDSMIN
+      IF (POSDEF) GO TO 900
+C
+      IF (RDSQ .LT. ( - RDSMIN )) GO TO 610
+C
+C  ---------------------------------------------------------------------
+C  THE PROJECTED HESSIAN IS SINGULAR.
+C  ---------------------------------------------------------------------
+C  THE QUADRATIC HAS NO CURVATURE ALONG AT LEAST ONE DIRECTION.  THE
+C  PERTURBATION  EMAX  IS CHOSEN TO MAKE THE NEW EIGENVALUE OF  ZTHZ
+C  SMALL AND POSITIVE.
+C
+      EMAX   = RDSMIN - RDSQ
+      RDSQ   = RDSMIN
+      NOCURV = .TRUE.
+      GO TO 900
+C
+C  ---------------------------------------------------------------------
+C  THE PROJECTED HESSIAN IS INDEFINITE.  THERE ARE TWO CASES.
+C  ---------------------------------------------------------------------
+C  CASE 1.  THE MODULUS OF THE NEW LAST DIAGONAL OF  R  IS NOT TOO
+C  LARGE.  THE MODULUS OF  RDSQ  IS USED FOR THE SQUARE ROOT.
+C
+  610 RDSMAX  = TEN * HSIZE
+      IF (RDSQ .LT. ( - RDSMAX )) GO TO 620
+      EMAX    = - TWO*RDSQ
+      GO TO 900
+C
+C  CASE 2.  THE MODULUS OF THE LAST DIAGONAL OF  R  IS JUDGED TO BE TOO
+C  LARGE (SOME LOSS OF PRECISION MAY HAVE OCCURRED).  SET  RENEWR  SO
+C  THAT THE LAST COLUMN IS RECOMPUTED LATER.
+C
+  620 EMAX   = RDSMAX - RDSQ
+      RENEWR = .TRUE.
+      RDSQ   = RDSMAX
+C
+C  COMPUTE THE LAST DIAGONAL ELEMENT.
+C
+  900 RDLAST = DSQRT( DABS( RDSQ ) )
+      RT(NCOLR,NCOLR) = RDLAST
+C
+      IF (MSG .GE. 80  .AND.  (.NOT. POSDEF))
+     *WRITE (NOUT, 9000) POSDEF, NOCURV, EMAX, RDLAST
+C
+      RETURN
+C
+ 9000 FORMAT(/ 54H //QPCOLR//  POSDEF NOCURV          EMAX        RDLAST
+     *       / 13H //QPCOLR//  , L6, 1X, L6, 2(1PE14.4) )
+C
+C  END OF QPCOLR
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/qpcore.f
@@ -0,0 +1,590 @@
+      SUBROUTINE QPCORE( NAMED, ORTHOG, UNITQ, INFORM, ITER, ITMAX,
+     *                   N, NCLIN, NCTOTL, NROWA, NROWH, NCOLH,
+     *                   NACTIV, NFREE, QPHESS, ISTATE, KACTIV, KFREE,
+     *                   OBJQP, XNORM,
+     *                   A, AX, BL, BU, CLAMDA, CVEC,
+     *                   FEATOL, HESS, SCALE, X, IW, LIW, W, LW )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      INTEGER            INFORM, ITER, ITMAX, N, NCLIN, NCTOTL, NROWA,
+     *                   NROWH, NCOLH, NACTIV, NFREE, LIW, LW
+      INTEGER            ISTATE(NCTOTL), KACTIV(N), KFREE(N)
+      INTEGER            IW(LIW)
+      DOUBLE PRECISION   ASIZE, DTMAX, DTMIN, OBJQP, XNORM
+      DOUBLE PRECISION   A(NROWA,N), AX(NROWA), BL(NCTOTL), BU(NCTOTL),
+     *                   CLAMDA(NCTOTL), CVEC(N), FEATOL(NCTOTL),
+     *                   HESS(NROWH,NCOLH), SCALE(NCTOTL), X(N)
+      DOUBLE PRECISION   W(LW)
+      LOGICAL            NAMED, ORTHOG, UNITQ
+      EXTERNAL           QPHESS
+C
+      INTEGER            NOUT, MSG, ISTART, LENNAM, NROWRT, NCOLRT, NQ
+      DOUBLE PRECISION   PARM, WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+      COMMON    /SOL3CM/ LENNAM, NROWRT, NCOLRT, NQ
+      COMMON    /SOL4CM/ PARM(10)
+      COMMON    /SOL5CM/ ASIZE, DTMAX, DTMIN
+C
+      INTEGER            LOCLP
+      COMMON    /SOL1LP/ LOCLP(15)
+C
+C  *********************************************************************
+C  QPCORE, A SUBROUTINE FOR INDEFINITE QUADRATIC PROGRAMMING.
+C  IT IS ASSUMED THAT A PREVIOUS CALL TO EITHER  LPCORE  OR  QPCORE
+C  HAS DEFINED AN INITIAL WORKING SET OF LINEAR CONSTRAINTS AND BOUNDS.
+C  ISTATE, KACTIV  AND  KFREE  WILL HAVE BEEN SET ACCORDINGLY,
+C  AND THE ARRAYS  RT  AND  ZY  WILL CONTAIN THE TQ FACTORIZATION
+C  OF THE MATRIX WHOSE ROWS ARE THE GRADIENTS OF THE ACTIVE LINEAR
+C  CONSTRAINTS WITH THE COLUMNS CORRESPONDING TO THE ACTIVE BOUNDS
+C  REMOVED.  THE TQ FACTORIZATION OF THE RESULTING (NACTIV BY NFREE)
+C  MATRIX IS  A(FREE)*Q = (0 T),  WHERE  Q  IS (NFREE BY NFREE) AND  T
+C  IS REVERSE-TRIANGULAR.
+C
+C  VALUES OF ISTATE(J) FOR THE LINEAR CONSTRAINTS.......
+C
+C  ISTATE(J)
+C  ---------
+C          0   CONSTRAINT  J  IS NOT IN THE WORKING SET.
+C          1   CONSTRAINT  J  IS IN THE WORKING SET AT ITS LOWER BOUND.
+C          2   CONSTRAINT  J  IS IN THE WORKING SET AT ITS UPPER BOUND.
+C          3   CONSTRAINT  J  IS IN THE WORKING SET AS AN EQUALITY.
+C          4   THE J-TH VARIABLE IS TEMPORARILY FIXED AT THE VALUE X(J).
+C              THE CORRESPONDING ARTIFICIAL BOUND IS INCLUDED IN THE
+C              WORKING SET (THE  TQ  FACTORIZATION IS ADJUSTED
+C              ACCORDINGLY).
+C
+C  CONSTRAINT  J  MAY BE VIOLATED BY AS MUCH AS  FEATOL(J).
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION 1   OF DECEMBER 1981.
+C  VERSION 2   OF     JUNE 1982.
+C  VERSION 3   OF  JANUARY 1983.
+C  VERSION 3.1 OF    APRIL 1983.
+C  VERSION 3.2 OF    APRIL 1984.
+C
+C  COPYRIGHT  1983  STANFORD UNIVERSITY.
+C
+C  THIS MATERIAL MAY BE REPRODUCED BY OR FOR THE U.S. GOVERNMENT PURSU-
+C  ANT TO THE COPYRIGHT LICENSE UNDER DAR CLAUSE 7-104.9(A) (1979 MAR).
+C
+C  THIS MATERIAL IS BASED UPON WORK PARTIALLY SUPPORTED BY THE NATIONAL
+C  SCIENCE FOUNDATION UNDER GRANTS MCS-7926009 AND ECS-8012974; THE
+C  DEPARTMENT OF ENERGY CONTRACT AM03-76SF00326, PA NO. DE-AT03-
+C  76ER72018; AND THE ARMY RESEARCH OFFICE CONTRACT DAA29-79-C-0110.
+C
+C  *********************************************************************
+C
+      INTEGER            IADD, IDUMMY, IFIX, ISDEL, ISSAVE, JADD, JDEL,
+     *                   JDSAVE, JSMLST, KB, KDEL, KGFIX, KSMLST,
+     *                   LANORM, LAP, LENR, LNAMES, LPROB, LPX, LQTG,
+     *                   LRLAM, LROWA, LRT, LWRK, LZY, MODE, MSGLVL,
+     *                   MSTALL, NCNLN, NCLIN0, NCOLR, NCOLZ, NFIXED,
+     *                   NHESS, NROWJ, NSTALL, NUMINF
+      INTEGER            MAX0
+      DOUBLE PRECISION   ALFA, ALFHIT, ANORM, ATPHIT, BIGALF, BIGBND,
+     *                   BIGDX, BND, CONDH, CONDMX, CONDT, CSLAST,
+     *                   DINKY, DRMAX, DRMIN, EMAX, EPSMCH, EPSPT9,
+     *                   FLMAX, GFIXED, GFNORM, GTP, HSIZE,
+     *                   OBJSIZ, PALFA, PNORM, RDLAST, RTMAX, SMLLST,
+     *                   SNLAST, ZTGNRM
+      DOUBLE PRECISION   DSQRT, QUOTNT, V2NORM
+      DOUBLE PRECISION   DABS, DMAX1
+      LOGICAL            FIRSTV, HITLOW, MODFYG, MODFYR,
+     *                   NOCURV, NULLR, POSDEF, REFINE, RENEWR, STALL,
+     *                   UNCON, UNITPG, ZEROLM
+      DOUBLE PRECISION   ZERO  , ONE
+      DATA               ZERO  , ONE
+     *                  /0.0D+0, 1.0D+0/
+      DATA               LPROB     / 2HQP  /
+      DATA               MSTALL    /  50   /
+C
+C  SPECIFY MACHINE-DEPENDENT PARAMETERS.
+C
+      EPSMCH = WMACH(3)
+      FLMAX  = WMACH(7)
+      RTMAX  = WMACH(8)
+C
+      LNAMES = LOCLP( 1)
+      LANORM = LOCLP( 4)
+      LAP    = LOCLP( 5)
+      LPX    = LOCLP( 6)
+      LQTG   = LOCLP( 7)
+      LRLAM  = LOCLP( 8)
+      LRT    = LOCLP( 9)
+      LZY    = LOCLP(10)
+      LWRK   = LOCLP(11)
+C
+C  INITIALIZE
+C
+      INFORM = 0
+      ITER   = 0
+      JADD   = 0
+      JDEL   = 0
+      JDSAVE = 0
+      LROWA  = NROWA*(N - 1) + 1
+      NCLIN0 = MAX0( NCLIN, 1 )
+      NCNLN  = 0
+      NCOLZ  = NFREE - NACTIV
+      NROWJ  = 1
+      NSTALL = 0
+      NHESS  = 0
+      NUMINF = 0
+C
+      MSGLVL = MSG
+      MSG    = 0
+      IF (ISTART .EQ. 0) MSG = MSGLVL
+C
+      BIGBND = PARM(1)
+      BIGDX  = PARM(2)
+      EPSPT9 = PARM(4)
+C
+      ALFA   = ZERO
+      CONDMX = FLMAX
+      DRMAX  = ONE
+      DRMIN  = ONE
+      EMAX   = ZERO
+      HSIZE  = ONE
+C
+      FIRSTV = .FALSE.
+      MODFYR = .TRUE.
+      MODFYG = .TRUE.
+      NOCURV = .FALSE.
+      NULLR  = .FALSE.
+      POSDEF = .TRUE.
+      REFINE = .FALSE.
+      STALL  = .TRUE.
+      UNCON  = .FALSE.
+      UNITPG = .FALSE.
+      ZEROLM = .FALSE.
+C
+C  ---------------------------------------------------------------------
+C  GIVEN THE  TQ  FACTORIZATION OF THE MATRIX OF CONSTRAINTS IN THE
+C  WORKING SET, COMPUTE THE FOLLOWING QUANTITIES....
+C  (1) THE CHOLESKY FACTOR  R,  OF  Z(T)HZ  (IF  Z(T)HZ  IS NOT POSITIVE
+C      DEFINITE, FIND A POSITIVE-DEFINITE  (NCOLR)-TH  ORDER PRINCIPAL
+C      SUBMATRIX OF  Z(T)H Z,
+C  (2) THE  QP  OBJECTIVE FUNCTION,
+C  (3) THE VECTOR  Q(FREE)(T)G(FREE),
+C  (4) THE VECTOR  G(FIXED).
+C
+C  USE THE ARRAY  RLAM  AS TEMPORARY WORK SPACE.
+C  ---------------------------------------------------------------------
+      CALL QPCRSH( UNITQ, QPHESS, N, NCOLR, NCOLZ, NCTOTL, NFREE,
+     *             NHESS, NQ, NROWH, NCOLH, NROWRT, NCOLRT,
+     *             KFREE, HSIZE,
+     *             HESS, W(LRT), SCALE, W(LZY), W(LRLAM), W(LWRK) )
+C
+      MODE  = 1
+      CALL QPGRAD( MODE, UNITQ, QPHESS, N, NACTIV,
+     *             NCTOTL, NFREE, NHESS, NQ, NROWH, NCOLH, JADD,
+     *             KACTIV, KFREE, ALFA, OBJQP, GFIXED, GTP,
+     *             CVEC, HESS, W(LPX), W(LQTG), SCALE, X,
+     *             W(LZY), W(LWRK), W(LRLAM) )
+C
+C  .......................START OF THE MAIN LOOP........................
+C
+C  DURING THE MAIN LOOP, ONE OF THREE THINGS WILL HAPPEN
+C  (  I) THE CONVERGENCE CRITERION WILL BE SATISFIED AND THE ALGORITHM
+C        WILL TERMINATE.
+C  ( II) A LINEAR CONSTRAINT WILL BE DELETED.
+C  (III) A DIRECTION OF SEARCH WILL BE COMPUTED AND A CONSTRAINT MAY
+C        BE ADDED TO THE WORKING SET (NOTE THAT A ZERO STEP MAY BE TAKEN
+C        ALONG THE SEARCH DIRECTION).
+C
+C  THESE COMPUTATIONS OCCUR IN SECTIONS I, II, AND III OF THE MAIN LOOP.
+C
+C  ---------------------------------------------------------------------
+C    ******* SECTION I.  TEST FOR CONVERGENCE **************************
+C  ---------------------------------------------------------------------
+C  COMPUTE THE NORMS OF THE PROJECTED GRADIENT AND THE GRADIENT WITH
+C  RESPECT TO THE FREE VARIABLES.
+C
+  100 ZTGNRM = ZERO
+      IF (NCOLR .GT. 0) ZTGNRM = V2NORM( NCOLR, W(LQTG), NCOLR, 1 )
+      GFNORM = ZTGNRM
+      IF (NFREE .GT. 0  .AND.  NACTIV .GT. 0)
+     *                  GFNORM = V2NORM( NFREE, W(LQTG), NFREE, 1 )
+C
+C  DEFINE SMALL QUANTITIES THAT REFLECT THE MAGNITUDE OF  C,  X,  H
+C  AND THE MATRIX OF CONSTRAINTS IN THE WORKING SET.
+C
+      OBJSIZ = (EPSMCH + DABS( OBJQP )) / (EPSMCH + XNORM)
+      ANORM  = ZERO
+      IF (NACTIV .GT. 0) ANORM = DABS( DTMAX )
+      DINKY  = EPSPT9 * DMAX1( ANORM, OBJSIZ, GFNORM )
+C
+      IF (MSG .GE. 80) WRITE (NOUT, 9000) ZTGNRM, DINKY
+C
+C  ---------------------------------------------------------------------
+C  PRINT THE DETAILS OF THIS ITERATION.
+C  ---------------------------------------------------------------------
+C  USE THE LARGEST AND SMALLEST DIAGONALS OF  R  TO ESTIMATE THE
+C  CONDITION NUMBER OF THE PROJECTED HESSIAN MATRIX.
+C
+      CONDT  = QUOTNT( DTMAX, DTMIN )
+C
+      LENR   = NROWRT*NCOLR
+      IF (NCOLR .GT. 0)
+     *   CALL CONDVC( NCOLR, W(LRT), LENR, NROWRT + 1, DRMAX, DRMIN )
+      CONDH  = QUOTNT( DRMAX, DRMIN )
+      IF (CONDH .GE. RTMAX) CONDH = FLMAX
+      IF (CONDH .LT. RTMAX) CONDH = CONDH*CONDH
+C
+      CALL QPPRT ( ORTHOG, ISDEL, ITER, JADD, JDEL, NACTIV,
+     *             NCOLR, NCOLZ, NFREE, N, NCLIN, NCLIN0, NCTOTL,
+     *             NROWA, NROWRT, NCOLRT, NHESS,
+     *             ISTATE, KFREE,
+     *             ALFA, CONDH, CONDT, OBJQP, GFNORM, ZTGNRM, EMAX,
+     *             A, W(LRT), X, W(LWRK), W(LAP) )
+C
+      JADD   = 0
+      JDEL   = 0
+C
+      IF (.NOT. POSDEF) GO TO 300
+      IF (ZTGNRM .LE. DINKY) UNITPG = .TRUE.
+      IF (ZTGNRM .LE. DINKY) GO TO 110
+C
+      IF (.NOT. UNCON) REFINE = .FALSE.
+      IF (.NOT. UNCON) GO TO 300
+C
+      IF (UNITPG) UNITPG = .FALSE.
+C
+      IF (ZTGNRM .LE. DSQRT(DINKY)) GO TO 110
+C
+      IF (REFINE) GO TO 110
+C
+      REFINE = .TRUE.
+      GO TO 300
+C
+C  ---------------------------------------------------------------------
+C  THE PROJECTED GRADIENT IS NEGLIGIBLE AND THE PROJECTED HESSIAN
+C  IS POSITIVE DEFINITE.  IF  R  IS NOT COMPLETE IT MUST BE
+C  EXPANDED.  OTHERWISE, IF THE CURRENT POINT IS NOT OPTIMAL,
+C  A CONSTRAINT MUST BE DELETED FROM THE WORKING SET.
+C  ---------------------------------------------------------------------
+  110 ALFA   = ZERO
+      UNCON  = .FALSE.
+      REFINE = .FALSE.
+      JDEL   = - (NCOLR + 1)
+      IF (NCOLR .LT. NCOLZ) GO TO 220
+C
+      CALL GETLAM( LPROB, N, NCLIN0, NCTOTL,
+     *             NACTIV, NCOLZ, NFREE, NROWA,
+     *             NROWRT, NCOLRT, JSMLST, KSMLST, SMLLST,
+     *             ISTATE, KACTIV,
+     *             A, W(LANORM), W(LQTG), W(LRLAM), W(LRT) )
+C
+C  ---------------------------------------------------------------------
+C  TEST FOR CONVERGENCE.  IF THE LEAST (ADJUSTED) MULTIPLIER IS GREATER
+C  THAN THE SMALL POSITIVE QUANTITY  DINKY,  AN ADEQUATE SOLUTION HAS
+C  BEEN FOUND.
+C  ---------------------------------------------------------------------
+      IF (SMLLST .GT. DINKY) GO TO 900
+C
+C  ---------------------------------------------------------------------
+C    ******* SECTION II.  DELETE A CONSTRAINT FROM THE WORKING SET *****
+C  ---------------------------------------------------------------------
+C  DELETE THE CONSTRAINT WITH THE LEAST (ADJUSTED) MULTIPLIER.
+C
+C  FIRST CHECK IF THERE ARE ANY TINY MULTIPLIERS
+C
+      IF (SMLLST .GT. ( - DINKY )) ZEROLM = .TRUE.
+      JDEL   = JSMLST
+      JDSAVE = JSMLST
+      KDEL   = KSMLST
+      ISDEL  = ISTATE(JDEL)
+      ISSAVE = ISDEL
+      ISTATE(JDEL) = 0
+C
+C  UPDATE THE  TQ  FACTORIZATION OF THE MATRIX OF CONSTRAINTS IN THE
+C  WORKING SET.
+C
+      CALL DELCON( MODFYG, ORTHOG, UNITQ,
+     *             JDEL, KDEL, NACTIV, NCOLZ, NFREE,
+     *             N, NQ, NROWA, NROWRT, NCOLRT,
+     *             KACTIV, KFREE,
+     *             A, W(LQTG), W(LRT), W(LZY) )
+C
+      NCOLZ  = NCOLZ + 1
+      IF (JDEL .LE. N) NFREE  = NFREE  + 1
+      IF (JDEL .GT. N) NACTIV = NACTIV - 1
+C
+C  ---------------------------------------------------------------------
+C  THE PROJECTED HESSIAN IS EXPANDED BY A ROW AND COLUMN.  COMPUTE THE
+C  ELEMENTS OF THE NEW COLUMN OF THE CHOLESKY FACTOR  R.
+C  USE THE ARRAY  P  AS TEMPORARY WORK SPACE.
+C  ---------------------------------------------------------------------
+  220 RENEWR = .TRUE.
+      NCOLR  = NCOLR + 1
+      CALL QPCOLR( NOCURV, POSDEF, RENEWR, UNITQ, QPHESS,
+     *             N, NCOLR, NCTOTL, NFREE, NQ, NROWH, NCOLH,
+     *             NROWRT, NCOLRT, NHESS, KFREE,
+     *             CSLAST, SNLAST, DRMAX, EMAX, HSIZE, RDLAST,
+     *             HESS, W(LRT), SCALE, W(LZY), W(LPX), W(LWRK) )
+C
+C  REPEAT THE MAIN LOOP.
+C
+      GO TO 100
+C
+C  ---------------------------------------------------------------------
+C    ******* SECTION III.  COMPUTE THE SEARCH DIRECTION *******
+C  ---------------------------------------------------------------------
+C  FIRST, CHECK FOR A WEAK LOCAL MINIMUM. EXIT IF THE NORM OF THE
+C  PROJECTED GRADIENT IS SMALL AND THE CURVATURE ALONG  P  IS NOT
+C  SIGNIFICANT.  ALSO, CHECK FOR TOO MANY ITERATIONS AND UPDATE THE
+C  ITERATION COUNT.  THE ITERATION COUNTER IS ONLY UPDATED WHEN A SEARCH
+C  DIRECTION IS COMPUTED.
+C
+  300 IF(ZTGNRM .LT. DINKY .AND. NCOLR .EQ. NCOLZ .AND. NOCURV)GO TO 910
+      IF (ZEROLM             .AND.  NOCURV) GO TO 910
+      IF (ITER .GE. ITMAX)                  GO TO 950
+      ITER   = ITER + 1
+      IF (ITER .GE. ISTART) MSG = MSGLVL
+C
+      CALL FINDP ( NULLR, UNITPG, UNITQ,
+     *             N, NCLIN, NCLIN0, NCTOTL, NQ,
+     *             NROWA, NROWRT, NCOLRT, NCOLR, NCOLZ, NFREE,
+     *             ISTATE, KFREE,
+     *             DINKY, GTP, PNORM, RDLAST, ZTGNRM,
+     *             A, W(LAP), W(LPX), W(LQTG), W(LRT), W(LWRK),
+     *             W(LZY), W(LWRK) )
+C
+C  IF A CONSTRAINT HAS JUST BEEN DELETED AND THE PROJECTED GRADIENT IS
+C  SMALL (THIS CAN ONLY OCCUR HERE WHEN THE PROJECTED HESSIAN IS
+C  INDEFINITE), THE SIGN OF  P  MAY BE INCORRECT BECAUSE OF ROUNDING
+C  ERRORS IN THE COMPUTATION OF  ZTG.  FIX THE SIGN OF  P  BY FORCING IT
+C  TO SATISFY THE CONSTRAINT THAT WAS JUST DELETED.
+C
+      IF ((JDSAVE .GT. 0  .AND.  ZTGNRM .LE. DINKY)  .OR.  ZEROLM)
+     *CALL QPCHKP( N, NCLIN, NCLIN0, ISSAVE, JDSAVE, W(LAP), W(LPX) )
+C
+C  ---------------------------------------------------------------------
+C  FIND THE CONSTRAINT WE BUMP INTO ALONG P.
+C  UPDATE X AND A*X IF THE STEP ALFA IS NONZERO.
+C  ---------------------------------------------------------------------
+C  ALFHIT  IS INITIALIZED TO  BIGALF.  IF IT REMAINS THAT WAY AFTER
+C  THE CALL TO BNDALF, IT WILL BE REGARDED AS INFINITE.
+C
+      BIGALF = QUOTNT( BIGDX, PNORM )
+C
+      CALL BNDALF( FIRSTV, HITLOW, ISTATE, INFORM, JADD,
+     *             N, NROWA, NCLIN, NCLIN0, NCTOTL, NUMINF,
+     *             ALFHIT, PALFA, ATPHIT, BIGALF, BIGBND, PNORM,
+     *             W(LANORM), W(LAP), AX, BL, BU, FEATOL, W(LPX), X )
+C
+C  IF THE PROJECTED HESSIAN IS POSITIVE DEFINITE, THE STEP  ALFA = 1.0
+C  WILL BE THE STEP TO THE MINIMUM OF THE QUADRATIC FUNCTION ON THE
+C  CURRENT SUBSPACE.
+C
+      ALFA   = ONE
+C
+C  IF THE STEP TO THE MINIMUM ON THE SUBSPACE IS LESS THAN THE DISTANCE
+C  TO THE NEAREST CONSTRAINT,  THE CONSTRAINT IS NOT ADDED TO THE
+C  WORKING SET.
+C
+      UNCON  = PALFA .GT. ONE  .AND.  POSDEF
+      IF (      UNCON) JADD = 0
+      IF (.NOT. UNCON) ALFA = ALFHIT
+C
+C  CHECK FOR AN UNBOUNDED SOLUTION.
+C
+      IF (ALFA .GE. BIGALF) GO TO 920
+C
+C  TEST IF THE CHANGE IN  X  IS NEGLIGIBLE.
+C
+      STALL  = DABS( ALFA*PNORM ) .LE. EPSPT9*XNORM
+      IF (.NOT. STALL) GO TO 410
+C
+C  TAKE A ZERO STEP.
+C  EXIT IF MORE THAN  50  ITERATIONS OCCUR WITHOUT CHANGING  X.  IF SUCH
+C  AN EXIT IS MADE WHEN THERE ARE SOME NEAR-ZERO MULTIPLIERS, THE USER
+C  SHOULD CALL A SEPARATE ROUTINE THAT CHECKS THE SOLUTION.
+C
+      ALFA   = ZERO
+      NSTALL = NSTALL + 1
+      IF (NSTALL .LE. MSTALL) GO TO 420
+      GO TO 940
+C
+C  ---------------------------------------------------------------------
+C  COMPUTE THE NEW VALUE OF THE QP OBJECTIVE FUNCTION.  IF ITS VALUE HAS
+C  NOT INCREASED,  UPDATE  OBJQP,  Q(FREE)(T)G(FREE)  AND  G(FIXED).
+C  AN INCREASE IN THE OBJECTIVE CAN OCCUR ONLY AFTER A MOVE ALONG
+C  A DIRECTION OF NEGATIVE CURVATURE FROM A POINT WITH TINY MULTIPLIERS.
+C  USE THE ARRAY  RLAM  AS TEMPORARY STORAGE.
+C  ---------------------------------------------------------------------
+  410 MODE  = 2
+      CALL QPGRAD( MODE, UNITQ, QPHESS, N, NACTIV,
+     *             NCTOTL, NFREE, NHESS, NQ, NROWH, NCOLH, JADD,
+     *             KACTIV, KFREE, ALFA, OBJQP, GFIXED, GTP,
+     *             CVEC, HESS, W(LPX), W(LQTG), SCALE, X,
+     *             W(LZY), W(LWRK), W(LRLAM) )
+C
+      IF (MODE .LT. 0) GO TO 910
+C
+C  CHANGE  X  TO  X + ALFA*P.  UPDATE  AX  ALSO.
+C  WE NO LONGER NEED TO REMEMBER JDSAVE, THE LAST CONSTRAINT DELETED.
+C
+      NSTALL = 0
+      JDSAVE = 0
+      ZEROLM = .FALSE.
+C
+      CALL AXPY  ( N    , ALFA, W(LPX), N    , 1, X , N    , 1 )
+      IF (NCLIN .GT. 0)
+     *CALL AXPY  ( NCLIN, ALFA, W(LAP), NCLIN, 1, AX, NCLIN, 1 )
+C
+      XNORM  = V2NORM( N, X, N, 1 )
+C
+C  IF AN UNCONSTRAINED STEP WAS TAKEN, REPEAT THE MAIN LOOP.
+C
+  420 IF (UNCON) GO TO 100
+C
+C  ---------------------------------------------------------------------
+C  ADD A CONSTRAINT TO THE WORKING SET.
+C  ---------------------------------------------------------------------
+C  UPDATE  ISTATE.
+C
+      IF (      HITLOW)           ISTATE(JADD) = 1
+      IF (.NOT. HITLOW)           ISTATE(JADD) = 2
+      IF (BL(JADD) .EQ. BU(JADD)) ISTATE(JADD) = 3
+C
+C  IF A BOUND IS TO BE ADDED, MOVE  X  EXACTLY ONTO IT, EXCEPT WHEN
+C  A NEGATIVE STEP WAS TAKEN.  (BNDALF  MAY HAVE HAD TO MOVE TO SOME
+C  OTHER CLOSER CONSTRAINT.)
+C
+      IADD = JADD - N
+      IF (JADD .GT. N) GO TO 520
+      IF (      HITLOW) BND = BL(JADD)
+      IF (.NOT. HITLOW) BND = BU(JADD)
+      IF (ALFA .GE. ZERO) X(JADD) = BND
+C
+      DO 510 IFIX = 1, NFREE
+         IF (KFREE(IFIX) .EQ. JADD) GO TO 520
+  510 CONTINUE
+C
+C  UPDATE THE  TQ  FACTORS OF THE MATRIX OF CONSTRAINTS IN THE WORKING
+C  SET.  USE THE ARRAY  P  AS TEMPORARY WORK SPACE.
+C
+  520 CALL ADDCON( MODFYG, MODFYR, ORTHOG, UNITQ, INFORM,
+     *             IFIX, IADD, JADD, NACTIV, NCOLR, NCOLZ, NFREE,
+     *             N, NQ, NROWA, NROWRT, NCOLRT, KFREE,
+     *             CONDMX, CSLAST, SNLAST,
+     *             A, W(LQTG), W(LRT), W(LZY), W(LWRK), W(LPX) )
+C
+      NCOLR  = NCOLR - 1
+      NCOLZ  = NCOLZ - 1
+      NFIXED = N     - NFREE
+      IF (NFIXED .EQ. 0) GO TO 540
+      KB     = NACTIV + NFIXED
+      DO 530 IDUMMY = 1, NFIXED
+         KACTIV(KB+1) = KACTIV(KB)
+         KB           = KB - 1
+  530 CONTINUE
+  540 IF (JADD .GT. N) GO TO 550
+C
+C  ADD A BOUND.  IF STABILIZED ELIMINATIONS ARE BEING USED TO UPDATE
+C  THE  TQ  FACTORIZATION,  RECOMPUTE THE COMPONENT OF THE GRADIENT
+C  CORRESPONDING TO THE NEWLY FIXED VARIABLE.
+C  USE THE ARRAY  P  AS TEMPORARY WORK SPACE.
+C
+      NFREE  = NFREE  - 1
+      KACTIV(NACTIV+1) = JADD
+      IF (ORTHOG) GO TO 560
+C
+      KGFIX  = LQTG + NFREE
+      MODE   = 3
+      CALL QPGRAD( MODE, UNITQ, QPHESS, N, NACTIV,
+     *             NCTOTL, NFREE, NHESS, NQ, NROWH, NCOLH, JADD,
+     *             KACTIV, KFREE, ALFA, OBJQP, W(KGFIX), GTP,
+     *             CVEC, HESS, W(LPX), W(LQTG), SCALE, X,
+     *             W(LZY), W(LWRK), W(LPX) )
+C
+      GO TO 560
+C
+C  ADD A GENERAL LINEAR CONSTRAINT.
+C
+  550 NACTIV = NACTIV + 1
+      KACTIV(NACTIV) = IADD
+C
+C  REPEAT THE MAIN LOOP IF THE PROJECTED HESSIAN THAT WAS USED TO
+C  COMPUTE THIS SEARCH DIRECTION WAS POSITIVE DEFINITE.
+C
+  560 IF (NCOLR .EQ. 0) POSDEF = .TRUE.
+      IF (NCOLR .EQ. 0) EMAX   = ZERO
+C
+C  ---------------------------------------------------------------------
+C  THE PROJECTED HESSIAN WAS NOT SUFFICIENTLY POSITIVE DEFINITE BEFORE
+C  THE CONSTRAINT WAS ADDED.  EITHER COMPUTE THE TRUE VALUE OF THE LAST
+C  DIAGONAL OF  R  OR  RECOMPUTE THE WHOLE OF ITS LAST COLUMN.
+C  USE THE ARRAY  RLAM  AS TEMPORARY WORK SPACE.
+C  ---------------------------------------------------------------------
+      IF (.NOT. POSDEF)
+     *CALL QPCOLR( NOCURV, POSDEF, RENEWR, UNITQ, QPHESS,
+     *             N, NCOLR, NCTOTL, NFREE, NQ, NROWH, NCOLH,
+     *             NROWRT, NCOLRT, NHESS, KFREE,
+     *             CSLAST, SNLAST, DRMAX, EMAX, HSIZE, RDLAST,
+     *             HESS, W(LRT), SCALE, W(LZY), W(LRLAM), W(LWRK) )
+C
+C  REPEAT THE MAIN LOOP.
+C
+      GO TO 100
+C
+C  .........................END OF MAIN LOOP............................
+C
+C  OPTIMAL QP SOLUTION FOUND.
+C
+  900 INFORM = 0
+      GO TO 960
+C
+C  WEAK LOCAL MINIMUM.
+C
+  910 INFORM = 1
+      GO TO 960
+C
+C  UNBOUNDED QP.
+C
+  920 INFORM = 2
+      GO TO 960
+C
+C  UNABLE TO VERIFY OPTIMALITY OF A STATIONARY POINT WITH TINY OR
+C  ZERO MULTIPLIERS.
+C
+  930 INFORM = 3
+      GO TO 960
+C
+C  TOO MANY ITERATIONS WITHOUT CHANGING X.
+C
+  940 IF (ZEROLM) GO TO 930
+      INFORM = 4
+      GO TO 960
+C
+C  TOO MANY ITERATIONS.
+C
+  950 INFORM = 5
+C
+C  PRINT FULL SOLUTION.
+C
+  960 MSG    = MSGLVL
+      IF (MSG .GE. 1) WRITE (NOUT, 1000) INFORM, ITER
+C
+      IF (INFORM .GT. 0)
+     *CALL GETLAM( LPROB, N, NCLIN0, NCTOTL,
+     *             NACTIV, NCOLZ, NFREE, NROWA,
+     *             NROWRT, NCOLRT, JSMLST, KSMLST, SMLLST,
+     *             ISTATE, KACTIV,
+     *             A, W(LANORM), W(LQTG), W(LRLAM), W(LRT) )
+C
+      CALL PRTSOL( NFREE, NROWA, NROWJ,
+     *             N, NCLIN, NCNLN, NCTOTL, BIGBND,
+     *             NAMED, IW(LNAMES), LENNAM,
+     *             NACTIV, ISTATE, KACTIV,
+     *             A, BL, BU, X, CLAMDA, W(LRLAM), X )
+C
+      RETURN
+C
+ 1000 FORMAT(/ 26H EXIT QP PHASE.   INFORM =, I3, 9H   ITER =, I4)
+ 9000 FORMAT(/ 34H //QPCORE//      ZTGNRM      DINKY
+     *       / 11H //QPCORE//, 1P2E11.2 )
+C
+C  END OF QPCORE
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/qpcrsh.f
@@ -0,0 +1,188 @@
+      SUBROUTINE QPCRSH( UNITQ, QPHESS, N, NCOLR, NCOLZ, NCTOTL, NFREE,
+     *                   NHESS, NQ, NROWH, NCOLH, NROWRT, NCOLRT,
+     *                   KFREE, HSIZE,
+     *                   HESS, RT, SCALE, ZY, HZ, WRK )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      INTEGER            N, NCOLR, NCOLZ, NCTOTL, NFREE, NHESS, NQ,
+     *                   NROWH, NCOLH, NROWRT, NCOLRT
+      INTEGER            KFREE(N)
+      DOUBLE PRECISION   HSIZE
+      DOUBLE PRECISION   HESS(NROWH,NCOLH), RT(NROWRT,NCOLRT),
+     *                   SCALE(NCTOTL), ZY(NQ,NQ), HZ(N)
+      DOUBLE PRECISION   WRK(N)
+      LOGICAL            UNITQ
+      EXTERNAL           QPHESS
+C
+      INTEGER            NOUT, MSG, ISTART
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+C
+      LOGICAL            SCLDQP
+      COMMON    /SOL2LP/ SCLDQP
+C
+C  *********************************************************************
+C  QPCRSH  COMPUTES THE CHOLESKY FACTOR  R  OF THE PROJECTED HESSIAN
+C  Z(T) H Z,  GIVEN  Z  AND ITS DIMENSIONS  NFREE BY NCOLZ.
+C  IF THE PROJECTED HESSIAN IS INDEFINITE, A SMALLER CHOLESKY
+C  FACTORIZATION  R1(T) R1 = Z1(T) H Z1  IS RETURNED, WHERE  Z1  IS
+C  COMPOSED OF  NCOLR  COLUMNS OF  Z.  COLUMN INTERCHANGES ARE
+C  USED TO MAXIMIZE  NCOLR.  THESE ARE APPLIED TO  Z.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  ORIGINAL VERSION OF JANUARY 1983.
+C  *********************************************************************
+C
+      INTEGER            I, J, JTHCOL, J1, K, KMAX, KSAVE, LEN, NUM
+      DOUBLE PRECISION   D, DMAX, DMIN, EPSMCH, T
+      DOUBLE PRECISION   DSQRT
+      DOUBLE PRECISION   DABS, DMAX1
+      DOUBLE PRECISION   ZERO  , ONE
+      DATA               ZERO  , ONE
+     *                  /0.0D+0, 1.0D+0/
+C
+      EPSMCH = WMACH(3)
+C
+      NCOLR  = 0
+      IF (NCOLZ .EQ. 0) GO TO 900
+C
+C  ---------------------------------------------------------------------
+C  COMPUTE  Z(T) H Z  AND STORE THE UPPER-TRIANGULAR SYMMETRIC PART
+C  IN THE FIRST  NCOLZ  COLUMNS OF  RT.
+C  ---------------------------------------------------------------------
+      DO 200 K = 1, NCOLZ
+         CALL ZEROVC( N, WRK, N, 1 )
+         IF (UNITQ) GO TO 130
+C
+C        EXPAND THE COLUMN OF  Z  INTO AN  N-VECTOR.
+C
+         DO 120 I = 1, NFREE
+            J       = KFREE(I)
+            WRK(J) = ZY(I,K)
+  120    CONTINUE
+         IF (SCLDQP) CALL DSCALE( N, SCALE, N, 1, WRK, N, 1 )
+         JTHCOL = 0
+         GO TO 150
+C
+C        ONLY BOUNDS ARE IN THE WORKING SET.  THE  K-TH COLUMN OF  Z  IS
+C        JUST A COLUMN OF THE IDENTITY MATRIX.
+C
+  130    JTHCOL = KFREE(K)
+         WRK(JTHCOL) = ONE
+C
+C        SET  RT(*,K)  =  TOP OF   H * (COLUMN OF  Z).
+C
+  150    CALL QPHESS( N, NROWH, NCOLH, JTHCOL, HESS, WRK, HZ )
+         NHESS  = NHESS + 1
+C
+         IF (UNITQ  .AND.  SCLDQP)
+     *   CALL SSCALE( N, SCALE(JTHCOL), HZ, N, 1 )
+         IF (SCLDQP)
+     *   CALL DSCALE( N, SCALE, N, 1,   HZ, N, 1 )
+C
+         CALL ZYPROD( 4, N, NFREE, NCOLZ, NFREE, NQ, UNITQ,
+     *                KFREE, KFREE, HZ, ZY, WRK )
+C
+         CALL COPYVC( NCOLZ, HZ, NCOLZ, 1, RT(1,K), NCOLZ, 1 )
+C
+C        UPDATE AN ESTIMATE OF THE SIZE OF THE PROJECTED HESSIAN.
+C
+         HSIZE  = DMAX1( HSIZE, DABS(RT(K,K)) )
+  200 CONTINUE
+C
+C  ---------------------------------------------------------------------
+C  FORM THE CHOLESKY FACTORIZATION  R(T) R  =  Z(T) H Z  AS FAR AS
+C  POSSIBLE, USING SYMMETRIC ROW AND COLUMN INTERCHANGES.
+C  ---------------------------------------------------------------------
+      DMIN   = EPSMCH * HSIZE
+C
+      DO 400 J = 1, NCOLZ
+C
+C        FIND THE MAXIMUM REMAINING DIAGONAL.
+C
+         KMAX   = J
+         DMAX   = RT(J,J)
+         DO 310 K = J, NCOLZ
+            D     = RT(K,K)
+            IF (DMAX .GE. D) GO TO 310
+            DMAX  = D
+            KMAX  = K
+  310    CONTINUE
+C
+C        SEE IF THE DIAGONAL IS BIG ENOUGH.
+C
+         IF (DMAX .LE. DMIN) GO TO 500
+         NCOLR  = J
+C
+C        PERMUTE THE COLUMNS OF  Z.
+C
+         IF (KMAX .EQ. J) GO TO 350
+         IF (UNITQ) GO TO 315
+         CALL COPYVC( NFREE, ZY(1,KMAX), NFREE, 1, WRK      , NFREE, 1 )
+         CALL COPYVC( NFREE, ZY(1,J)   , NFREE, 1, ZY(1,KMAX),NFREE, 1 )
+         CALL COPYVC( NFREE, WRK       , NFREE, 1, ZY(1,J)   ,NFREE, 1 )
+         GO TO 312
+C
+C        Z  IS NOT STORED EXPLICITLY.
+C
+  315    KSAVE       = KFREE(KMAX)
+         KFREE(KMAX) = KFREE(J)
+         KFREE(J)    = KSAVE
+C
+C        INTERCHANGE ROWS AND COLUMNS OF THE PROJECTED HESSIAN.
+C
+  312    DO 320 I = 1, J
+            T          = RT(I,KMAX)
+            RT(I,KMAX) = RT(I,J)
+            RT(I,J)    = T
+  320    CONTINUE
+C
+         DO 330 K = J, KMAX
+            T          = RT(K,KMAX)
+            RT(K,KMAX) = RT(J,K)
+            RT(J,K)    = T
+  330    CONTINUE
+C
+         DO 340 K = KMAX, NCOLZ
+            T          = RT(KMAX,K)
+            RT(KMAX,K) = RT(J,K)
+            RT(J,K)    = T
+  340    CONTINUE
+C
+         RT(KMAX,KMAX) = RT(J,J)
+C
+C        SET THE DIAGONAL ELEMENT OF  R.
+C
+  350    D       = DSQRT(DMAX)
+         RT(J,J) = D
+         IF (J .EQ. NCOLZ) GO TO 400
+C
+C        SET THE ABOVE-DIAGONAL ELEMENTS OF THE K-TH ROW OF  R,
+C        AND UPDATE THE ELEMENTS OF ALL REMAINING ROWS.
+C
+         J1     = J + 1
+         DO 360 K = J1, NCOLZ
+            T       = RT(J,K)/D
+            RT(J,K) = T
+C
+C           R(I,K)  =  R(I,K)  - T * R(J,I),   I = J1, K.
+C
+            NUM    = K - J
+            LEN    = NROWRT*(NUM - 1) + 1
+            IF (T .NE. ZERO)
+     *      CALL AXPY( NUM, (- T), RT(J,J1), LEN, NROWRT,
+     *                             RT(J1,K), NUM, 1 )
+  360    CONTINUE
+  400 CONTINUE
+C
+  500 IF (NCOLR .EQ. NCOLZ) GO TO 900
+      IF (MSG .GE. 80) WRITE (NOUT, 1000) NCOLR, NCOLZ
+C
+  900 RETURN
+C
+ 1000 FORMAT(/ 42H //QPCRSH//  INDEFINITE PROJECTED HESSIAN.
+     *       / 20H //QPCRSH//  NCOLR =, I5, 6X, 7HNCOLZ =, I5)
+C
+C  END OF QPCRSH
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/qpdump.f
@@ -0,0 +1,60 @@
+      SUBROUTINE QPDUMP( N, NROWH, NCOLH,
+     *                   CVEC, HESS, QPHESS, WRK, HX )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      EXTERNAL           QPHESS
+      INTEGER            N, NROWH, NCOLH
+      DOUBLE PRECISION   CVEC(N), HESS(NROWH,NCOLH), WRK(N), HX(N)
+C
+      INTEGER            NOUT, MSG, ISTART
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+C
+C  *********************************************************************
+C  QPDUMP  PRINTS QUANTITIES DEFINING THE QUADRATIC FUNCTION GIVEN
+C  TO  QPCORE.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION OF APRIL 1982.
+C  *********************************************************************
+C
+      INTEGER            I, J, NHESS
+      INTEGER            MIN0
+      DOUBLE PRECISION   ZERO, ONE
+      DATA               ZERO/0.0D+0/, ONE/1.0D+0/
+C
+      WRITE (NOUT, 1000)
+      WRITE (NOUT, 1500) CVEC
+C
+C  PRINT  HESS  UNLESS IT APPEARS TO BE IMPLICIT.
+C
+      WRITE (NOUT, 2000) NROWH, NCOLH
+      IF (NROWH .EQ. 1  .AND.  NCOLH .EQ. 1) GO TO 200
+      IF (NCOLH .EQ. 1) WRITE (NOUT, 2100) HESS
+      IF (NCOLH .EQ. 1) GO TO 200
+      NHESS  = MIN0( NCOLH, N )
+      DO 100 J = 1, NHESS
+         WRITE (NOUT, 2200) J, (HESS(I,J), I=1,NHESS)
+  100 CONTINUE
+C
+C  CALL  QPHESS  TO COMPUTE EACH COLUMN OF THE HESSIAN.
+C
+  200 WRITE (NOUT, 3000)
+      CALL ZEROVC( N, WRK, N, 1 )
+      DO 300 J = 1, N
+         WRK(J) = ONE
+         CALL QPHESS( N, NROWH, NCOLH, J, HESS, WRK, HX )
+         WRITE (NOUT, 3100) J, HX
+         WRK(J) = ZERO
+  300 CONTINUE
+      RETURN
+C
+ 1000 FORMAT(1H1 / 19H OUTPUT FROM QPDUMP / 19H ******************)
+ 1500 FORMAT(/ 9H CVEC ... / (5G15.6))
+ 2000 FORMAT(/ 8H NROWH =, I6, 11H    NCOLH =, I6)
+ 2100 FORMAT(/ 9H HESS ... / (5G15.6))
+ 2200 FORMAT(/ 7H COLUMN, I6, 14H  OF  HESS ... / (5G15.6))
+ 3000 FORMAT(// 38H THE FOLLOWING IS RETURNED BY  QPHESS.)
+ 3100 FORMAT(/ 7H COLUMN, I6, 18H  FROM  QPHESS ... / (5G15.6))
+C
+C  END OF QPDUMP
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/qpgrad.f
@@ -0,0 +1,115 @@
+      SUBROUTINE QPGRAD( MODE, UNITQ, QPHESS, N, NACTIV,
+     *                   NCTOTL, NFREE, NHESS, NQ, NROWH, NCOLH, JADD,
+     *                   KACTIV, KFREE, ALFA, OBJQP, GFIXED, GTP,
+     *                   CVEC, HESS, P, QTG, SCALE, X, ZY, WRK1, WRK2 )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      INTEGER            MODE, N, NACTIV, NCTOTL, NFREE, NHESS, NQ,
+     *                   NROWH, NCOLH, JADD
+      INTEGER            KACTIV(N), KFREE(N)
+      DOUBLE PRECISION   ALFA, OBJQP, GFIXED, GTP
+      DOUBLE PRECISION   CVEC(N), HESS(NROWH,NCOLH), P(N), QTG(N),
+     *                   SCALE(NCTOTL), X(N), ZY(NQ,NQ)
+      DOUBLE PRECISION   WRK1(N), WRK2(N)
+      LOGICAL            UNITQ
+      EXTERNAL           QPHESS
+C
+      LOGICAL            SCLDQP
+      COMMON    /SOL2LP/ SCLDQP
+C
+C  *********************************************************************
+C  QPGRAD  COMPUTES OR UPDATES...
+C  (1)  OBJQP, THE VALUE OF THE QUADRATIC OBJECTIVE FUNCTION, AND
+C  (2)  THE VECTORS  Q(FREE)(T)G(FREE)  AND  G(FIXED),  WHERE  Q(FREE)
+C       IS THE ORTHOGONAL FACTOR OF THE  A(FREE)  AND  A  IS THE MATRIX
+C       OF CONSTRAINTS IN THE WORKING SET.  THESE VECTORS ARE STORED IN
+C       ELEMENTS  1,2,...,NFREE  AND  NFREE+1,...,N,  RESPECTIVELY,  OF
+C       THE ARRAY  QTG.
+C  (3)  THE COMPONENT OF THE GRADIENT VECTOR CORRESPONDING TO A BOUND
+C       CONSTRAINT THAT HAS JUST BEEN ADDED TO THE WORKING SET.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  ORIGINAL VERSION OF OCTOBER 1982.
+C  *********************************************************************
+C
+      INTEGER            JTHCOL, NCOLZ
+      DOUBLE PRECISION   DELTAF
+      DOUBLE PRECISION   DOT
+      DOUBLE PRECISION   ZERO  , HALF  , ONE
+      DATA               ZERO  , HALF  , ONE
+     *                  /0.0D+0, 0.5D+0, 1.0D+0/
+C
+      JTHCOL = 0
+      GO TO ( 100, 200, 300 ), MODE
+C
+C  ---------------------------------------------------------------------
+C  MODE = 1  ---  COMPUTE THE OBJECTIVE FUNCTION AND GRADIENT FROM
+C                 SCRATCH.  ALLOW FOR A DIAGONAL SCALING OF  X.
+C  ---------------------------------------------------------------------
+  100 CALL COPYVC( N, X    , N, 1, WRK1, N, 1 )
+C
+      IF (SCLDQP) CALL DSCALE( N, SCALE, N, 1, WRK1, N, 1 )
+C
+      CALL QPHESS( N, NROWH, NCOLH, JTHCOL, HESS, WRK1, QTG )
+      OBJQP  = HALF*DOT( N, QTG , N, 1, WRK1, N, 1 )
+     *            + DOT( N, CVEC, N, 1, WRK1, N, 1 )
+      CALL AXPY  ( N, ONE, CVEC , N, 1, QTG, N, 1 )
+C
+      IF (SCLDQP) CALL DSCALE( N, SCALE, N, 1, QTG, N, 1 )
+C
+C  COMPUTE  Q(FREE)(T)(G(FREE)  AND  G(FIXED).  THE ELEMENTS OF  G(FREE)
+C  ARE NOT STORED.
+C
+      CALL ZYPROD( 6, N, NACTIV, NCOLZ, NFREE, NQ, UNITQ,
+     *             KACTIV, KFREE, QTG, ZY, WRK1 )
+C
+      GO TO 900
+C
+C  ---------------------------------------------------------------------
+C  MODE = 2  ---  IF THE QP OBJECTIVE FUNCTION IS REDUCED BY A POSITIVE
+C                 STEP  ALFA,  OR  ALFA  IS NEGATIVE, UPDATE  OBJF,
+C                 Q(FREE)(T)G(FREE)  AND  G(FIXED)  CORRESPONDING TO
+C                 THE CHANGE,  X = X + ALFA P.
+C  ---------------------------------------------------------------------
+  200 CALL QPHESS( N, NROWH, NCOLH, JTHCOL, HESS, P, WRK1 )
+C
+      IF (SCLDQP) CALL DSCALE( N, SCALE, N, 1, WRK1, N, 1 )
+C
+C  UPDATE  OBJQP.
+C
+      DELTAF = ALFA*GTP + HALF*ALFA*ALFA*DOT( N, P, N, 1, WRK1, N, 1 )
+      IF (DELTAF .GT. ZERO  .AND.  ALFA .GT. ZERO) GO TO 999
+      OBJQP  = OBJQP + DELTAF
+C
+C  UPDATE THE ARRAY  QTG.  USE THE ARRAY  P  AS TEMPORARY WORK SPACE.
+C
+      CALL ZYPROD( 6, N, NACTIV, NCOLZ, NFREE, NQ, UNITQ,
+     *             KACTIV, KFREE, WRK1, ZY, WRK2 )
+C
+      CALL AXPY  ( N, ALFA, WRK1, N, 1, QTG, N, 1 )
+      GO TO 900
+C
+C  ---------------------------------------------------------------------
+C  MODE = 3  ---  COMPUTE THE  JADD-TH COMPONENT OF THE GRADIENT VECTOR.
+C  ---------------------------------------------------------------------
+  300 JTHCOL = JADD
+      CALL ZEROVC( N, WRK2, N, 1 )
+      WRK2(JTHCOL) = ONE
+      CALL QPHESS( N, NROWH, NCOLH, JTHCOL, HESS, WRK2, WRK1 )
+C
+      IF (      SCLDQP) CALL DSCALE( N, SCALE, N, 1, WRK1, N, 1 )
+      IF (      SCLDQP)
+     *GFIXED = SCALE(JADD)*(DOT( N, WRK1, N, 1, X, N, 1 ) + CVEC(JADD))
+      IF (.NOT. SCLDQP)
+     *GFIXED =              DOT( N, WRK1, N, 1, X, N, 1 ) + CVEC(JADD)
+C
+  900 NHESS  = NHESS + 1
+      RETURN
+C
+C  THE STEP  ALFA  DOES NOT DECREASE THE OBJECTIVE FUNCTION.
+C
+  999 MODE = - 1
+      RETURN
+C
+C  END OF QPGRAD
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/qpprt.f
@@ -0,0 +1,139 @@
+      SUBROUTINE QPPRT ( ORTHOG, ISDEL, ITER, JADD, JDEL, NACTIV,
+     *                   NCOLR, NCOLZ, NFREE, N, NCLIN, NCLIN0, NCTOTL,
+     *                   NROWA, NROWRT, NCOLRT, NHESS,
+     *                   ISTATE, KFREE,
+     *                   ALFA, CONDH, CONDT, OBJ, GFNORM, ZTGNRM, EMAX,
+     *                   A, RT, X, WRK1, WRK2 )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      LOGICAL            ORTHOG
+      INTEGER            ISDEL, ITER, JADD, JDEL, NACTIV, NCOLR, NCOLZ,
+     *                   NFREE, N, NCLIN, NCLIN0, NCTOTL, NROWA,
+     *                   NROWRT, NCOLRT, NHESS
+      INTEGER            ISTATE(NCTOTL), KFREE(N)
+      DOUBLE PRECISION   ALFA, CONDH, CONDT, OBJ, GFNORM, ZTGNRM, EMAX
+      DOUBLE PRECISION   A(NROWA,N), RT(NROWRT,NCOLRT), X(N)
+      DOUBLE PRECISION   WRK1(N), WRK2(NCLIN0)
+C
+      INTEGER            NOUT, MSG, ISTART
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+C
+C  *********************************************************************
+C  QPPRT  PRINTS VARIOUS LEVELS OF OUTPUT FOR  QPCORE.
+C
+C           MSG    CUMULATIVE RESULT
+C           ---    -----------------
+C
+C        LE   0    NO OUTPUT.
+C
+C        EQ   1    NOTHING NOW (BUT FULL OUTPUT LATER).
+C
+C        EQ   5    ONE TERSE LINE OF OUTPUT.
+C
+C        GE  10    SAME AS 5 (BUT FULL OUTPUT LATER).
+C
+C        GE  15    NOTHING MORE IF  ITER .LT. ISTART.
+C                  OTHERWISE,  X,  ISTATE  AND  KFREE.
+C
+C        GE  20    MULTIPLIERS (PRINTED OUTSIDE QPPRT).
+C                  THE ARRAY  AX.
+C
+C        GE  30    DIAGONALS OF  T  AND  R.
+C
+C        GE  80    DEBUG OUTPUT.
+C
+C        EQ  99    CVEC  AND  HESS  (CALLED FROM QPDUMP).
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION OF APRIL 1982.  REV. OCT. 1982.
+C  *********************************************************************
+C
+      INTEGER            INCT, J, K, LADD, LDEL, LENT, LROWA, L1, L2
+      INTEGER            LSTATE(6)
+      DOUBLE PRECISION   DOT
+      DATA               LSTATE(1), LSTATE(2) /      1H ,       1HL /
+      DATA               LSTATE(3), LSTATE(4) /      1HU,       1HE /
+      DATA               LSTATE(5)            /      1HT            /
+      DATA               LSTATE(6)            /      1HV            /
+C
+      IF (MSG .LT. 5) GO TO 900
+C
+      LDEL   = 0
+      LADD   = 0
+      IF (JDEL .GT. 0) LDEL = ISDEL
+      IF (JDEL .LT. 0) LDEL = 5
+      IF (JDEL .LT. 0) JDEL = - JDEL
+      IF (JADD .GT. 0) LADD = ISTATE(JADD)
+      LDEL   = LSTATE(LDEL + 1)
+      LADD   = LSTATE(LADD + 1)
+      IF (MSG .GE. 15) GO TO 100
+C
+C  ---------------------------------------------------------------------
+C  PRINT HEADING (POSSIBLY) AND TERSE LINE.
+C  ---------------------------------------------------------------------
+      IF (ITER .GT. 0  .OR.  JDEL .GT. 0) GO TO 50
+      IF (      ORTHOG) WRITE (NOUT, 1100)
+      IF (.NOT. ORTHOG) WRITE (NOUT, 1110)
+   50 WRITE (NOUT, 1200) ITER, JDEL, LDEL, JADD, LADD, ALFA, NHESS,
+     *                   OBJ, NCOLZ, GFNORM, ZTGNRM, CONDT, CONDH, EMAX
+      GO TO 900
+C
+C  ---------------------------------------------------------------------
+C  PRINT TERSE LINE,  X,  ISTATE,  KFREE.
+C  ---------------------------------------------------------------------
+  100 WRITE (NOUT, 1000) ITER
+      IF (      ORTHOG) WRITE (NOUT, 1100)
+      IF (.NOT. ORTHOG) WRITE (NOUT, 1110)
+      WRITE (NOUT, 1200) ITER, JDEL, LDEL, JADD, LADD, ALFA, NHESS,
+     *                   OBJ, NCOLZ, GFNORM, ZTGNRM, CONDT, CONDH, EMAX
+      WRITE (NOUT, 1300) X
+      WRITE (NOUT, 1600) (ISTATE(J), J=1,N)
+      L1 = N + 1
+      L2 = N + NCLIN
+      IF (L1     .LE. L2) WRITE (NOUT, 1610) (ISTATE(J), J=L1,L2)
+      IF (NFREE  .GT.  0) WRITE (NOUT, 1700) (KFREE(K), K=1,NFREE)
+C
+C  ---------------------------------------------------------------------
+C  COMPUTE AND PRINT  AX.  USE  WORK  TO AVOID SIDE EFFECTS.
+C  ---------------------------------------------------------------------
+      IF (MSG  .LT. 20) GO TO 900
+      IF (NCLIN .EQ. 0) GO TO 300
+      LROWA  = NROWA*(N - 1) + 1
+      DO 250 K = 1, NCLIN
+         WRK2(K) = DOT( N, A(K,1), LROWA, NROWA, X, N, 1 )
+  250 CONTINUE
+      WRITE (NOUT, 2000) (WRK2(K), K=1,NCLIN)
+C
+C  ---------------------------------------------------------------------
+C  PRINT ALL THE DIAGONALS OF  T  AND  R.
+C  ---------------------------------------------------------------------
+  300 IF (MSG .LT. 30) GO TO 900
+      LENT   = NROWRT*(NACTIV - 1) + 1
+      INCT   = NROWRT - 1
+      IF (NACTIV .GT. 0) CALL COPYVC( NACTIV, RT(NACTIV,NCOLZ+1),
+     *                                LENT, INCT, WRK1, NACTIV, 1 )
+      IF (NACTIV .GT. 0) WRITE (NOUT, 3000) (WRK1(J), J=1,NACTIV)
+      IF (NCOLZ  .GT. 0) WRITE (NOUT, 3100) (RT(J,J), J=1,NCOLZ)
+C
+  900 RETURN
+C
+ 1000 FORMAT(/// 18H ================= / 13H QP ITERATION, I5
+     *         / 18H ================= )
+ 1100 FORMAT(// 5H  ITN, 12H JDEL  JADD , 10H      STEP,
+     *   6H NHESS, 12H   OBJECTIVE, 6H NCOLZ, 11H NORM GFREE,
+     *   10H  NORM ZTG, 9H   COND T, 9H COND ZHZ, 10H  HESS MOD)
+ 1110 FORMAT(// 5H  ITN, 12H JDEL  JADD , 10H      STEP,
+     *   6H NHESS, 12H   OBJECTIVE, 6H NCOLZ, 11H   NORM QTG,
+     *   10H  NORM ZTG, 9H   COND T, 9H COND ZHZ, 10H  HESS MOD)
+ 1200 FORMAT(I5, I5, A1, I5, A1, 1PE10.2, I6, 1PE12.4, I6,
+     *   1PE11.2, 1PE10.2, 1P2E9.1, 1PE10.2)
+ 1300 FORMAT(/ 13H QP VARIABLES                            / (1P5E15.6))
+ 1600 FORMAT(/ 35H STATUS OF THE QP BOUND CONSTRAINTS      / (1X, 10I4))
+ 1610 FORMAT(/ 37H STATUS OF THE QP GENERAL CONSTRAINTS    / (1X, 10I4))
+ 1700 FORMAT(/ 26H LIST OF FREE QP VARIABLES               / (1X, 10I4))
+ 2000 FORMAT(/ 40H VALUES OF QP GENERAL LINEAR CONSTRAINTS / (1P5E15.6))
+ 3000 FORMAT(/ 40H DIAGONALS OF QP WORKING SET FACTOR  T   / (1P5E15.6))
+ 3100 FORMAT(/ 40H DIAGONALS OF QP PRJ. HESSIAN FACTOR  R  / (1P5E15.6))
+C
+C  END OF QPPRT
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/qpsol.f
@@ -0,0 +1,325 @@
+      SUBROUTINE QPSOL ( ITMAX, MSGLVL, N,
+     *                   NCLIN, NCTOTL, NROWA, NROWH, NCOLH,
+     *                   BIGBND, A, BL, BU, CVEC, FEATOL, HESS, QPHESS,
+     *                   COLD, LP, ORTHOG, ISTATE, X,
+     *                   INFORM, ITER, OBJ, CLAMDA,
+     *                   IW, LENIW, W, LENW )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      INTEGER            ITMAX, MSGLVL, N, NCLIN, NCTOTL, NROWA,
+     *                   NROWH, NCOLH, INFORM, ITER
+      INTEGER            LENIW, LENW
+      INTEGER            ISTATE(NCTOTL), IW(LENIW)
+      DOUBLE PRECISION   BIGBND, OBJ
+      DOUBLE PRECISION   A(NROWA,N), BL(NCTOTL), BU(NCTOTL)
+      DOUBLE PRECISION   CLAMDA(NCTOTL), CVEC(N), FEATOL(NCTOTL)
+      DOUBLE PRECISION   HESS(NROWH,NCOLH), X(N), W(LENW)
+      LOGICAL            COLD, LP, ORTHOG
+      EXTERNAL           QPHESS
+C
+C  *********************************************************************
+C  QPSOL  SOLVES QUADRATIC PROGRAMMING (QP) PROBLEMS OF THE FORM
+C
+C                MINIMIZE     C(T)*X  +  1/2 X(T)*H*X
+C
+C                SUBJECT TO           (  X  )
+C                             BL  .LE.(     ).GE.  BU
+C                                     ( A*X )
+C
+C
+C  WHERE  (T)  DENOTES THE TRANSPOSE OF A COLUMN VECTOR.
+C  THE SYMMETRIC MATRIX  H  MAY BE POSITIVE-DEFINITE, POSITIVE
+C  SEMI-DEFINITE, OR INDEFINITE.
+C
+C  N  IS THE NUMBER OF VARIABLES (DIMENSION OF  X).
+C
+C  NCLIN  IS THE NUMBER OF GENERAL LINEAR CONSTRAINTS (ROWS OF  A).
+C  (NCLIN MAY BE ZERO.)
+C
+C  THE MATRIX   H  IS DEFINED BY THE SUBROUTINE  QPHESS, WHICH
+C  MUST COMPUTE THE MATRIX-VECTOR PRODUCT  H*X  FOR ANY VECTOR  X.
+C
+C  THE VECTOR  C  IS ENTERED IN THE ONE-DIMENSIONAL ARRAY  CVEC.
+C
+C  THE FIRST  N  COMPONENTS OF  BL  AND   BU  ARE LOWER AND UPPER
+C  BOUNDS ON THE VARIABLES.  THE NEXT  NCLIN  COMPONENTS ARE
+C  LOWER AND UPPER BOUNDS ON THE GENERAL LINEAR CONSTRAINTS.
+C
+C  THE MATRIX  A  OF COEFFICIENTS IN THE GENERAL LINEAR CONSTRAINTS
+C  IS ENTERED AS THE TWO-DIMENSIONAL ARRAY  A  (OF DIMENSION
+C  NROWA  BY  N).  IF NCLIN = 0,  A  IS NOT ACCESSED.
+C
+C  THE VECTOR  X  MUST CONTAIN AN INITIAL ESTIMATE OF THE SOLUTION,
+C  AND WILL CONTAIN THE COMPUTED SOLUTION ON OUTPUT.
+C
+C
+C
+C  COMPLETE DOCUMENTATION FOR  QPSOL  IS CONTAINED IN REPORT SOL 83-12,
+C  USERS GUIDE FOR SOL/QPSOL, BY P.E. GILL, W. MURRAY, M.A. SAUNDERS
+C  AND M.H. WRIGHT, DEPARTMENT OF OPERATIONS RESEARCH, STANFORD
+C  UNIVERSITY, STANFORD, CALIFORNIA 94305.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION 1   OF DECEMBER 1981.
+C  VERSION 2   OF     JUNE 1982.
+C  VERSION 3   OF  JANUARY 1983.
+C  VERSION 3.1 OF    APRIL 1983.
+C  VERSION 3.2 OF    JUNE  1984.
+C
+C  COPYRIGHT  1983  STANFORD UNIVERSITY.
+C
+C  THIS MATERIAL MAY BE REPRODUCED BY OR FOR THE U.S. GOVERNMENT PURSU-
+C  ANT TO THE COPYRIGHT LICENSE UNDER DAR CLAUSE 7-104.9(A) (1979 MAR).
+C
+C  THIS MATERIAL IS BASED UPON WORK PARTIALLY SUPPORTED BY THE NATIONAL
+C  SCIENCE FOUNDATION UNDER GRANTS MCS-7926009 AND ECS-8012974; THE
+C  OFFICE OF NAVAL RESEARCH CONTRACT N00014-75-C-0267;  THE DEPARTMENT
+C  OF ENERGY CONTRACT AM03-76SF00326, PA NO. DE-AT03-76ER72018; AND THE
+C  ARMY RESEARCH OFFICE CONTRACT DAA29-79-C-0110.
+C  *********************************************************************
+C
+C  COMMON BLOCKS.
+C
+      INTEGER            NOUT, MSG, ISTART, LENNAM, NROWRT, NCOLRT, NQ
+      DOUBLE PRECISION   ASIZE, DTMAX, DTMIN
+      DOUBLE PRECISION   WMACH, PARM
+      COMMON    /SOLMCH/ WMACH(15)
+      COMMON    /SOL1CM/ NOUT, MSG, ISTART
+      COMMON    /SOL3CM/ LENNAM, NROWRT, NCOLRT, NQ
+      COMMON    /SOL4CM/ PARM(10)
+      COMMON    /SOL5CM/ ASIZE, DTMAX, DTMIN
+C
+      LOGICAL            SCLDQP
+      INTEGER            LOCLP
+      COMMON    /SOL1LP/ LOCLP(15)
+      COMMON    /SOL2LP/ SCLDQP
+C
+C  INTRINSIC FUNCTIONS.
+C
+      INTEGER            MAX0, MIN0
+C
+C  LOCAL VARIABLES.
+C
+      LOGICAL            MINSUM, NAMED, UNITQ, VERTEX
+      INTEGER            L, LAX, LCRASH, LITOTL, LKACTV, LKFREE,
+     *                   LNAMES, LPX, LSCALE, LWRK, LWTOTL,
+     *                   MAXACT, MXCOLZ, MXFREE, MINACT, MINFXD,
+     *                   NACTIV, NALG, NCNLN, NERROR, NFREE,
+     *                   NROWJ, NUMINF
+      DOUBLE PRECISION   BIGDX, EPSMCH, EPSPT9, TOLACT, XNORM
+      DOUBLE PRECISION   POINT9
+      INTEGER            LPQP(2)
+      DATA               LPQP(1), LPQP(2)
+     *                  /2HLP   , 2HQP   /
+      DATA               POINT9
+     *                 / 0.9D+0 /
+C
+C  SET THE MACHINE-DEPENDENT CONSTANTS.
+C
+      CALL MCHPAR
+      EPSMCH = WMACH( 3)
+      NOUT   = WMACH(11)
+C
+C  QPSOL  WILL PROVIDE DEFAULT NAMES FOR VARIABLES DURING PRINTING.
+C
+      NAMED  = .FALSE.
+C
+C  IF THERE IS NO FEASIBLE POINT FOR THE LINEAR CONSTRAINTS AND BOUNDS,
+C  COMPUTE THE MINIMUM SUM OF INFEASIBILITIES.
+C  IT IS NOT NECESSARY TO START THE QP PHASE AT A VERTEX.
+C
+      MINSUM = .TRUE.
+      VERTEX = .FALSE.
+C
+C  ANY CHANGE IN X THAT IS GREATER THAN  BIGDX  WILL BE REGARDED AS AN
+C  INFINITE STEP.
+C
+      BIGDX  = 1.0D+20
+C
+C  DURING SELECTION OF THE INITIAL WORKING SET (BY CRASH),
+C  CONSTRAINTS WITH RESIDUALS LESS THAN  TOLACT  WILL BE MADE ACTIVE.
+C
+      TOLACT = 0.01D+0
+C
+      EPSPT9 = EPSMCH**(POINT9)
+C
+      PARM(1) = BIGBND
+      PARM(2) = BIGDX
+      PARM(3) = TOLACT
+      PARM(4) = EPSPT9
+C
+C  ASSIGN THE DIMENSIONS OF ARRAYS IN THE PARAMETER LIST OF QPCORE.
+C  ECONOMIES OF STORAGE ARE POSSIBLE IF THE MINIMUM NUMBER OF ACTIVE
+C  CONSTRAINTS AND THE MINIMUM NUMBER OF FIXED VARIABLES ARE KNOWN IN
+C  ADVANCE.  THE EXPERT USER SHOULD ALTER  MINACT  AND  MINFXD
+C  ACCORDINGLY.
+C  IF A LINEAR PROGRAM IS BEING SOLVED AND THE MATRIX OF GENERAL
+C  CONSTRAINTS IS FAT,  I.E.,  NCLIN .LT. N,  A NON-ZERO VALUE IS
+C  KNOWN FOR  MINFXD.  NOTE THAT IN THIS CASE,  VERTEX  MUST BE .TRUE..
+C
+      MINACT = 0
+      MINFXD = 0
+C
+      IF (LP  .AND.  NCLIN .LT. N) MINFXD = N - NCLIN - 1
+      IF (LP  .AND.  NCLIN .LT. N) VERTEX = .TRUE.
+C
+      MXFREE = N - MINFXD
+      MAXACT = MAX0( 1, MIN0( N, NCLIN ) )
+      MXCOLZ = N - ( MINFXD + MINACT )
+      NQ     = MAX0( 1, MXFREE )
+      NROWRT = MAX0( MXCOLZ, MAXACT )
+      NCOLRT = MAX0( 1, MXFREE )
+C
+      NCNLN  = 0
+      LENNAM = 1
+C
+C  ALLOCATE CERTAIN ARRAYS THAT ARE NOT DONE IN  ALLOC.
+C
+      LNAMES = 1
+      LITOTL = 0
+C
+      LAX    = 1
+      LWTOTL = LAX    + NROWA  - 1
+C
+C  ALLOCATE REMAINING WORK ARRAYS.
+C
+      NALG   = 2
+      LOCLP(1) = LNAMES
+      CALL ALLOC ( NALG, N, NCLIN, NCNLN, NCTOTL, NROWA, NROWJ,
+     *             LITOTL, LWTOTL )
+C
+      LKACTV = LOCLP( 2)
+      LKFREE = LOCLP( 3)
+C
+      LPX    = LOCLP( 6)
+      LWRK   = LOCLP(11)
+C
+C  SET THE MESSAGE LEVEL FOR  LPDUMP, QPDUMP, CHKDAT  AND  LPCORE.
+C
+      MSG    = 0
+      IF (MSGLVL .GE.  5) MSG = 5
+      IF (LP  .OR.  MSGLVL .GE. 15) MSG = MSGLVL
+C
+C  ******* THE FOLLOWING STATEMENT MUST BE EXECUTED IF  ISTART   *******
+C  ******* IS NOT SET IN THE CALLING ROUTINE.                    *******
+C
+      ISTART = 0
+C
+      LCRASH = 1
+      IF (COLD) LCRASH = 0
+C
+C  CHECK INPUT PARAMETERS AND STORAGE LIMITS.
+C
+      IF (MSGLVL .EQ. 99)
+     *CALL LPDUMP( N, NCLIN, NCTOTL, NROWA,
+     *             LCRASH, LP, MINSUM, NAMED, VERTEX,
+     *             ISTATE, A, W(LAX), BL, BU, CVEC, X )
+C
+      IF (MSGLVL .EQ. 99)
+     *CALL QPDUMP( N, NROWH, NCOLH,
+     *             CVEC, HESS, QPHESS, W(LWRK), W(LPX) )
+C
+      CALL CHKDAT( NERROR, LENIW, LENW, LITOTL, LWTOTL,
+     *             NROWA, N, NCLIN, NCNLN, NCTOTL,
+     *             ISTATE, IW(LKACTV),
+     *             LCRASH, NAMED, IW(LNAMES), LENNAM,
+     *             BIGBND, A, BL, BU, FEATOL, X )
+C
+      INFORM = 9
+      ITER   = 0
+      IF (NERROR .NE. 0) GO TO 900
+C
+C  NO SCALING IS PROVIDED BY THIS VERSION OF  QPSOL.
+C  GIVE A FAKE VALUE FOR THE START OF THE SCALE ARRAY.
+C
+      SCLDQP = .FALSE.
+      LSCALE = 1
+C
+C  ---------------------------------------------------------------------
+C  CALL  LPCORE  TO OBTAIN A FEASIBLE POINT, OR SOLVE A LINEAR PROBLEM.
+C  ---------------------------------------------------------------------
+      CALL LPCORE( LP, MINSUM, NAMED, ORTHOG, UNITQ, VERTEX,
+     *             INFORM, ITER, ITMAX, LCRASH,
+     *             N, NCLIN, NCTOTL, NROWA, NACTIV, NFREE, NUMINF,
+     *             ISTATE, IW(LKACTV), IW(LKFREE),
+     *             OBJ, XNORM,
+     *             A, W(LAX), BL, BU, CLAMDA, CVEC, FEATOL, X,
+     *             IW, LENIW, W, LENW )
+C
+      IF (LP           ) GO TO 50
+      IF (INFORM .EQ. 0) GO TO 100
+C
+C  TROUBLE IN  LPCORE.
+C
+C  INFORM CANNOT BE GIVEN THE VALUE  2  WHEN FINDING A FEASIBLE POINT,
+C  SO IT IS NECESSARY TO DECREMENT ALL THE VALUES OF  INFORM  THAT ARE
+C  GREATER THAN  2.
+C
+      IF (INFORM .GT. 2) INFORM = INFORM - 1
+      INFORM = INFORM + 5
+      GO TO 900
+C
+C  THE PROBLEM WAS AN LP, NOT A QP.
+C
+   50 IF (INFORM .GT. 2) INFORM = INFORM + 4
+      IF (INFORM .EQ. 1) INFORM = 6
+      GO TO 900
+C
+C  ---------------------------------------------------------------------
+C  CALL  QPCORE  TO SOLVE A QUADRATIC PROBLEM.
+C  ---------------------------------------------------------------------
+C
+  100 MSG    = MSGLVL
+C
+C  ******* THE FOLLOWING STATEMENT MUST BE EXECUTED IF  ISTART   *******
+C  ******* IS NOT SET IN THE CALLING ROUTINE.                    *******
+C
+      ISTART = 0
+C
+      CALL QPCORE( NAMED, ORTHOG, UNITQ, INFORM, ITER, ITMAX,
+     *             N, NCLIN, NCTOTL, NROWA, NROWH, NCOLH,
+     *             NACTIV, NFREE, QPHESS, ISTATE, IW(LKACTV),IW(LKFREE),
+     *             OBJ, XNORM,
+     *             A, W(LAX), BL, BU, CLAMDA, CVEC,
+     *             FEATOL, HESS, W(LSCALE), X, IW, LENIW, W, LENW )
+C
+C  PRINT MESSAGES IF REQUIRED.
+C
+C
+  900 IF (MSGLVL .LE.   0) RETURN
+      IF (      LP) L = 1
+      IF (.NOT. LP) L = 2
+      IF (INFORM .EQ.   0) WRITE (NOUT, 1000) LPQP(L)
+      IF (INFORM .EQ.   1) WRITE (NOUT, 1010)
+      IF (INFORM .EQ.   2) WRITE (NOUT, 1020) LPQP(L)
+      IF (INFORM .EQ.   3) WRITE (NOUT, 1030)
+      IF (INFORM .EQ.   4) WRITE (NOUT, 1040)
+      IF (INFORM .EQ.   5) WRITE (NOUT, 1050)
+      IF (INFORM .EQ.   6) WRITE (NOUT, 1060)
+      IF (INFORM .EQ.   7) WRITE (NOUT, 1070)
+      IF (INFORM .EQ.   8) WRITE (NOUT, 1080)
+      IF (INFORM .EQ.   9) WRITE (NOUT, 1090) NERROR
+      IF (INFORM .EQ.   9) RETURN
+C
+      IF (NUMINF .EQ.   0) WRITE (NOUT, 2000) LPQP(L), OBJ
+      IF (NUMINF .GT.   0) WRITE (NOUT, 2010) OBJ
+      RETURN
+C
+ 1000 FORMAT(/ 22H EXIT QPSOL - OPTIMAL , A2, 10H SOLUTION.)
+ 1010 FORMAT(/ 33H EXIT QPSOL - WEAK LOCAL MINIMUM.)
+ 1020 FORMAT(/ 14H EXIT QPSOL - , A2, 23H SOLUTION IS UNBOUNDED.)
+ 1030 FORMAT(/ 31H EXIT QPSOL - ZERO MULTIPLIERS.)
+ 1040 FORMAT(/ 53H EXIT QPSOL - TOO MANY ITERATIONS WITHOUT CHANGING X.)
+ 1050 FORMAT(/ 34H EXIT QPSOL - TOO MANY ITERATIONS.)
+ 1060 FORMAT(/ 52H EXIT QPSOL - CANNOT SATISFY THE LINEAR CONSTRAINTS.)
+ 1070 FORMAT(/ 52H EXIT QPSOL - TOO MANY ITERATIONS WITHOUT CHANGING X,
+     *         21H DURING THE LP PHASE.)
+ 1080 FORMAT(/ 33H EXIT QPSOL - TOO MANY ITERATIONS,
+     *         21H DURING THE LP PHASE.)
+ 1090 FORMAT(/ 14H EXIT QPSOL - , I10, 26H ERRORS FOUND IN THE INPUT,
+     *         32H PARAMETERS.  PROBLEM ABANDONED.)
+ 2000 FORMAT(/  7H FINAL , A2, 18H OBJECTIVE VALUE =, G16.7)
+ 2010 FORMAT(/ 31H FINAL SUM OF INFEASIBILITIES =,    G16.7)
+C
+C  END OF QPSOL
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/quotnt.f
@@ -0,0 +1,27 @@
+      DOUBLE PRECISION FUNCTION QUOTNT( U, V )
+C
+      DOUBLE PRECISION   U, V
+C
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+C
+C  QUOTNT  RETURNS THE QUOTIENT  U / V,  GUARDING AGAINST OVERFLOW.
+C  VERSION OF FEBRUARY 1983.
+C
+      DOUBLE PRECISION   ABSV, FLMAX, ZERO, ONE
+      DOUBLE PRECISION   DABS
+      DATA               ZERO, ONE / 0.0D+0, 1.0D+0 /
+C
+      FLMAX  = WMACH(7)
+C
+      ABSV   = DABS( V )
+      IF (ABSV .GE. ONE) GO TO 100
+      QUOTNT = FLMAX
+      IF (V .EQ. ZERO  .AND.  U .LT. ZERO) QUOTNT = - FLMAX
+      IF (DABS( U ) .GE. ABSV*FLMAX) GO TO 110
+  100 QUOTNT = U / V
+C
+  110 RETURN
+C
+C  END OF QUOTNT
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/refgen.f
@@ -0,0 +1,91 @@
+      SUBROUTINE REFGEN( N, ALPHA, X, LENX, INCX, BETA, DELTA )
+C
+      INTEGER            N, LENX, INCX
+      DOUBLE PRECISION   ALPHA, BETA, DELTA
+      DOUBLE PRECISION   X(LENX)
+C
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+C
+C  *********************************************************************
+C  REFGEN  GENERATES A HOUSEHOLDER REFLECTION  P  SUCH THAT
+C
+C     P ( ALPHA )  =  ( DELTA ) ,      P(T) P = I,
+C       (   X   )     (   0   )
+C
+C  WHERE  P  HAS THE FORM
+C
+C            P  =  ( I   )  -  1/BETA ( BETA ) ( BETA  Z(T) )
+C                  (   1 )            (  Z   )
+C
+C  FOR SOME  BETA  AND  Z,  WHERE  Z  IS A VECTOR WITH  N  ELEMENTS.
+C
+C  IN CERTAIN CIRCUMSTANCES ( X  VERY SMALL IN ABSOLUTE TERMS OR
+C  X  VERY SMALL COMPARED TO  ALPHA),  P  WILL BE THE IDENTITY MATRIX.
+C  REFGEN  WILL THEN LEAVE  ALPHA  AND  X  UNALTERED, AND WILL RETURN
+C  BETA = ZERO   AND   DELTA = ALPHA.
+C
+C  OTHERWISE,  REFGEN  RETURNS  BETA  IN THE RANGE (1.0, 2.0),
+C  SETS  ALPHA = BETA,  AND STORES  Z  IN THE ARRAY  X.
+C  (IN SOME CASES, SETTING  ALPHA = BETA  IS CONVENIENT FOR LATER USE.)
+C
+C  REFGEN  GUARDS AGAINST OVERFLOW AND UNDERFLOW.
+C  IT IS ASSUMED THAT  FLMIN .LT. EPSMCH**2  (I.E.  RTMIN .LT. EPSMCH).
+C
+C  VERSION 1, MARCH 30 1983.  DERIVED FROM SVEN HAMMARLING'S  NREFG.
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  *********************************************************************
+C
+      INTEGER            I, NINCX
+      DOUBLE PRECISION   ABSALF, EPSMCH, GAMMA, ONE, RTMIN, TOL, XNORM,
+     *                   ZERO
+      DOUBLE PRECISION   DABS
+      DOUBLE PRECISION   DSQRT, V2NORM
+C
+      DATA               ZERO/0.0D+0/, ONE/1.0D+0/
+C
+      BETA   = ZERO
+      DELTA  = ALPHA
+      IF (N .LT. 1) RETURN
+      EPSMCH = WMACH(3)
+      RTMIN  = WMACH(6)
+C
+      ABSALF = DABS(ALPHA)
+      XNORM  = V2NORM( N, X, LENX, INCX )
+      IF (XNORM   .LE.  RTMIN          ) RETURN
+      IF (ABSALF  .LE.  EPSMCH * XNORM ) GO TO 50
+      IF (XNORM   .LE.  EPSMCH * ABSALF) RETURN
+      GO TO 100
+C
+C  ALPHA  IS SMALL ENOUGH TO BE REGARDED AS ZERO.
+C
+   50 DELTA  = XNORM
+      BETA   = ONE
+      GO TO 200
+C
+C  NORMAL CASE.
+C  WE KNOW THAT   EPSMCH  .LT.  XNORM / ABSALF  .LT.  1/EPSMCH.
+C
+  100 GAMMA  = DSQRT( ONE  +  (XNORM/ALPHA)**2 )
+      DELTA  = ALPHA * GAMMA
+      BETA   = ONE + ONE/GAMMA
+C
+C  SET  X  =  X / DELTA,  WHERE  DABS(DELTA) = NORM( ALPHA, X ).
+C  CHANGE NEGLIGIBLE ELEMENTS TO ZERO TO AVOID UNDERFLOW LATER ON.
+C
+  200 TOL    = DABS( DELTA ) * EPSMCH
+      NINCX  = N * INCX
+      DO 300 I = 1, NINCX, INCX
+         IF (DABS( X(I) ) .LE. TOL) GO TO 250
+         X(I)  = X(I) / DELTA
+         GO TO 300
+C
+  250    X(I)  = ZERO
+  300 CONTINUE
+C
+      ALPHA  =   BETA
+      DELTA  = - DELTA
+      RETURN
+C
+C  END OF REFGEN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/rot3.f
@@ -0,0 +1,71 @@
+      SUBROUTINE ROT3  ( N, X, LENX, INCX, Y, LENY, INCY, CS, SN )
+C
+      INTEGER            N, LENX, INCX, LENY, INCY
+      DOUBLE PRECISION   CS, SN
+      DOUBLE PRECISION   X(LENX), Y(LENY)
+C
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+C
+C  *********************************************************************
+C  ROT3  APPLIES THE PLANE ROTATION DEFINED BY  CS  AND  SN
+C  TO THE COLUMNS OF A  2 BY N  MATRIX HELD IN  X  AND  Y.
+C  THE METHOD USED REQUIRES 3 MULTIPLICATIONS AND 3 ADDITIONS
+C  PER COLUMN, AS DESCRIBED IN GILL, GOLUB, MURRAY AND SAUNDERS,
+C  MATHEMATICS OF COMPUTATION 28 (1974) 505--535 (SEE PAGE 508).
+C
+C  ROT3  GUARDS AGAINST UNDERFLOW, AND OVERFLOW IS EXTREMELY UNLIKELY.
+C  IT IS ASSUMED THAT  CS  AND  SN  HAVE BEEN GENERATED BY  ROTGEN,
+C  ENSURING THAT  CS  LIES IN THE CLOSED INTERVAL  (0, 1),  AND THAT
+C  THE ABSOLUTE VALUE OF  CS  AND  SN  (IF NONZERO) IS NO LESS THAN THE
+C  MACHINE PRECISION,  EPS.  IT IS ALSO ASSUMED THAT  RTMIN .LT. EPS.
+C  NOTE THAT THE MAGIC NUMBER  Z  IS THEREFORE NO LESS THAN  0.5*EPS
+C  IN ABSOLUTE VALUE, SO IT IS SAFE TO USE  TOL = 2*RTMIN IN THE
+C  UNDERFLOW TEST INVOLVING  Z*A.  FOR EFFICIENCY WE USE THE SAME TOL
+C  IN THE PREVIOUS TWO TESTS.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION OF JANUARY 1982.
+C  *********************************************************************
+C
+      INTEGER            I, IX, IY
+      DOUBLE PRECISION   A, B, ONE, RTMIN, TOL, W, Z, ZERO
+      DOUBLE PRECISION   DABS
+      DATA               ONE/1.0D+0/, ZERO/0.0D+0/
+C
+      IF (N .LT. 1  .OR.  SN .EQ. ZERO) RETURN
+      IX = 1
+      IY = 1
+      IF (CS .EQ. ZERO) GO TO 100
+      RTMIN  = WMACH(6)
+      TOL    = RTMIN + RTMIN
+      Z      = SN/(ONE + CS)
+C
+      DO 10 I = 1, N
+         A     = X(IX)
+         B     = Y(IY)
+         W     = ZERO
+         IF (DABS(A) .GT. TOL) W = CS*A
+         IF (DABS(B) .GT. TOL) W = W + SN*B
+         X(IX) = W
+         A     = A + W
+         IF (DABS(A) .GT. TOL) B = B - Z*A
+         Y(IY) = - B
+         IX    = IX + INCX
+         IY    = IY + INCY
+   10 CONTINUE
+      RETURN
+C
+C  JUST SWAP  X  AND  Y.
+C
+  100 DO 110 I = 1, N
+         A     = X(IX)
+         X(IX) = Y(IY)
+         Y(IY) = A
+         IX    = IX + INCX
+         IY    = IY + INCY
+  110 CONTINUE
+      RETURN
+C
+C  END OF ROT3
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/rotgen.f
@@ -0,0 +1,71 @@
+      SUBROUTINE ROTGEN( X, Y, CS, SN )
+C
+      DOUBLE PRECISION   X, Y, CS, SN
+C
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+C
+C  *********************************************************************
+C  ROTGEN  GENERATES A PLANE ROTATION THAT REDUCES THE VECTOR (X, Y)
+C  TO THE VECTOR (A, 0),  WHERE  A  IS DEFINED AS FOLLOWS...
+C
+C     IF BOTH X AND Y ARE NEGLIGIBLY SMALL, OR
+C     IF Y IS NEGLIGIBLE RELATIVE TO X,
+C     THEN  A = X,  AND THE IDENTITY ROTATION IS RETURNED.
+C
+C     IF X IS NEGLIGIBLE RELATIVE TO Y,
+C     THEN  A = Y,  AND THE SWAP ROTATION IS RETURNED.
+C
+C     OTHERWISE,  A = SIGN(X) * SQRT( X**2 + Y**2 ).
+C
+C  IN ALL CASES,  X  AND  Y  ARE OVERWRITTEN BY  A  AND  0,
+C  AND  CS  WILL LIE IN THE CLOSED INTERVAL  (0, 1).  ALSO,
+C  THE ABSOLUTE VALUE OF  CS  AND  SN  (IF NONZERO) WILL BE NO LESS
+C  THAN THE MACHINE PRECISION,  EPS.
+C
+C  ROTGEN  GUARDS AGAINST OVERFLOW AND UNDERFLOW.
+C  IT IS ASSUMED THAT  FLMIN .LT. EPS**2  (I.E.  RTMIN .LT. EPS).
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION OF JANUARY 1982.
+C  *********************************************************************
+C
+      DOUBLE PRECISION   A, B, EPS, ONE, RTMIN, ZERO
+      DOUBLE PRECISION   DSQRT
+      DOUBLE PRECISION   DABS, DMAX1
+      DATA               ONE/1.0D+0/, ZERO/0.0D+0/
+C
+      IF (Y .EQ. ZERO) GO TO 100
+      IF (X .EQ. ZERO) GO TO 200
+C
+      EPS    = WMACH(3)
+      RTMIN  = WMACH(6)
+      A      = DABS(X)
+      B      = DABS(Y)
+      IF (DMAX1(A,B) .LE. RTMIN) GO TO 100
+      IF (A .LT. B) GO TO 50
+      IF (B .LE. EPS*A) GO TO 100
+      A  = A * DSQRT( ONE + (B/A)**2 )
+      GO TO 60
+C
+   50 IF (A .LE. EPS*B) GO TO 200
+      A  = B * DSQRT( ONE + (A/B)**2 )
+C
+   60 IF (X .LT. ZERO) A = - A
+      CS = X/A
+      SN = Y/A
+      X  = A
+      GO TO 300
+C
+  100 CS = ONE
+      SN = ZERO
+      GO TO 300
+C
+  200 CS = ZERO
+      SN = ONE
+      X  = Y
+  300 Y  = ZERO
+      RETURN
+C
+C  END OF ROTGEN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/rsolve.f
@@ -0,0 +1,43 @@
+      SUBROUTINE RSOLVE( MODE, NROWR, N, R, Y )
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      INTEGER            MODE, NROWR, N
+      DOUBLE PRECISION   R(NROWR,N), Y(N)
+C
+C  *********************************************************************
+C  RSOLVE  SOLVES EQUATIONS INVOLVING AN UPPER-TRIANGULAR MATRIX  R
+C  AND A RIGHT-HAND-SIDE VECTOR  Y,  RETURNING THE SOLUTION IN  Y.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION OF SEPTEMBER 1981.
+C  *********************************************************************
+C
+      INTEGER            J, JJ
+      DOUBLE PRECISION   YJ, ZERO
+      DOUBLE PRECISION   DOT
+      DATA               ZERO /0.0D+0/
+C
+      IF (MODE .NE. 1) GO TO 400
+C
+C  MODE = 1  ---  SOLVE  R * Y(NEW) = Y(OLD).
+C
+      DO 100 JJ = 1, N
+         J  = N + 1 - JJ
+         YJ = Y(J)/R(J,J)
+         Y(J) = YJ
+         IF (J .GT. 1  .AND.  YJ .NE. ZERO)
+     *   CALL AXPY( J-1, (-YJ), R(1,J), J, 1, Y, J, 1 )
+  100 CONTINUE
+      RETURN
+C
+C  MODE = 2  ---  SOLVE  R(TRANSPOSE) * Y(NEW) = Y(OLD).
+C
+  400 DO 500 J = 1, N
+         YJ = Y(J)
+         IF (J .GT. 1)
+     *   YJ = YJ - DOT( J-1, R(1,J), J, 1, Y, J, 1 )
+         Y(J) = YJ/R(J,J)
+  500 CONTINUE
+      RETURN
+C
+C  END OF RSOLVE
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/sscale.f
@@ -0,0 +1,26 @@
+      SUBROUTINE SSCALE( N, A, X, LENX, INCX )
+C
+      INTEGER            N, LENX, INCX
+      DOUBLE PRECISION   A
+      DOUBLE PRECISION   X(LENX)
+C
+C  SCALE THE VECTOR  X  BY THE SCALAR  A.
+C
+      INTEGER             I, IX
+C
+      IF (N .LT. 1) RETURN
+      IF (INCX .EQ. 1) GO TO 50
+      IX = 1
+      DO 10 I = 1, N
+         X(IX) = A * X(IX)
+         IX    = IX + INCX
+   10 CONTINUE
+      RETURN
+C
+   50 DO 60 I = 1, N
+         X(I) = A * X(I)
+   60 CONTINUE
+      RETURN
+C
+C  END OF SSCALE
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/tqadd.f
@@ -0,0 +1,70 @@
+      SUBROUTINE TQADD ( ORTHOG, UNITQ,
+     *                   INFORM, K1, K2, NACTIV, NCOLZ, NFREE,
+     *                   N, NCTOTL, NQ, NROWA, NROWRT, NCOLRT,
+     *                   ISTATE, KACTIV, KFREE,
+     *                   CONDMX,
+     *                   A, QTG, RT, ZY, WRK1, WRK2 )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      LOGICAL            ORTHOG, UNITQ
+      INTEGER            INFORM, K1, K2, N, NCTOTL, NQ, NROWA,
+     *                   NROWRT, NCOLRT, NACTIV, NCOLZ, NFREE
+      INTEGER            ISTATE(NCTOTL), KACTIV(N), KFREE(N)
+      DOUBLE PRECISION   CONDMX
+      DOUBLE PRECISION   A(NROWA,N), QTG(N), RT(NROWRT,NCOLRT),
+     *                   ZY(NQ,NQ), WRK1(N), WRK2(N)
+C
+      DOUBLE PRECISION   ASIZE, DTMAX, DTMIN
+      COMMON    /SOL5CM/ ASIZE, DTMAX, DTMIN
+C
+C  *********************************************************************
+C  TQADD  INCLUDES GENERAL LINEAR CONSTRAINTS  K1  THRU  K2  AS NEW
+C  COLUMNS OF THE TQ FACTORIZATION STORED IN  RT, ZY.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION OF SEPTEMBER 1981.  REV. OCT 1982, JAN 1983.
+C  *********************************************************************
+C
+      INTEGER            I, IADD, IFIX, ISWAP, JADD, K, L
+      DOUBLE PRECISION   CSLAST, SNLAST
+C
+      DO 200 K = K1, K2
+         IADD = KACTIV(K)
+         JADD = N + IADD
+         IF (NACTIV .EQ. NFREE) GO TO 100
+C
+         CALL ADDCON( .FALSE., .FALSE., ORTHOG, UNITQ, INFORM,
+     *                IFIX, IADD, JADD, NACTIV, NCOLZ, NCOLZ, NFREE,
+     *                N, NQ, NROWA, NROWRT, NCOLRT, KFREE,
+     *                CONDMX, CSLAST, SNLAST,
+     *                A, QTG, RT, ZY, WRK1, WRK2 )
+C
+         IF (INFORM .GT. 0) GO TO 100
+         NACTIV = NACTIV + 1
+         NCOLZ  = NCOLZ  - 1
+         GO TO 200
+C
+  100    ISTATE(JADD) = 0
+         KACTIV(K)    = - KACTIV(K)
+  200 CONTINUE
+C
+      IF (NACTIV .EQ. K2) RETURN
+C
+C  SOME OF THE CONSTRAINTS WERE CLASSED AS DEPENDENT AND NOT INCLUDED
+C  IN THE FACTORIZATION.  MOVE ACCEPTED INDICES TO THE FRONT OF  KACTIV
+C  AND SHIFT REJECTED INDICES (WITH NEGATIVE VALUES) TO THE END.
+C
+      L     = K1 - 1
+      DO 300 K = K1, K2
+         I         = KACTIV(K)
+         IF (I .LT. 0) GO TO 300
+         L         = L + 1
+         IF (L .EQ. K) GO TO 300
+         ISWAP     = KACTIV(L)
+         KACTIV(L) = I
+         KACTIV(K) = ISWAP
+  300 CONTINUE
+      RETURN
+C
+C  END OF TQADD
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/tsolve.f
@@ -0,0 +1,59 @@
+      SUBROUTINE TSOLVE( MODE, NROWT, N, T, Y )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      INTEGER            MODE, NROWT, N
+      DOUBLE PRECISION   T(NROWT,N), Y(N)
+C
+C  *********************************************************************
+C  TSOLVE  SOLVES EQUATIONS INVOLVING A REVERSE-TRIANGULAR MATRIX  T
+C  AND A RIGHT-HAND-SIDE VECTOR  Y,  RETURNING THE SOLUTION IN  Y.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION OF SEPTEMBER 1981.
+C  *********************************************************************
+C
+      INTEGER            J, JJ, L, LROW, N1
+      DOUBLE PRECISION   YJ, ZERO
+      DATA               ZERO /0.0D+0/
+C
+      N1 = N + 1
+      IF (MODE .NE. 1) GO TO 400
+C
+C  MODE = 1  ---  SOLVE  T * Y(NEW) = Y(OLD).
+C
+      DO 100 J = 1, N
+         JJ = N1 - J
+         YJ = Y(J)/T(J,JJ)
+         Y(J) = YJ
+         L  = JJ - 1
+         IF (L .GT. 0  .AND.  YJ .NE. ZERO)
+     *   CALL AXPY( L, (-YJ), T(J+1,JJ), L, 1, Y(J+1), L, 1 )
+  100 CONTINUE
+      GO TO 700
+C
+C  MODE = 2  ---  SOLVE  T(TRANSPOSE) * Y(NEW) = Y(OLD).
+C
+  400 DO 500 J = 1, N
+         JJ = N1 - J
+         YJ = Y(J)/T(JJ,J)
+         Y(J) = YJ
+         L  = JJ - 1
+         LROW = NROWT*(L - 1) + 1
+         IF (L .GT. 0  .AND.  YJ .NE. ZERO)
+     *   CALL AXPY( L, (-YJ), T(JJ,J+1), LROW, NROWT, Y(J+1), L, 1 )
+  500 CONTINUE
+C
+C  REVERSE THE SOLUTION VECTOR.
+C
+  700 IF (N .LE. 1) RETURN
+      L = N/2
+      DO 800 J = 1, L
+         JJ    = N1 - J
+         YJ    = Y(J)
+         Y(J)  = Y(JJ)
+         Y(JJ) = YJ
+  800 CONTINUE
+      RETURN
+C
+C  END OF TSOLVE
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/v2norm.f
@@ -0,0 +1,72 @@
+      DOUBLE PRECISION FUNCTION V2NORM( N, X, LENX, INCX )
+C
+      INTEGER            N, LENX, INCX
+      DOUBLE PRECISION   X(LENX)
+C
+      DOUBLE PRECISION   WMACH
+      COMMON    /SOLMCH/ WMACH(15)
+C
+C  *********************************************************************
+C  V2NORM  RETURNS THE EUCLIDEAN NORM OF THE VECTOR X.
+C  THE NORM IS COMPUTED BY A ONE-PASS METHOD (DUE TO SVEN HAMMARLING)
+C  THAT GUARDS AGAINST OVERFLOW AND (OPTIONALLY) UNDERFLOW.
+C
+C  SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY.
+C  VERSION OF NOVEMBER 1981.
+C  *********************************************************************
+C
+      INTEGER            I, IX
+      DOUBLE PRECISION   ABSXI, FLMAX, ONE, Q, RTMIN, SCALE, SQROOT,
+     *                   SUMSQ, UNDFLW, ZERO
+      DOUBLE PRECISION   DSQRT
+      DOUBLE PRECISION   DABS
+      DATA               ZERO, ONE/0.0D+0, 1.0D+0/
+C
+      V2NORM = ZERO
+      IF (N .LT. 1) RETURN
+      RTMIN  = WMACH(6)
+      FLMAX  = WMACH(7)
+      UNDFLW = WMACH(9)
+C
+      IX    = 1
+      SCALE = ZERO
+      SUMSQ = ONE
+      IF (UNDFLW .GT. ZERO) GO TO 130
+C
+C  NO CHECK FOR UNDERFLOW.
+C
+      DO 120 I = 1, N
+         ABSXI = DABS( X(IX) )
+         IF (ABSXI .EQ.  ZERO) GO TO 110
+         IF (SCALE .GE. ABSXI) GO TO 100
+         SUMSQ = ONE + SUMSQ*(SCALE/ABSXI)**2
+         SCALE = ABSXI
+         GO TO 110
+  100    SUMSQ = SUMSQ + (ABSXI/SCALE)**2
+  110    IX    = IX + INCX
+  120 CONTINUE
+      GO TO 170
+C
+C  CHECK FOR UNNECESSARY UNDERFLOWS.
+C
+  130 DO 160 I = 1, N
+         ABSXI = DABS( X(IX) )
+         IF (ABSXI .EQ. ZERO) GO TO 150
+         Q     = ZERO
+         IF (SCALE .LT. ABSXI) GO TO 140
+         IF (SCALE .GT. RTMIN) Q = SCALE*RTMIN
+         IF (ABSXI .GE. Q) SUMSQ = SUMSQ + (ABSXI/SCALE)**2
+         GO TO 150
+  140    IF (ABSXI .GT. RTMIN) Q = ABSXI*RTMIN
+         IF (SCALE .GE. Q) SUMSQ = ONE + SUMSQ*(SCALE/ABSXI)**2
+         SCALE = ABSXI
+  150    IX    = IX + INCX
+  160 CONTINUE
+C
+  170 SQROOT = DSQRT( SUMSQ )
+      V2NORM = FLMAX
+      IF (SCALE .LT. FLMAX/SQROOT) V2NORM = SCALE*SQROOT
+      RETURN
+C
+C  END OF V2NORM
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/zerovc.f
@@ -0,0 +1,28 @@
+      SUBROUTINE ZEROVC( N, X, LENX, INCX )
+C
+      INTEGER            N, LENX, INCX
+      DOUBLE PRECISION   X(LENX)
+C
+C  SET X TO ZERO.
+C
+      INTEGER            I, IX
+      DOUBLE PRECISION   ZERO
+C
+      DATA               ZERO/0.0D+0/
+C
+      IF (N    .LT. 1) RETURN
+      IF (INCX .EQ. 1) GO TO 50
+      IX = 1
+      DO 10 I = 1, N
+         X(IX) = ZERO
+         IX = IX + INCX
+   10 CONTINUE
+      RETURN
+C
+   50 DO 60 I = 1, N
+         X(I) = ZERO
+   60 CONTINUE
+      RETURN
+C
+C  END OF ZEROVC
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/qpsol/zyprod.f
@@ -0,0 +1,138 @@
+      SUBROUTINE ZYPROD( MODE, N, NACTIV, NCOLZ, NFREE, NQ, UNITQ,
+     *                   KACTIV, KFREE, V, ZY, WRK )
+C
+C     IMPLICIT           REAL*8(A-H,O-Z)
+      LOGICAL            UNITQ
+      INTEGER            MODE, N, NACTIV, NCOLZ, NFREE, NQ
+      INTEGER            KACTIV(N), KFREE(N)
+      DOUBLE PRECISION   V(N), ZY(NQ,NQ), WRK(N)
+C
+C  *********************************************************************
+C  ZYPROD  TRANSFORMS THE VECTOR  V  IN VARIOUS WAYS USING THE
+C  MATRIX  Q = ( Z  Y )  DEFINED BY THE INPUT PARAMETERS.
+C
+C     MODE               RESULT
+C     ----               ------
+C
+C       1                V = Z*V
+C       2                V = Y*V
+C       3                V = Q*V       (NOT YET USED)
+C
+C  ON INPUT,  V  IS ASSUMED TO BE ORDERED AS  ( V(FREE)  V(FIXED) ).
+C  ON OUTPUT, V  IS A FULL N-VECTOR.
+C
+C
+C       4                V = Z(T)*V
+C       5                V = Y(T)*V
+C       6                V = Q(T)*V
+C
+C  ON INPUT,  V  IS A FULL N-VECTOR.
+C  ON OUTPUT, V  IS ORDERED AS  ( V(FREE)  V(FIXED) ).
+C
+C       7                V = Y(T)*V
+C       8                V = Q(T)*V
+C
+C  ON INPUT,  V  IS A FULL N-VECTOR.
+C  ON OUTPUT, V  IS AS IN MODES 5 AND 6 EXCEPT THAT V(FIXED) IS NOT SET.
+C
+C  BEWARE THAT  NCOLZ  WILL SOMETIMES BE  NCOLR.
+C  ALSO, MODES  1, 4, 7 AND 8  DO NOT INVOLVE  V(FIXED).
+C  NACTIV  AND  THE ARRAY  KACTIV  ARE NOT USED FOR THOSE CASES.
+C  ORIGINAL VERSION  APRIL 1983. MODES 7 AND 8 ADDED  APRIL 1984.
+C  *********************************************************************
+C
+      INTEGER            J, J1, J2, K, KA, KW, L, LENV, NFIXED
+      DOUBLE PRECISION   ZERO
+      DOUBLE PRECISION   DOT
+      DATA               ZERO /0.0D+0/
+C
+      NFIXED = N - NFREE
+      J1     = 1
+      J2     = NFREE
+      IF (MODE .EQ. 1  .OR.  MODE .EQ. 4) J2 = NCOLZ
+      IF (MODE .EQ. 2  .OR.  MODE .EQ. 5  .OR.  MODE .EQ. 7)
+     *J1 = NCOLZ + 1
+      LENV   = J2 - J1 + 1
+      IF (MODE .GE. 4) GO TO 400
+C
+C  ---------------------------------------------------------------------
+C  MODE = 1, 2  OR  3.
+C  ---------------------------------------------------------------------
+      IF (NFREE .GT. 0) CALL ZEROVC( NFREE, WRK, NFREE, 1 )
+C
+C  COPY  V(FIXED)  INTO THE END OF  WRK.
+C
+      IF (MODE .EQ. 1  .OR.  NFIXED .EQ. 0) GO TO 100
+      CALL COPYVC( NFIXED,   V(NFREE+1), NFIXED, 1,
+     *                     WRK(NFREE+1), NFIXED, 1 )
+C
+C  SET  WRK  =  RELEVANT PART OF  ZY * V.
+C
+  100 IF (LENV .LE. 0) GO TO 200
+      IF (UNITQ) CALL COPYVC( LENV, V(J1), LENV, 1, WRK(J1), LENV, 1 )
+      IF (UNITQ) GO TO 200
+      DO 120 J = J1, J2
+         IF (V(J) .NE. ZERO)
+     *   CALL AXPY( NFREE, V(J), ZY(1,J), NFREE, 1, WRK, NFREE, 1 )
+  120 CONTINUE
+C
+C  EXPAND  WRK  INTO  V  AS A FULL N-VECTOR.
+C
+  200 CALL ZEROVC( N, V, N, 1 )
+      IF (NFREE .EQ. 0) GO TO 300
+      DO 220 K = 1, NFREE
+         J    = KFREE(K)
+         V(J) = WRK(K)
+  220 CONTINUE
+C
+C  COPY  WRK(FIXED)  INTO THE APPROPRIATE PARTS OF  V.
+C
+  300 IF (MODE .EQ. 1  .OR.  NFIXED .EQ. 0) GO TO 900
+      DO 320 L = 1, NFIXED
+         KW      = NFREE  + L
+         KA      = NACTIV + L
+         J       = KACTIV(KA)
+         V(J)    = WRK(KW)
+  320 CONTINUE
+      GO TO 900
+C
+C  ---------------------------------------------------------------------
+C  MODE = 4, 5, 6, 7  OR  8.
+C  ---------------------------------------------------------------------
+C  PUT THE FIXED COMPONENTS OF  V  INTO THE END OF  WRK.
+C
+  400 IF (MODE .EQ. 4  .OR.  MODE .GT. 6  .OR.  NFIXED .EQ. 0) GO TO 500
+      DO 420 L = 1, NFIXED
+         KW      = NFREE  + L
+         KA      = NACTIV + L
+         J       = KACTIV(KA)
+         WRK(KW) = V(J)
+  420 CONTINUE
+C
+C  PUT THE FREE  COMPONENTS OF  V  INTO THE BEGINNING OF  WRK.
+C
+  500 IF (NFREE .EQ. 0) GO TO 600
+      DO 520 K = 1, NFREE
+         J      = KFREE(K)
+         WRK(K) = V(J)
+  520 CONTINUE
+C
+C  SET  V  =  RELEVANT PART OF  ZY(T) * WRK.
+C
+      IF (LENV .LE. 0) GO TO 600
+      IF (UNITQ) CALL COPYVC( LENV, WRK(J1), LENV, 1, V(J1), LENV, 1 )
+      IF (UNITQ) GO TO 600
+      DO 540 J = J1, J2
+         V(J) = DOT( NFREE, ZY(1,J), NFREE, 1, WRK, NFREE, 1 )
+  540 CONTINUE
+C
+C  COPY THE FIXED COMPONENTS OF  WRK  INTO THE END OF  V.
+C
+  600 IF (MODE .EQ. 4  .OR.  MODE .GT. 6  .OR.  NFIXED .EQ. 0) GO TO 900
+      CALL COPYVC( NFIXED, WRK(NFREE+1), NFIXED, 1,
+     *                       V(NFREE+1), NFIXED, 1 )
+C
+  900 RETURN
+C
+C  END OF ZYPROD
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/quadpack/dqagi.f
@@ -0,0 +1,191 @@
+      SUBROUTINE DQAGI(F,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,
+     *   IER,LIMIT,LENW,LAST,IWORK,WORK)
+C***BEGIN PROLOGUE  DQAGI
+C***DATE WRITTEN   800101   (YYMMDD)
+C***REVISION DATE  830518   (YYMMDD)
+C***CATEGORY NO.  H2A3A1,H2A4A1
+C***KEYWORDS  AUTOMATIC INTEGRATOR, INFINITE INTERVALS,
+C             GENERAL-PURPOSE, TRANSFORMATION, EXTRAPOLATION,
+C             GLOBALLY ADAPTIVE
+C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
+C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. -K.U.LEUVEN
+C***PURPOSE  THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN
+C            INTEGRAL   I = INTEGRAL OF F OVER (BOUND,+INFINITY)
+C            OR I = INTEGRAL OF F OVER (-INFINITY,BOUND)
+C            OR I = INTEGRAL OF F OVER (-INFINITY,+INFINITY)
+C            HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
+C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
+C***DESCRIPTION
+C
+C        INTEGRATION OVER INFINITE INTERVALS
+C        STANDARD FORTRAN SUBROUTINE
+C
+C        PARAMETERS
+C         ON ENTRY
+C            F      - DOUBLE PRECISION
+C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
+C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
+C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
+C
+C            BOUND  - DOUBLE PRECISION
+C                     FINITE BOUND OF INTEGRATION RANGE
+C                     (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE)
+C
+C            INF    - INTEGER
+C                     INDICATING THE KIND OF INTEGRATION RANGE INVOLVED
+C                     INF = 1 CORRESPONDS TO  (BOUND,+INFINITY),
+C                     INF = -1            TO  (-INFINITY,BOUND),
+C                     INF = 2             TO (-INFINITY,+INFINITY).
+C
+C            EPSABS - DOUBLE PRECISION
+C                     ABSOLUTE ACCURACY REQUESTED
+C            EPSREL - DOUBLE PRECISION
+C                     RELATIVE ACCURACY REQUESTED
+C                     IF  EPSABS.LE.0
+C                     AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
+C                     THE ROUTINE WILL END WITH IER = 6.
+C
+C
+C         ON RETURN
+C            RESULT - DOUBLE PRECISION
+C                     APPROXIMATION TO THE INTEGRAL
+C
+C            ABSERR - DOUBLE PRECISION
+C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
+C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
+C
+C            NEVAL  - INTEGER
+C                     NUMBER OF INTEGRAND EVALUATIONS
+C
+C            IER    - INTEGER
+C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
+C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
+C                             ACCURACY HAS BEEN ACHIEVED.
+C                   - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE
+C                             ESTIMATES FOR RESULT AND ERROR ARE LESS
+C                             RELIABLE. IT IS ASSUMED THAT THE REQUESTED
+C                             ACCURACY HAS NOT BEEN ACHIEVED.
+C            ERROR MESSAGES
+C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
+C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE
+C                             SUBDIVISIONS BY INCREASING THE VALUE OF
+C                             LIMIT (AND TAKING THE ACCORDING DIMENSION
+C                             ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF
+C                             THIS YIELDS NO IMPROVEMENT IT IS ADVISED
+C                             TO ANALYZE THE INTEGRAND IN ORDER TO
+C                             DETERMINE THE INTEGRATION DIFFICULTIES. IF
+C                             THE POSITION OF A LOCAL DIFFICULTY CAN BE
+C                             DETERMINED (E.G. SINGULARITY,
+C                             DISCONTINUITY WITHIN THE INTERVAL) ONE
+C                             WILL PROBABLY GAIN FROM SPLITTING UP THE
+C                             INTERVAL AT THIS POINT AND CALLING THE
+C                             INTEGRATOR ON THE SUBRANGES. IF POSSIBLE,
+C                             AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR
+C                             SHOULD BE USED, WHICH IS DESIGNED FOR
+C                             HANDLING THE TYPE OF DIFFICULTY INVOLVED.
+C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS
+C                             DETECTED, WHICH PREVENTS THE REQUESTED
+C                             TOLERANCE FROM BEING ACHIEVED.
+C                             THE ERROR MAY BE UNDER-ESTIMATED.
+C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS
+C                             AT SOME POINTS OF THE INTEGRATION
+C                             INTERVAL.
+C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
+C                             ROUNDOFF ERROR IS DETECTED IN THE
+C                             EXTRAPOLATION TABLE.
+C                             IT IS ASSUMED THAT THE REQUESTED TOLERANCE
+C                             CANNOT BE ACHIEVED, AND THAT THE RETURNED
+C                             RESULT IS THE BEST WHICH CAN BE OBTAINED.
+C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
+C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
+C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
+C                             OF IER.
+C                         = 6 THE INPUT IS INVALID, BECAUSE
+C                             (EPSABS.LE.0 AND
+C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28))
+C                              OR LIMIT.LT.1 OR LENIW.LT.LIMIT*4.
+C                             RESULT, ABSERR, NEVAL, LAST ARE SET TO
+C                             ZERO. EXEPT WHEN LIMIT OR LENIW IS
+C                             INVALID, IWORK(1), WORK(LIMIT*2+1) AND
+C                             WORK(LIMIT*3+1) ARE SET TO ZERO, WORK(1)
+C                             IS SET TO A AND WORK(LIMIT+1) TO B.
+C
+C         DIMENSIONING PARAMETERS
+C            LIMIT - INTEGER
+C                    DIMENSIONING PARAMETER FOR IWORK
+C                    LIMIT DETERMINES THE MAXIMUM NUMBER OF SUBINTERVALS
+C                    IN THE PARTITION OF THE GIVEN INTEGRATION INTERVAL
+C                    (A,B), LIMIT.GE.1.
+C                    IF LIMIT.LT.1, THE ROUTINE WILL END WITH IER = 6.
+C
+C            LENW  - INTEGER
+C                    DIMENSIONING PARAMETER FOR WORK
+C                    LENW MUST BE AT LEAST LIMIT*4.
+C                    IF LENW.LT.LIMIT*4, THE ROUTINE WILL END
+C                    WITH IER = 6.
+C
+C            LAST  - INTEGER
+C                    ON RETURN, LAST EQUALS THE NUMBER OF SUBINTERVALS
+C                    PRODUCED IN THE SUBDIVISION PROCESS, WHICH
+C                    DETERMINES THE NUMBER OF SIGNIFICANT ELEMENTS
+C                    ACTUALLY IN THE WORK ARRAYS.
+C
+C         WORK ARRAYS
+C            IWORK - INTEGER
+C                    VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
+C                    K ELEMENTS OF WHICH CONTAIN POINTERS
+C                    TO THE ERROR ESTIMATES OVER THE SUBINTERVALS,
+C                    SUCH THAT WORK(LIMIT*3+IWORK(1)),... ,
+C                    WORK(LIMIT*3+IWORK(K)) FORM A DECREASING
+C                    SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), AND
+C                    K = LIMIT+1-LAST OTHERWISE
+C
+C            WORK  - DOUBLE PRECISION
+C                    VECTOR OF DIMENSION AT LEAST LENW
+C                    ON RETURN
+C                    WORK(1), ..., WORK(LAST) CONTAIN THE LEFT
+C                     END POINTS OF THE SUBINTERVALS IN THE
+C                     PARTITION OF (A,B),
+C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN
+C                     THE RIGHT END POINTS,
+C                    WORK(LIMIT*2+1), ...,WORK(LIMIT*2+LAST) CONTAIN THE
+C                     INTEGRAL APPROXIMATIONS OVER THE SUBINTERVALS,
+C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3)
+C                     CONTAIN THE ERROR ESTIMATES.
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  DQAGIE,XERROR
+C***END PROLOGUE  DQAGI
+C
+      DOUBLE PRECISION ABSERR,BOUND,EPSABS,EPSREL,F,RESULT,WORK
+      INTEGER IER,INF,IWORK,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL
+C
+      DIMENSION IWORK(LIMIT),WORK(LENW)
+C
+      EXTERNAL F
+C
+C         CHECK VALIDITY OF LIMIT AND LENW.
+C
+C***FIRST EXECUTABLE STATEMENT  DQAGI
+      IER = 6
+      NEVAL = 0
+      LAST = 0
+      RESULT = 0.0D+00
+      ABSERR = 0.0D+00
+      IF(LIMIT.LT.1.OR.LENW.LT.LIMIT*4) GO TO 10
+C
+C         PREPARE CALL FOR DQAGIE.
+C
+      L1 = LIMIT+1
+      L2 = LIMIT+L1
+      L3 = LIMIT+L2
+C
+      CALL DQAGIE(F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
+     *  NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST)
+C
+C         CALL ERROR HANDLER IF NECESSARY.
+C
+       LVL = 0
+10    IF(IER.EQ.6) LVL = 1
+      IF(IER.GT.0) CALL XERROR(26HABNORMAL RETURN FROM DQAGI,26,IER,LVL)
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/quadpack/dqagie.f
@@ -0,0 +1,458 @@
+      SUBROUTINE DQAGIE(F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
+     *   NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST)
+C***BEGIN PROLOGUE  DQAGIE
+C***DATE WRITTEN   800101   (YYMMDD)
+C***REVISION DATE  830518   (YYMMDD)
+C***CATEGORY NO.  H2A3A1,H2A4A1
+C***KEYWORDS  AUTOMATIC INTEGRATOR, INFINITE INTERVALS,
+C             GENERAL-PURPOSE, TRANSFORMATION, EXTRAPOLATION,
+C             GLOBALLY ADAPTIVE
+C***AUTHOR  PIESSENS,ROBERT,APPL. MATH & PROGR. DIV - K.U.LEUVEN
+C           DE DONCKER,ELISE,APPL. MATH & PROGR. DIV - K.U.LEUVEN
+C***PURPOSE  THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN
+C            INTEGRAL   I = INTEGRAL OF F OVER (BOUND,+INFINITY)
+C            OR I = INTEGRAL OF F OVER (-INFINITY,BOUND)
+C            OR I = INTEGRAL OF F OVER (-INFINITY,+INFINITY),
+C            HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
+C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I))
+C***DESCRIPTION
+C
+C INTEGRATION OVER INFINITE INTERVALS
+C STANDARD FORTRAN SUBROUTINE
+C
+C            F      - DOUBLE PRECISION
+C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
+C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
+C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
+C
+C            BOUND  - DOUBLE PRECISION
+C                     FINITE BOUND OF INTEGRATION RANGE
+C                     (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE)
+C
+C            INF    - DOUBLE PRECISION
+C                     INDICATING THE KIND OF INTEGRATION RANGE INVOLVED
+C                     INF = 1 CORRESPONDS TO  (BOUND,+INFINITY),
+C                     INF = -1            TO  (-INFINITY,BOUND),
+C                     INF = 2             TO (-INFINITY,+INFINITY).
+C
+C            EPSABS - DOUBLE PRECISION
+C                     ABSOLUTE ACCURACY REQUESTED
+C            EPSREL - DOUBLE PRECISION
+C                     RELATIVE ACCURACY REQUESTED
+C                     IF  EPSABS.LE.0
+C                     AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
+C                     THE ROUTINE WILL END WITH IER = 6.
+C
+C            LIMIT  - INTEGER
+C                     GIVES AN UPPER BOUND ON THE NUMBER OF SUBINTERVALS
+C                     IN THE PARTITION OF (A,B), LIMIT.GE.1
+C
+C         ON RETURN
+C            RESULT - DOUBLE PRECISION
+C                     APPROXIMATION TO THE INTEGRAL
+C
+C            ABSERR - DOUBLE PRECISION
+C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
+C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
+C
+C            NEVAL  - INTEGER
+C                     NUMBER OF INTEGRAND EVALUATIONS
+C
+C            IER    - INTEGER
+C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
+C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
+C                             ACCURACY HAS BEEN ACHIEVED.
+C                     IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE
+C                             ESTIMATES FOR RESULT AND ERROR ARE LESS
+C                             RELIABLE. IT IS ASSUMED THAT THE REQUESTED
+C                             ACCURACY HAS NOT BEEN ACHIEVED.
+C                     IER.LT.0 EXIT REQUESTED FROM USER-SUPPLIED
+C                             FUNCTION.
+C
+C            ERROR MESSAGES
+C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
+C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE
+C                             SUBDIVISIONS BY INCREASING THE VALUE OF
+C                             LIMIT (AND TAKING THE ACCORDING DIMENSION
+C                             ADJUSTMENTS INTO ACCOUNT). HOWEVER,IF
+C                             THIS YIELDS NO IMPROVEMENT IT IS ADVISED
+C                             TO ANALYZE THE INTEGRAND IN ORDER TO
+C                             DETERMINE THE INTEGRATION DIFFICULTIES.
+C                             IF THE POSITION OF A LOCAL DIFFICULTY CAN
+C                             BE DETERMINED (E.G. SINGULARITY,
+C                             DISCONTINUITY WITHIN THE INTERVAL) ONE
+C                             WILL PROBABLY GAIN FROM SPLITTING UP THE
+C                             INTERVAL AT THIS POINT AND CALLING THE
+C                             INTEGRATOR ON THE SUBRANGES. IF POSSIBLE,
+C                             AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR
+C                             SHOULD BE USED, WHICH IS DESIGNED FOR
+C                             HANDLING THE TYPE OF DIFFICULTY INVOLVED.
+C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS
+C                             DETECTED, WHICH PREVENTS THE REQUESTED
+C                             TOLERANCE FROM BEING ACHIEVED.
+C                             THE ERROR MAY BE UNDER-ESTIMATED.
+C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS
+C                             AT SOME POINTS OF THE INTEGRATION
+C                             INTERVAL.
+C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
+C                             ROUNDOFF ERROR IS DETECTED IN THE
+C                             EXTRAPOLATION TABLE.
+C                             IT IS ASSUMED THAT THE REQUESTED TOLERANCE
+C                             CANNOT BE ACHIEVED, AND THAT THE RETURNED
+C                             RESULT IS THE BEST WHICH CAN BE OBTAINED.
+C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
+C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
+C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
+C                             OF IER.
+C                         = 6 THE INPUT IS INVALID, BECAUSE
+C                             (EPSABS.LE.0 AND
+C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
+C                             RESULT, ABSERR, NEVAL, LAST, RLIST(1),
+C                             ELIST(1) AND IORD(1) ARE SET TO ZERO.
+C                             ALIST(1) AND BLIST(1) ARE SET TO 0
+C                             AND 1 RESPECTIVELY.
+C
+C            ALIST  - DOUBLE PRECISION
+C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
+C                      LAST  ELEMENTS OF WHICH ARE THE LEFT
+C                     END POINTS OF THE SUBINTERVALS IN THE PARTITION
+C                     OF THE TRANSFORMED INTEGRATION RANGE (0,1).
+C
+C            BLIST  - DOUBLE PRECISION
+C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
+C                      LAST  ELEMENTS OF WHICH ARE THE RIGHT
+C                     END POINTS OF THE SUBINTERVALS IN THE PARTITION
+C                     OF THE TRANSFORMED INTEGRATION RANGE (0,1).
+C
+C            RLIST  - DOUBLE PRECISION
+C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
+C                      LAST  ELEMENTS OF WHICH ARE THE INTEGRAL
+C                     APPROXIMATIONS ON THE SUBINTERVALS
+C
+C            ELIST  - DOUBLE PRECISION
+C                     VECTOR OF DIMENSION AT LEAST LIMIT,  THE FIRST
+C                     LAST ELEMENTS OF WHICH ARE THE MODULI OF THE
+C                     ABSOLUTE ERROR ESTIMATES ON THE SUBINTERVALS
+C
+C            IORD   - INTEGER
+C                     VECTOR OF DIMENSION LIMIT, THE FIRST K
+C                     ELEMENTS OF WHICH ARE POINTERS TO THE
+C                     ERROR ESTIMATES OVER THE SUBINTERVALS,
+C                     SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K))
+C                     FORM A DECREASING SEQUENCE, WITH K = LAST
+C                     IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST
+C                     OTHERWISE
+C
+C            LAST   - INTEGER
+C                     NUMBER OF SUBINTERVALS ACTUALLY PRODUCED
+C                     IN THE SUBDIVISION PROCESS
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  D1MACH,DQELG,DQK15I,DQPSRT
+C***END PROLOGUE  DQAGIE
+      DOUBLE PRECISION ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,
+     *  A2,BLIST,BOUN,BOUND,B1,B2,CORREC,DABS,DEFABS,DEFAB1,DEFAB2,
+     *  DMAX1,DRES,D1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,
+     *  ERRBND,ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RESABS,
+     *  RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,UFLOW
+      INTEGER ID,IER,IERRO,INF,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN,
+     *  KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2
+      LOGICAL EXTRAP,NOEXT
+C
+      DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT),
+     *  RES3LA(3),RLIST(LIMIT),RLIST2(52)
+C
+      EXTERNAL F
+C
+C            THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF
+C            LIMEXP IN SUBROUTINE DQELG.
+C
+C
+C            LIST OF MAJOR VARIABLES
+C            -----------------------
+C
+C           ALIST     - LIST OF LEFT END POINTS OF ALL SUBINTERVALS
+C                       CONSIDERED UP TO NOW
+C           BLIST     - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS
+C                       CONSIDERED UP TO NOW
+C           RLIST(I)  - APPROXIMATION TO THE INTEGRAL OVER
+C                       (ALIST(I),BLIST(I))
+C           RLIST2    - ARRAY OF DIMENSION AT LEAST (LIMEXP+2),
+C                       CONTAINING THE PART OF THE EPSILON TABLE
+C                       WICH IS STILL NEEDED FOR FURTHER COMPUTATIONS
+C           ELIST(I)  - ERROR ESTIMATE APPLYING TO RLIST(I)
+C           MAXERR    - POINTER TO THE INTERVAL WITH LARGEST ERROR
+C                       ESTIMATE
+C           ERRMAX    - ELIST(MAXERR)
+C           ERLAST    - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED
+C                       (BEFORE THAT SUBDIVISION HAS TAKEN PLACE)
+C           AREA      - SUM OF THE INTEGRALS OVER THE SUBINTERVALS
+C           ERRSUM    - SUM OF THE ERRORS OVER THE SUBINTERVALS
+C           ERRBND    - REQUESTED ACCURACY MAX(EPSABS,EPSREL*
+C                       ABS(RESULT))
+C           *****1    - VARIABLE FOR THE LEFT SUBINTERVAL
+C           *****2    - VARIABLE FOR THE RIGHT SUBINTERVAL
+C           LAST      - INDEX FOR SUBDIVISION
+C           NRES      - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE
+C           NUMRL2    - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN
+C                       APPROPRIATE APPROXIMATION TO THE COMPOUNDED
+C                       INTEGRAL HAS BEEN OBTAINED, IT IS PUT IN
+C                       RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED
+C                       BY ONE.
+C           SMALL     - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP
+C                       TO NOW, MULTIPLIED BY 1.5
+C           ERLARG    - SUM OF THE ERRORS OVER THE INTERVALS LARGER
+C                       THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW
+C           EXTRAP    - LOGICAL VARIABLE DENOTING THAT THE ROUTINE
+C                       IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E.
+C                       BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE
+C                       TRY TO DECREASE THE VALUE OF ERLARG.
+C           NOEXT     - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION
+C                       IS NO LONGER ALLOWED (TRUE-VALUE)
+C
+C            MACHINE DEPENDENT CONSTANTS
+C            ---------------------------
+C
+C           EPMACH IS THE LARGEST RELATIVE SPACING.
+C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
+C           OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
+C
+C***FIRST EXECUTABLE STATEMENT  DQAGIE
+       EPMACH = D1MACH(4)
+C
+C           TEST ON VALIDITY OF PARAMETERS
+C           -----------------------------
+C
+      IER = 0
+      NEVAL = 0
+      LAST = 0
+      RESULT = 0.0D+00
+      ABSERR = 0.0D+00
+      ALIST(1) = 0.0D+00
+      BLIST(1) = 0.1D+01
+      RLIST(1) = 0.0D+00
+      ELIST(1) = 0.0D+00
+      IORD(1) = 0
+      IF(EPSABS.LE.0.0D+00.AND.EPSREL.LT.DMAX1(0.5D+02*EPMACH,0.5D-28))
+     *  IER = 6
+       IF(IER.EQ.6) GO TO 999
+C
+C
+C           FIRST APPROXIMATION TO THE INTEGRAL
+C           -----------------------------------
+C
+C           DETERMINE THE INTERVAL TO BE MAPPED ONTO (0,1).
+C           IF INF = 2 THE INTEGRAL IS COMPUTED AS I = I1+I2, WHERE
+C           I1 = INTEGRAL OF F OVER (-INFINITY,0),
+C           I2 = INTEGRAL OF F OVER (0,+INFINITY).
+C
+      BOUN = BOUND
+      IF(INF.EQ.2) BOUN = 0.0D+00
+      CALL DQK15I(F,BOUN,INF,0.0D+00,0.1D+01,RESULT,ABSERR,
+     *  DEFABS,RESABS,IER)
+      IF (IER .LT. 0) RETURN
+C
+C           TEST ON ACCURACY
+C
+      LAST = 1
+      RLIST(1) = RESULT
+      ELIST(1) = ABSERR
+      IORD(1) = 1
+      DRES = DABS(RESULT)
+      ERRBND = DMAX1(EPSABS,EPSREL*DRES)
+      IF(ABSERR.LE.1.0D+02*EPMACH*DEFABS.AND.ABSERR.GT.ERRBND) IER = 2
+      IF(LIMIT.EQ.1) IER = 1
+      IF(IER.NE.0.OR.(ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS).OR.
+     *  ABSERR.EQ.0.0D+00) GO TO 130
+C
+C           INITIALIZATION
+C           --------------
+C
+      UFLOW = D1MACH(1)
+      OFLOW = D1MACH(2)
+      RLIST2(1) = RESULT
+      ERRMAX = ABSERR
+      MAXERR = 1
+      AREA = RESULT
+      ERRSUM = ABSERR
+      ABSERR = OFLOW
+      NRMAX = 1
+      NRES = 0
+      KTMIN = 0
+      NUMRL2 = 2
+      EXTRAP = .FALSE.
+      NOEXT = .FALSE.
+      IERRO = 0
+      IROFF1 = 0
+      IROFF2 = 0
+      IROFF3 = 0
+      KSGN = -1
+      IF(DRES.GE.(0.1D+01-0.5D+02*EPMACH)*DEFABS) KSGN = 1
+C
+C           MAIN DO-LOOP
+C           ------------
+C
+      DO 90 LAST = 2,LIMIT
+C
+C           BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE.
+C
+        A1 = ALIST(MAXERR)
+        B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR))
+        A2 = B1
+        B2 = BLIST(MAXERR)
+        ERLAST = ERRMAX
+        CALL DQK15I(F,BOUN,INF,A1,B1,AREA1,ERROR1,RESABS,DEFAB1,IER)
+        IF (IER .LT. 0) RETURN
+        CALL DQK15I(F,BOUN,INF,A2,B2,AREA2,ERROR2,RESABS,DEFAB2,IER)
+        IF (IER .LT. 0) RETURN
+C
+C           IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL
+C           AND ERROR AND TEST FOR ACCURACY.
+C
+        AREA12 = AREA1+AREA2
+        ERRO12 = ERROR1+ERROR2
+        ERRSUM = ERRSUM+ERRO12-ERRMAX
+        AREA = AREA+AREA12-RLIST(MAXERR)
+        IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2)GO TO 15
+        IF(DABS(RLIST(MAXERR)-AREA12).GT.0.1D-04*DABS(AREA12)
+     *  .OR.ERRO12.LT.0.99D+00*ERRMAX) GO TO 10
+        IF(EXTRAP) IROFF2 = IROFF2+1
+        IF(.NOT.EXTRAP) IROFF1 = IROFF1+1
+   10   IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1
+   15   RLIST(MAXERR) = AREA1
+        RLIST(LAST) = AREA2
+        ERRBND = DMAX1(EPSABS,EPSREL*DABS(AREA))
+C
+C           TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG.
+C
+        IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2
+        IF(IROFF2.GE.5) IERRO = 3
+C
+C           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF
+C           SUBINTERVALS EQUALS LIMIT.
+C
+        IF(LAST.EQ.LIMIT) IER = 1
+C
+C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
+C           AT SOME POINTS OF THE INTEGRATION RANGE.
+C
+        IF(DMAX1(DABS(A1),DABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH)*
+     *  (DABS(A2)+0.1D+04*UFLOW)) IER = 4
+C
+C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
+C
+        IF(ERROR2.GT.ERROR1) GO TO 20
+        ALIST(LAST) = A2
+        BLIST(MAXERR) = B1
+        BLIST(LAST) = B2
+        ELIST(MAXERR) = ERROR1
+        ELIST(LAST) = ERROR2
+        GO TO 30
+   20   ALIST(MAXERR) = A2
+        ALIST(LAST) = A1
+        BLIST(LAST) = B1
+        RLIST(MAXERR) = AREA2
+        RLIST(LAST) = AREA1
+        ELIST(MAXERR) = ERROR2
+        ELIST(LAST) = ERROR1
+C
+C           CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING
+C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL
+C           WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT).
+C
+   30   CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
+        IF(ERRSUM.LE.ERRBND) GO TO 115
+        IF(IER.NE.0) GO TO 100
+        IF(LAST.EQ.2) GO TO 80
+        IF(NOEXT) GO TO 90
+        ERLARG = ERLARG-ERLAST
+        IF(DABS(B1-A1).GT.SMALL) ERLARG = ERLARG+ERRO12
+        IF(EXTRAP) GO TO 40
+C
+C           TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE
+C           SMALLEST INTERVAL.
+C
+        IF(DABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90
+        EXTRAP = .TRUE.
+        NRMAX = 2
+   40   IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 60
+C
+C           THE SMALLEST INTERVAL HAS THE LARGEST ERROR.
+C           BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER THE
+C           LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION.
+C
+        ID = NRMAX
+        JUPBND = LAST
+        IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST
+        DO 50 K = ID,JUPBND
+          MAXERR = IORD(NRMAX)
+          ERRMAX = ELIST(MAXERR)
+          IF(DABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90
+          NRMAX = NRMAX+1
+   50   CONTINUE
+C
+C           PERFORM EXTRAPOLATION.
+C
+   60   NUMRL2 = NUMRL2+1
+        RLIST2(NUMRL2) = AREA
+        CALL DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES)
+        KTMIN = KTMIN+1
+        IF(KTMIN.GT.5.AND.ABSERR.LT.0.1D-02*ERRSUM) IER = 5
+        IF(ABSEPS.GE.ABSERR) GO TO 70
+        KTMIN = 0
+        ABSERR = ABSEPS
+        RESULT = RESEPS
+        CORREC = ERLARG
+        ERTEST = DMAX1(EPSABS,EPSREL*DABS(RESEPS))
+        IF(ABSERR.LE.ERTEST) GO TO 100
+C
+C            PREPARE BISECTION OF THE SMALLEST INTERVAL.
+C
+   70   IF(NUMRL2.EQ.1) NOEXT = .TRUE.
+        IF(IER.EQ.5) GO TO 100
+        MAXERR = IORD(1)
+        ERRMAX = ELIST(MAXERR)
+        NRMAX = 1
+        EXTRAP = .FALSE.
+        SMALL = SMALL*0.5D+00
+        ERLARG = ERRSUM
+        GO TO 90
+   80   SMALL = 0.375D+00
+        ERLARG = ERRSUM
+        ERTEST = ERRBND
+        RLIST2(2) = AREA
+   90 CONTINUE
+C
+C           SET FINAL RESULT AND ERROR ESTIMATE.
+C           ------------------------------------
+C
+  100 IF(ABSERR.EQ.OFLOW) GO TO 115
+      IF((IER+IERRO).EQ.0) GO TO 110
+      IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC
+      IF(IER.EQ.0) IER = 3
+      IF(RESULT.NE.0.0D+00.AND.AREA.NE.0.0D+00)GO TO 105
+      IF(ABSERR.GT.ERRSUM)GO TO 115
+      IF(AREA.EQ.0.0D+00) GO TO 130
+      GO TO 110
+  105 IF(ABSERR/DABS(RESULT).GT.ERRSUM/DABS(AREA))GO TO 115
+C
+C           TEST ON DIVERGENCE
+C
+  110 IF(KSGN.EQ.(-1).AND.DMAX1(DABS(RESULT),DABS(AREA)).LE.
+     * DEFABS*0.1D-01) GO TO 130
+      IF(0.1D-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1D+03.
+     *OR.ERRSUM.GT.DABS(AREA)) IER = 6
+      GO TO 130
+C
+C           COMPUTE GLOBAL INTEGRAL SUM.
+C
+  115 RESULT = 0.0D+00
+      DO 120 K = 1,LAST
+        RESULT = RESULT+RLIST(K)
+  120 CONTINUE
+      ABSERR = ERRSUM
+  130 NEVAL = 30*LAST-15
+      IF(INF.EQ.2) NEVAL = 2*NEVAL
+      IF(IER.GT.2) IER=IER-1
+  999 RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/quadpack/dqagp.f
@@ -0,0 +1,225 @@
+      SUBROUTINE DQAGP(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR,
+     *   NEVAL,IER,LENIW,LENW,LAST,IWORK,WORK)
+C***BEGIN PROLOGUE  DQAGP
+C***DATE WRITTEN   800101   (YYMMDD)
+C***REVISION DATE  830518   (YYMMDD)
+C***CATEGORY NO.  H2A2A1
+C***KEYWORDS  AUTOMATIC INTEGRATOR, GENERAL-PURPOSE,
+C             SINGULARITIES AT USER SPECIFIED POINTS,
+C             EXTRAPOLATION, GLOBALLY ADAPTIVE
+C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV - K.U.LEUVEN
+C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
+C***PURPOSE  THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN
+C            DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B),
+C            HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
+C            BREAK POINTS OF THE INTEGRATION INTERVAL, WHERE LOCAL
+C            DIFFICULTIES OF THE INTEGRAND MAY OCCUR (E.G.
+C            SINGULARITIES, DISCONTINUITIES), ARE PROVIDED BY THE USER.
+C***DESCRIPTION
+C
+C        COMPUTATION OF A DEFINITE INTEGRAL
+C        STANDARD FORTRAN SUBROUTINE
+C        DOUBLE PRECISION VERSION
+C
+C        PARAMETERS
+C         ON ENTRY
+C            F      - DOUBLE PRECISION
+C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
+C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
+C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
+C
+C            A      - DOUBLE PRECISION
+C                     LOWER LIMIT OF INTEGRATION
+C
+C            B      - DOUBLE PRECISION
+C                     UPPER LIMIT OF INTEGRATION
+C
+C            NPTS2  - INTEGER
+C                     NUMBER EQUAL TO TWO MORE THAN THE NUMBER OF
+C                     USER-SUPPLIED BREAK POINTS WITHIN THE INTEGRATION
+C                     RANGE, NPTS.GE.2.
+C                     IF NPTS2.LT.2, THE ROUTINE WILL END WITH IER = 6.
+C
+C            POINTS - DOUBLE PRECISION
+C                     VECTOR OF DIMENSION NPTS2, THE FIRST (NPTS2-2)
+C                     ELEMENTS OF WHICH ARE THE USER PROVIDED BREAK
+C                     POINTS. IF THESE POINTS DO NOT CONSTITUTE AN
+C                     ASCENDING SEQUENCE THERE WILL BE AN AUTOMATIC
+C                     SORTING.
+C
+C            EPSABS - DOUBLE PRECISION
+C                     ABSOLUTE ACCURACY REQUESTED
+C            EPSREL - DOUBLE PRECISION
+C                     RELATIVE ACCURACY REQUESTED
+C                     IF  EPSABS.LE.0
+C                     AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
+C                     THE ROUTINE WILL END WITH IER = 6.
+C
+C         ON RETURN
+C            RESULT - DOUBLE PRECISION
+C                     APPROXIMATION TO THE INTEGRAL
+C
+C            ABSERR - DOUBLE PRECISION
+C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
+C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
+C
+C            NEVAL  - INTEGER
+C                     NUMBER OF INTEGRAND EVALUATIONS
+C
+C            IER    - INTEGER
+C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
+C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
+C                             ACCURACY HAS BEEN ACHIEVED.
+C                     IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE.
+C                             THE ESTIMATES FOR INTEGRAL AND ERROR ARE
+C                             LESS RELIABLE. IT IS ASSUMED THAT THE
+C                             REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.
+C            ERROR MESSAGES
+C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
+C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE
+C                             SUBDIVISIONS BY INCREASING THE VALUE OF
+C                             LIMIT (AND TAKING THE ACCORDING DIMENSION
+C                             ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF
+C                             THIS YIELDS NO IMPROVEMENT IT IS ADVISED
+C                             TO ANALYZE THE INTEGRAND IN ORDER TO
+C                             DETERMINE THE INTEGRATION DIFFICULTIES. IF
+C                             THE POSITION OF A LOCAL DIFFICULTY CAN BE
+C                             DETERMINED (I.E. SINGULARITY,
+C                             DISCONTINUITY WITHIN THE INTERVAL), IT
+C                             SHOULD BE SUPPLIED TO THE ROUTINE AS AN
+C                             ELEMENT OF THE VECTOR POINTS. IF NECESSARY
+C                             AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR
+C                             MUST BE USED, WHICH IS DESIGNED FOR
+C                             HANDLING THE TYPE OF DIFFICULTY INVOLVED.
+C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS
+C                             DETECTED, WHICH PREVENTS THE REQUESTED
+C                             TOLERANCE FROM BEING ACHIEVED.
+C                             THE ERROR MAY BE UNDER-ESTIMATED.
+C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS
+C                             AT SOME POINTS OF THE INTEGRATION
+C                             INTERVAL.
+C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
+C                             ROUNDOFF ERROR IS DETECTED IN THE
+C                             EXTRAPOLATION TABLE.
+C                             IT IS PRESUMED THAT THE REQUESTED
+C                             TOLERANCE CANNOT BE ACHIEVED, AND THAT
+C                             THE RETURNED RESULT IS THE BEST WHICH
+C                             CAN BE OBTAINED.
+C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
+C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
+C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
+C                             OF IER.GT.0.
+C                         = 6 THE INPUT IS INVALID BECAUSE
+C                             NPTS2.LT.2 OR
+C                             BREAK POINTS ARE SPECIFIED OUTSIDE
+C                             THE INTEGRATION RANGE OR
+C                             (EPSABS.LE.0 AND
+C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28))
+C                             RESULT, ABSERR, NEVAL, LAST ARE SET TO
+C                             ZERO. EXEPT WHEN LENIW OR LENW OR NPTS2 IS
+C                             INVALID, IWORK(1), IWORK(LIMIT+1),
+C                             WORK(LIMIT*2+1) AND WORK(LIMIT*3+1)
+C                             ARE SET TO ZERO.
+C                             WORK(1) IS SET TO A AND WORK(LIMIT+1)
+C                             TO B (WHERE LIMIT = (LENIW-NPTS2)/2).
+C
+C         DIMENSIONING PARAMETERS
+C            LENIW - INTEGER
+C                    DIMENSIONING PARAMETER FOR IWORK
+C                    LENIW DETERMINES LIMIT = (LENIW-NPTS2)/2,
+C                    WHICH IS THE MAXIMUM NUMBER OF SUBINTERVALS IN THE
+C                    PARTITION OF THE GIVEN INTEGRATION INTERVAL (A,B),
+C                    LENIW.GE.(3*NPTS2-2).
+C                    IF LENIW.LT.(3*NPTS2-2), THE ROUTINE WILL END WITH
+C                    IER = 6.
+C
+C            LENW  - INTEGER
+C                    DIMENSIONING PARAMETER FOR WORK
+C                    LENW MUST BE AT LEAST LENIW*2-NPTS2.
+C                    IF LENW.LT.LENIW*2-NPTS2, THE ROUTINE WILL END
+C                    WITH IER = 6.
+C
+C            LAST  - INTEGER
+C                    ON RETURN, LAST EQUALS THE NUMBER OF SUBINTERVALS
+C                    PRODUCED IN THE SUBDIVISION PROCESS, WHICH
+C                    DETERMINES THE NUMBER OF SIGNIFICANT ELEMENTS
+C                    ACTUALLY IN THE WORK ARRAYS.
+C
+C         WORK ARRAYS
+C            IWORK - INTEGER
+C                    VECTOR OF DIMENSION AT LEAST LENIW. ON RETURN,
+C                    THE FIRST K ELEMENTS OF WHICH CONTAIN
+C                    POINTERS TO THE ERROR ESTIMATES OVER THE
+C                    SUBINTERVALS, SUCH THAT WORK(LIMIT*3+IWORK(1)),...,
+C                    WORK(LIMIT*3+IWORK(K)) FORM A DECREASING
+C                    SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), AND
+C                    K = LIMIT+1-LAST OTHERWISE
+C                    IWORK(LIMIT+1), ...,IWORK(LIMIT+LAST) CONTAIN THE
+C                     SUBDIVISION LEVELS OF THE SUBINTERVALS, I.E.
+C                     IF (AA,BB) IS A SUBINTERVAL OF (P1,P2)
+C                     WHERE P1 AS WELL AS P2 IS A USER-PROVIDED
+C                     BREAK POINT OR INTEGRATION LIMIT, THEN (AA,BB) HAS
+C                     LEVEL L IF ABS(BB-AA) = ABS(P2-P1)*2**(-L),
+C                    IWORK(LIMIT*2+1), ..., IWORK(LIMIT*2+NPTS2) HAVE
+C                     NO SIGNIFICANCE FOR THE USER,
+C                    NOTE THAT LIMIT = (LENIW-NPTS2)/2.
+C
+C            WORK  - DOUBLE PRECISION
+C                    VECTOR OF DIMENSION AT LEAST LENW
+C                    ON RETURN
+C                    WORK(1), ..., WORK(LAST) CONTAIN THE LEFT
+C                     END POINTS OF THE SUBINTERVALS IN THE
+C                     PARTITION OF (A,B),
+C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN
+C                     THE RIGHT END POINTS,
+C                    WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) CONTAIN
+C                     THE INTEGRAL APPROXIMATIONS OVER THE SUBINTERVALS,
+C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST)
+C                     CONTAIN THE CORRESPONDING ERROR ESTIMATES,
+C                    WORK(LIMIT*4+1), ..., WORK(LIMIT*4+NPTS2)
+C                     CONTAIN THE INTEGRATION LIMITS AND THE
+C                     BREAK POINTS SORTED IN AN ASCENDING SEQUENCE.
+C                    NOTE THAT LIMIT = (LENIW-NPTS2)/2.
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  DQAGPE,XERROR
+C***END PROLOGUE  DQAGP
+C
+      DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,F,POINTS,RESULT,WORK
+      INTEGER IER,IWORK,LAST,LENIW,LENW,LIMIT,LVL,L1,L2,L3,L4,NEVAL,
+     *  NPTS2
+C
+      DIMENSION IWORK(LENIW),POINTS(NPTS2),WORK(LENW)
+C
+      EXTERNAL F
+C
+C         CHECK VALIDITY OF LIMIT AND LENW.
+C
+C***FIRST EXECUTABLE STATEMENT  DQAGP
+      IER = 6
+      NEVAL = 0
+      LAST = 0
+      RESULT = 0.0D+00
+      ABSERR = 0.0D+00
+      IF(LENIW.LT.(3*NPTS2-2).OR.LENW.LT.(LENIW*2-NPTS2).OR.NPTS2.LT.2)
+     *  GO TO 10
+C
+C         PREPARE CALL FOR DQAGPE.
+C
+      LIMIT = (LENIW-NPTS2)/2
+      L1 = LIMIT+1
+      L2 = LIMIT+L1
+      L3 = LIMIT+L2
+      L4 = LIMIT+L3
+C
+      CALL DQAGPE(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
+     *  NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),WORK(L4),
+     *  IWORK(1),IWORK(L1),IWORK(L2),LAST)
+C
+C         CALL ERROR HANDLER IF NECESSARY.
+C
+      LVL = 0
+10    IF(IER.EQ.6) LVL = 1
+      IF(IER.GT.0) CALL XERROR(26HABNORMAL RETURN FROM DQAGP,26,IER,LVL)
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/quadpack/dqagpe.f
@@ -0,0 +1,556 @@
+      SUBROUTINE DQAGPE(F,A,B,NPTS2,POINTS,EPSABS,EPSREL,LIMIT,RESULT,
+     *   ABSERR,NEVAL,IER,ALIST,BLIST,RLIST,ELIST,PTS,IORD,LEVEL,NDIN,
+     *   LAST)
+C***BEGIN PROLOGUE  DQAGPE
+C***DATE WRITTEN   800101   (YYMMDD)
+C***REVISION DATE  830518   (YYMMDD)
+C***CATEGORY NO.  H2A2A1
+C***KEYWORDS  AUTOMATIC INTEGRATOR, GENERAL-PURPOSE,
+C             SINGULARITIES AT USER SPECIFIED POINTS,
+C             EXTRAPOLATION, GLOBALLY ADAPTIVE.
+C***AUTHOR  PIESSENS,ROBERT ,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
+C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
+C***PURPOSE  THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN
+C            DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B), HOPEFULLY
+C            SATISFYING FOLLOWING CLAIM FOR ACCURACY ABS(I-RESULT).LE.
+C            MAX(EPSABS,EPSREL*ABS(I)). BREAK POINTS OF THE INTEGRATION
+C            INTERVAL, WHERE LOCAL DIFFICULTIES OF THE INTEGRAND MAY
+C            OCCUR(E.G. SINGULARITIES,DISCONTINUITIES),PROVIDED BY USER.
+C***DESCRIPTION
+C
+C        COMPUTATION OF A DEFINITE INTEGRAL
+C        STANDARD FORTRAN SUBROUTINE
+C        DOUBLE PRECISION VERSION
+C
+C        PARAMETERS
+C         ON ENTRY
+C            F      - DOUBLE PRECISION
+C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
+C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
+C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
+C
+C            A      - DOUBLE PRECISION
+C                     LOWER LIMIT OF INTEGRATION
+C
+C            B      - DOUBLE PRECISION
+C                     UPPER LIMIT OF INTEGRATION
+C
+C            NPTS2  - INTEGER
+C                     NUMBER EQUAL TO TWO MORE THAN THE NUMBER OF
+C                     USER-SUPPLIED BREAK POINTS WITHIN THE INTEGRATION
+C                     RANGE, NPTS2.GE.2.
+C                     IF NPTS2.LT.2, THE ROUTINE WILL END WITH IER = 6.
+C
+C            POINTS - DOUBLE PRECISION
+C                     VECTOR OF DIMENSION NPTS2, THE FIRST (NPTS2-2)
+C                     ELEMENTS OF WHICH ARE THE USER PROVIDED BREAK
+C                     POINTS. IF THESE POINTS DO NOT CONSTITUTE AN
+C                     ASCENDING SEQUENCE THERE WILL BE AN AUTOMATIC
+C                     SORTING.
+C
+C            EPSABS - DOUBLE PRECISION
+C                     ABSOLUTE ACCURACY REQUESTED
+C            EPSREL - DOUBLE PRECISION
+C                     RELATIVE ACCURACY REQUESTED
+C                     IF  EPSABS.LE.0
+C                     AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
+C                     THE ROUTINE WILL END WITH IER = 6.
+C
+C            LIMIT  - INTEGER
+C                     GIVES AN UPPER BOUND ON THE NUMBER OF SUBINTERVALS
+C                     IN THE PARTITION OF (A,B), LIMIT.GE.NPTS2
+C                     IF LIMIT.LT.NPTS2, THE ROUTINE WILL END WITH
+C                     IER = 6.
+C
+C         ON RETURN
+C            RESULT - DOUBLE PRECISION
+C                     APPROXIMATION TO THE INTEGRAL
+C
+C            ABSERR - DOUBLE PRECISION
+C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
+C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
+C
+C            NEVAL  - INTEGER
+C                     NUMBER OF INTEGRAND EVALUATIONS
+C
+C            IER    - INTEGER
+C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
+C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
+C                             ACCURACY HAS BEEN ACHIEVED.
+C                     IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE.
+C                             THE ESTIMATES FOR INTEGRAL AND ERROR ARE
+C                             LESS RELIABLE. IT IS ASSUMED THAT THE
+C                             REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.
+C                      IER.LT.0 EXIT REQUESTED FROM USER-SUPPLIED
+C                             FUNCTION.
+C
+C            ERROR MESSAGES
+C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
+C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE
+C                             SUBDIVISIONS BY INCREASING THE VALUE OF
+C                             LIMIT (AND TAKING THE ACCORDING DIMENSION
+C                             ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF
+C                             THIS YIELDS NO IMPROVEMENT IT IS ADVISED
+C                             TO ANALYZE THE INTEGRAND IN ORDER TO
+C                             DETERMINE THE INTEGRATION DIFFICULTIES. IF
+C                             THE POSITION OF A LOCAL DIFFICULTY CAN BE
+C                             DETERMINED (I.E. SINGULARITY,
+C                             DISCONTINUITY WITHIN THE INTERVAL), IT
+C                             SHOULD BE SUPPLIED TO THE ROUTINE AS AN
+C                             ELEMENT OF THE VECTOR POINTS. IF NECESSARY
+C                             AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR
+C                             MUST BE USED, WHICH IS DESIGNED FOR
+C                             HANDLING THE TYPE OF DIFFICULTY INVOLVED.
+C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS
+C                             DETECTED, WHICH PREVENTS THE REQUESTED
+C                             TOLERANCE FROM BEING ACHIEVED.
+C                             THE ERROR MAY BE UNDER-ESTIMATED.
+C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS
+C                             AT SOME POINTS OF THE INTEGRATION
+C                             INTERVAL.
+C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
+C                             ROUNDOFF ERROR IS DETECTED IN THE
+C                             EXTRAPOLATION TABLE. IT IS PRESUMED THAT
+C                             THE REQUESTED TOLERANCE CANNOT BE
+C                             ACHIEVED, AND THAT THE RETURNED RESULT IS
+C                             THE BEST WHICH CAN BE OBTAINED.
+C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
+C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
+C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
+C                             OF IER.GT.0.
+C                         = 6 THE INPUT IS INVALID BECAUSE
+C                             NPTS2.LT.2 OR
+C                             BREAK POINTS ARE SPECIFIED OUTSIDE
+C                             THE INTEGRATION RANGE OR
+C                             (EPSABS.LE.0 AND
+C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28))
+C                             OR LIMIT.LT.NPTS2.
+C                             RESULT, ABSERR, NEVAL, LAST, RLIST(1),
+C                             AND ELIST(1) ARE SET TO ZERO. ALIST(1) AND
+C                             BLIST(1) ARE SET TO A AND B RESPECTIVELY.
+C
+C            ALIST  - DOUBLE PRECISION
+C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
+C                      LAST  ELEMENTS OF WHICH ARE THE LEFT END POINTS
+C                     OF THE SUBINTERVALS IN THE PARTITION OF THE GIVEN
+C                     INTEGRATION RANGE (A,B)
+C
+C            BLIST  - DOUBLE PRECISION
+C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
+C                      LAST  ELEMENTS OF WHICH ARE THE RIGHT END POINTS
+C                     OF THE SUBINTERVALS IN THE PARTITION OF THE GIVEN
+C                     INTEGRATION RANGE (A,B)
+C
+C            RLIST  - DOUBLE PRECISION
+C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
+C                      LAST  ELEMENTS OF WHICH ARE THE INTEGRAL
+C                     APPROXIMATIONS ON THE SUBINTERVALS
+C
+C            ELIST  - DOUBLE PRECISION
+C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
+C                      LAST  ELEMENTS OF WHICH ARE THE MODULI OF THE
+C                     ABSOLUTE ERROR ESTIMATES ON THE SUBINTERVALS
+C
+C            PTS    - DOUBLE PRECISION
+C                     VECTOR OF DIMENSION AT LEAST NPTS2, CONTAINING THE
+C                     INTEGRATION LIMITS AND THE BREAK POINTS OF THE
+C                     INTERVAL IN ASCENDING SEQUENCE.
+C
+C            LEVEL  - INTEGER
+C                     VECTOR OF DIMENSION AT LEAST LIMIT, CONTAINING THE
+C                     SUBDIVISION LEVELS OF THE SUBINTERVAL, I.E. IF
+C                     (AA,BB) IS A SUBINTERVAL OF (P1,P2) WHERE P1 AS
+C                     WELL AS P2 IS A USER-PROVIDED BREAK POINT OR
+C                     INTEGRATION LIMIT, THEN (AA,BB) HAS LEVEL L IF
+C                     ABS(BB-AA) = ABS(P2-P1)*2**(-L).
+C
+C            NDIN   - INTEGER
+C                     VECTOR OF DIMENSION AT LEAST NPTS2, AFTER FIRST
+C                     INTEGRATION OVER THE INTERVALS (PTS(I)),PTS(I+1),
+C                     I = 0,1, ..., NPTS2-2, THE ERROR ESTIMATES OVER
+C                     SOME OF THE INTERVALS MAY HAVE BEEN INCREASED
+C                     ARTIFICIALLY, IN ORDER TO PUT THEIR SUBDIVISION
+C                     FORWARD. IF THIS HAPPENS FOR THE SUBINTERVAL
+C                     NUMBERED K, NDIN(K) IS PUT TO 1, OTHERWISE
+C                     NDIN(K) = 0.
+C
+C            IORD   - INTEGER
+C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K
+C                     ELEMENTS OF WHICH ARE POINTERS TO THE
+C                     ERROR ESTIMATES OVER THE SUBINTERVALS,
+C                     SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K))
+C                     FORM A DECREASING SEQUENCE, WITH K = LAST
+C                     IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST
+C                     OTHERWISE
+C
+C            LAST   - INTEGER
+C                     NUMBER OF SUBINTERVALS ACTUALLY PRODUCED IN THE
+C                     SUBDIVISIONS PROCESS
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  D1MACH,DQELG,DQK21,DQPSRT
+C***END PROLOGUE  DQAGPE
+      DOUBLE PRECISION A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,
+     *  A2,B,BLIST,B1,B2,CORREC,DABS,DEFABS,DEFAB1,DEFAB2,DMAX1,DMIN1,
+     *  DRES,D1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND,
+     *  ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,ERTEST,F,OFLOW,POINTS,PTS,
+     *  RESA,RESABS,RESEPS,RESULT,RES3LA,RLIST,RLIST2,SIGN,TEMP,UFLOW
+      INTEGER I,ID,IER,IERRO,IND1,IND2,IORD,IP1,IROFF1,IROFF2,IROFF3,J,
+     *  JLOW,JUPBND,K,KSGN,KTMIN,LAST,LEVCUR,LEVEL,LEVMAX,LIMIT,MAXERR,
+     *  NDIN,NEVAL,NINT,NINTP1,NPTS,NPTS2,NRES,NRMAX,NUMRL2
+      LOGICAL EXTRAP,NOEXT
+C
+C
+      DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT),
+     *  LEVEL(LIMIT),NDIN(NPTS2),POINTS(NPTS2),PTS(NPTS2),RES3LA(3),
+     *  RLIST(LIMIT),RLIST2(52)
+C
+      EXTERNAL F
+C
+C            THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF
+C            LIMEXP IN SUBROUTINE EPSALG (RLIST2 SHOULD BE OF DIMENSION
+C            (LIMEXP+2) AT LEAST).
+C
+C
+C            LIST OF MAJOR VARIABLES
+C            -----------------------
+C
+C           ALIST     - LIST OF LEFT END POINTS OF ALL SUBINTERVALS
+C                       CONSIDERED UP TO NOW
+C           BLIST     - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS
+C                       CONSIDERED UP TO NOW
+C           RLIST(I)  - APPROXIMATION TO THE INTEGRAL OVER
+C                       (ALIST(I),BLIST(I))
+C           RLIST2    - ARRAY OF DIMENSION AT LEAST LIMEXP+2
+C                       CONTAINING THE PART OF THE EPSILON TABLE WHICH
+C                       IS STILL NEEDED FOR FURTHER COMPUTATIONS
+C           ELIST(I)  - ERROR ESTIMATE APPLYING TO RLIST(I)
+C           MAXERR    - POINTER TO THE INTERVAL WITH LARGEST ERROR
+C                       ESTIMATE
+C           ERRMAX    - ELIST(MAXERR)
+C           ERLAST    - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED
+C                       (BEFORE THAT SUBDIVISION HAS TAKEN PLACE)
+C           AREA      - SUM OF THE INTEGRALS OVER THE SUBINTERVALS
+C           ERRSUM    - SUM OF THE ERRORS OVER THE SUBINTERVALS
+C           ERRBND    - REQUESTED ACCURACY MAX(EPSABS,EPSREL*
+C                       ABS(RESULT))
+C           *****1    - VARIABLE FOR THE LEFT SUBINTERVAL
+C           *****2    - VARIABLE FOR THE RIGHT SUBINTERVAL
+C           LAST      - INDEX FOR SUBDIVISION
+C           NRES      - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE
+C           NUMRL2    - NUMBER OF ELEMENTS IN RLIST2. IF AN APPROPRIATE
+C                       APPROXIMATION TO THE COMPOUNDED INTEGRAL HAS
+C                       BEEN OBTAINED, IT IS PUT IN RLIST2(NUMRL2) AFTER
+C                       NUMRL2 HAS BEEN INCREASED BY ONE.
+C           ERLARG    - SUM OF THE ERRORS OVER THE INTERVALS LARGER
+C                       THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW
+C           EXTRAP    - LOGICAL VARIABLE DENOTING THAT THE ROUTINE
+C                       IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E.
+C                       BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE
+C                       TRY TO DECREASE THE VALUE OF ERLARG.
+C           NOEXT     - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION IS
+C                       NO LONGER ALLOWED (TRUE-VALUE)
+C
+C            MACHINE DEPENDENT CONSTANTS
+C            ---------------------------
+C
+C           EPMACH IS THE LARGEST RELATIVE SPACING.
+C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
+C           OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
+C
+C***FIRST EXECUTABLE STATEMENT  DQAGPE
+      EPMACH = D1MACH(4)
+C
+C            TEST ON VALIDITY OF PARAMETERS
+C            -----------------------------
+C
+      IER = 0
+      NEVAL = 0
+      LAST = 0
+      RESULT = 0.0D+00
+      ABSERR = 0.0D+00
+      ALIST(1) = A
+      BLIST(1) = B
+      RLIST(1) = 0.0D+00
+      ELIST(1) = 0.0D+00
+      IORD(1) = 0
+      LEVEL(1) = 0
+      NPTS = NPTS2-2
+      IF(NPTS2.LT.2.OR.LIMIT.LE.NPTS.OR.(EPSABS.LE.0.0D+00.AND.
+     *  EPSREL.LT.DMAX1(0.5D+02*EPMACH,0.5D-28))) IER = 6
+      IF(IER.EQ.6) GO TO 999
+C
+C            IF ANY BREAK POINTS ARE PROVIDED, SORT THEM INTO AN
+C            ASCENDING SEQUENCE.
+C
+      SIGN = 1.0D+00
+      IF(A.GT.B) SIGN = -1.0D+00
+      PTS(1) = DMIN1(A,B)
+      IF(NPTS.EQ.0) GO TO 15
+      DO 10 I = 1,NPTS
+        PTS(I+1) = POINTS(I)
+   10 CONTINUE
+   15 PTS(NPTS+2) = DMAX1(A,B)
+      NINT = NPTS+1
+      A1 = PTS(1)
+      IF(NPTS.EQ.0) GO TO 40
+      NINTP1 = NINT+1
+      DO 20 I = 1,NINT
+        IP1 = I+1
+        DO 20 J = IP1,NINTP1
+          IF(PTS(I).LE.PTS(J)) GO TO 20
+          TEMP = PTS(I)
+          PTS(I) = PTS(J)
+          PTS(J) = TEMP
+   20 CONTINUE
+      IF(PTS(1).NE.DMIN1(A,B).OR.PTS(NINTP1).NE.DMAX1(A,B)) IER = 6
+      IF(IER.EQ.6) GO TO 999
+C
+C            COMPUTE FIRST INTEGRAL AND ERROR APPROXIMATIONS.
+C            ------------------------------------------------
+C
+   40 RESABS = 0.0D+00
+      DO 50 I = 1,NINT
+        B1 = PTS(I+1)
+        CALL DQK21(F,A1,B1,AREA1,ERROR1,DEFABS,RESA,IER)
+        IF (IER .LT. 0) RETURN
+        ABSERR = ABSERR+ERROR1
+        RESULT = RESULT+AREA1
+        NDIN(I) = 0
+        IF(ERROR1.EQ.RESA.AND.ERROR1.NE.0.0D+00) NDIN(I) = 1
+        RESABS = RESABS+DEFABS
+        LEVEL(I) = 0
+        ELIST(I) = ERROR1
+        ALIST(I) = A1
+        BLIST(I) = B1
+        RLIST(I) = AREA1
+        IORD(I) = I
+        A1 = B1
+   50 CONTINUE
+      ERRSUM = 0.0D+00
+      DO 55 I = 1,NINT
+        IF(NDIN(I).EQ.1) ELIST(I) = ABSERR
+        ERRSUM = ERRSUM+ELIST(I)
+   55 CONTINUE
+C
+C           TEST ON ACCURACY.
+C
+      LAST = NINT
+      NEVAL = 21*NINT
+      DRES = DABS(RESULT)
+      ERRBND = DMAX1(EPSABS,EPSREL*DRES)
+      IF(ABSERR.LE.0.1D+03*EPMACH*RESABS.AND.ABSERR.GT.ERRBND) IER = 2
+      IF(NINT.EQ.1) GO TO 80
+      DO 70 I = 1,NPTS
+        JLOW = I+1
+        IND1 = IORD(I)
+        DO 60 J = JLOW,NINT
+          IND2 = IORD(J)
+          IF(ELIST(IND1).GT.ELIST(IND2)) GO TO 60
+          IND1 = IND2
+          K = J
+   60   CONTINUE
+        IF(IND1.EQ.IORD(I)) GO TO 70
+        IORD(K) = IORD(I)
+        IORD(I) = IND1
+   70 CONTINUE
+      IF(LIMIT.LT.NPTS2) IER = 1
+   80 IF(IER.NE.0.OR.ABSERR.LE.ERRBND) GO TO 210
+C
+C           INITIALIZATION
+C           --------------
+C
+      RLIST2(1) = RESULT
+      MAXERR = IORD(1)
+      ERRMAX = ELIST(MAXERR)
+      AREA = RESULT
+      NRMAX = 1
+      NRES = 0
+      NUMRL2 = 1
+      KTMIN = 0
+      EXTRAP = .FALSE.
+      NOEXT = .FALSE.
+      ERLARG = ERRSUM
+      ERTEST = ERRBND
+      LEVMAX = 1
+      IROFF1 = 0
+      IROFF2 = 0
+      IROFF3 = 0
+      IERRO = 0
+      UFLOW = D1MACH(1)
+      OFLOW = D1MACH(2)
+      ABSERR = OFLOW
+      KSGN = -1
+      IF(DRES.GE.(0.1D+01-0.5D+02*EPMACH)*RESABS) KSGN = 1
+C
+C           MAIN DO-LOOP
+C           ------------
+C
+      DO 160 LAST = NPTS2,LIMIT
+C
+C           BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ERROR
+C           ESTIMATE.
+C
+        LEVCUR = LEVEL(MAXERR)+1
+        A1 = ALIST(MAXERR)
+        B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR))
+        A2 = B1
+        B2 = BLIST(MAXERR)
+        ERLAST = ERRMAX
+        CALL DQK21(F,A1,B1,AREA1,ERROR1,RESA,DEFAB1,IER)
+        IF (IER .LT. 0) RETURN
+        CALL DQK21(F,A2,B2,AREA2,ERROR2,RESA,DEFAB2,IER)
+        IF (IER .LT. 0) RETURN
+C
+C           IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL
+C           AND ERROR AND TEST FOR ACCURACY.
+C
+        NEVAL = NEVAL+42
+        AREA12 = AREA1+AREA2
+        ERRO12 = ERROR1+ERROR2
+        ERRSUM = ERRSUM+ERRO12-ERRMAX
+        AREA = AREA+AREA12-RLIST(MAXERR)
+        IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2) GO TO 95
+        IF(DABS(RLIST(MAXERR)-AREA12).GT.0.1D-04*DABS(AREA12)
+     *  .OR.ERRO12.LT.0.99D+00*ERRMAX) GO TO 90
+        IF(EXTRAP) IROFF2 = IROFF2+1
+        IF(.NOT.EXTRAP) IROFF1 = IROFF1+1
+   90   IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1
+   95   LEVEL(MAXERR) = LEVCUR
+        LEVEL(LAST) = LEVCUR
+        RLIST(MAXERR) = AREA1
+        RLIST(LAST) = AREA2
+        ERRBND = DMAX1(EPSABS,EPSREL*DABS(AREA))
+C
+C           TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG.
+C
+        IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2
+        IF(IROFF2.GE.5) IERRO = 3
+C
+C           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF
+C           SUBINTERVALS EQUALS LIMIT.
+C
+        IF(LAST.EQ.LIMIT) IER = 1
+C
+C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
+C           AT A POINT OF THE INTEGRATION RANGE
+C
+        IF(DMAX1(DABS(A1),DABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH)*
+     *  (DABS(A2)+0.1D+04*UFLOW)) IER = 4
+C
+C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
+C
+        IF(ERROR2.GT.ERROR1) GO TO 100
+        ALIST(LAST) = A2
+        BLIST(MAXERR) = B1
+        BLIST(LAST) = B2
+        ELIST(MAXERR) = ERROR1
+        ELIST(LAST) = ERROR2
+        GO TO 110
+  100   ALIST(MAXERR) = A2
+        ALIST(LAST) = A1
+        BLIST(LAST) = B1
+        RLIST(MAXERR) = AREA2
+        RLIST(LAST) = AREA1
+        ELIST(MAXERR) = ERROR2
+        ELIST(LAST) = ERROR1
+C
+C           CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING
+C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL
+C           WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT).
+C
+  110   CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
+C ***JUMP OUT OF DO-LOOP
+        IF(ERRSUM.LE.ERRBND) GO TO 190
+C ***JUMP OUT OF DO-LOOP
+        IF(IER.NE.0) GO TO 170
+        IF(NOEXT) GO TO 160
+        ERLARG = ERLARG-ERLAST
+        IF(LEVCUR+1.LE.LEVMAX) ERLARG = ERLARG+ERRO12
+        IF(EXTRAP) GO TO 120
+C
+C           TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE
+C           SMALLEST INTERVAL.
+C
+        IF(LEVEL(MAXERR)+1.LE.LEVMAX) GO TO 160
+        EXTRAP = .TRUE.
+        NRMAX = 2
+  120   IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 140
+C
+C           THE SMALLEST INTERVAL HAS THE LARGEST ERROR.
+C           BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER
+C           THE LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION.
+C
+        ID = NRMAX
+        JUPBND = LAST
+        IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST
+        DO 130 K = ID,JUPBND
+          MAXERR = IORD(NRMAX)
+          ERRMAX = ELIST(MAXERR)
+C ***JUMP OUT OF DO-LOOP
+          IF(LEVEL(MAXERR)+1.LE.LEVMAX) GO TO 160
+          NRMAX = NRMAX+1
+  130   CONTINUE
+C
+C           PERFORM EXTRAPOLATION.
+C
+  140   NUMRL2 = NUMRL2+1
+        RLIST2(NUMRL2) = AREA
+        IF(NUMRL2.LE.2) GO TO 155
+        CALL DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES)
+        KTMIN = KTMIN+1
+        IF(KTMIN.GT.5.AND.ABSERR.LT.0.1D-02*ERRSUM) IER = 5
+        IF(ABSEPS.GE.ABSERR) GO TO 150
+        KTMIN = 0
+        ABSERR = ABSEPS
+        RESULT = RESEPS
+        CORREC = ERLARG
+        ERTEST = DMAX1(EPSABS,EPSREL*DABS(RESEPS))
+C ***JUMP OUT OF DO-LOOP
+        IF(ABSERR.LT.ERTEST) GO TO 170
+C
+C           PREPARE BISECTION OF THE SMALLEST INTERVAL.
+C
+  150   IF(NUMRL2.EQ.1) NOEXT = .TRUE.
+        IF(IER.GE.5) GO TO 170
+  155   MAXERR = IORD(1)
+        ERRMAX = ELIST(MAXERR)
+        NRMAX = 1
+        EXTRAP = .FALSE.
+        LEVMAX = LEVMAX+1
+        ERLARG = ERRSUM
+  160 CONTINUE
+C
+C           SET THE FINAL RESULT.
+C           ---------------------
+C
+C
+  170 IF(ABSERR.EQ.OFLOW) GO TO 190
+      IF((IER+IERRO).EQ.0) GO TO 180
+      IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC
+      IF(IER.EQ.0) IER = 3
+      IF(RESULT.NE.0.0D+00.AND.AREA.NE.0.0D+00)GO TO 175
+      IF(ABSERR.GT.ERRSUM)GO TO 190
+      IF(AREA.EQ.0.0D+00) GO TO 210
+      GO TO 180
+  175 IF(ABSERR/DABS(RESULT).GT.ERRSUM/DABS(AREA))GO TO 190
+C
+C           TEST ON DIVERGENCE.
+C
+  180 IF(KSGN.EQ.(-1).AND.DMAX1(DABS(RESULT),DABS(AREA)).LE.
+     *  RESABS*0.1D-01) GO TO 210
+      IF(0.1D-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1D+03.OR.
+     *  ERRSUM.GT.DABS(AREA)) IER = 6
+      GO TO 210
+C
+C           COMPUTE GLOBAL INTEGRAL SUM.
+C
+  190 RESULT = 0.0D+00
+      DO 200 K = 1,LAST
+        RESULT = RESULT+RLIST(K)
+  200 CONTINUE
+      ABSERR = ERRSUM
+  210 IF(IER.GT.2) IER = IER-1
+      RESULT = RESULT*SIGN
+  999 RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/quadpack/dqelg.f
@@ -0,0 +1,184 @@
+      SUBROUTINE DQELG(N,EPSTAB,RESULT,ABSERR,RES3LA,NRES)
+C***BEGIN PROLOGUE  DQELG
+C***REFER TO  DQAGIE,DQAGOE,DQAGPE,DQAGSE
+C***ROUTINES CALLED  D1MACH
+C***REVISION DATE  830518   (YYMMDD)
+C***KEYWORDS  EPSILON ALGORITHM, CONVERGENCE ACCELERATION,
+C             EXTRAPOLATION
+C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
+C           DE DONCKER,ELISE,APPL. MATH & PROGR. DIV. - K.U.LEUVEN
+C***PURPOSE  THE ROUTINE DETERMINES THE LIMIT OF A GIVEN SEQUENCE OF
+C            APPROXIMATIONS, BY MEANS OF THE EPSILON ALGORITHM OF
+C            P.WYNN. AN ESTIMATE OF THE ABSOLUTE ERROR IS ALSO GIVEN.
+C            THE CONDENSED EPSILON TABLE IS COMPUTED. ONLY THOSE
+C            ELEMENTS NEEDED FOR THE COMPUTATION OF THE NEXT DIAGONAL
+C            ARE PRESERVED.
+C***DESCRIPTION
+C
+C           EPSILON ALGORITHM
+C           STANDARD FORTRAN SUBROUTINE
+C           DOUBLE PRECISION VERSION
+C
+C           PARAMETERS
+C              N      - INTEGER
+C                       EPSTAB(N) CONTAINS THE NEW ELEMENT IN THE
+C                       FIRST COLUMN OF THE EPSILON TABLE.
+C
+C              EPSTAB - DOUBLE PRECISION
+C                       VECTOR OF DIMENSION 52 CONTAINING THE ELEMENTS
+C                       OF THE TWO LOWER DIAGONALS OF THE TRIANGULAR
+C                       EPSILON TABLE. THE ELEMENTS ARE NUMBERED
+C                       STARTING AT THE RIGHT-HAND CORNER OF THE
+C                       TRIANGLE.
+C
+C              RESULT - DOUBLE PRECISION
+C                       RESULTING APPROXIMATION TO THE INTEGRAL
+C
+C              ABSERR - DOUBLE PRECISION
+C                       ESTIMATE OF THE ABSOLUTE ERROR COMPUTED FROM
+C                       RESULT AND THE 3 PREVIOUS RESULTS
+C
+C              RES3LA - DOUBLE PRECISION
+C                       VECTOR OF DIMENSION 3 CONTAINING THE LAST 3
+C                       RESULTS
+C
+C              NRES   - INTEGER
+C                       NUMBER OF CALLS TO THE ROUTINE
+C                       (SHOULD BE ZERO AT FIRST CALL)
+C
+C***END PROLOGUE  DQELG
+C
+      DOUBLE PRECISION ABSERR,DABS,DELTA1,DELTA2,DELTA3,DMAX1,D1MACH,
+     *  EPMACH,EPSINF,EPSTAB,ERROR,ERR1,ERR2,ERR3,E0,E1,E1ABS,E2,E3,
+     *  OFLOW,RES,RESULT,RES3LA,SS,TOL1,TOL2,TOL3
+      INTEGER I,IB,IB2,IE,INDX,K1,K2,K3,LIMEXP,N,NEWELM,NRES,NUM
+      DIMENSION EPSTAB(52),RES3LA(3)
+C
+C           LIST OF MAJOR VARIABLES
+C           -----------------------
+C
+C           E0     - THE 4 ELEMENTS ON WHICH THE COMPUTATION OF A NEW
+C           E1       ELEMENT IN THE EPSILON TABLE IS BASED
+C           E2
+C           E3                 E0
+C                        E3    E1    NEW
+C                              E2
+C           NEWELM - NUMBER OF ELEMENTS TO BE COMPUTED IN THE NEW
+C                    DIAGONAL
+C           ERROR  - ERROR = ABS(E1-E0)+ABS(E2-E1)+ABS(NEW-E2)
+C           RESULT - THE ELEMENT IN THE NEW DIAGONAL WITH LEAST VALUE
+C                    OF ERROR
+C
+C           MACHINE DEPENDENT CONSTANTS
+C           ---------------------------
+C
+C           EPMACH IS THE LARGEST RELATIVE SPACING.
+C           OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
+C           LIMEXP IS THE MAXIMUM NUMBER OF ELEMENTS THE EPSILON
+C           TABLE CAN CONTAIN. IF THIS NUMBER IS REACHED, THE UPPER
+C           DIAGONAL OF THE EPSILON TABLE IS DELETED.
+C
+C***FIRST EXECUTABLE STATEMENT  DQELG
+      EPMACH = D1MACH(4)
+      OFLOW = D1MACH(2)
+      NRES = NRES+1
+      ABSERR = OFLOW
+      RESULT = EPSTAB(N)
+      IF(N.LT.3) GO TO 100
+      LIMEXP = 50
+      EPSTAB(N+2) = EPSTAB(N)
+      NEWELM = (N-1)/2
+      EPSTAB(N) = OFLOW
+      NUM = N
+      K1 = N
+      DO 40 I = 1,NEWELM
+        K2 = K1-1
+        K3 = K1-2
+        RES = EPSTAB(K1+2)
+        E0 = EPSTAB(K3)
+        E1 = EPSTAB(K2)
+        E2 = RES
+        E1ABS = DABS(E1)
+        DELTA2 = E2-E1
+        ERR2 = DABS(DELTA2)
+        TOL2 = DMAX1(DABS(E2),E1ABS)*EPMACH
+        DELTA3 = E1-E0
+        ERR3 = DABS(DELTA3)
+        TOL3 = DMAX1(E1ABS,DABS(E0))*EPMACH
+        IF(ERR2.GT.TOL2.OR.ERR3.GT.TOL3) GO TO 10
+C
+C           IF E0, E1 AND E2 ARE EQUAL TO WITHIN MACHINE
+C           ACCURACY, CONVERGENCE IS ASSUMED.
+C           RESULT = E2
+C           ABSERR = ABS(E1-E0)+ABS(E2-E1)
+C
+        RESULT = RES
+        ABSERR = ERR2+ERR3
+C ***JUMP OUT OF DO-LOOP
+        GO TO 100
+   10   E3 = EPSTAB(K1)
+        EPSTAB(K1) = E1
+        DELTA1 = E1-E3
+        ERR1 = DABS(DELTA1)
+        TOL1 = DMAX1(E1ABS,DABS(E3))*EPMACH
+C
+C           IF TWO ELEMENTS ARE VERY CLOSE TO EACH OTHER, OMIT
+C           A PART OF THE TABLE BY ADJUSTING THE VALUE OF N
+C
+        IF(ERR1.LE.TOL1.OR.ERR2.LE.TOL2.OR.ERR3.LE.TOL3) GO TO 20
+        SS = 0.1D+01/DELTA1+0.1D+01/DELTA2-0.1D+01/DELTA3
+        EPSINF = DABS(SS*E1)
+C
+C           TEST TO DETECT IRREGULAR BEHAVIOUR IN THE TABLE, AND
+C           EVENTUALLY OMIT A PART OF THE TABLE ADJUSTING THE VALUE
+C           OF N.
+C
+        IF(EPSINF.GT.0.1D-03) GO TO 30
+   20   N = I+I-1
+C ***JUMP OUT OF DO-LOOP
+        GO TO 50
+C
+C           COMPUTE A NEW ELEMENT AND EVENTUALLY ADJUST
+C           THE VALUE OF RESULT.
+C
+   30   RES = E1+0.1D+01/SS
+        EPSTAB(K1) = RES
+        K1 = K1-2
+        ERROR = ERR2+DABS(RES-E2)+ERR3
+        IF(ERROR.GT.ABSERR) GO TO 40
+        ABSERR = ERROR
+        RESULT = RES
+   40 CONTINUE
+C
+C           SHIFT THE TABLE.
+C
+   50 IF(N.EQ.LIMEXP) N = 2*(LIMEXP/2)-1
+      IB = 1
+      IF((NUM/2)*2.EQ.NUM) IB = 2
+      IE = NEWELM+1
+      DO 60 I=1,IE
+        IB2 = IB+2
+        EPSTAB(IB) = EPSTAB(IB2)
+        IB = IB2
+   60 CONTINUE
+      IF(NUM.EQ.N) GO TO 80
+      INDX = NUM-N+1
+      DO 70 I = 1,N
+        EPSTAB(I)= EPSTAB(INDX)
+        INDX = INDX+1
+   70 CONTINUE
+   80 IF(NRES.GE.4) GO TO 90
+      RES3LA(NRES) = RESULT
+      ABSERR = OFLOW
+      GO TO 100
+C
+C           COMPUTE ERROR ESTIMATE
+C
+   90 ABSERR = DABS(RESULT-RES3LA(3))+DABS(RESULT-RES3LA(2))
+     *  +DABS(RESULT-RES3LA(1))
+      RES3LA(1) = RES3LA(2)
+      RES3LA(2) = RES3LA(3)
+      RES3LA(3) = RESULT
+  100 ABSERR = DMAX1(ABSERR,0.5D+01*EPMACH*DABS(RESULT))
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/quadpack/dqk15i.f
@@ -0,0 +1,212 @@
+      SUBROUTINE DQK15I(F,BOUN,INF,A,B,RESULT,ABSERR,RESABS,RESASC,
+     1   IERR)
+C***BEGIN PROLOGUE  DQK15I
+C***DATE WRITTEN   800101   (YYMMDD)
+C***REVISION DATE  830518   (YYMMDD)
+C***CATEGORY NO.  H2A3A2,H2A4A2
+C***KEYWORDS  15-POINT TRANSFORMED GAUSS-KRONROD RULES
+C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
+C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
+C***PURPOSE  THE ORIGINAL (INFINITE INTEGRATION RANGE IS MAPPED
+C            ONTO THE INTERVAL (0,1) AND (A,B) IS A PART OF (0,1).
+C            IT IS THE PURPOSE TO COMPUTE
+C            I = INTEGRAL OF TRANSFORMED INTEGRAND OVER (A,B),
+C            J = INTEGRAL OF ABS(TRANSFORMED INTEGRAND) OVER (A,B).
+C***DESCRIPTION
+C
+C           INTEGRATION RULE
+C           STANDARD FORTRAN SUBROUTINE
+C           DOUBLE PRECISION VERSION
+C
+C           PARAMETERS
+C            ON ENTRY
+C              F      - DOUBLE PRECISION
+C                       FUCTION SUBPROGRAM DEFINING THE INTEGRAND
+C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
+C                       DECLARED E X T E R N A L IN THE CALLING PROGRAM.
+C
+C              BOUN   - DOUBLE PRECISION
+C                       FINITE BOUND OF ORIGINAL INTEGRATION
+C                       RANGE (SET TO ZERO IF INF = +2)
+C
+C              INF    - INTEGER
+C                       IF INF = -1, THE ORIGINAL INTERVAL IS
+C                                   (-INFINITY,BOUND),
+C                       IF INF = +1, THE ORIGINAL INTERVAL IS
+C                                   (BOUND,+INFINITY),
+C                       IF INF = +2, THE ORIGINAL INTERVAL IS
+C                                   (-INFINITY,+INFINITY) AND
+C                       THE INTEGRAL IS COMPUTED AS THE SUM OF TWO
+C                       INTEGRALS, ONE OVER (-INFINITY,0) AND ONE OVER
+C                       (0,+INFINITY).
+C
+C              A      - DOUBLE PRECISION
+C                       LOWER LIMIT FOR INTEGRATION OVER SUBRANGE
+C                       OF (0,1)
+C
+C              B      - DOUBLE PRECISION
+C                       UPPER LIMIT FOR INTEGRATION OVER SUBRANGE
+C                       OF (0,1)
+C
+C            ON RETURN
+C              RESULT - DOUBLE PRECISION
+C                       APPROXIMATION TO THE INTEGRAL I
+C                       RESULT IS COMPUTED BY APPLYING THE 15-POINT
+C                       KRONROD RULE(RESK) OBTAINED BY OPTIMAL ADDITION
+C                       OF ABSCISSAE TO THE 7-POINT GAUSS RULE(RESG).
+C
+C              ABSERR - DOUBLE PRECISION
+C                       ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
+C                       WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
+C
+C              RESABS - DOUBLE PRECISION
+C                       APPROXIMATION TO THE INTEGRAL J
+C
+C              RESASC - DOUBLE PRECISION
+C                       APPROXIMATION TO THE INTEGRAL OF
+C                       ABS((TRANSFORMED INTEGRAND)-I/(B-A)) OVER (A,B)
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  D1MACH
+C***END PROLOGUE  DQK15I
+C
+      DOUBLE PRECISION A,ABSC,ABSC1,ABSC2,ABSERR,B,BOUN,CENTR,DABS,DINF,
+     *  DMAX1,DMIN1,D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,
+     *  RESABS,RESASC,RESG,RESK,RESKH,RESULT,TABSC1,TABSC2,UFLOW,WG,WGK,
+     *  XGK,FVALT
+      INTEGER INF,J
+      EXTERNAL F
+C
+      DIMENSION FV1(7),FV2(7),XGK(8),WGK(8),WG(8)
+C
+C           THE ABSCISSAE AND WEIGHTS ARE SUPPLIED FOR THE INTERVAL
+C           (-1,1).  BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND
+C           THEIR CORRESPONDING WEIGHTS ARE GIVEN.
+C
+C           XGK    - ABSCISSAE OF THE 15-POINT KRONROD RULE
+C                    XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT
+C                    GAUSS RULE
+C                    XGK(1), XGK(3), ...  ABSCISSAE WHICH ARE OPTIMALLY
+C                    ADDED TO THE 7-POINT GAUSS RULE
+C
+C           WGK    - WEIGHTS OF THE 15-POINT KRONROD RULE
+C
+C           WG     - WEIGHTS OF THE 7-POINT GAUSS RULE, CORRESPONDING
+C                    TO THE ABSCISSAE XGK(2), XGK(4), ...
+C                    WG(1), WG(3), ... ARE SET TO ZERO.
+C
+      DATA WG(1) / 0.0D0 /
+      DATA WG(2) / 0.1294849661 6886969327 0611432679 082D0 /
+      DATA WG(3) / 0.0D0 /
+      DATA WG(4) / 0.2797053914 8927666790 1467771423 780D0 /
+      DATA WG(5) / 0.0D0 /
+      DATA WG(6) / 0.3818300505 0511894495 0369775488 975D0 /
+      DATA WG(7) / 0.0D0 /
+      DATA WG(8) / 0.4179591836 7346938775 5102040816 327D0 /
+C
+      DATA XGK(1) / 0.9914553711 2081263920 6854697526 329D0 /
+      DATA XGK(2) / 0.9491079123 4275852452 6189684047 851D0 /
+      DATA XGK(3) / 0.8648644233 5976907278 9712788640 926D0 /
+      DATA XGK(4) / 0.7415311855 9939443986 3864773280 788D0 /
+      DATA XGK(5) / 0.5860872354 6769113029 4144838258 730D0 /
+      DATA XGK(6) / 0.4058451513 7739716690 6606412076 961D0 /
+      DATA XGK(7) / 0.2077849550 0789846760 0689403773 245D0 /
+      DATA XGK(8) / 0.0000000000 0000000000 0000000000 000D0 /
+C
+      DATA WGK(1) / 0.0229353220 1052922496 3732008058 970D0 /
+      DATA WGK(2) / 0.0630920926 2997855329 0700663189 204D0 /
+      DATA WGK(3) / 0.1047900103 2225018383 9876322541 518D0 /
+      DATA WGK(4) / 0.1406532597 1552591874 5189590510 238D0 /
+      DATA WGK(5) / 0.1690047266 3926790282 6583426598 550D0 /
+      DATA WGK(6) / 0.1903505780 6478540991 3256402421 014D0 /
+      DATA WGK(7) / 0.2044329400 7529889241 4161999234 649D0 /
+      DATA WGK(8) / 0.2094821410 8472782801 2999174891 714D0 /
+C
+C
+C           LIST OF MAJOR VARIABLES
+C           -----------------------
+C
+C           CENTR  - MID POINT OF THE INTERVAL
+C           HLGTH  - HALF-LENGTH OF THE INTERVAL
+C           ABSC*  - ABSCISSA
+C           TABSC* - TRANSFORMED ABSCISSA
+C           FVAL*  - FUNCTION VALUE
+C           RESG   - RESULT OF THE 7-POINT GAUSS FORMULA
+C           RESK   - RESULT OF THE 15-POINT KRONROD FORMULA
+C           RESKH  - APPROXIMATION TO THE MEAN VALUE OF THE TRANSFORMED
+C                    INTEGRAND OVER (A,B), I.E. TO I/(B-A)
+C
+C           MACHINE DEPENDENT CONSTANTS
+C           ---------------------------
+C
+C           EPMACH IS THE LARGEST RELATIVE SPACING.
+C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
+C
+C***FIRST EXECUTABLE STATEMENT  DQK15I
+      EPMACH = D1MACH(4)
+      UFLOW = D1MACH(1)
+      DINF = MIN0(1,INF)
+C
+      CENTR = 0.5D+00*(A+B)
+      HLGTH = 0.5D+00*(B-A)
+      TABSC1 = BOUN+DINF*(0.1D+01-CENTR)/CENTR
+      IERR = 0
+      FVAL1 = F(TABSC1,IERR)
+      IF (IERR .LT. 0) RETURN
+      IF(INF.EQ.2) THEN
+        FVALT = F(-TABSC1,IERR)
+        IF (IERR .LT. 0) RETURN
+        FVAL1 = FVAL1+FVALT
+      ENDIF
+      FC = (FVAL1/CENTR)/CENTR
+C
+C           COMPUTE THE 15-POINT KRONROD APPROXIMATION TO
+C           THE INTEGRAL, AND ESTIMATE THE ERROR.
+C
+      RESG = WG(8)*FC
+      RESK = WGK(8)*FC
+      RESABS = DABS(RESK)
+      DO 10 J=1,7
+        ABSC = HLGTH*XGK(J)
+        ABSC1 = CENTR-ABSC
+        ABSC2 = CENTR+ABSC
+        TABSC1 = BOUN+DINF*(0.1D+01-ABSC1)/ABSC1
+        TABSC2 = BOUN+DINF*(0.1D+01-ABSC2)/ABSC2
+        FVAL1 = F(TABSC1,IERR)
+        IF (IERR .LT. 0) RETURN
+        FVAL2 = F(TABSC2,IERR)
+        IF (IERR .LT. 0) RETURN
+        IF(INF.EQ.2) THEN
+          FVALT = F(-TABSC1,IERR)
+          IF (IERR .LT. 0) RETURN
+          FVAL1 = FVAL1+FVALT
+        ENDIF
+        IF(INF.EQ.2) THEN
+          FVALT = F(-TABSC2,IERR)
+          IF (IERR .LT. 0) RETURN
+          FVAL2 = FVAL2+FVALT
+        ENDIF
+        FVAL1 = (FVAL1/ABSC1)/ABSC1
+        FVAL2 = (FVAL2/ABSC2)/ABSC2
+        FV1(J) = FVAL1
+        FV2(J) = FVAL2
+        FSUM = FVAL1+FVAL2
+        RESG = RESG+WG(J)*FSUM
+        RESK = RESK+WGK(J)*FSUM
+        RESABS = RESABS+WGK(J)*(DABS(FVAL1)+DABS(FVAL2))
+   10 CONTINUE
+      RESKH = RESK*0.5D+00
+      RESASC = WGK(8)*DABS(FC-RESKH)
+      DO 20 J=1,7
+        RESASC = RESASC+WGK(J)*(DABS(FV1(J)-RESKH)+DABS(FV2(J)-RESKH))
+   20 CONTINUE
+      RESULT = RESK*HLGTH
+      RESASC = RESASC*HLGTH
+      RESABS = RESABS*HLGTH
+      ABSERR = DABS((RESK-RESG)*HLGTH)
+      IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.D0) ABSERR = RESASC*
+     * DMIN1(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00)
+      IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = DMAX1
+     * ((EPMACH*0.5D+02)*RESABS,ABSERR)
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/quadpack/dqk21.f
@@ -0,0 +1,188 @@
+      SUBROUTINE DQK21(F,A,B,RESULT,ABSERR,RESABS,RESASC,IERR)
+C***BEGIN PROLOGUE  DQK21
+C***DATE WRITTEN   800101   (YYMMDD)
+C***REVISION DATE  830518   (YYMMDD)
+C***CATEGORY NO.  H2A1A2
+C***KEYWORDS  21-POINT GAUSS-KRONROD RULES
+C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
+C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
+C***PURPOSE  TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR
+C                           ESTIMATE
+C                       J = INTEGRAL OF ABS(F) OVER (A,B)
+C***DESCRIPTION
+C
+C           INTEGRATION RULES
+C           STANDARD FORTRAN SUBROUTINE
+C           DOUBLE PRECISION VERSION
+C
+C           PARAMETERS
+C            ON ENTRY
+C              F      - DOUBLE PRECISION
+C                       FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
+C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
+C                       DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
+C
+C              A      - DOUBLE PRECISION
+C                       LOWER LIMIT OF INTEGRATION
+C
+C              B      - DOUBLE PRECISION
+C                       UPPER LIMIT OF INTEGRATION
+C
+C            ON RETURN
+C              RESULT - DOUBLE PRECISION
+C                       APPROXIMATION TO THE INTEGRAL I
+C                       RESULT IS COMPUTED BY APPLYING THE 21-POINT
+C                       KRONROD RULE (RESK) OBTAINED BY OPTIMAL ADDITION
+C                       OF ABSCISSAE TO THE 10-POINT GAUSS RULE (RESG).
+C
+C              ABSERR - DOUBLE PRECISION
+C                       ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
+C                       WHICH SHOULD NOT EXCEED ABS(I-RESULT)
+C
+C              RESABS - DOUBLE PRECISION
+C                       APPROXIMATION TO THE INTEGRAL J
+C
+C              RESASC - DOUBLE PRECISION
+C                       APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A))
+C                       OVER (A,B)
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  D1MACH
+C***END PROLOGUE  DQK21
+C
+      DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DABS,DHLGTH,DMAX1,DMIN1,
+     *  D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC,
+     *  RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK
+      INTEGER J,JTW,JTWM1
+      EXTERNAL F
+C
+      DIMENSION FV1(10),FV2(10),WG(5),WGK(11),XGK(11)
+C
+C           THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1).
+C           BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR
+C           CORRESPONDING WEIGHTS ARE GIVEN.
+C
+C           XGK    - ABSCISSAE OF THE 21-POINT KRONROD RULE
+C                    XGK(2), XGK(4), ...  ABSCISSAE OF THE 10-POINT
+C                    GAUSS RULE
+C                    XGK(1), XGK(3), ...  ABSCISSAE WHICH ARE OPTIMALLY
+C                    ADDED TO THE 10-POINT GAUSS RULE
+C
+C           WGK    - WEIGHTS OF THE 21-POINT KRONROD RULE
+C
+C           WG     - WEIGHTS OF THE 10-POINT GAUSS RULE
+C
+C
+C GAUSS QUADRATURE WEIGHTS AND KRONRON QUADRATURE ABSCISSAE AND WEIGHTS
+C AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON,
+C BELL LABS, NOV. 1981.
+C
+      DATA WG  (  1) / 0.0666713443 0868813759 3568809893 332 D0 /
+      DATA WG  (  2) / 0.1494513491 5058059314 5776339657 697 D0 /
+      DATA WG  (  3) / 0.2190863625 1598204399 5534934228 163 D0 /
+      DATA WG  (  4) / 0.2692667193 0999635509 1226921569 469 D0 /
+      DATA WG  (  5) / 0.2955242247 1475287017 3892994651 338 D0 /
+C
+      DATA XGK (  1) / 0.9956571630 2580808073 5527280689 003 D0 /
+      DATA XGK (  2) / 0.9739065285 1717172007 7964012084 452 D0 /
+      DATA XGK (  3) / 0.9301574913 5570822600 1207180059 508 D0 /
+      DATA XGK (  4) / 0.8650633666 8898451073 2096688423 493 D0 /
+      DATA XGK (  5) / 0.7808177265 8641689706 3717578345 042 D0 /
+      DATA XGK (  6) / 0.6794095682 9902440623 4327365114 874 D0 /
+      DATA XGK (  7) / 0.5627571346 6860468333 9000099272 694 D0 /
+      DATA XGK (  8) / 0.4333953941 2924719079 9265943165 784 D0 /
+      DATA XGK (  9) / 0.2943928627 0146019813 1126603103 866 D0 /
+      DATA XGK ( 10) / 0.1488743389 8163121088 4826001129 720 D0 /
+      DATA XGK ( 11) / 0.0000000000 0000000000 0000000000 000 D0 /
+C
+      DATA WGK (  1) / 0.0116946388 6737187427 8064396062 192 D0 /
+      DATA WGK (  2) / 0.0325581623 0796472747 8818972459 390 D0 /
+      DATA WGK (  3) / 0.0547558965 7435199603 1381300244 580 D0 /
+      DATA WGK (  4) / 0.0750396748 1091995276 7043140916 190 D0 /
+      DATA WGK (  5) / 0.0931254545 8369760553 5065465083 366 D0 /
+      DATA WGK (  6) / 0.1093871588 0229764189 9210590325 805 D0 /
+      DATA WGK (  7) / 0.1234919762 6206585107 7958109831 074 D0 /
+      DATA WGK (  8) / 0.1347092173 1147332592 8054001771 707 D0 /
+      DATA WGK (  9) / 0.1427759385 7706008079 7094273138 717 D0 /
+      DATA WGK ( 10) / 0.1477391049 0133849137 4841515972 068 D0 /
+      DATA WGK ( 11) / 0.1494455540 0291690566 4936468389 821 D0 /
+C
+C
+C           LIST OF MAJOR VARIABLES
+C           -----------------------
+C
+C           CENTR  - MID POINT OF THE INTERVAL
+C           HLGTH  - HALF-LENGTH OF THE INTERVAL
+C           ABSC   - ABSCISSA
+C           FVAL*  - FUNCTION VALUE
+C           RESG   - RESULT OF THE 10-POINT GAUSS FORMULA
+C           RESK   - RESULT OF THE 21-POINT KRONROD FORMULA
+C           RESKH  - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B),
+C                    I.E. TO I/(B-A)
+C
+C
+C           MACHINE DEPENDENT CONSTANTS
+C           ---------------------------
+C
+C           EPMACH IS THE LARGEST RELATIVE SPACING.
+C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
+C
+C***FIRST EXECUTABLE STATEMENT  DQK21
+      EPMACH = D1MACH(4)
+      UFLOW = D1MACH(1)
+C
+      CENTR = 0.5D+00*(A+B)
+      HLGTH = 0.5D+00*(B-A)
+      DHLGTH = DABS(HLGTH)
+C
+C           COMPUTE THE 21-POINT KRONROD APPROXIMATION TO
+C           THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR.
+C
+      RESG = 0.0D+00
+      IERR = 0
+      FC = F(CENTR,IERR)
+      IF (IERR .LT. 0) RETURN
+      RESK = WGK(11)*FC
+      RESABS = DABS(RESK)
+      DO 10 J=1,5
+        JTW = 2*J
+        ABSC = HLGTH*XGK(JTW)
+        FVAL1 = F(CENTR-ABSC,IERR)
+        IF (IERR .LT. 0) RETURN
+        FVAL2 = F(CENTR+ABSC,IERR)
+        IF (IERR .LT. 0) RETURN
+        FV1(JTW) = FVAL1
+        FV2(JTW) = FVAL2
+        FSUM = FVAL1+FVAL2
+        RESG = RESG+WG(J)*FSUM
+        RESK = RESK+WGK(JTW)*FSUM
+        RESABS = RESABS+WGK(JTW)*(DABS(FVAL1)+DABS(FVAL2))
+   10 CONTINUE
+      DO 15 J = 1,5
+        JTWM1 = 2*J-1
+        ABSC = HLGTH*XGK(JTWM1)
+        FVAL1 = F(CENTR-ABSC,IERR)
+        IF (IERR .LT. 0) RETURN
+        FVAL2 = F(CENTR+ABSC,IERR)
+        IF (IERR .LT. 0) RETURN
+        FV1(JTWM1) = FVAL1
+        FV2(JTWM1) = FVAL2
+        FSUM = FVAL1+FVAL2
+        RESK = RESK+WGK(JTWM1)*FSUM
+        RESABS = RESABS+WGK(JTWM1)*(DABS(FVAL1)+DABS(FVAL2))
+   15 CONTINUE
+      RESKH = RESK*0.5D+00
+      RESASC = WGK(11)*DABS(FC-RESKH)
+      DO 20 J=1,10
+        RESASC = RESASC+WGK(J)*(DABS(FV1(J)-RESKH)+DABS(FV2(J)-RESKH))
+   20 CONTINUE
+      RESULT = RESK*HLGTH
+      RESABS = RESABS*DHLGTH
+      RESASC = RESASC*DHLGTH
+      ABSERR = DABS((RESK-RESG)*HLGTH)
+      IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00)
+     *  ABSERR = RESASC*DMIN1(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00)
+      IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = DMAX1
+     *  ((EPMACH*0.5D+02)*RESABS,ABSERR)
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/quadpack/dqpsrt.f
@@ -0,0 +1,129 @@
+      SUBROUTINE DQPSRT(LIMIT,LAST,MAXERR,ERMAX,ELIST,IORD,NRMAX)
+C***BEGIN PROLOGUE  DQPSRT
+C***REFER TO  DQAGE,DQAGIE,DQAGPE,DQAWSE
+C***ROUTINES CALLED  (NONE)
+C***REVISION DATE  810101   (YYMMDD)
+C***KEYWORDS  SEQUENTIAL SORTING
+C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
+C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
+C***PURPOSE  THIS ROUTINE MAINTAINS THE DESCENDING ORDERING IN THE
+C            LIST OF THE LOCAL ERROR ESTIMATED RESULTING FROM THE
+C            INTERVAL SUBDIVISION PROCESS. AT EACH CALL TWO ERROR
+C            ESTIMATES ARE INSERTED USING THE SEQUENTIAL SEARCH
+C            METHOD, TOP-DOWN FOR THE LARGEST ERROR ESTIMATE AND
+C            BOTTOM-UP FOR THE SMALLEST ERROR ESTIMATE.
+C***DESCRIPTION
+C
+C           ORDERING ROUTINE
+C           STANDARD FORTRAN SUBROUTINE
+C           DOUBLE PRECISION VERSION
+C
+C           PARAMETERS (MEANING AT OUTPUT)
+C              LIMIT  - INTEGER
+C                       MAXIMUM NUMBER OF ERROR ESTIMATES THE LIST
+C                       CAN CONTAIN
+C
+C              LAST   - INTEGER
+C                       NUMBER OF ERROR ESTIMATES CURRENTLY IN THE LIST
+C
+C              MAXERR - INTEGER
+C                       MAXERR POINTS TO THE NRMAX-TH LARGEST ERROR
+C                       ESTIMATE CURRENTLY IN THE LIST
+C
+C              ERMAX  - DOUBLE PRECISION
+C                       NRMAX-TH LARGEST ERROR ESTIMATE
+C                       ERMAX = ELIST(MAXERR)
+C
+C              ELIST  - DOUBLE PRECISION
+C                       VECTOR OF DIMENSION LAST CONTAINING
+C                       THE ERROR ESTIMATES
+C
+C              IORD   - INTEGER
+C                       VECTOR OF DIMENSION LAST, THE FIRST K ELEMENTS
+C                       OF WHICH CONTAIN POINTERS TO THE ERROR
+C                       ESTIMATES, SUCH THAT
+C                       ELIST(IORD(1)),...,  ELIST(IORD(K))
+C                       FORM A DECREASING SEQUENCE, WITH
+C                       K = LAST IF LAST.LE.(LIMIT/2+2), AND
+C                       K = LIMIT+1-LAST OTHERWISE
+C
+C              NRMAX  - INTEGER
+C                       MAXERR = IORD(NRMAX)
+C
+C***END PROLOGUE  DQPSRT
+C
+      DOUBLE PRECISION ELIST,ERMAX,ERRMAX,ERRMIN
+      INTEGER I,IBEG,IDO,IORD,ISUCC,J,JBND,JUPBN,K,LAST,LIMIT,MAXERR,
+     *  NRMAX
+      DIMENSION ELIST(LAST),IORD(LAST)
+C
+C           CHECK WHETHER THE LIST CONTAINS MORE THAN
+C           TWO ERROR ESTIMATES.
+C
+C***FIRST EXECUTABLE STATEMENT  DQPSRT
+      IF(LAST.GT.2) GO TO 10
+      IORD(1) = 1
+      IORD(2) = 2
+      GO TO 90
+C
+C           THIS PART OF THE ROUTINE IS ONLY EXECUTED IF, DUE TO A
+C           DIFFICULT INTEGRAND, SUBDIVISION INCREASED THE ERROR
+C           ESTIMATE. IN THE NORMAL CASE THE INSERT PROCEDURE SHOULD
+C           START AFTER THE NRMAX-TH LARGEST ERROR ESTIMATE.
+C
+   10 ERRMAX = ELIST(MAXERR)
+      IF(NRMAX.EQ.1) GO TO 30
+      IDO = NRMAX-1
+      DO 20 I = 1,IDO
+        ISUCC = IORD(NRMAX-1)
+C ***JUMP OUT OF DO-LOOP
+        IF(ERRMAX.LE.ELIST(ISUCC)) GO TO 30
+        IORD(NRMAX) = ISUCC
+        NRMAX = NRMAX-1
+   20    CONTINUE
+C
+C           COMPUTE THE NUMBER OF ELEMENTS IN THE LIST TO BE MAINTAINED
+C           IN DESCENDING ORDER. THIS NUMBER DEPENDS ON THE NUMBER OF
+C           SUBDIVISIONS STILL ALLOWED.
+C
+   30 JUPBN = LAST
+      IF(LAST.GT.(LIMIT/2+2)) JUPBN = LIMIT+3-LAST
+      ERRMIN = ELIST(LAST)
+C
+C           INSERT ERRMAX BY TRAVERSING THE LIST TOP-DOWN,
+C           STARTING COMPARISON FROM THE ELEMENT ELIST(IORD(NRMAX+1)).
+C
+      JBND = JUPBN-1
+      IBEG = NRMAX+1
+      IF(IBEG.GT.JBND) GO TO 50
+      DO 40 I=IBEG,JBND
+        ISUCC = IORD(I)
+C ***JUMP OUT OF DO-LOOP
+        IF(ERRMAX.GE.ELIST(ISUCC)) GO TO 60
+        IORD(I-1) = ISUCC
+   40 CONTINUE
+   50 IORD(JBND) = MAXERR
+      IORD(JUPBN) = LAST
+      GO TO 90
+C
+C           INSERT ERRMIN BY TRAVERSING THE LIST BOTTOM-UP.
+C
+   60 IORD(I-1) = MAXERR
+      K = JBND
+      DO 70 J=I,JBND
+        ISUCC = IORD(K)
+C ***JUMP OUT OF DO-LOOP
+        IF(ERRMIN.LT.ELIST(ISUCC)) GO TO 80
+        IORD(K+1) = ISUCC
+        K = K-1
+   70 CONTINUE
+      IORD(I) = LAST
+      GO TO 90
+   80 IORD(K+1) = LAST
+C
+C           SET MAXERR AND ERMAX.
+C
+   90 MAXERR = IORD(NRMAX)
+      ERMAX = ELIST(MAXERR)
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/quadpack/xerror.f
@@ -0,0 +1,39 @@
+      SUBROUTINE XERROR(MESSG,NMESSG,NERR,LEVEL)
+C
+C     ABSTRACT
+C        XERROR PROCESSES A DIAGNOSTIC MESSAGE, IN A MANNER
+C        DETERMINED BY THE VALUE OF LEVEL AND THE CURRENT VALUE
+C        OF THE LIBRARY ERROR CONTROL FLAG, KONTRL.
+C        (SEE SUBROUTINE XSETF FOR DETAILS.)
+C
+C     DESCRIPTION OF PARAMETERS
+C      --INPUT--
+C        MESSG - THE HOLLERITH MESSAGE TO BE PROCESSED, CONTAINING
+C                NO MORE THAN 72 CHARACTERS.
+C        NMESSG- THE ACTUAL NUMBER OF CHARACTERS IN MESSG.
+C        NERR  - THE ERROR NUMBER ASSOCIATED WITH THIS MESSAGE.
+C                NERR MUST NOT BE ZERO.
+C        LEVEL - ERROR CATEGORY.
+C                =2 MEANS THIS IS AN UNCONDITIONALLY FATAL ERROR.
+C                =1 MEANS THIS IS A RECOVERABLE ERROR.  (I.E., IT IS
+C                   NON-FATAL IF XSETF HAS BEEN APPROPRIATELY CALLED.)
+C                =0 MEANS THIS IS A WARNING MESSAGE ONLY.
+C                =-1 MEANS THIS IS A WARNING MESSAGE WHICH IS TO BE
+C                   PRINTED AT MOST ONCE, REGARDLESS OF HOW MANY
+C                   TIMES THIS CALL IS EXECUTED.
+C
+C     EXAMPLES
+C        CALL XERROR(23HSMOOTH -- NUM WAS ZERO.,23,1,2)
+C        CALL XERROR(43HINTEG  -- LESS THAN FULL ACCURACY ACHIEVED.,
+C                    43,2,1)
+C        CALL XERROR(65HROOTER -- ACTUAL ZERO OF F FOUND BEFORE INTERVAL
+C    1 FULLY COLLAPSED.,65,3,0)
+C        CALL XERROR(39HEXP    -- UNDERFLOWS BEING SET TO ZERO.,39,1,-1)
+C
+C     WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE
+C     LATEST REVISION ---  7 FEB 1979
+C
+      DIMENSION MESSG(NMESSG)
+      CALL XERRWV(MESSG,NMESSG,NERR,LEVEL,0,0,0,0,0.,0.)
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/advnst.f
@@ -0,0 +1,80 @@
+      SUBROUTINE advnst(k)
+C**********************************************************************
+C
+C     SUBROUTINE ADVNST(K)
+C               ADV-a-N-ce ST-ate
+C
+C     Advances the state  of  the current  generator  by 2^K values  and
+C     resets the initial seed to that value.
+C
+C     This is  a  transcription from   Pascal to  Fortran    of  routine
+C     Advance_State from the paper
+C
+C     L'Ecuyer, P. and  Cote, S. "Implementing  a  Random Number Package
+C     with  Splitting   Facilities."  ACM  Transactions  on Mathematical
+C     Software, 17:98-111 (1991)
+C
+C
+C                              Arguments
+C
+C
+C     K -> The generator is advanced by2^K values
+C                                   INTEGER K
+C
+C**********************************************************************
+C     .. Parameters ..
+      INTEGER numg
+      PARAMETER (numg=32)
+C     ..
+C     .. Scalar Arguments ..
+      INTEGER k
+C     ..
+C     .. Scalars in Common ..
+      INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2
+C     ..
+C     .. Arrays in Common ..
+      INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg),
+     +        lg2(numg)
+      LOGICAL qanti(numg)
+C     ..
+C     .. Local Scalars ..
+      INTEGER g,i,ib1,ib2
+C     ..
+C     .. External Functions ..
+      INTEGER mltmod
+      LOGICAL qrgnin
+      EXTERNAL mltmod,qrgnin
+C     ..
+C     .. External Subroutines ..
+      EXTERNAL getcgn,setsd
+C     ..
+C     .. Common blocks ..
+      COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1,
+     +       cg2,qanti
+C     ..
+C     .. Save statement ..
+      SAVE /globe/
+C     ..
+C     .. Executable Statements ..
+C     Abort unless random number generator initialized
+      IF (qrgnin()) GO TO 10
+      WRITE (*,*) ' ADVNST called before random number generator ',
+     +  ' initialized -- abort!'
+      CALL XSTOPX
+     + (' ADVNST called before random number generator initialized')
+
+   10 CALL getcgn(g)
+C
+      ib1 = a1
+      ib2 = a2
+      DO 20,i = 1,k
+          ib1 = mltmod(ib1,ib1,m1)
+          ib2 = mltmod(ib2,ib2,m2)
+   20 CONTINUE
+      CALL setsd(mltmod(ib1,cg1(g),m1),mltmod(ib2,cg2(g),m2))
+C
+C     NOW, IB1 = A1**K AND IB2 = A2**K
+C
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/genbet.f
@@ -0,0 +1,192 @@
+      REAL FUNCTION genbet(aa,bb)
+C**********************************************************************
+C
+C     REAL FUNCTION GENBET( A, B )
+C               GeNerate BETa random deviate
+C
+C
+C                              Function
+C
+C
+C     Returns a single random deviate from the beta distribution with
+C     parameters A and B.  The density of the beta is
+C               x^(a-1) * (1-x)^(b-1) / B(a,b) for 0 < x < 1
+C
+C
+C                              Arguments
+C
+C
+C     A --> First parameter of the beta distribution
+C                         REAL A
+C
+C     B --> Second parameter of the beta distribution
+C                         REAL B
+C
+C
+C                              Method
+C
+C
+C     R. C. H. Cheng
+C     Generating Beta Variatew with Nonintegral Shape Parameters
+C     Communications of the ACM, 21:317-322  (1978)
+C     (Algorithms BB and BC)
+C
+C**********************************************************************
+C     .. Parameters ..
+C     Close to the largest number that can be exponentiated
+      REAL expmax
+      PARAMETER (expmax=89.0)
+C     Close to the largest representable single precision number
+      REAL infnty
+      PARAMETER (infnty=1.0E38)
+C     ..
+C     .. Scalar Arguments ..
+      REAL aa,bb
+C     ..
+C     .. Local Scalars ..
+      REAL a,alpha,b,beta,delta,gamma,k1,k2,olda,oldb,r,s,t,u1,u2,v,w,y,
+     +     z
+      LOGICAL qsame
+C     ..
+C     .. External Functions ..
+      REAL ranf
+      EXTERNAL ranf
+C     ..
+C     .. Intrinsic Functions ..
+      INTRINSIC exp,log,max,min,sqrt
+C     ..
+C     .. Save statement ..
+      SAVE olda,oldb,alpha,beta,gamma,k1,k2
+C     ..
+C     .. Data statements ..
+      DATA olda,oldb/-1,-1/
+C     ..
+C     .. Executable Statements ..
+      qsame = (olda.EQ.aa) .AND. (oldb.EQ.bb)
+      IF (qsame) GO TO 20
+      IF (.NOT. (aa.LE.0.0.OR.bb.LE.0.0)) GO TO 10
+      WRITE (*,*) ' AA or BB <= 0 in GENBET - Abort!'
+      WRITE (*,*) ' AA: ',aa,' BB ',bb
+      CALL XSTOPX (' AA or BB <= 0 in GENBET - Abort!')
+
+   10 olda = aa
+      oldb = bb
+   20 IF (.NOT. (min(aa,bb).GT.1.0)) GO TO 100
+
+
+C     Alborithm BB
+
+C
+C     Initialize
+C
+      IF (qsame) GO TO 30
+      a = min(aa,bb)
+      b = max(aa,bb)
+      alpha = a + b
+      beta = sqrt((alpha-2.0)/ (2.0*a*b-alpha))
+      gamma = a + 1.0/beta
+   30 CONTINUE
+   40 u1 = ranf()
+C
+C     Step 1
+C
+      u2 = ranf()
+      v = beta*log(u1/ (1.0-u1))
+      IF (.NOT. (v.GT.expmax)) GO TO 50
+      w = infnty
+      GO TO 60
+
+   50 w = a*exp(v)
+   60 z = u1**2*u2
+      r = gamma*v - 1.3862944
+      s = a + r - w
+C
+C     Step 2
+C
+      IF ((s+2.609438).GE. (5.0*z)) GO TO 70
+C
+C     Step 3
+C
+      t = log(z)
+      IF (s.GT.t) GO TO 70
+C
+C     Step 4
+C
+      IF ((r+alpha*log(alpha/ (b+w))).LT.t) GO TO 40
+C
+C     Step 5
+C
+   70 IF (.NOT. (aa.EQ.a)) GO TO 80
+      genbet = w/ (b+w)
+      GO TO 90
+
+   80 genbet = b/ (b+w)
+   90 GO TO 230
+
+
+C     Algorithm BC
+
+C
+C     Initialize
+C
+  100 IF (qsame) GO TO 110
+      a = max(aa,bb)
+      b = min(aa,bb)
+      alpha = a + b
+      beta = 1.0/b
+      delta = 1.0 + a - b
+      k1 = delta* (0.0138889+0.0416667*b)/ (a*beta-0.777778)
+      k2 = 0.25 + (0.5+0.25/delta)*b
+  110 CONTINUE
+  120 u1 = ranf()
+C
+C     Step 1
+C
+      u2 = ranf()
+      IF (u1.GE.0.5) GO TO 130
+C
+C     Step 2
+C
+      y = u1*u2
+      z = u1*y
+      IF ((0.25*u2+z-y).GE.k1) GO TO 120
+      GO TO 170
+C
+C     Step 3
+C
+  130 z = u1**2*u2
+      IF (.NOT. (z.LE.0.25)) GO TO 160
+      v = beta*log(u1/ (1.0-u1))
+      IF (.NOT. (v.GT.expmax)) GO TO 140
+      w = infnty
+      GO TO 150
+
+  140 w = a*exp(v)
+  150 GO TO 200
+
+  160 IF (z.GE.k2) GO TO 120
+C
+C     Step 4
+C
+C
+C     Step 5
+C
+  170 v = beta*log(u1/ (1.0-u1))
+      IF (.NOT. (v.GT.expmax)) GO TO 180
+      w = infnty
+      GO TO 190
+
+  180 w = a*exp(v)
+  190 IF ((alpha* (log(alpha/ (b+w))+v)-1.3862944).LT.log(z)) GO TO 120
+C
+C     Step 6
+C
+  200 IF (.NOT. (a.EQ.aa)) GO TO 210
+      genbet = w/ (b+w)
+      GO TO 220
+
+  210 genbet = b/ (b+w)
+  220 CONTINUE
+  230 RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/genchi.f
@@ -0,0 +1,45 @@
+      REAL FUNCTION genchi(df)
+C**********************************************************************
+C
+C     REAL FUNCTION GENCHI( DF )
+C                Generate random value of CHIsquare variable
+C
+C
+C                              Function
+C
+C
+C     Generates random deviate from the distribution of a chisquare
+C     with DF degrees of freedom random variable.
+C
+C
+C                              Arguments
+C
+C
+C     DF --> Degrees of freedom of the chisquare
+C            (Must be positive)
+C                         REAL DF
+C
+C
+C                              Method
+C
+C
+C     Uses relation between chisquare and gamma.
+C
+C**********************************************************************
+C     .. Scalar Arguments ..
+      REAL df
+C     ..
+C     .. External Functions ..
+      REAL gengam
+      EXTERNAL gengam
+C     ..
+C     .. Executable Statements ..
+      IF (.NOT. (df.LE.0.0)) GO TO 10
+      WRITE (*,*) 'DF <= 0 in GENCHI - ABORT'
+      WRITE (*,*) 'Value of DF: ',df
+      CALL XSTOPX ('DF <= 0 in GENCHI - ABORT')
+
+   10 genchi = 2.0*gengam(1.0,df/2.0)
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/genexp.f
@@ -0,0 +1,52 @@
+      REAL FUNCTION genexp(av)
+C**********************************************************************
+C
+C     REAL FUNCTION GENEXP( AV )
+C
+C                    GENerate EXPonential random deviate
+C
+C
+C                              Function
+C
+C
+C     Generates a single random deviate from an exponential
+C     distribution with mean AV.
+C
+C
+C                              Arguments
+C
+C
+C     AV --> The mean of the exponential distribution from which
+C            a random deviate is to be generated.
+C                              REAL AV
+C
+C     GENEXP <-- The random deviate.
+C                              REAL GENEXP
+C
+C
+C                              Method
+C
+C
+C     Renames SEXPO from TOMS as slightly modified by BWB to use RANF
+C     instead of SUNIF.
+C
+C     For details see:
+C
+C               Ahrens, J.H. and Dieter, U.
+C               Computer Methods for Sampling From the
+C               Exponential and Normal Distributions.
+C               Comm. ACM, 15,10 (Oct. 1972), 873 - 882.
+C
+C**********************************************************************
+C     .. Scalar Arguments ..
+      REAL av
+C     ..
+C     .. External Functions ..
+      REAL sexpo
+      EXTERNAL sexpo
+C     ..
+C     .. Executable Statements ..
+      genexp = sexpo()*av
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/genf.f
@@ -0,0 +1,62 @@
+      REAL FUNCTION genf(dfn,dfd)
+C**********************************************************************
+C
+C     REAL FUNCTION GENF( DFN, DFD )
+C                GENerate random deviate from the F distribution
+C
+C
+C                              Function
+C
+C
+C     Generates a random deviate from the F (variance ratio)
+C     distribution with DFN degrees of freedom in the numerator
+C     and DFD degrees of freedom in the denominator.
+C
+C
+C                              Arguments
+C
+C
+C     DFN --> Numerator degrees of freedom
+C             (Must be positive)
+C                              REAL DFN
+C      DFD --> Denominator degrees of freedom
+C             (Must be positive)
+C                              REAL DFD
+C
+C
+C                              Method
+C
+C
+C     Directly generates ratio of chisquare variates
+C
+C**********************************************************************
+C     .. Scalar Arguments ..
+      REAL dfd,dfn
+C     ..
+C     .. Local Scalars ..
+      REAL xden,xnum
+C     ..
+C     .. External Functions ..
+      REAL genchi
+      EXTERNAL genchi
+C     ..
+C     .. Executable Statements ..
+      IF (.NOT. (dfn.LE.0.0.OR.dfd.LE.0.0)) GO TO 10
+      WRITE (*,*) 'Degrees of freedom nonpositive in GENF - abort!'
+      WRITE (*,*) 'DFN value: ',dfn,'DFD value: ',dfd
+      CALL XSTOPX ('Degrees of freedom nonpositive in GENF - abort!')
+
+   10 xnum = genchi(dfn)/dfn
+C      GENF = ( GENCHI( DFN ) / DFN ) / ( GENCHI( DFD ) / DFD )
+      xden = genchi(dfd)/dfd
+      IF (.NOT. (xden.LE. (1.2E-38*xnum))) GO TO 20
+      WRITE (*,*) ' GENF - generated numbers would cause overflow'
+      WRITE (*,*) ' Numerator ',xnum,' Denominator ',xden
+      WRITE (*,*) ' GENF returning 1.0E38'
+      genf = 1.0E38
+      GO TO 30
+
+   20 genf = xnum/xden
+   30 RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/gengam.f
@@ -0,0 +1,60 @@
+      REAL FUNCTION gengam(a,r)
+C**********************************************************************
+C
+C     REAL FUNCTION GENGAM( A, R )
+C           GENerates random deviates from GAMma distribution
+C
+C
+C                              Function
+C
+C
+C     Generates random deviates from the gamma distribution whose
+C     density is
+C          (A**R)/Gamma(R) * X**(R-1) * Exp(-A*X)
+C
+C
+C                              Arguments
+C
+C
+C     A --> Location parameter of Gamma distribution
+C                              REAL A
+C
+C     R --> Shape parameter of Gamma distribution
+C                              REAL R
+C
+C
+C                              Method
+C
+C
+C     Renames SGAMMA from TOMS as slightly modified by BWB to use RANF
+C     instead of SUNIF.
+C
+C     For details see:
+C               (Case R >= 1.0)
+C               Ahrens, J.H. and Dieter, U.
+C               Generating Gamma Variates by a
+C               Modified Rejection Technique.
+C               Comm. ACM, 25,1 (Jan. 1982), 47 - 54.
+C     Algorithm GD
+C
+C               (Case 0.0 <= R <= 1.0)
+C               Ahrens, J.H. and Dieter, U.
+C               Computer Methods for Sampling from Gamma,
+C               Beta, Poisson and Binomial Distributions.
+C               Computing, 12 (1974), 223-246/
+C     Adapted algorithm GS.
+C
+C**********************************************************************
+C     .. Scalar Arguments ..
+      REAL a,r
+C     ..
+C     .. External Functions ..
+      REAL sgamma
+      EXTERNAL sgamma
+C     ..
+C     .. Executable Statements ..
+      gengam = sgamma(r)
+      gengam = gengam/a
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/genmn.f
@@ -0,0 +1,82 @@
+      SUBROUTINE genmn(parm,x,work)
+C**********************************************************************
+C
+C     SUBROUTINE GENMN(PARM,X,WORK)
+C              GENerate Multivariate Normal random deviate
+C
+C
+C                              Arguments
+C
+C
+C     PARM --> Parameters needed to generate multivariate normal
+C               deviates (MEANV and Cholesky decomposition of
+C               COVM). Set by a previous call to SETGMN.
+C               1 : 1                - size of deviate, P
+C               2 : P + 1            - mean vector
+C               P+2 : P*(P+3)/2 + 1  - upper half of cholesky
+C                                       decomposition of cov matrix
+C                                             REAL PARM(*)
+C
+C     X    <-- Vector deviate generated.
+C                                             REAL X(P)
+C
+C     WORK <--> Scratch array
+C                                             REAL WORK(P)
+C
+C
+C                              Method
+C
+C
+C     1) Generate P independent standard normal deviates - Ei ~ N(0,1)
+C
+C     2) Using Cholesky decomposition find A s.t. trans(A)*A = COVM
+C
+C     3) trans(A)E + MEANV ~ N(MEANV,COVM)
+C
+C**********************************************************************
+C     .. Array Arguments ..
+      REAL parm(*),work(*),x(*)
+C     ..
+C     .. Local Scalars ..
+      REAL ae
+      INTEGER i,icount,j,p
+C     ..
+C     .. External Functions ..
+      REAL snorm
+      EXTERNAL snorm
+C     ..
+C     .. Intrinsic Functions ..
+      INTRINSIC int
+C     ..
+C     .. Executable Statements ..
+      p = int(parm(1))
+C
+C     Generate P independent normal deviates - WORK ~ N(0,1)
+C
+      DO 10,i = 1,p
+          work(i) = snorm()
+   10 CONTINUE
+      DO 30,i = 1,p
+C
+C     PARM (P+2 : P*(P+3)/2 + 1) contains A, the Cholesky
+C      decomposition of the desired covariance matrix.
+C          trans(A)(1,1) = PARM(P+2)
+C          trans(A)(2,1) = PARM(P+3)
+C          trans(A)(2,2) = PARM(P+2+P)
+C          trans(A)(3,1) = PARM(P+4)
+C          trans(A)(3,2) = PARM(P+3+P)
+C          trans(A)(3,3) = PARM(P+2-1+2P)  ...
+C
+C     trans(A)*WORK + MEANV ~ N(MEANV,COVM)
+C
+          icount = 0
+          ae = 0.0
+          DO 20,j = 1,i
+              icount = icount + j - 1
+              ae = ae + parm(i+ (j-1)*p-icount+p+1)*work(j)
+   20     CONTINUE
+          x(i) = ae + parm(i+1)
+   30 CONTINUE
+      RETURN
+C
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/gennch.f
@@ -0,0 +1,56 @@
+      REAL FUNCTION gennch(df,xnonc)
+C**********************************************************************
+C
+C     REAL FUNCTION GENNCH( DF, XNONC )
+C           Generate random value of Noncentral CHIsquare variable
+C
+C
+C                              Function
+C
+C
+
+C     Generates random deviate  from the  distribution  of a  noncentral
+C     chisquare with DF degrees  of freedom and noncentrality  parameter
+C     XNONC.
+C
+C
+C                              Arguments
+C
+C
+C     DF --> Degrees of freedom of the chisquare
+C            (Must be > 1.0)
+C                         REAL DF
+C
+C     XNONC --> Noncentrality parameter of the chisquare
+C               (Must be >= 0.0)
+C                         REAL XNONC
+C
+C
+C                              Method
+C
+C
+C     Uses fact that  noncentral chisquare  is  the  sum of a  chisquare
+C     deviate with DF-1  degrees of freedom plus the  square of a normal
+C     deviate with mean XNONC and standard deviation 1.
+C
+C**********************************************************************
+C     .. Scalar Arguments ..
+      REAL df,xnonc
+C     ..
+C     .. External Functions ..
+      REAL genchi,gennor
+      EXTERNAL genchi,gennor
+C     ..
+C     .. Intrinsic Functions ..
+      INTRINSIC sqrt
+C     ..
+C     .. Executable Statements ..
+      IF (.NOT. (df.LE.1.0.OR.xnonc.LT.0.0)) GO TO 10
+      WRITE (*,*) 'DF <= 1 or XNONC < 0 in GENNCH - ABORT'
+      WRITE (*,*) 'Value of DF: ',df,' Value of XNONC',xnonc
+      CALL XSTOPX ('DF <= 1 or XNONC < 0 in GENNCH - ABORT')
+
+   10 gennch = genchi(df-1.0) + gennor(sqrt(xnonc),1.0)**2
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/gennf.f
@@ -0,0 +1,75 @@
+      REAL FUNCTION gennf(dfn,dfd,xnonc)
+
+C**********************************************************************
+C
+C     REAL FUNCTION GENNF( DFN, DFD, XNONC )
+C           GENerate random deviate from the Noncentral F distribution
+C
+C
+C                              Function
+C
+C
+C     Generates a random deviate from the  noncentral F (variance ratio)
+C     distribution with DFN degrees of freedom in the numerator, and DFD
+C     degrees of freedom in the denominator, and noncentrality parameter
+C     XNONC.
+C
+C
+C                              Arguments
+C
+C
+C     DFN --> Numerator degrees of freedom
+C             (Must be >= 1.0)
+C                              REAL DFN
+C      DFD --> Denominator degrees of freedom
+C             (Must be positive)
+C                              REAL DFD
+C
+C     XNONC --> Noncentrality parameter
+C               (Must be nonnegative)
+C                              REAL XNONC
+C
+C
+C                              Method
+C
+C
+C     Directly generates ratio of noncentral numerator chisquare variate
+C     to central denominator chisquare variate.
+C
+C**********************************************************************
+C     .. Scalar Arguments ..
+      REAL dfd,dfn,xnonc
+C     ..
+C     .. Local Scalars ..
+      REAL xden,xnum
+      LOGICAL qcond
+C     ..
+C     .. External Functions ..
+      REAL genchi,gennch
+      EXTERNAL genchi,gennch
+C     ..
+C     .. Executable Statements ..
+      qcond = dfn .LE. 1.0 .OR. dfd .LE. 0.0 .OR. xnonc .LT. 0.0
+      IF (.NOT. (qcond)) GO TO 10
+      WRITE (*,*) 'In GENNF - Either (1) Numerator DF <= 1.0 or'
+      WRITE (*,*) '(2) Denominator DF < 0.0 or '
+      WRITE (*,*) '(3) Noncentrality parameter < 0.0'
+      WRITE (*,*) 'DFN value: ',dfn,'DFD value: ',dfd,'XNONC value: ',
+     +  xnonc
+      CALL XSTOPX
+     + ('Degrees of freedom or noncent param our of range in GENNF')
+
+   10 xnum = gennch(dfn,xnonc)/dfn
+C      GENNF = ( GENNCH( DFN, XNONC ) / DFN ) / ( GENCHI( DFD ) / DFD )
+      xden = genchi(dfd)/dfd
+      IF (.NOT. (xden.LE. (1.2E-38*xnum))) GO TO 20
+      WRITE (*,*) ' GENNF - generated numbers would cause overflow'
+      WRITE (*,*) ' Numerator ',xnum,' Denominator ',xden
+      WRITE (*,*) ' GENNF returning 1.0E38'
+      gennf = 1.0E38
+      GO TO 30
+
+   20 gennf = xnum/xden
+   30 RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/gennor.f
@@ -0,0 +1,54 @@
+      REAL FUNCTION gennor(av,sd)
+C**********************************************************************
+C
+C     REAL FUNCTION GENNOR( AV, SD )
+C
+C         GENerate random deviate from a NORmal distribution
+C
+C
+C                              Function
+C
+C
+C     Generates a single random deviate from a normal distribution
+C     with mean, AV, and standard deviation, SD.
+C
+C
+C                              Arguments
+C
+C
+C     AV --> Mean of the normal distribution.
+C                              REAL AV
+C
+C     SD --> Standard deviation of the normal distribution.
+C                              REAL SD
+C
+C     GENNOR <-- Generated normal deviate.
+C                              REAL GENNOR
+C
+C
+C                              Method
+C
+C
+C     Renames SNORM from TOMS as slightly modified by BWB to use RANF
+C     instead of SUNIF.
+C
+C     For details see:
+C               Ahrens, J.H. and Dieter, U.
+C               Extensions of Forsythe's Method for Random
+C               Sampling from the Normal Distribution.
+C               Math. Comput., 27,124 (Oct. 1973), 927 - 937.
+C
+C
+C**********************************************************************
+C     .. Scalar Arguments ..
+      REAL av,sd
+C     ..
+C     .. External Functions ..
+      REAL snorm
+      EXTERNAL snorm
+C     ..
+C     .. Executable Statements ..
+      gennor = sd*snorm() + av
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/genprm.f
@@ -0,0 +1,41 @@
+      SUBROUTINE genprm(iarray,larray)
+C**********************************************************************
+C
+C    SUBROUTINE GENPRM( IARRAY, LARRAY )
+C               GENerate random PeRMutation of iarray
+C
+C
+C                              Arguments
+C
+C
+C     IARRAY <--> On output IARRAY is a random permutation of its
+C                 value on input
+C                         INTEGER IARRAY( LARRAY )
+C
+C     LARRAY <--> Length of IARRAY
+C                         INTEGER LARRAY
+C
+C**********************************************************************
+C     .. Scalar Arguments ..
+      INTEGER larray
+C     ..
+C     .. Array Arguments ..
+      INTEGER iarray(larray)
+C     ..
+C     .. Local Scalars ..
+      INTEGER i,itmp,iwhich
+C     ..
+C     .. External Functions ..
+      INTEGER ignuin
+      EXTERNAL ignuin
+C     ..
+C     .. Executable Statements ..
+      DO 10,i = 1,larray
+          iwhich = ignuin(i,larray)
+          itmp = iarray(iwhich)
+          iarray(iwhich) = iarray(i)
+          iarray(i) = itmp
+   10 CONTINUE
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/genunf.f
@@ -0,0 +1,42 @@
+      REAL FUNCTION genunf(low,high)
+C**********************************************************************
+C
+C     REAL FUNCTION GENUNF( LOW, HIGH )
+C
+C               GeNerate Uniform Real between LOW and HIGH
+C
+C
+C                              Function
+C
+C
+C     Generates a real uniformly distributed between LOW and HIGH.
+C
+C
+C                              Arguments
+C
+C
+C     LOW --> Low bound (exclusive) on real value to be generated
+C                         REAL LOW
+C
+C     HIGH --> High bound (exclusive) on real value to be generated
+C                         REAL HIGH
+C
+C**********************************************************************
+C     .. Scalar Arguments ..
+      REAL high,low
+C     ..
+C     .. External Functions ..
+      REAL ranf
+      EXTERNAL ranf
+C     ..
+C     .. Executable Statements ..
+      IF (.NOT. (low.GT.high)) GO TO 10
+      WRITE (*,*) 'LOW > HIGH in GENUNF: LOW ',low,' HIGH: ',high
+      WRITE (*,*) 'Abort'
+      CALL XSTOPX ('LOW > High in GENUNF - Abort')
+
+   10 genunf = low + (high-low)*ranf()
+
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/getcgn.f
@@ -0,0 +1,55 @@
+      SUBROUTINE getcgn(g)
+      INTEGER g
+C**********************************************************************
+C
+C      SUBROUTINE GETCGN(G)
+C                         Get GeNerator
+C
+C     Returns in G the number of the current random number generator
+C
+C
+C                              Arguments
+C
+C
+C     G <-- Number of the current random number generator (1..32)
+C                    INTEGER G
+C
+C**********************************************************************
+C
+      INTEGER curntg,numg
+      SAVE curntg
+      PARAMETER (numg=32)
+      DATA curntg/1/
+C
+      g = curntg
+      RETURN
+
+      ENTRY setcgn(g)
+C**********************************************************************
+C
+C     SUBROUTINE SETCGN( G )
+C                      Set GeNerator
+C
+C     Sets  the  current  generator to G.    All references to a generat
+C     are to the current generator.
+C
+C
+C                              Arguments
+C
+C
+C     G --> Number of the current random number generator (1..32)
+C                    INTEGER G
+C
+C**********************************************************************
+C
+C     Abort if generator number out of range
+C
+      IF (.NOT. (g.LT.0.OR.g.GT.numg)) GO TO 10
+      WRITE (*,*) ' Generator number out of range in SETCGN:',
+     +  ' Legal range is 1 to ',numg,' -- ABORT!'
+      CALL XSTOPX (' Generator number out of range in SETCGN')
+
+   10 curntg = g
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/getsd.f
@@ -0,0 +1,73 @@
+      SUBROUTINE getsd(iseed1,iseed2)
+C**********************************************************************
+C
+C     SUBROUTINE GETSD(ISEED1,ISEED2)
+C               GET SeeD
+C
+C     Returns the value of two integer seeds of the current generator
+C
+C     This  is   a  transcription from  Pascal   to  Fortran  of routine
+C     Get_State from the paper
+C
+C     L'Ecuyer, P. and  Cote,  S. "Implementing a Random Number  Package
+C     with   Splitting Facilities."  ACM  Transactions   on Mathematical
+C     Software, 17:98-111 (1991)
+C
+C
+C                              Arguments
+C
+C
+C
+C     ISEED1 <- First integer seed of generator G
+C                                   INTEGER ISEED1
+C
+C     ISEED2 <- Second integer seed of generator G
+C                                   INTEGER ISEED1
+C
+C**********************************************************************
+C     .. Parameters ..
+      INTEGER numg
+      PARAMETER (numg=32)
+C     ..
+C     .. Scalar Arguments ..
+      INTEGER iseed1,iseed2
+C     ..
+C     .. Scalars in Common ..
+      INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2
+C     ..
+C     .. Arrays in Common ..
+      INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg),
+     +        lg2(numg)
+      LOGICAL qanti(numg)
+C     ..
+C     .. Local Scalars ..
+      INTEGER g
+C     ..
+C     .. External Functions ..
+      LOGICAL qrgnin
+      EXTERNAL qrgnin
+C     ..
+C     .. External Subroutines ..
+      EXTERNAL getcgn
+C     ..
+C     .. Common blocks ..
+      COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1,
+     +       cg2,qanti
+C     ..
+C     .. Save statement ..
+      SAVE /globe/
+C     ..
+C     .. Executable Statements ..
+C     Abort unless random number generator initialized
+      IF (qrgnin()) GO TO 10
+      WRITE (*,*) ' GETSD called before random number generator ',
+     +  ' initialized -- abort!'
+      CALL XSTOPX
+     + (' GETSD called before random number generator initialized')
+
+   10 CALL getcgn(g)
+      iseed1 = cg1(g)
+      iseed2 = cg2(g)
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/ignbin.f
@@ -0,0 +1,303 @@
+      INTEGER FUNCTION ignbin(n,pp)
+C**********************************************************************
+C
+C     INTEGER FUNCTION IGNBIN( N, P )
+C
+C                    GENerate BINomial random deviate
+C
+C
+C                              Function
+C
+C
+C     Generates a single random deviate from a binomial
+C     distribution whose number of trials is N and whose
+C     probability of an event in each trial is P.
+C
+C
+C                              Arguments
+C
+C
+C     N  --> The number of trials in the binomial distribution
+C            from which a random deviate is to be generated.
+C                              INTEGER N
+C
+C     P  --> The probability of an event in each trial of the
+C            binomial distribution from which a random deviate
+C            is to be generated.
+C                              REAL P
+C
+C     IGNBIN <-- A random deviate yielding the number of events
+C                from N independent trials, each of which has
+C                a probability of event P.
+C                              INTEGER IGNBIN
+C
+C
+C                              Note
+C
+C
+C     Uses RANF so the value of the seeds, ISEED1 and ISEED2 must be set
+C     by a call similar to the following
+C          DUM = RANSET( ISEED1, ISEED2 )
+C
+C
+C                              Method
+C
+C
+C     This is algorithm BTPE from:
+C
+C         Kachitvichyanukul, V. and Schmeiser, B. W.
+C
+C         Binomial Random Variate Generation.
+C         Communications of the ACM, 31, 2
+C         (February, 1988) 216.
+C
+C**********************************************************************
+C     SUBROUTINE BTPEC(N,PP,ISEED,JX)
+C
+C     BINOMIAL RANDOM VARIATE GENERATOR
+C     MEAN .LT. 30 -- INVERSE CDF
+C       MEAN .GE. 30 -- ALGORITHM BTPE:  ACCEPTANCE-REJECTION VIA
+C       FOUR REGION COMPOSITION.  THE FOUR REGIONS ARE A TRIANGLE
+C       (SYMMETRIC IN THE CENTER), A PAIR OF PARALLELOGRAMS (ABOVE
+C       THE TRIANGLE), AND EXPONENTIAL LEFT AND RIGHT TAILS.
+C
+C     BTPE REFERS TO BINOMIAL-TRIANGLE-PARALLELOGRAM-EXPONENTIAL.
+C     BTPEC REFERS TO BTPE AND "COMBINED."  THUS BTPE IS THE
+C       RESEARCH AND BTPEC IS THE IMPLEMENTATION OF A COMPLETE
+C       USABLE ALGORITHM.
+C     REFERENCE:  VORATAS KACHITVICHYANUKUL AND BRUCE SCHMEISER,
+C       "BINOMIAL RANDOM VARIATE GENERATION,"
+C       COMMUNICATIONS OF THE ACM, FORTHCOMING
+C     WRITTEN:  SEPTEMBER 1980.
+C       LAST REVISED:  MAY 1985, JULY 1987
+C     REQUIRED SUBPROGRAM:  RAND() -- A UNIFORM (0,1) RANDOM NUMBER
+C                           GENERATOR
+C     ARGUMENTS
+C
+C       N : NUMBER OF BERNOULLI TRIALS            (INPUT)
+C       PP : PROBABILITY OF SUCCESS IN EACH TRIAL (INPUT)
+C       ISEED:  RANDOM NUMBER SEED                (INPUT AND OUTPUT)
+C       JX:  RANDOMLY GENERATED OBSERVATION       (OUTPUT)
+C
+C     VARIABLES
+C       PSAVE: VALUE OF PP FROM THE LAST CALL TO BTPEC
+C       NSAVE: VALUE OF N FROM THE LAST CALL TO BTPEC
+C       XNP:  VALUE OF THE MEAN FROM THE LAST CALL TO BTPEC
+C
+C       P: PROBABILITY USED IN THE GENERATION PHASE OF BTPEC
+C       FFM: TEMPORARY VARIABLE EQUAL TO XNP + P
+C       M:  INTEGER VALUE OF THE CURRENT MODE
+C       FM:  FLOATING POINT VALUE OF THE CURRENT MODE
+C       XNPQ: TEMPORARY VARIABLE USED IN SETUP AND SQUEEZING STEPS
+C       P1:  AREA OF THE TRIANGLE
+C       C:  HEIGHT OF THE PARALLELOGRAMS
+C       XM:  CENTER OF THE TRIANGLE
+C       XL:  LEFT END OF THE TRIANGLE
+C       XR:  RIGHT END OF THE TRIANGLE
+C       AL:  TEMPORARY VARIABLE
+C       XLL:  RATE FOR THE LEFT EXPONENTIAL TAIL
+C       XLR:  RATE FOR THE RIGHT EXPONENTIAL TAIL
+C       P2:  AREA OF THE PARALLELOGRAMS
+C       P3:  AREA OF THE LEFT EXPONENTIAL TAIL
+C       P4:  AREA OF THE RIGHT EXPONENTIAL TAIL
+C       U:  A U(0,P4) RANDOM VARIATE USED FIRST TO SELECT ONE OF THE
+C           FOUR REGIONS AND THEN CONDITIONALLY TO GENERATE A VALUE
+C           FROM THE REGION
+C       V:  A U(0,1) RANDOM NUMBER USED TO GENERATE THE RANDOM VALUE
+C           (REGION 1) OR TRANSFORMED INTO THE VARIATE TO ACCEPT OR
+C           REJECT THE CANDIDATE VALUE
+C       IX:  INTEGER CANDIDATE VALUE
+C       X:  PRELIMINARY CONTINUOUS CANDIDATE VALUE IN REGION 2 LOGIC
+C           AND A FLOATING POINT IX IN THE ACCEPT/REJECT LOGIC
+C       K:  ABSOLUTE VALUE OF (IX-M)
+C       F:  THE HEIGHT OF THE SCALED DENSITY FUNCTION USED IN THE
+C           ACCEPT/REJECT DECISION WHEN BOTH M AND IX ARE SMALL
+C           ALSO USED IN THE INVERSE TRANSFORMATION
+C       R: THE RATIO P/Q
+C       G: CONSTANT USED IN CALCULATION OF PROBABILITY
+C       MP:  MODE PLUS ONE, THE LOWER INDEX FOR EXPLICIT CALCULATION
+C            OF F WHEN IX IS GREATER THAN M
+C       IX1:  CANDIDATE VALUE PLUS ONE, THE LOWER INDEX FOR EXPLICIT
+C             CALCULATION OF F WHEN IX IS LESS THAN M
+C       I:  INDEX FOR EXPLICIT CALCULATION OF F FOR BTPE
+C       AMAXP: MAXIMUM ERROR OF THE LOGARITHM OF NORMAL BOUND
+C       YNORM: LOGARITHM OF NORMAL BOUND
+C       ALV:  NATURAL LOGARITHM OF THE ACCEPT/REJECT VARIATE V
+C
+C       X1,F1,Z,W,Z2,X2,F2, AND W2 ARE TEMPORARY VARIABLES TO BE
+C       USED IN THE FINAL ACCEPT/REJECT TEST
+C
+C       QN: PROBABILITY OF NO SUCCESS IN N TRIALS
+C
+C     REMARK
+C       IX AND JX COULD LOGICALLY BE THE SAME VARIABLE, WHICH WOULD
+C       SAVE A MEMORY POSITION AND A LINE OF CODE.  HOWEVER, SOME
+C       COMPILERS (E.G.,CDC MNF) OPTIMIZE BETTER WHEN THE ARGUMENTS
+C       ARE NOT INVOLVED.
+C
+C     ISEED NEEDS TO BE DOUBLE PRECISION IF THE IMSL ROUTINE
+C     GGUBFS IS USED TO GENERATE UNIFORM RANDOM NUMBER, OTHERWISE
+C     TYPE OF ISEED SHOULD BE DICTATED BY THE UNIFORM GENERATOR
+C
+C**********************************************************************
+
+C
+C
+C
+C*****DETERMINE APPROPRIATE ALGORITHM AND WHETHER SETUP IS NECESSARY
+C
+C     ..
+C     .. Scalar Arguments ..
+      REAL pp
+      INTEGER n
+C     ..
+C     .. Local Scalars ..
+      REAL al,alv,amaxp,c,f,f1,f2,ffm,fm,g,p,p1,p2,p3,p4,psave,q,qn,r,u,
+     +     v,w,w2,x,x1,x2,xl,xll,xlr,xm,xnp,xnpq,xr,ynorm,z,z2
+      INTEGER i,ix,ix1,k,m,mp,nsave
+C     ..
+C     .. External Functions ..
+      REAL ranf
+      EXTERNAL ranf
+C     ..
+C     .. Intrinsic Functions ..
+      INTRINSIC abs,alog,amin1,iabs,int,sqrt
+C     ..
+C     .. Data statements ..
+      DATA psave,nsave/-1.,-1/
+C     ..
+C     .. Executable Statements ..
+      IF (pp.NE.psave) GO TO 10
+      IF (n.NE.nsave) GO TO 20
+      IF (xnp-30.) 150,30,30
+C
+C*****SETUP, PERFORM ONLY WHEN PARAMETERS CHANGE
+C
+   10 psave = pp
+      p = amin1(psave,1.-psave)
+      q = 1. - p
+   20 xnp = n*p
+      nsave = n
+      IF (xnp.LT.30.) GO TO 140
+      ffm = xnp + p
+      m = ffm
+      fm = m
+      xnpq = xnp*q
+      p1 = int(2.195*sqrt(xnpq)-4.6*q) + 0.5
+      xm = fm + 0.5
+      xl = xm - p1
+      xr = xm + p1
+      c = 0.134 + 20.5/ (15.3+fm)
+      al = (ffm-xl)/ (ffm-xl*p)
+      xll = al* (1.+.5*al)
+      al = (xr-ffm)/ (xr*q)
+      xlr = al* (1.+.5*al)
+      p2 = p1* (1.+c+c)
+      p3 = p2 + c/xll
+      p4 = p3 + c/xlr
+C      WRITE(6,100) N,P,P1,P2,P3,P4,XL,XR,XM,FM
+C  100 FORMAT(I15,4F18.7/5F18.7)
+C
+C*****GENERATE VARIATE
+C
+   30 u = ranf()*p4
+      v = ranf()
+C
+C     TRIANGULAR REGION
+C
+      IF (u.GT.p1) GO TO 40
+      ix = xm - p1*v + u
+      GO TO 170
+C
+C     PARALLELOGRAM REGION
+C
+   40 IF (u.GT.p2) GO TO 50
+      x = xl + (u-p1)/c
+      v = v*c + 1. - abs(xm-x)/p1
+      IF (v.GT.1. .OR. v.LE.0.) GO TO 30
+      ix = x
+      GO TO 70
+C
+C     LEFT TAIL
+C
+   50 IF (u.GT.p3) GO TO 60
+      ix = xl + alog(v)/xll
+      IF (ix.LT.0) GO TO 30
+      v = v* (u-p2)*xll
+      GO TO 70
+C
+C     RIGHT TAIL
+C
+   60 ix = xr - alog(v)/xlr
+      IF (ix.GT.n) GO TO 30
+      v = v* (u-p3)*xlr
+C
+C*****DETERMINE APPROPRIATE WAY TO PERFORM ACCEPT/REJECT TEST
+C
+   70 k = iabs(ix-m)
+      IF (k.GT.20 .AND. k.LT.xnpq/2-1) GO TO 130
+C
+C     EXPLICIT EVALUATION
+C
+      f = 1.0
+      r = p/q
+      g = (n+1)*r
+      IF (m-ix) 80,120,100
+   80 mp = m + 1
+      DO 90 i = mp,ix
+          f = f* (g/i-r)
+   90 CONTINUE
+      GO TO 120
+
+  100 ix1 = ix + 1
+      DO 110 i = ix1,m
+          f = f/ (g/i-r)
+  110 CONTINUE
+  120 IF (v-f) 170,170,30
+C
+C     SQUEEZING USING UPPER AND LOWER BOUNDS ON ALOG(F(X))
+C
+  130 amaxp = (k/xnpq)* ((k* (k/3.+.625)+.1666666666666)/xnpq+.5)
+      ynorm = -k*k/ (2.*xnpq)
+      alv = alog(v)
+      IF (alv.LT.ynorm-amaxp) GO TO 170
+      IF (alv.GT.ynorm+amaxp) GO TO 30
+C
+C     STIRLING'S FORMULA TO MACHINE ACCURACY FOR
+C     THE FINAL ACCEPTANCE/REJECTION TEST
+C
+      x1 = ix + 1
+      f1 = fm + 1.
+      z = n + 1 - fm
+      w = n - ix + 1.
+      z2 = z*z
+      x2 = x1*x1
+      f2 = f1*f1
+      w2 = w*w
+      IF (alv- (xm*alog(f1/x1)+ (n-m+.5)*alog(z/w)+ (ix-
+     +    m)*alog(w*p/ (x1*q))+ (13860.- (462.- (132.- (99.-
+     +    140./f2)/f2)/f2)/f2)/f1/166320.+ (13860.- (462.- (132.- (99.-
+     +    140./z2)/z2)/z2)/z2)/z/166320.+ (13860.- (462.- (132.- (99.-
+     +    140./x2)/x2)/x2)/x2)/x1/166320.+ (13860.- (462.- (132.- (99.-
+     +    140./w2)/w2)/w2)/w2)/w/166320.)) 170,170,30
+C
+C     INVERSE CDF LOGIC FOR MEAN LESS THAN 30
+C
+  140 qn = q**n
+      r = p/q
+      g = r* (n+1)
+  150 ix = 0
+      f = qn
+      u = ranf()
+  160 IF (u.LT.f) GO TO 170
+      IF (ix.GT.110) GO TO 150
+      u = u - f
+      ix = ix + 1
+      f = f* (g/ix-r)
+      GO TO 160
+
+  170 IF (psave.GT.0.5) ix = n - ix
+      ignbin = ix
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/ignlgi.f
@@ -0,0 +1,77 @@
+      INTEGER FUNCTION ignlgi()
+C**********************************************************************
+C
+C     INTEGER FUNCTION IGNLGI()
+C               GeNerate LarGe Integer
+C
+C     Returns a random integer following a uniform distribution over
+C     (1, 2147483562) using the current generator.
+C
+C     This is a transcription from Pascal to Fortran of routine
+C     Random from the paper
+C
+C     L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package
+C     with Splitting Facilities." ACM Transactions on Mathematical
+C     Software, 17:98-111 (1991)
+C
+C**********************************************************************
+C     .. Parameters ..
+      INTEGER numg
+      PARAMETER (numg=32)
+C     ..
+C     .. Scalars in Common ..
+      INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2
+C     ..
+C     .. Arrays in Common ..
+      INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg),
+     +        lg2(numg)
+      LOGICAL qanti(numg)
+C     ..
+C     .. Local Scalars ..
+      INTEGER curntg,k,s1,s2,z
+      LOGICAL qqssd
+C     ..
+C     .. External Functions ..
+      LOGICAL qrgnin
+      EXTERNAL qrgnin
+C     ..
+C     .. External Subroutines ..
+      EXTERNAL getcgn,inrgcm,rgnqsd,setall
+C     ..
+C     .. Common blocks ..
+      COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1,
+     +       cg2,qanti
+C     ..
+C     .. Save statement ..
+      SAVE /globe/
+C     ..
+C     .. Executable Statements ..
+C
+C     IF THE RANDOM NUMBER PACKAGE HAS NOT BEEN INITIALIZED YET, DO SO.
+C     IT CAN BE INITIALIZED IN ONE OF TWO WAYS : 1) THE FIRST CALL TO
+C     THIS ROUTINE  2) A CALL TO SETALL.
+C
+      IF (.NOT. (qrgnin())) CALL inrgcm()
+      CALL rgnqsd(qqssd)
+      IF (.NOT. (qqssd)) CALL setall(1234567890,123456789)
+C
+C     Get Current Generator
+C
+      CALL getcgn(curntg)
+      s1 = cg1(curntg)
+      s2 = cg2(curntg)
+      k = s1/53668
+      s1 = a1* (s1-k*53668) - k*12211
+      IF (s1.LT.0) s1 = s1 + m1
+      k = s2/52774
+      s2 = a2* (s2-k*52774) - k*3791
+      IF (s2.LT.0) s2 = s2 + m2
+      cg1(curntg) = s1
+      cg2(curntg) = s2
+      z = s1 - s2
+      IF (z.LT.1) z = z + m1 - 1
+      IF (qanti(curntg)) z = m1 - z
+      ignlgi = z
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/ignpoi.f
@@ -0,0 +1,261 @@
+      INTEGER FUNCTION ignpoi(mu)
+C**********************************************************************
+C
+C     INTEGER FUNCTION IGNPOI( AV )
+C
+C                    GENerate POIsson random deviate
+C
+C
+C                              Function
+C
+C
+C     Generates a single random deviate from a Poisson
+C     distribution with mean AV.
+C
+C
+C                              Arguments
+C
+C
+C     AV --> The mean of the Poisson distribution from which
+C            a random deviate is to be generated.
+C                              REAL AV
+C
+C     GENEXP <-- The random deviate.
+C                              REAL GENEXP
+C
+C
+C                              Method
+C
+C
+C     Renames KPOIS from TOMS as slightly modified by BWB to use RANF
+C     instead of SUNIF.
+C
+C     For details see:
+C
+C               Ahrens, J.H. and Dieter, U.
+C               Computer Generation of Poisson Deviates
+C               From Modified Normal Distributions.
+C               ACM Trans. Math. Software, 8, 2
+C               (June 1982),163-179
+C
+C**********************************************************************
+C**********************************************************************C
+C**********************************************************************C
+C                                                                      C
+C                                                                      C
+C     P O I S S O N  DISTRIBUTION                                      C
+C                                                                      C
+C                                                                      C
+C**********************************************************************C
+C**********************************************************************C
+C                                                                      C
+C     FOR DETAILS SEE:                                                 C
+C                                                                      C
+C               AHRENS, J.H. AND DIETER, U.                            C
+C               COMPUTER GENERATION OF POISSON DEVIATES                C
+C               FROM MODIFIED NORMAL DISTRIBUTIONS.                    C
+C               ACM TRANS. MATH. SOFTWARE, 8,2 (JUNE 1982), 163 - 179. C
+C                                                                      C
+C     (SLIGHTLY MODIFIED VERSION OF THE PROGRAM IN THE ABOVE ARTICLE)  C
+C                                                                      C
+C**********************************************************************C
+C
+C      INTEGER FUNCTION IGNPOI(IR,MU)
+C
+C     INPUT:  IR=CURRENT STATE OF BASIC RANDOM NUMBER GENERATOR
+C             MU=MEAN MU OF THE POISSON DISTRIBUTION
+C     OUTPUT: IGNPOI=SAMPLE FROM THE POISSON-(MU)-DISTRIBUTION
+C
+C
+C
+C     MUPREV=PREVIOUS MU, MUOLD=MU AT LAST EXECUTION OF STEP P OR B.
+C     TABLES: COEFFICIENTS A0-A7 FOR STEP F. FACTORIALS FACT
+C     COEFFICIENTS A(K) - FOR PX = FK*V*V*SUM(A(K)*V**K)-DEL
+C
+C
+C
+C     SEPARATION OF CASES A AND B
+C
+C     .. Scalar Arguments ..
+      REAL mu
+C     ..
+C     .. Local Scalars ..
+      REAL a0,a1,a2,a3,a4,a5,a6,a7,b1,b2,c,c0,c1,c2,c3,d,del,difmuk,e,
+     +     fk,fx,fy,g,muold,muprev,omega,p,p0,px,py,q,s,t,u,v,x,xx
+      INTEGER j,k,kflag,l,m
+C     ..
+C     .. Local Arrays ..
+      REAL fact(10),pp(35)
+C     ..
+C     .. External Functions ..
+      REAL ranf,sexpo,snorm
+      EXTERNAL ranf,sexpo,snorm
+C     ..
+C     .. Intrinsic Functions ..
+      INTRINSIC abs,alog,exp,float,ifix,max0,min0,sign,sqrt
+C     ..
+C     .. Data statements ..
+      DATA muprev,muold/0.,0./
+      DATA a0,a1,a2,a3,a4,a5,a6,a7/-.5,.3333333,-.2500068,.2000118,
+     +     -.1661269,.1421878,-.1384794,.1250060/
+      DATA fact/1.,1.,2.,6.,24.,120.,720.,5040.,40320.,362880./
+C     ..
+C     .. Executable Statements ..
+      IF (mu.EQ.muprev) GO TO 10
+      IF (mu.LT.10.0) GO TO 120
+C
+C     C A S E  A. (RECALCULATION OF S,D,L IF MU HAS CHANGED)
+C
+      muprev = mu
+      s = sqrt(mu)
+      d = 6.0*mu*mu
+C
+C             THE POISSON PROBABILITIES PK EXCEED THE DISCRETE NORMAL
+C             PROBABILITIES FK WHENEVER K >= M(MU). L=IFIX(MU-1.1484)
+C             IS AN UPPER BOUND TO M(MU) FOR ALL MU >= 10 .
+C
+      l = ifix(mu-1.1484)
+C
+C     STEP N. NORMAL SAMPLE - SNORM(IR) FOR STANDARD NORMAL DEVIATE
+C
+   10 g = mu + s*snorm()
+      IF (g.LT.0.0) GO TO 20
+      ignpoi = ifix(g)
+C
+C     STEP I. IMMEDIATE ACCEPTANCE IF IGNPOI IS LARGE ENOUGH
+C
+      IF (ignpoi.GE.l) RETURN
+C
+C     STEP S. SQUEEZE ACCEPTANCE - SUNIF(IR) FOR (0,1)-SAMPLE U
+C
+      fk = float(ignpoi)
+      difmuk = mu - fk
+      u = ranf()
+      IF (d*u.GE.difmuk*difmuk*difmuk) RETURN
+C
+C     STEP P. PREPARATIONS FOR STEPS Q AND H.
+C             (RECALCULATIONS OF PARAMETERS IF NECESSARY)
+C             .3989423=(2*PI)**(-.5)  .416667E-1=1./24.  .1428571=1./7.
+C             THE QUANTITIES B1, B2, C3, C2, C1, C0 ARE FOR THE HERMITE
+C             APPROXIMATIONS TO THE DISCRETE NORMAL PROBABILITIES FK.
+C             C=.1069/MU GUARANTEES MAJORIZATION BY THE 'HAT'-FUNCTION.
+C
+   20 IF (mu.EQ.muold) GO TO 30
+      muold = mu
+      omega = .3989423/s
+      b1 = .4166667E-1/mu
+      b2 = .3*b1*b1
+      c3 = .1428571*b1*b2
+      c2 = b2 - 15.*c3
+      c1 = b1 - 6.*b2 + 45.*c3
+      c0 = 1. - b1 + 3.*b2 - 15.*c3
+      c = .1069/mu
+   30 IF (g.LT.0.0) GO TO 50
+C
+C             'SUBROUTINE' F IS CALLED (KFLAG=0 FOR CORRECT RETURN)
+C
+      kflag = 0
+      GO TO 70
+C
+C     STEP Q. QUOTIENT ACCEPTANCE (RARE CASE)
+C
+   40 IF (fy-u*fy.LE.py*exp(px-fx)) RETURN
+C
+C     STEP E. EXPONENTIAL SAMPLE - SEXPO(IR) FOR STANDARD EXPONENTIAL
+C             DEVIATE E AND SAMPLE T FROM THE LAPLACE 'HAT'
+C             (IF T <= -.6744 THEN PK < FK FOR ALL MU >= 10.)
+C
+   50 e = sexpo()
+      u = ranf()
+      u = u + u - 1.0
+      t = 1.8 + sign(e,u)
+      IF (t.LE. (-.6744)) GO TO 50
+      ignpoi = ifix(mu+s*t)
+      fk = float(ignpoi)
+      difmuk = mu - fk
+C
+C             'SUBROUTINE' F IS CALLED (KFLAG=1 FOR CORRECT RETURN)
+C
+      kflag = 1
+      GO TO 70
+C
+C     STEP H. HAT ACCEPTANCE (E IS REPEATED ON REJECTION)
+C
+   60 IF (c*abs(u).GT.py*exp(px+e)-fy*exp(fx+e)) GO TO 50
+      RETURN
+C
+C     STEP F. 'SUBROUTINE' F. CALCULATION OF PX,PY,FX,FY.
+C             CASE IGNPOI .LT. 10 USES FACTORIALS FROM TABLE FACT
+C
+   70 IF (ignpoi.GE.10) GO TO 80
+      px = -mu
+      py = mu**ignpoi/fact(ignpoi+1)
+      GO TO 110
+C
+C             CASE IGNPOI .GE. 10 USES POLYNOMIAL APPROXIMATION
+C             A0-A7 FOR ACCURACY WHEN ADVISABLE
+C             .8333333E-1=1./12.  .3989423=(2*PI)**(-.5)
+C
+   80 del = .8333333E-1/fk
+      del = del - 4.8*del*del*del
+      v = difmuk/fk
+      IF (abs(v).LE.0.25) GO TO 90
+      px = fk*alog(1.0+v) - difmuk - del
+      GO TO 100
+
+   90 px = fk*v*v* (((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v+a0) -
+     +     del
+  100 py = .3989423/sqrt(fk)
+  110 x = (0.5-difmuk)/s
+      xx = x*x
+      fx = -0.5*xx
+      fy = omega* (((c3*xx+c2)*xx+c1)*xx+c0)
+      IF (kflag) 40,40,60
+C
+C     C A S E  B. (START NEW TABLE AND CALCULATE P0 IF NECESSARY)
+C
+  120 muprev = 0.0
+      IF (mu.EQ.muold) GO TO 130
+      muold = mu
+      m = max0(1,ifix(mu))
+      l = 0
+      p = exp(-mu)
+      q = p
+      p0 = p
+C
+C     STEP U. UNIFORM SAMPLE FOR INVERSION METHOD
+C
+  130 u = ranf()
+      ignpoi = 0
+      IF (u.LE.p0) RETURN
+C
+C     STEP T. TABLE COMPARISON UNTIL THE END PP(L) OF THE
+C             PP-TABLE OF CUMULATIVE POISSON PROBABILITIES
+C             (0.458=PP(9) FOR MU=10)
+C
+      IF (l.EQ.0) GO TO 150
+      j = 1
+      IF (u.GT.0.458) j = min0(l,m)
+      DO 140 k = j,l
+          IF (u.LE.pp(k)) GO TO 180
+  140 CONTINUE
+      IF (l.EQ.35) GO TO 130
+C
+C     STEP C. CREATION OF NEW POISSON PROBABILITIES P
+C             AND THEIR CUMULATIVES Q=PP(K)
+C
+  150 l = l + 1
+      DO 160 k = l,35
+          p = p*mu/float(k)
+          q = q + p
+          pp(k) = q
+          IF (u.LE.q) GO TO 170
+  160 CONTINUE
+      l = 35
+      GO TO 130
+
+  170 l = k
+  180 ignpoi = k
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/initgn.f
@@ -0,0 +1,93 @@
+      SUBROUTINE initgn(isdtyp)
+C**********************************************************************
+C
+C     SUBROUTINE INITGN(ISDTYP)
+C          INIT-ialize current G-e-N-erator
+C
+C     Reinitializes the state of the current generator
+C
+C     This is a transcription from Pascal to Fortran of routine
+C     Init_Generator from the paper
+C
+C     L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package
+C     with Splitting Facilities." ACM Transactions on Mathematical
+C     Software, 17:98-111 (1991)
+C
+C
+C                              Arguments
+C
+C
+C     ISDTYP -> The state to which the generator is to be set
+C
+C          ISDTYP = -1  => sets the seeds to their initial value
+C          ISDTYP =  0  => sets the seeds to the first value of
+C                          the current block
+C          ISDTYP =  1  => sets the seeds to the first value of
+C                          the next block
+C
+C                                   INTEGER ISDTYP
+C
+C**********************************************************************
+C     .. Parameters ..
+      INTEGER numg
+      PARAMETER (numg=32)
+C     ..
+C     .. Scalar Arguments ..
+      INTEGER isdtyp
+C     ..
+C     .. Scalars in Common ..
+      INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2
+C     ..
+C     .. Arrays in Common ..
+      INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg),
+     +        lg2(numg)
+      LOGICAL qanti(numg)
+C     ..
+C     .. Local Scalars ..
+      INTEGER g
+C     ..
+C     .. External Functions ..
+      LOGICAL qrgnin
+      INTEGER mltmod
+      EXTERNAL qrgnin,mltmod
+C     ..
+C     .. External Subroutines ..
+      EXTERNAL getcgn
+C     ..
+C     .. Common blocks ..
+      COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1,
+     +       cg2,qanti
+C     ..
+C     .. Save statement ..
+      SAVE /globe/
+C     ..
+C     .. Executable Statements ..
+C     Abort unless random number generator initialized
+      IF (qrgnin()) GO TO 10
+      WRITE (*,*) ' INITGN called before random number generator ',
+     +  ' initialized -- abort!'
+      CALL XSTOPX
+     + (' INITGN called before random number generator initialized')
+
+   10 CALL getcgn(g)
+      IF ((-1).NE. (isdtyp)) GO TO 20
+      lg1(g) = ig1(g)
+      lg2(g) = ig2(g)
+      GO TO 50
+
+   20 IF ((0).NE. (isdtyp)) GO TO 30
+      CONTINUE
+      GO TO 50
+C     do nothing
+   30 IF ((1).NE. (isdtyp)) GO TO 40
+      lg1(g) = mltmod(a1w,lg1(g),m1)
+      lg2(g) = mltmod(a2w,lg2(g),m2)
+      GO TO 50
+
+   40 STOP 'ISDTYP NOT IN RANGE'
+
+   50 cg1(g) = lg1(g)
+      cg2(g) = lg2(g)
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/inrgcm.f
@@ -0,0 +1,70 @@
+      SUBROUTINE inrgcm()
+C**********************************************************************
+C
+C     SUBROUTINE INRGCM()
+C          INitialize Random number Generator CoMmon
+C
+C
+C                              Function
+C
+C
+C     Initializes common area  for random number  generator.  This saves
+C     the  nuisance  of  a  BLOCK DATA  routine  and the  difficulty  of
+C     assuring that the routine is loaded with the other routines.
+C
+C**********************************************************************
+C     .. Parameters ..
+      INTEGER numg
+      PARAMETER (numg=32)
+C     ..
+C     .. Scalars in Common ..
+      INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2
+C     ..
+C     .. Arrays in Common ..
+      INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg),
+     +        lg2(numg)
+      LOGICAL qanti(numg)
+C     ..
+C     .. Local Scalars ..
+      INTEGER i
+      LOGICAL qdum
+C     ..
+C     .. External Functions ..
+      LOGICAL qrgnsn
+      EXTERNAL qrgnsn
+C     ..
+C     .. Common blocks ..
+      COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1,
+     +       cg2,qanti
+C     ..
+C     .. Save statement ..
+      SAVE /globe/
+C     ..
+C     .. Executable Statements ..
+C     V=20;                            W=30;
+C
+C     A1W = MOD(A1**(2**W),M1)         A2W = MOD(A2**(2**W),M2)
+C     A1VW = MOD(A1**(2**(V+W)),M1)    A2VW = MOD(A2**(2**(V+W)),M2)
+C
+C   If V or W is changed A1W, A2W, A1VW, and A2VW need to be recomputed.
+C    An efficient way to precompute a**(2*j) MOD m is to start with
+C    a and square it j times modulo m using the function MLTMOD.
+C
+      m1 = 2147483563
+      m2 = 2147483399
+      a1 = 40014
+      a2 = 40692
+      a1w = 1033780774
+      a2w = 1494757890
+      a1vw = 2082007225
+      a2vw = 784306273
+      DO 10,i = 1,numg
+          qanti(i) = .FALSE.
+   10 CONTINUE
+C
+C     Tell the world that common has been initialized
+C
+      qdum = qrgnsn(.TRUE.)
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/lennob.f
@@ -0,0 +1,36 @@
+      INTEGER FUNCTION lennob(string)
+      IMPLICIT INTEGER (a-p,r-z),LOGICAL (q)
+C**********************************************************************
+C
+C     INTEGER FUNCTION LENNOB( STRING )
+C                LENgth NOt counting trailing Blanks
+C
+C
+C                              Function
+C
+C
+C     Returns the length of STRING up to and including the last
+C     non-blank character.
+C
+C
+C                              Arguments
+C
+C
+C     STRING --> String whose length not counting trailing blanks
+C                is returned.
+C
+C**********************************************************************
+      CHARACTER*(*) string
+
+      end = len(string)
+      DO 20,i = end,1,-1
+          IF (.NOT. (string(i:i).NE.' ')) GO TO 10
+          lennob = i
+          RETURN
+
+   10     CONTINUE
+   20 CONTINUE
+      lennob = 0
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/mltmod.f
@@ -0,0 +1,106 @@
+      INTEGER FUNCTION mltmod(a,s,m)
+C**********************************************************************
+C
+C     INTEGER FUNCTION MLTMOD(A,S,M)
+C
+C                    Returns (A*S) MOD M
+C
+C     This is a transcription from Pascal to Fortran of routine
+C     MULtMod_Decompos from the paper
+C
+C     L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package
+C     with Splitting Facilities." ACM Transactions on Mathematical
+C     Software, 17:98-111 (1991)
+C
+C
+C                              Arguments
+C
+C
+C     A, S, M  -->
+C                         INTEGER A,S,M
+C
+C**********************************************************************
+C     .. Parameters ..
+      INTEGER h
+      PARAMETER (h=32768)
+C     ..
+C     .. Scalar Arguments ..
+      INTEGER a,m,s
+C     ..
+C     .. Local Scalars ..
+      INTEGER a0,a1,k,p,q,qh,rh
+C     ..
+C     .. Executable Statements ..
+C
+C     H = 2**((b-2)/2) where b = 32 because we are using a 32 bit
+C      machine. On a different machine recompute H
+C
+      IF (.NOT. (a.LE.0.OR.a.GE.m.OR.s.LE.0.OR.s.GE.m)) GO TO 10
+      WRITE (*,*) ' A, M, S out of order in MLTMOD - ABORT!'
+      WRITE (*,*) ' A = ',a,' S = ',s,' M = ',m
+      WRITE (*,*) ' MLTMOD requires: 0 < A < M; 0 < S < M'
+      CALL XSTOPX (' A, M, S out of order in MLTMOD - ABORT!')
+
+   10 IF (.NOT. (a.LT.h)) GO TO 20
+      a0 = a
+      p = 0
+      GO TO 120
+
+   20 a1 = a/h
+      a0 = a - h*a1
+      qh = m/h
+      rh = m - h*qh
+      IF (.NOT. (a1.GE.h)) GO TO 50
+      a1 = a1 - h
+      k = s/qh
+      p = h* (s-k*qh) - k*rh
+   30 IF (.NOT. (p.LT.0)) GO TO 40
+      p = p + m
+      GO TO 30
+
+   40 GO TO 60
+
+   50 p = 0
+C
+C     P = (A2*S*H)MOD M
+C
+   60 IF (.NOT. (a1.NE.0)) GO TO 90
+      q = m/a1
+      k = s/q
+      p = p - k* (m-a1*q)
+      IF (p.GT.0) p = p - m
+      p = p + a1* (s-k*q)
+   70 IF (.NOT. (p.LT.0)) GO TO 80
+      p = p + m
+      GO TO 70
+
+   80 CONTINUE
+   90 k = p/qh
+C
+C     P = ((A2*H + A1)*S)MOD M
+C
+      p = h* (p-k*qh) - k*rh
+  100 IF (.NOT. (p.LT.0)) GO TO 110
+      p = p + m
+      GO TO 100
+
+  110 CONTINUE
+  120 IF (.NOT. (a0.NE.0)) GO TO 150
+C
+C     P = ((A2*H + A1)*H*S)MOD M
+C
+      q = m/a0
+      k = s/q
+      p = p - k* (m-a0*q)
+      IF (p.GT.0) p = p - m
+      p = p + a0* (s-k*q)
+  130 IF (.NOT. (p.LT.0)) GO TO 140
+      p = p + m
+      GO TO 130
+
+  140 CONTINUE
+  150 mltmod = p
+C
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/phrtsd.f
@@ -0,0 +1,84 @@
+      SUBROUTINE phrtsd(phrase,seed1,seed2)
+C**********************************************************************
+C
+C     SUBROUTINE PHRTSD( PHRASE, SEED1, SEED2 )
+C               PHRase To SeeDs
+C
+C
+C                              Function
+C
+C
+C     Uses a phrase (character string) to generate two seeds for the RGN
+C     random number generator.
+C
+C
+C                              Arguments
+C
+C
+C     PHRASE --> Phrase to be used for random number generation
+C                         CHARACTER*(*) PHRASE
+C
+C     SEED1 <-- First seed for RGN generator
+C                         INTEGER SEED1
+C
+C     SEED2 <-- Second seed for RGN generator
+C                         INTEGER SEED2
+C
+C
+C                              Note
+C
+C
+C     Trailing blanks are eliminated before the seeds are generated.
+C
+C     Generated seed values will fall in the range 1..2^30
+C     (1..1,073,741,824)
+C
+C**********************************************************************
+C     .. Parameters ..
+      CHARACTER*(*) table
+      PARAMETER (table='abcdefghijklmnopqrstuvwxyz'//
+     +          'ABCDEFGHIJKLMNOPQRSTUVWXYZ'//'0123456789'//
+     +          '!@#$%^&*()_+[];:''"<>?,./')
+      INTEGER twop30
+      PARAMETER (twop30=1073741824)
+C     ..
+C     .. Scalar Arguments ..
+      INTEGER seed1,seed2
+      CHARACTER phrase* (*)
+C     ..
+C     .. Local Scalars ..
+      INTEGER i,ichr,j,lphr
+C     ..
+C     .. Local Arrays ..
+      INTEGER shift(0:4),values(5)
+C     ..
+C     .. External Functions ..
+      INTEGER lennob
+      EXTERNAL lennob
+C     ..
+C     .. Intrinsic Functions ..
+      INTRINSIC index,mod
+C     ..
+C     .. Data statements ..
+      DATA shift/1,64,4096,262144,16777216/
+C     ..
+C     .. Executable Statements ..
+      seed1 = 1234567890
+      seed2 = 123456789
+      lphr = lennob(phrase)
+      IF (lphr.LT.1) RETURN
+      DO 30,i = 1,lphr
+          ichr = mod(index(table,phrase(i:i)),64)
+          IF (ichr.EQ.0) ichr = 63
+          DO 10,j = 1,5
+              values(j) = ichr - j
+              IF (values(j).LT.1) values(j) = values(j) + 63
+   10     CONTINUE
+          DO 20,j = 1,5
+              seed1 = mod(seed1+shift(j-1)*values(j),twop30)
+              seed2 = mod(seed2+shift(j-1)*values(6-j),twop30)
+   20     CONTINUE
+   30 CONTINUE
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/qrgnin.f
@@ -0,0 +1,48 @@
+      LOGICAL FUNCTION qrgnin()
+C**********************************************************************
+C
+C     LOGICAL FUNCTION QRGNIN()
+C               Q Random GeNerators INitialized?
+C
+C     A trivial routine to determine whether or not the random
+C     number generator has been initialized.  Returns .TRUE. if
+C     it has, else .FALSE.
+C
+C**********************************************************************
+C     .. Scalar Arguments ..
+      LOGICAL qvalue
+C     ..
+C     .. Local Scalars ..
+      LOGICAL qinit
+C     ..
+C     .. Entry Points ..
+      LOGICAL qrgnsn
+C     ..
+C     .. Save statement ..
+      SAVE qinit
+C     ..
+C     .. Data statements ..
+      DATA qinit/.FALSE./
+C     ..
+C     .. Executable Statements ..
+      qrgnin = qinit
+      RETURN
+
+      ENTRY qrgnsn(qvalue)
+C**********************************************************************
+C
+C     LOGICAL FUNCTION QRGNSN( QVALUE )
+C               Q Random GeNerators Set whether iNitialized
+C
+C     Sets state of whether random number generator is initialized
+C     to QVALUE.
+C
+C     This routine is actually an entry in QRGNIN, hence it is a
+C     logical function.  It returns the (meaningless) value .TRUE.
+C
+C**********************************************************************
+      qinit = qvalue
+      qrgnsn = .TRUE.
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/ranf.f
@@ -0,0 +1,31 @@
+      REAL FUNCTION ranf()
+C**********************************************************************
+C
+C     REAL FUNCTION RANF()
+C                RANDom number generator as a Function
+C
+C     Returns a random floating point number from a uniform distribution
+C     over 0 - 1 (endpoints of this interval are not returned) using the
+C     current generator
+C
+C     This is a transcription from Pascal to Fortran of routine
+C     Uniform_01 from the paper
+C
+C     L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package
+C     with Splitting Facilities." ACM Transactions on Mathematical
+C     Software, 17:98-111 (1991)
+C
+C**********************************************************************
+C     .. External Functions ..
+      INTEGER ignlgi
+      EXTERNAL ignlgi
+C     ..
+C     .. Executable Statements ..
+C
+C     4.656613057E-10 is 1/M1  M1 is set in a data statement in IGNLGI
+C      and is currently 2147483563. If M1 changes, change this also.
+C
+      ranf = ignlgi()*4.656613057E-10
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/setall.f
@@ -0,0 +1,103 @@
+      SUBROUTINE setall(iseed1,iseed2)
+C**********************************************************************
+C
+C      SUBROUTINE SETALL(ISEED1,ISEED2)
+C               SET ALL random number generators
+C
+C     Sets the initial seed of generator 1 to ISEED1 and ISEED2. The
+C     initial seeds of the other generators are set accordingly, and
+C     all generators states are set to these seeds.
+C
+C     This is a transcription from Pascal to Fortran of routine
+C     Set_Initial_Seed from the paper
+C
+C     L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package
+C     with Splitting Facilities." ACM Transactions on Mathematical
+C     Software, 17:98-111 (1991)
+C
+C
+C                              Arguments
+C
+C
+C     ISEED1 -> First of two integer seeds
+C                                   INTEGER ISEED1
+C
+C     ISEED2 -> Second of two integer seeds
+C                                   INTEGER ISEED1
+C
+C**********************************************************************
+C     .. Parameters ..
+      INTEGER numg
+      PARAMETER (numg=32)
+C     ..
+C     .. Scalar Arguments ..
+      INTEGER iseed1,iseed2
+      LOGICAL qssd
+C     ..
+C     .. Scalars in Common ..
+      INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2
+C     ..
+C     .. Arrays in Common ..
+      INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg),
+     +        lg2(numg)
+      LOGICAL qanti(numg)
+C     ..
+C     .. Local Scalars ..
+      INTEGER g,ocgn
+      LOGICAL qqssd
+C     ..
+C     .. External Functions ..
+      INTEGER mltmod
+      LOGICAL qrgnin
+      EXTERNAL mltmod,qrgnin
+C     ..
+C     .. External Subroutines ..
+      EXTERNAL getcgn,initgn,inrgcm,setcgn
+C     ..
+C     .. Common blocks ..
+      COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1,
+     +       cg2,qanti
+C     ..
+C     .. Save statement ..
+      SAVE /globe/,qqssd
+C     ..
+C     .. Data statements ..
+      DATA qqssd/.FALSE./
+C     ..
+C     .. Executable Statements ..
+C
+C     TELL IGNLGI, THE ACTUAL NUMBER GENERATOR, THAT THIS ROUTINE
+C      HAS BEEN CALLED.
+C
+      qqssd = .TRUE.
+      CALL getcgn(ocgn)
+C
+C     Initialize Common Block if Necessary
+C
+      IF (.NOT. (qrgnin())) CALL inrgcm()
+      ig1(1) = iseed1
+      ig2(1) = iseed2
+      CALL initgn(-1)
+      DO 10,g = 2,numg
+          ig1(g) = mltmod(a1vw,ig1(g-1),m1)
+          ig2(g) = mltmod(a2vw,ig2(g-1),m2)
+          CALL setcgn(g)
+          CALL initgn(-1)
+   10 CONTINUE
+      CALL setcgn(ocgn)
+      RETURN
+
+      ENTRY rgnqsd(qssd)
+C**********************************************************************
+C
+C     SUBROUTINE RGNQSD
+C                    Random Number Generator Query SeeD set?
+C
+C     Returns (LOGICAL) QSSD as .TRUE. if SETALL has been invoked,
+C     otherwise returns .FALSE.
+C
+C**********************************************************************
+      qssd = qqssd
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/setant.f
@@ -0,0 +1,75 @@
+      SUBROUTINE setant(qvalue)
+C**********************************************************************
+C
+C      SUBROUTINE SETANT(QVALUE)
+C               SET ANTithetic
+C
+C     Sets whether the current generator produces antithetic values.  If
+C     X   is  the value  normally returned  from  a uniform [0,1] random
+C     number generator then 1  - X is the antithetic  value. If X is the
+C     value  normally  returned  from a   uniform  [0,N]  random  number
+C     generator then N - 1 - X is the antithetic value.
+C
+C     All generators are initialized to NOT generate antithetic values.
+C
+C     This is a transcription from Pascal to Fortran of routine
+C     Set_Antithetic from the paper
+C
+C     L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package
+C     with Splitting Facilities." ACM Transactions on Mathematical
+C     Software, 17:98-111 (1991)
+C
+C
+C                              Arguments
+C
+C
+C     QVALUE -> .TRUE. if generator G is to generating antithetic
+C                    values, otherwise .FALSE.
+C                                   LOGICAL QVALUE
+C
+C**********************************************************************
+C     .. Parameters ..
+      INTEGER numg
+      PARAMETER (numg=32)
+C     ..
+C     .. Scalar Arguments ..
+      LOGICAL qvalue
+C     ..
+C     .. Scalars in Common ..
+      INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2
+C     ..
+C     .. Arrays in Common ..
+      INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg),
+     +        lg2(numg)
+      LOGICAL qanti(numg)
+C     ..
+C     .. Local Scalars ..
+      INTEGER g
+C     ..
+C     .. External Functions ..
+      LOGICAL qrgnin
+      EXTERNAL qrgnin
+C     ..
+C     .. External Subroutines ..
+      EXTERNAL getcgn
+C     ..
+C     .. Common blocks ..
+      COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1,
+     +       cg2,qanti
+C     ..
+C     .. Save statement ..
+      SAVE /globe/
+C     ..
+C     .. Executable Statements ..
+C     Abort unless random number generator initialized
+      IF (qrgnin()) GO TO 10
+      WRITE (*,*) ' SETANT called before random number generator ',
+     +  ' initialized -- abort!'
+      CALL XSTOPX
+     + (' SETANT called before random number generator initialized')
+
+   10 CALL getcgn(g)
+      qanti(g) = qvalue
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/setgmn.f
@@ -0,0 +1,92 @@
+      SUBROUTINE setgmn(meanv,covm,p,parm)
+C**********************************************************************
+C
+C     SUBROUTINE SETGMN( MEANV, COVM, P, PARM)
+C            SET Generate Multivariate Normal random deviate
+C
+C
+C                              Function
+C
+C
+C      Places P, MEANV, and the Cholesky factoriztion of COVM
+C      in GENMN.
+C
+C
+C                              Arguments
+C
+C
+C     MEANV --> Mean vector of multivariate normal distribution.
+C                                        REAL MEANV(P)
+C
+C     COVM   <--> (Input) Covariance   matrix    of  the  multivariate
+C                 normal distribution
+C                 (Output) Destroyed on output
+C                                        REAL COVM(P,P)
+C
+C     P     --> Dimension of the normal, or length of MEANV.
+C                                        INTEGER P
+C
+C     PARM <-- Array of parameters needed to generate multivariate norma
+C                deviates (P, MEANV and Cholesky decomposition of
+C                COVM).
+C                1 : 1                - P
+C                2 : P + 1            - MEANV
+C                P+2 : P*(P+3)/2 + 1  - Cholesky decomposition of COVM
+C                                             REAL PARM(P*(P+3)/2 + 1)
+C
+C**********************************************************************
+C     .. Scalar Arguments ..
+      INTEGER p
+C     ..
+C     .. Array Arguments ..
+      REAL covm(p,p),meanv(p),parm(p* (p+3)/2+1)
+C     ..
+C     .. Local Scalars ..
+      INTEGER i,icount,info,j
+C     ..
+C     .. External Subroutines ..
+      EXTERNAL spofa
+C     ..
+C     .. Executable Statements ..
+C
+C
+C     TEST THE INPUT
+C
+      IF (.NOT. (p.LE.0)) GO TO 10
+      WRITE (*,*) 'P nonpositive in SETGMN'
+      WRITE (*,*) 'Value of P: ',p
+      CALL XSTOPX ('P nonpositive in SETGMN')
+
+   10 parm(1) = p
+C
+C     PUT P AND MEANV INTO PARM
+C
+      DO 20,i = 2,p + 1
+          parm(i) = meanv(i-1)
+   20 CONTINUE
+C
+C      Cholesky decomposition to find A s.t. trans(A)*(A) = COVM
+C
+      CALL spofa(covm,p,p,info)
+      IF (.NOT. (info.NE.0)) GO TO 30
+      WRITE (*,*) ' COVM not positive definite in SETGMN'
+      CALL XSTOPX (' COVM not positive definite in SETGMN')
+
+   30 icount = p + 1
+C
+C     PUT UPPER HALF OF A, WHICH IS NOW THE CHOLESKY FACTOR, INTO PARM
+C          COVM(1,1) = PARM(P+2)
+C          COVM(1,2) = PARM(P+3)
+C                    :
+C          COVM(1,P) = PARM(2P+1)
+C          COVM(2,2) = PARM(2P+2)  ...
+C
+      DO 50,i = 1,p
+          DO 40,j = i,p
+              icount = icount + 1
+              parm(icount) = covm(i,j)
+   40     CONTINUE
+   50 CONTINUE
+      RETURN
+C
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/setsd.f
@@ -0,0 +1,74 @@
+      SUBROUTINE setsd(iseed1,iseed2)
+C**********************************************************************
+C
+C     SUBROUTINE SETSD(ISEED1,ISEED2)
+C               SET S-ee-D of current generator
+C
+C     Resets the initial  seed of  the current  generator to  ISEED1 and
+C     ISEED2. The seeds of the other generators remain unchanged.
+C
+C     This is a transcription from Pascal to Fortran of routine
+C     Set_Seed from the paper
+C
+C     L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package
+C     with Splitting Facilities." ACM Transactions on Mathematical
+C     Software, 17:98-111 (1991)
+C
+C
+C                              Arguments
+C
+C
+C     ISEED1 -> First integer seed
+C                                   INTEGER ISEED1
+C
+C     ISEED2 -> Second integer seed
+C                                   INTEGER ISEED1
+C
+C**********************************************************************
+C     .. Parameters ..
+      INTEGER numg
+      PARAMETER (numg=32)
+C     ..
+C     .. Scalar Arguments ..
+      INTEGER iseed1,iseed2
+C     ..
+C     .. Scalars in Common ..
+      INTEGER a1,a1vw,a1w,a2,a2vw,a2w,m1,m2
+C     ..
+C     .. Arrays in Common ..
+      INTEGER cg1(numg),cg2(numg),ig1(numg),ig2(numg),lg1(numg),
+     +        lg2(numg)
+      LOGICAL qanti(numg)
+C     ..
+C     .. Local Scalars ..
+      INTEGER g
+C     ..
+C     .. External Functions ..
+      LOGICAL qrgnin
+      EXTERNAL qrgnin
+C     ..
+C     .. External Subroutines ..
+      EXTERNAL getcgn,initgn
+C     ..
+C     .. Common blocks ..
+      COMMON /globe/m1,m2,a1,a2,a1w,a2w,a1vw,a2vw,ig1,ig2,lg1,lg2,cg1,
+     +       cg2,qanti
+C     ..
+C     .. Save statement ..
+      SAVE /globe/
+C     ..
+C     .. Executable Statements ..
+C     Abort unless random number generator initialized
+      IF (qrgnin()) GO TO 10
+      WRITE (*,*) ' SETSD called before random number generator ',
+     +  ' initialized -- abort!'
+      CALL XSTOPX
+     + (' SETSD called before random number generator initialized')
+
+   10 CALL getcgn(g)
+      ig1(g) = iseed1
+      ig2(g) = iseed2
+      CALL initgn(-1)
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/sexpo.f
@@ -0,0 +1,57 @@
+      REAL FUNCTION sexpo()
+C**********************************************************************C
+C                                                                      C
+C                                                                      C
+C     (STANDARD-)  E X P O N E N T I A L   DISTRIBUTION                C
+C                                                                      C
+C                                                                      C
+C**********************************************************************C
+C**********************************************************************C
+C                                                                      C
+C     FOR DETAILS SEE:                                                 C
+C                                                                      C
+C               AHRENS, J.H. AND DIETER, U.                            C
+C               COMPUTER METHODS FOR SAMPLING FROM THE                 C
+C               EXPONENTIAL AND NORMAL DISTRIBUTIONS.                  C
+C               COMM. ACM, 15,10 (OCT. 1972), 873 - 882.               C
+C                                                                      C
+C     ALL STATEMENT NUMBERS CORRESPOND TO THE STEPS OF ALGORITHM       C
+C     'SA' IN THE ABOVE PAPER (SLIGHTLY MODIFIED IMPLEMENTATION)       C
+C                                                                      C
+C     Modified by Barry W. Brown, Feb 3, 1988 to use RANF instead of   C
+C     SUNIF.  The argument IR thus goes away.                          C
+C                                                                      C
+C**********************************************************************C
+C
+      DIMENSION q(8)
+      EQUIVALENCE (q(1),q1)
+C
+C     Q(N) = SUM(ALOG(2.0)**K/K!)    K=1,..,N ,      THE HIGHEST N
+C     (HERE 8) IS DETERMINED BY Q(N)=1.0 WITHIN STANDARD PRECISION
+C
+      DATA q/.6931472,.9333737,.9888778,.9984959,.9998293,.9999833,
+     +     .9999986,.9999999/
+C
+   10 a = 0.0
+      u = ranf()
+      GO TO 30
+
+   20 a = a + q1
+   30 u = u + u
+      IF (u.LE.1.0) GO TO 20
+   40 u = u - 1.0
+      IF (u.GT.q1) GO TO 60
+   50 sexpo = a + u
+      RETURN
+
+   60 i = 1
+      ustar = ranf()
+      umin = ustar
+   70 ustar = ranf()
+      IF (ustar.LT.umin) umin = ustar
+   80 i = i + 1
+      IF (u.GT.q(i)) GO TO 70
+   90 sexpo = a + umin*q1
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/sgamma.f
@@ -0,0 +1,191 @@
+      REAL FUNCTION sgamma(a)
+C**********************************************************************C
+C                                                                      C
+C                                                                      C
+C     (STANDARD-)  G A M M A  DISTRIBUTION                             C
+C                                                                      C
+C                                                                      C
+C**********************************************************************C
+C**********************************************************************C
+C                                                                      C
+C               PARAMETER  A >= 1.0  !                                 C
+C                                                                      C
+C**********************************************************************C
+C                                                                      C
+C     FOR DETAILS SEE:                                                 C
+C                                                                      C
+C               AHRENS, J.H. AND DIETER, U.                            C
+C               GENERATING GAMMA VARIATES BY A                         C
+C               MODIFIED REJECTION TECHNIQUE.                          C
+C               COMM. ACM, 25,1 (JAN. 1982), 47 - 54.                  C
+C                                                                      C
+C     STEP NUMBERS CORRESPOND TO ALGORITHM 'GD' IN THE ABOVE PAPER     C
+C                                 (STRAIGHTFORWARD IMPLEMENTATION)     C
+C                                                                      C
+C     Modified by Barry W. Brown, Feb 3, 1988 to use RANF instead of   C
+C     SUNIF.  The argument IR thus goes away.                          C
+C                                                                      C
+C**********************************************************************C
+C                                                                      C
+C               PARAMETER  0.0 < A < 1.0  !                            C
+C                                                                      C
+C**********************************************************************C
+C                                                                      C
+C     FOR DETAILS SEE:                                                 C
+C                                                                      C
+C               AHRENS, J.H. AND DIETER, U.                            C
+C               COMPUTER METHODS FOR SAMPLING FROM GAMMA,              C
+C               BETA, POISSON AND BINOMIAL DISTRIBUTIONS.              C
+C               COMPUTING, 12 (1974), 223 - 246.                       C
+C                                                                      C
+C     (ADAPTED IMPLEMENTATION OF ALGORITHM 'GS' IN THE ABOVE PAPER)    C
+C                                                                      C
+C**********************************************************************C
+C
+C
+C     INPUT: A =PARAMETER (MEAN) OF THE STANDARD GAMMA DISTRIBUTION
+C     OUTPUT: SGAMMA = SAMPLE FROM THE GAMMA-(A)-DISTRIBUTION
+C
+C     COEFFICIENTS Q(K) - FOR Q0 = SUM(Q(K)*A**(-K))
+C     COEFFICIENTS A(K) - FOR Q = Q0+(T*T/2)*SUM(A(K)*V**K)
+C     COEFFICIENTS E(K) - FOR EXP(Q)-1 = SUM(E(K)*Q**K)
+C
+      DATA q1,q2,q3,q4,q5,q6,q7/.04166669,.02083148,.00801191,.00144121,
+     +     -.00007388,.00024511,.00024240/
+      DATA a1,a2,a3,a4,a5,a6,a7/.3333333,-.2500030,.2000062,-.1662921,
+     +     .1423657,-.1367177,.1233795/
+      DATA e1,e2,e3,e4,e5/1.,.4999897,.1668290,.0407753,.0102930/
+C
+C     PREVIOUS A PRE-SET TO ZERO - AA IS A', AAA IS A"
+C     SQRT32 IS THE SQUAREROOT OF 32 = 5.656854249492380
+C
+      DATA aa/0.0/,aaa/0.0/,sqrt32/5.656854/
+C
+      IF (a.EQ.aa) GO TO 10
+      IF (a.LT.1.0) GO TO 120
+C
+C     STEP  1:  RECALCULATIONS OF S2,S,D IF A HAS CHANGED
+C
+      aa = a
+      s2 = a - 0.5
+      s = sqrt(s2)
+      d = sqrt32 - 12.0*s
+C
+C     STEP  2:  T=STANDARD NORMAL DEVIATE,
+C               X=(S,1/2)-NORMAL DEVIATE.
+C               IMMEDIATE ACCEPTANCE (I)
+C
+   10 t = snorm()
+      x = s + 0.5*t
+      sgamma = x*x
+      IF (t.GE.0.0) RETURN
+C
+C     STEP  3:  U= 0,1 -UNIFORM SAMPLE. SQUEEZE ACCEPTANCE (S)
+C
+      u = ranf()
+      IF (d*u.LE.t*t*t) RETURN
+C
+C     STEP  4:  RECALCULATIONS OF Q0,B,SI,C IF NECESSARY
+C
+      IF (a.EQ.aaa) GO TO 40
+      aaa = a
+      r = 1.0/a
+      q0 = ((((((q7*r+q6)*r+q5)*r+q4)*r+q3)*r+q2)*r+q1)*r
+C
+C               APPROXIMATION DEPENDING ON SIZE OF PARAMETER A
+C               THE CONSTANTS IN THE EXPRESSIONS FOR B, SI AND
+C               C WERE ESTABLISHED BY NUMERICAL EXPERIMENTS
+C
+      IF (a.LE.3.686) GO TO 30
+      IF (a.LE.13.022) GO TO 20
+C
+C               CASE 3:  A .GT. 13.022
+C
+      b = 1.77
+      si = .75
+      c = .1515/s
+      GO TO 40
+C
+C               CASE 2:  3.686 .LT. A .LE. 13.022
+C
+   20 b = 1.654 + .0076*s2
+      si = 1.68/s + .275
+      c = .062/s + .024
+      GO TO 40
+C
+C               CASE 1:  A .LE. 3.686
+C
+   30 b = .463 + s - .178*s2
+      si = 1.235
+      c = .195/s - .079 + .016*s
+C
+C     STEP  5:  NO QUOTIENT TEST IF X NOT POSITIVE
+C
+   40 IF (x.LE.0.0) GO TO 70
+C
+C     STEP  6:  CALCULATION OF V AND QUOTIENT Q
+C
+      v = t/ (s+s)
+      IF (abs(v).LE.0.25) GO TO 50
+      q = q0 - s*t + 0.25*t*t + (s2+s2)*alog(1.0+v)
+      GO TO 60
+
+   50 q = q0 + 0.5*t*t* ((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v
+C
+C     STEP  7:  QUOTIENT ACCEPTANCE (Q)
+C
+   60 IF (alog(1.0-u).LE.q) RETURN
+C
+C     STEP  8:  E=STANDARD EXPONENTIAL DEVIATE
+C               U= 0,1 -UNIFORM DEVIATE
+C               T=(B,SI)-DOUBLE EXPONENTIAL (LAPLACE) SAMPLE
+C
+   70 e = sexpo()
+      u = ranf()
+      u = u + u - 1.0
+      t = b + sign(si*e,u)
+C
+C     STEP  9:  REJECTION IF T .LT. TAU(1) = -.71874483771719
+C
+      IF (t.LT. (-.7187449)) GO TO 70
+C
+C     STEP 10:  CALCULATION OF V AND QUOTIENT Q
+C
+      v = t/ (s+s)
+      IF (abs(v).LE.0.25) GO TO 80
+      q = q0 - s*t + 0.25*t*t + (s2+s2)*alog(1.0+v)
+      GO TO 90
+
+   80 q = q0 + 0.5*t*t* ((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v
+C
+C     STEP 11:  HAT ACCEPTANCE (H) (IF Q NOT POSITIVE GO TO STEP 8)
+C
+   90 IF (q.LE.0.0) GO TO 70
+      IF (q.LE.0.5) GO TO 100
+      w = exp(q) - 1.0
+      GO TO 110
+
+  100 w = ((((e5*q+e4)*q+e3)*q+e2)*q+e1)*q
+C
+C               IF T IS REJECTED, SAMPLE AGAIN AT STEP 8
+C
+  110 IF (c*abs(u).GT.w*exp(e-0.5*t*t)) GO TO 70
+      x = s + 0.5*t
+      sgamma = x*x
+      RETURN
+C
+C     ALTERNATE METHOD FOR PARAMETERS A BELOW 1  (.3678794=EXP(-1.))
+C
+  120 aa = 0.0
+      b = 1.0 + .3678794*a
+  130 p = b*ranf()
+      IF (p.GE.1.0) GO TO 140
+      sgamma = exp(alog(p)/a)
+      IF (sexpo().LT.sgamma) GO TO 130
+      RETURN
+
+  140 sgamma = -alog((b-p)/a)
+      IF (sexpo().LT. (1.0-a)*alog(sgamma)) GO TO 130
+      RETURN
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/snorm.f
@@ -0,0 +1,118 @@
+      REAL FUNCTION snorm()
+C**********************************************************************C
+C                                                                      C
+C                                                                      C
+C     (STANDARD-)  N O R M A L  DISTRIBUTION                           C
+C                                                                      C
+C                                                                      C
+C**********************************************************************C
+C**********************************************************************C
+C                                                                      C
+C     FOR DETAILS SEE:                                                 C
+C                                                                      C
+C               AHRENS, J.H. AND DIETER, U.                            C
+C               EXTENSIONS OF FORSYTHE'S METHOD FOR RANDOM             C
+C               SAMPLING FROM THE NORMAL DISTRIBUTION.                 C
+C               MATH. COMPUT., 27,124 (OCT. 1973), 927 - 937.          C
+C                                                                      C
+C     ALL STATEMENT NUMBERS CORRESPOND TO THE STEPS OF ALGORITHM 'FL'  C
+C     (M=5) IN THE ABOVE PAPER     (SLIGHTLY MODIFIED IMPLEMENTATION)  C
+C                                                                      C
+C     Modified by Barry W. Brown, Feb 3, 1988 to use RANF instead of   C
+C     SUNIF.  The argument IR thus goes away.                          C
+C                                                                      C
+C**********************************************************************C
+C
+      DIMENSION a(32),d(31),t(31),h(31)
+C
+C     THE DEFINITIONS OF THE CONSTANTS A(K), D(K), T(K) AND
+C     H(K) ARE ACCORDING TO THE ABOVEMENTIONED ARTICLE
+C
+      DATA a/0.0,.3917609E-1,.7841241E-1,.1177699,.1573107,.1970991,
+     +     .2372021,.2776904,.3186394,.3601299,.4022501,.4450965,
+     +     .4887764,.5334097,.5791322,.6260990,.6744898,.7245144,
+     +     .7764218,.8305109,.8871466,.9467818,1.009990,1.077516,
+     +     1.150349,1.229859,1.318011,1.417797,1.534121,1.675940,
+     +     1.862732,2.153875/
+      DATA d/5*0.0,.2636843,.2425085,.2255674,.2116342,.1999243,
+     +     .1899108,.1812252,.1736014,.1668419,.1607967,.1553497,
+     +     .1504094,.1459026,.1417700,.1379632,.1344418,.1311722,
+     +     .1281260,.1252791,.1226109,.1201036,.1177417,.1155119,
+     +     .1134023,.1114027,.1095039/
+      DATA t/.7673828E-3,.2306870E-2,.3860618E-2,.5438454E-2,
+     +     .7050699E-2,.8708396E-2,.1042357E-1,.1220953E-1,.1408125E-1,
+     +     .1605579E-1,.1815290E-1,.2039573E-1,.2281177E-1,.2543407E-1,
+     +     .2830296E-1,.3146822E-1,.3499233E-1,.3895483E-1,.4345878E-1,
+     +     .4864035E-1,.5468334E-1,.6184222E-1,.7047983E-1,.8113195E-1,
+     +     .9462444E-1,.1123001,.1364980,.1716886,.2276241,.3304980,
+     +     .5847031/
+      DATA h/.3920617E-1,.3932705E-1,.3950999E-1,.3975703E-1,
+     +     .4007093E-1,.4045533E-1,.4091481E-1,.4145507E-1,.4208311E-1,
+     +     .4280748E-1,.4363863E-1,.4458932E-1,.4567523E-1,.4691571E-1,
+     +     .4833487E-1,.4996298E-1,.5183859E-1,.5401138E-1,.5654656E-1,
+     +     .5953130E-1,.6308489E-1,.6737503E-1,.7264544E-1,.7926471E-1,
+     +     .8781922E-1,.9930398E-1,.1155599,.1404344,.1836142,.2790016,
+     +     .7010474/
+C
+   10 u = ranf()
+      s = 0.0
+      IF (u.GT.0.5) s = 1.0
+      u = u + u - s
+   20 u = 32.0*u
+      i = int(u)
+      IF (i.EQ.32) i = 31
+      IF (i.EQ.0) GO TO 100
+C
+C                                START CENTER
+C
+   30 ustar = u - float(i)
+      aa = a(i)
+   40 IF (ustar.LE.t(i)) GO TO 60
+      w = (ustar-t(i))*h(i)
+C
+C                                EXIT   (BOTH CASES)
+C
+   50 y = aa + w
+      snorm = y
+      IF (s.EQ.1.0) snorm = -y
+      RETURN
+C
+C                                CENTER CONTINUED
+C
+   60 u = ranf()
+      w = u* (a(i+1)-aa)
+      tt = (0.5*w+aa)*w
+      GO TO 80
+
+   70 tt = u
+      ustar = ranf()
+   80 IF (ustar.GT.tt) GO TO 50
+   90 u = ranf()
+      IF (ustar.GE.u) GO TO 70
+      ustar = ranf()
+      GO TO 40
+C
+C                                START TAIL
+C
+  100 i = 6
+      aa = a(32)
+      GO TO 120
+
+  110 aa = aa + d(i)
+      i = i + 1
+  120 u = u + u
+      IF (u.LT.1.0) GO TO 110
+  130 u = u - 1.0
+  140 w = u*d(i)
+      tt = (0.5*w+aa)*w
+      GO TO 160
+
+  150 tt = u
+  160 ustar = ranf()
+      IF (ustar.GT.tt) GO TO 50
+  170 u = ranf()
+      IF (ustar.GE.u) GO TO 150
+      u = ranf()
+      GO TO 140
+
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/ranlib/wrap.f
@@ -0,0 +1,10 @@
+      subroutine dgennor (av, sd, result)
+      double precision av, sd, result
+      result = gennor (real (av), real (sd))
+      return
+      end
+      subroutine dgenunf (low, high, result)
+      double precision low, high, result
+      result = genunf (real (low), real (high))
+      return
+      end
new file mode 100644
--- /dev/null
+++ b/libcruft/slatec-fn/d9lgmc.f
@@ -0,0 +1,76 @@
+*DECK D9LGMC
+      DOUBLE PRECISION FUNCTION D9LGMC (X)
+C***BEGIN PROLOGUE  D9LGMC
+C***SUBSIDIARY
+C***PURPOSE  Compute the log Gamma correction factor so that
+C            LOG(DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-5.)*LOG(X) - X
+C            + D9LGMC(X).
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C7E
+C***TYPE      DOUBLE PRECISION (R9LGMC-S, D9LGMC-D, C9LGMC-C)
+C***KEYWORDS  COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB,
+C             LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C Compute the log gamma correction factor for X .GE. 10. so that
+C LOG (DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + D9lGMC(X)
+C
+C Series for ALGM       on the interval  0.          to  1.00000E-02
+C                                        with weighted error   1.28E-31
+C                                         log weighted error  30.89
+C                               significant figures required  29.81
+C                                    decimal places required  31.48
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  D1MACH, DCSEVL, INITDS, XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   770601  DATE WRITTEN
+C   890531  Changed all specific intrinsics to generic.  (WRB)
+C   890531  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+C   900720  Routine changed from user-callable to subsidiary.  (WRB)
+C***END PROLOGUE  D9LGMC
+      DOUBLE PRECISION X, ALGMCS(15), XBIG, XMAX, DCSEVL, D1MACH
+      LOGICAL FIRST
+      SAVE ALGMCS, NALGM, XBIG, XMAX, FIRST
+      DATA ALGMCS(  1) / +.1666389480 4518632472 0572965082 2 D+0      /
+      DATA ALGMCS(  2) / -.1384948176 0675638407 3298605913 5 D-4      /
+      DATA ALGMCS(  3) / +.9810825646 9247294261 5717154748 7 D-8      /
+      DATA ALGMCS(  4) / -.1809129475 5724941942 6330626671 9 D-10     /
+      DATA ALGMCS(  5) / +.6221098041 8926052271 2601554341 6 D-13     /
+      DATA ALGMCS(  6) / -.3399615005 4177219443 0333059966 6 D-15     /
+      DATA ALGMCS(  7) / +.2683181998 4826987489 5753884666 6 D-17     /
+      DATA ALGMCS(  8) / -.2868042435 3346432841 4462239999 9 D-19     /
+      DATA ALGMCS(  9) / +.3962837061 0464348036 7930666666 6 D-21     /
+      DATA ALGMCS( 10) / -.6831888753 9857668701 1199999999 9 D-23     /
+      DATA ALGMCS( 11) / +.1429227355 9424981475 7333333333 3 D-24     /
+      DATA ALGMCS( 12) / -.3547598158 1010705471 9999999999 9 D-26     /
+      DATA ALGMCS( 13) / +.1025680058 0104709120 0000000000 0 D-27     /
+      DATA ALGMCS( 14) / -.3401102254 3167487999 9999999999 9 D-29     /
+      DATA ALGMCS( 15) / +.1276642195 6300629333 3333333333 3 D-30     /
+      DATA FIRST /.TRUE./
+C***FIRST EXECUTABLE STATEMENT  D9LGMC
+      IF (FIRST) THEN
+         NALGM = INITDS (ALGMCS, 15, REAL(D1MACH(3)) )
+         XBIG = 1.0D0/SQRT(D1MACH(3))
+         XMAX = EXP (MIN(LOG(D1MACH(2)/12.D0), -LOG(12.D0*D1MACH(1))))
+      ENDIF
+      FIRST = .FALSE.
+C
+      IF (X .LT. 10.D0) CALL XERMSG ('SLATEC', 'D9LGMC',
+     +   'X MUST BE GE 10', 1, 2)
+      IF (X.GE.XMAX) GO TO 20
+C
+      D9LGMC = 1.D0/(12.D0*X)
+      IF (X.LT.XBIG) D9LGMC = DCSEVL (2.0D0*(10.D0/X)**2-1.D0, ALGMCS,
+     1  NALGM) / X
+      RETURN
+C
+ 20   D9LGMC = 0.D0
+      CALL XERMSG ('SLATEC', 'D9LGMC', 'X SO BIG D9LGMC UNDERFLOWS', 2,
+     +   1)
+      RETURN
+C
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/slatec-fn/dacosh.f
@@ -0,0 +1,40 @@
+*DECK DACOSH
+      DOUBLE PRECISION FUNCTION DACOSH (X)
+C***BEGIN PROLOGUE  DACOSH
+C***PURPOSE  Compute the arc hyperbolic cosine.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C4C
+C***TYPE      DOUBLE PRECISION (ACOSH-S, DACOSH-D, CACOSH-C)
+C***KEYWORDS  ACOSH, ARC HYPERBOLIC COSINE, ELEMENTARY FUNCTIONS, FNLIB,
+C             INVERSE HYPERBOLIC COSINE
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C DACOSH(X) calculates the double precision arc hyperbolic cosine for
+C double precision argument X.  The result is returned on the
+C positive branch.
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  D1MACH, XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   770601  DATE WRITTEN
+C   890531  Changed all specific intrinsics to generic.  (WRB)
+C   890531  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+C***END PROLOGUE  DACOSH
+      DOUBLE PRECISION X, DLN2, XMAX,  D1MACH
+      SAVE DLN2, XMAX
+      DATA DLN2 / 0.6931471805 5994530941 7232121458 18 D0 /
+      DATA XMAX / 0.D0 /
+C***FIRST EXECUTABLE STATEMENT  DACOSH
+      IF (XMAX.EQ.0.D0) XMAX = 1.0D0/SQRT(D1MACH(3))
+C
+      IF (X .LT. 1.D0) CALL XERMSG ('SLATEC', 'DACOSH',
+     +   'X LESS THAN 1', 1, 2)
+C
+      IF (X.LT.XMAX) DACOSH = LOG (X+SQRT(X*X-1.0D0))
+      IF (X.GE.XMAX) DACOSH = DLN2 + LOG(X)
+C
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/slatec-fn/dasinh.f
@@ -0,0 +1,89 @@
+*DECK DASINH
+      DOUBLE PRECISION FUNCTION DASINH (X)
+C***BEGIN PROLOGUE  DASINH
+C***PURPOSE  Compute the arc hyperbolic sine.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C4C
+C***TYPE      DOUBLE PRECISION (ASINH-S, DASINH-D, CASINH-C)
+C***KEYWORDS  ARC HYPERBOLIC SINE, ASINH, ELEMENTARY FUNCTIONS, FNLIB,
+C             INVERSE HYPERBOLIC SINE
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C DASINH(X) calculates the double precision arc hyperbolic
+C sine for double precision argument X.
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  D1MACH, DCSEVL, INITDS
+C***REVISION HISTORY  (YYMMDD)
+C   770601  DATE WRITTEN
+C   890531  Changed all specific intrinsics to generic.  (WRB)
+C   890531  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C***END PROLOGUE  DASINH
+      DOUBLE PRECISION X, ASNHCS(39), ALN2, SQEPS, XMAX, Y,
+     1  DCSEVL, D1MACH
+      LOGICAL FIRST
+      SAVE ASNHCS, ALN2, NTERMS, XMAX, SQEPS, FIRST
+      DATA ASNHCS(  1) / -.1282003991 1738186343 3721273592 68 D+0     /
+      DATA ASNHCS(  2) / -.5881176118 9951767565 2117571383 62 D-1     /
+      DATA ASNHCS(  3) / +.4727465432 2124815640 7252497560 29 D-2     /
+      DATA ASNHCS(  4) / -.4938363162 6536172101 3601747902 73 D-3     /
+      DATA ASNHCS(  5) / +.5850620705 8557412287 4948352593 21 D-4     /
+      DATA ASNHCS(  6) / -.7466998328 9313681354 7550692171 88 D-5     /
+      DATA ASNHCS(  7) / +.1001169358 3558199265 9661920158 12 D-5     /
+      DATA ASNHCS(  8) / -.1390354385 8708333608 6164722588 86 D-6     /
+      DATA ASNHCS(  9) / +.1982316948 3172793547 3173602371 48 D-7     /
+      DATA ASNHCS( 10) / -.2884746841 7848843612 7472728003 17 D-8     /
+      DATA ASNHCS( 11) / +.4267296546 7159937953 4575149959 07 D-9     /
+      DATA ASNHCS( 12) / -.6397608465 4366357868 7526323096 81 D-10    /
+      DATA ASNHCS( 13) / +.9699168608 9064704147 8782931311 79 D-11    /
+      DATA ASNHCS( 14) / -.1484427697 2043770830 2466583656 96 D-11    /
+      DATA ASNHCS( 15) / +.2290373793 9027447988 0401843789 83 D-12    /
+      DATA ASNHCS( 16) / -.3558839513 2732645159 9789426513 10 D-13    /
+      DATA ASNHCS( 17) / +.5563969408 0056789953 3745390885 54 D-14    /
+      DATA ASNHCS( 18) / -.8746250959 9624678045 6665935201 62 D-15    /
+      DATA ASNHCS( 19) / +.1381524884 4526692155 8688022981 29 D-15    /
+      DATA ASNHCS( 20) / -.2191668828 2900363984 9551422641 49 D-16    /
+      DATA ASNHCS( 21) / +.3490465852 4827565638 3139237068 80 D-17    /
+      DATA ASNHCS( 22) / -.5578578840 0895742439 6301570321 06 D-18    /
+      DATA ASNHCS( 23) / +.8944514661 7134012551 0508827989 33 D-19    /
+      DATA ASNHCS( 24) / -.1438342634 6571317305 5518452394 66 D-19    /
+      DATA ASNHCS( 25) / +.2319181187 2169963036 3261446826 66 D-20    /
+      DATA ASNHCS( 26) / -.3748700795 3314343674 5706045439 99 D-21    /
+      DATA ASNHCS( 27) / +.6073210982 2064279404 5492428800 00 D-22    /
+      DATA ASNHCS( 28) / -.9859940276 4633583177 3701734400 00 D-23    /
+      DATA ASNHCS( 29) / +.1603921745 2788496315 2326382933 33 D-23    /
+      DATA ASNHCS( 30) / -.2613884735 0287686596 7161343999 99 D-24    /
+      DATA ASNHCS( 31) / +.4267084960 6857390833 3581653333 33 D-25    /
+      DATA ASNHCS( 32) / -.6977021703 9185243299 7307733333 33 D-26    /
+      DATA ASNHCS( 33) / +.1142508833 6806858659 8126933333 33 D-26    /
+      DATA ASNHCS( 34) / -.1873529207 8860968933 0210133333 33 D-27    /
+      DATA ASNHCS( 35) / +.3076358441 4464922794 0659200000 00 D-28    /
+      DATA ASNHCS( 36) / -.5057736403 1639824787 0463999999 99 D-29    /
+      DATA ASNHCS( 37) / +.8325075471 2689142224 2133333333 33 D-30    /
+      DATA ASNHCS( 38) / -.1371845728 2501044163 9253333333 33 D-30    /
+      DATA ASNHCS( 39) / +.2262986842 6552784104 1066666666 66 D-31    /
+      DATA ALN2 / 0.6931471805 5994530941 7232121458 18D0 /
+      DATA FIRST /.TRUE./
+C***FIRST EXECUTABLE STATEMENT  DASINH
+      IF (FIRST) THEN
+         NTERMS = INITDS (ASNHCS, 39, 0.1*REAL(D1MACH(3)) )
+         SQEPS = SQRT(D1MACH(3))
+         XMAX = 1.0D0/SQEPS
+      ENDIF
+      FIRST = .FALSE.
+C
+      Y = ABS(X)
+      IF (Y.GT.1.0D0) GO TO 20
+C
+      DASINH = X
+      IF (Y.GT.SQEPS) DASINH = X*(1.0D0 + DCSEVL (2.D0*X*X-1.D0,
+     1  ASNHCS, NTERMS) )
+      RETURN
+ 20   IF (Y.LT.XMAX) DASINH = LOG (Y+SQRT(Y*Y+1.D0))
+      IF (Y.GE.XMAX) DASINH = ALN2 + LOG(Y)
+      DASINH = SIGN (DASINH, X)
+      RETURN
+C
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/slatec-fn/datanh.f
@@ -0,0 +1,83 @@
+*DECK DATANH
+      DOUBLE PRECISION FUNCTION DATANH (X)
+C***BEGIN PROLOGUE  DATANH
+C***PURPOSE  Compute the arc hyperbolic tangent.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C4C
+C***TYPE      DOUBLE PRECISION (ATANH-S, DATANH-D, CATANH-C)
+C***KEYWORDS  ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS,
+C             FNLIB, INVERSE HYPERBOLIC TANGENT
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C DATANH(X) calculates the double precision arc hyperbolic
+C tangent for double precision argument X.
+C
+C Series for ATNH       on the interval  0.          to  2.50000E-01
+C                                        with weighted error   6.86E-32
+C                                         log weighted error  31.16
+C                               significant figures required  30.00
+C                                    decimal places required  31.88
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  D1MACH, DCSEVL, INITDS, XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   770601  DATE WRITTEN
+C   890531  Changed all specific intrinsics to generic.  (WRB)
+C   890531  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+C***END PROLOGUE  DATANH
+      DOUBLE PRECISION X, ATNHCS(27), DXREL, SQEPS, Y, DCSEVL, D1MACH
+      LOGICAL FIRST
+      SAVE ATNHCS, NTERMS, DXREL, SQEPS, FIRST
+      DATA ATNHCS(  1) / +.9439510239 3195492308 4289221863 3 D-1      /
+      DATA ATNHCS(  2) / +.4919843705 5786159472 0003457666 8 D-1      /
+      DATA ATNHCS(  3) / +.2102593522 4554327634 7932733175 2 D-2      /
+      DATA ATNHCS(  4) / +.1073554449 7761165846 4073104527 6 D-3      /
+      DATA ATNHCS(  5) / +.5978267249 2930314786 4278751787 2 D-5      /
+      DATA ATNHCS(  6) / +.3505062030 8891348459 6683488620 0 D-6      /
+      DATA ATNHCS(  7) / +.2126374343 7653403508 9621931443 1 D-7      /
+      DATA ATNHCS(  8) / +.1321694535 7155271921 2980172305 5 D-8      /
+      DATA ATNHCS(  9) / +.8365875501 1780703646 2360405295 9 D-10     /
+      DATA ATNHCS( 10) / +.5370503749 3110021638 8143458777 2 D-11     /
+      DATA ATNHCS( 11) / +.3486659470 1571079229 7124578429 0 D-12     /
+      DATA ATNHCS( 12) / +.2284549509 6034330155 2402411972 2 D-13     /
+      DATA ATNHCS( 13) / +.1508407105 9447930448 7422906755 8 D-14     /
+      DATA ATNHCS( 14) / +.1002418816 8041091261 3699572283 7 D-15     /
+      DATA ATNHCS( 15) / +.6698674738 1650695397 1552688298 6 D-17     /
+      DATA ATNHCS( 16) / +.4497954546 4949310830 8332762453 3 D-18     /
+      DATA ATNHCS( 17) / +.3032954474 2794535416 8236714666 6 D-19     /
+      DATA ATNHCS( 18) / +.2052702064 1909368264 6386141866 6 D-20     /
+      DATA ATNHCS( 19) / +.1393848977 0538377131 9301461333 3 D-21     /
+      DATA ATNHCS( 20) / +.9492580637 2245769719 5895466666 6 D-23     /
+      DATA ATNHCS( 21) / +.6481915448 2423076049 8244266666 6 D-24     /
+      DATA ATNHCS( 22) / +.4436730205 7236152726 3232000000 0 D-25     /
+      DATA ATNHCS( 23) / +.3043465618 5431616389 1200000000 0 D-26     /
+      DATA ATNHCS( 24) / +.2091881298 7923934740 4799999999 9 D-27     /
+      DATA ATNHCS( 25) / +.1440445411 2340505613 6533333333 3 D-28     /
+      DATA ATNHCS( 26) / +.9935374683 1416404650 6666666666 6 D-30     /
+      DATA ATNHCS( 27) / +.6863462444 3582600533 3333333333 3 D-31     /
+      DATA FIRST /.TRUE./
+C***FIRST EXECUTABLE STATEMENT  DATANH
+      IF (FIRST) THEN
+         NTERMS = INITDS (ATNHCS, 27, 0.1*REAL(D1MACH(3)) )
+         DXREL = SQRT(D1MACH(4))
+         SQEPS = SQRT(3.0D0*D1MACH(3))
+      ENDIF
+      FIRST = .FALSE.
+C
+      Y = ABS(X)
+      IF (Y .GE. 1.D0) CALL XERMSG ('SLATEC', 'DATANH', 'ABS(X) GE 1',
+     +   2, 2)
+C
+      IF (1.D0-Y .LT. DXREL) CALL XERMSG ('SLATEC', 'DATANH',
+     +   'ANSWER LT HALF PRECISION BECAUSE ABS(X) TOO NEAR 1', 1, 1)
+C
+      DATANH = X
+      IF (Y.GT.SQEPS .AND. Y.LE.0.5D0) DATANH = X*(1.0D0 +
+     1  DCSEVL (8.D0*X*X-1.D0, ATNHCS, NTERMS) )
+      IF (Y.GT.0.5D0) DATANH = 0.5D0*LOG ((1.0D0+X)/(1.0D0-X))
+C
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/slatec-fn/dcsevl.f
@@ -0,0 +1,65 @@
+*DECK DCSEVL
+      DOUBLE PRECISION FUNCTION DCSEVL (X, CS, N)
+C***BEGIN PROLOGUE  DCSEVL
+C***PURPOSE  Evaluate a Chebyshev series.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C3A2
+C***TYPE      DOUBLE PRECISION (CSEVL-S, DCSEVL-D)
+C***KEYWORDS  CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C  Evaluate the N-term Chebyshev series CS at X.  Adapted from
+C  a method presented in the paper by Broucke referenced below.
+C
+C       Input Arguments --
+C  X    value at which the series is to be evaluated.
+C  CS   array of N terms of a Chebyshev series.  In evaluating
+C       CS, only half the first coefficient is summed.
+C  N    number of terms in array CS.
+C
+C***REFERENCES  R. Broucke, Ten subroutines for the manipulation of
+C                 Chebyshev series, Algorithm 446, Communications of
+C                 the A.C.M. 16, (1973) pp. 254-256.
+C               L. Fox and I. B. Parker, Chebyshev Polynomials in
+C                 Numerical Analysis, Oxford University Press, 1968,
+C                 page 56.
+C***ROUTINES CALLED  D1MACH, XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   770401  DATE WRITTEN
+C   890831  Modified array declarations.  (WRB)
+C   890831  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+C   900329  Prologued revised extensively and code rewritten to allow
+C           X to be slightly outside interval (-1,+1).  (WRB)
+C   920501  Reformatted the REFERENCES section.  (WRB)
+C***END PROLOGUE  DCSEVL
+      DOUBLE PRECISION B0, B1, B2, CS(*), ONEPL, TWOX, X, D1MACH
+      LOGICAL FIRST
+      SAVE FIRST, ONEPL
+      DATA FIRST /.TRUE./
+C***FIRST EXECUTABLE STATEMENT  DCSEVL
+      IF (FIRST) ONEPL = 1.0D0 + D1MACH(4)
+      FIRST = .FALSE.
+      IF (N .LT. 1) CALL XERMSG ('SLATEC', 'DCSEVL',
+     +   'NUMBER OF TERMS .LE. 0', 2, 2)
+      IF (N .GT. 1000) CALL XERMSG ('SLATEC', 'DCSEVL',
+     +   'NUMBER OF TERMS .GT. 1000', 3, 2)
+      IF (ABS(X) .GT. ONEPL) CALL XERMSG ('SLATEC', 'DCSEVL',
+     +   'X OUTSIDE THE INTERVAL (-1,+1)', 1, 1)
+C
+      B1 = 0.0D0
+      B0 = 0.0D0
+      TWOX = 2.0D0*X
+      DO 10 I = 1,N
+         B2 = B1
+         B1 = B0
+         NI = N + 1 - I
+         B0 = TWOX*B1 - B2 + CS(NI)
+   10 CONTINUE
+C
+      DCSEVL = 0.5D0*(B0-B2)
+C
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/slatec-fn/derf.f
@@ -0,0 +1,83 @@
+*DECK DERF
+      DOUBLE PRECISION FUNCTION DERF (X)
+C***BEGIN PROLOGUE  DERF
+C***PURPOSE  Compute the error function.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C8A, L5A1E
+C***TYPE      DOUBLE PRECISION (ERF-S, DERF-D)
+C***KEYWORDS  ERF, ERROR FUNCTION, FNLIB, SPECIAL FUNCTIONS
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C DERF(X) calculates the double precision error function for double
+C precision argument X.
+C
+C Series for ERF        on the interval  0.          to  1.00000E+00
+C                                        with weighted error   1.28E-32
+C                                         log weighted error  31.89
+C                               significant figures required  31.05
+C                                    decimal places required  32.55
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  D1MACH, DCSEVL, DERFC, INITDS
+C***REVISION HISTORY  (YYMMDD)
+C   770701  DATE WRITTEN
+C   890531  Changed all specific intrinsics to generic.  (WRB)
+C   890531  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900727  Added EXTERNAL statement.  (WRB)
+C   920618  Removed space from variable name.  (RWC, WRB)
+C***END PROLOGUE  DERF
+      DOUBLE PRECISION X, ERFCS(21), SQEPS, SQRTPI, XBIG, Y, D1MACH,
+     1  DCSEVL, DERFC
+      LOGICAL FIRST
+      EXTERNAL DERFC
+      SAVE ERFCS, SQRTPI, NTERF, XBIG, SQEPS, FIRST
+      DATA ERFCS(  1) / -.4904612123 4691808039 9845440333 76 D-1     /
+      DATA ERFCS(  2) / -.1422612051 0371364237 8247418996 31 D+0     /
+      DATA ERFCS(  3) / +.1003558218 7599795575 7546767129 33 D-1     /
+      DATA ERFCS(  4) / -.5768764699 7674847650 8270255091 67 D-3     /
+      DATA ERFCS(  5) / +.2741993125 2196061034 4221607914 71 D-4     /
+      DATA ERFCS(  6) / -.1104317550 7344507604 1353812959 05 D-5     /
+      DATA ERFCS(  7) / +.3848875542 0345036949 9613114981 74 D-7     /
+      DATA ERFCS(  8) / -.1180858253 3875466969 6317518015 81 D-8     /
+      DATA ERFCS(  9) / +.3233421582 6050909646 4029309533 54 D-10    /
+      DATA ERFCS( 10) / -.7991015947 0045487581 6073747085 95 D-12    /
+      DATA ERFCS( 11) / +.1799072511 3961455611 9672454866 34 D-13    /
+      DATA ERFCS( 12) / -.3718635487 8186926382 3168282094 93 D-15    /
+      DATA ERFCS( 13) / +.7103599003 7142529711 6899083946 66 D-17    /
+      DATA ERFCS( 14) / -.1261245511 9155225832 4954248533 33 D-18    /
+      DATA ERFCS( 15) / +.2091640694 1769294369 1705002666 66 D-20    /
+      DATA ERFCS( 16) / -.3253973102 9314072982 3641600000 00 D-22    /
+      DATA ERFCS( 17) / +.4766867209 7976748332 3733333333 33 D-24    /
+      DATA ERFCS( 18) / -.6598012078 2851343155 1999999999 99 D-26    /
+      DATA ERFCS( 19) / +.8655011469 9637626197 3333333333 33 D-28    /
+      DATA ERFCS( 20) / -.1078892517 7498064213 3333333333 33 D-29    /
+      DATA ERFCS( 21) / +.1281188399 3017002666 6666666666 66 D-31    /
+      DATA SQRTPI / 1.772453850 9055160272 9816748334 115D0 /
+      DATA FIRST /.TRUE./
+C***FIRST EXECUTABLE STATEMENT  DERF
+      IF (FIRST) THEN
+         NTERF = INITDS (ERFCS, 21, 0.1*REAL(D1MACH(3)))
+         XBIG = SQRT(-LOG(SQRTPI*D1MACH(3)))
+         SQEPS = SQRT(2.0D0*D1MACH(3))
+      ENDIF
+      FIRST = .FALSE.
+C
+      Y = ABS(X)
+      IF (Y.GT.1.D0) GO TO 20
+C
+C ERF(X) = 1.0 - ERFC(X)  FOR  -1.0 .LE. X .LE. 1.0
+C
+      IF (Y.LE.SQEPS) DERF = 2.0D0*X*X/SQRTPI
+      IF (Y.GT.SQEPS) DERF = X*(1.0D0 + DCSEVL (2.D0*X*X-1.D0,
+     1  ERFCS, NTERF))
+      RETURN
+C
+C ERF(X) = 1.0 - ERFC(X) FOR ABS(X) .GT. 1.0
+C
+ 20   IF (Y.LE.XBIG) DERF = SIGN (1.0D0-DERFC(Y), X)
+      IF (Y.GT.XBIG) DERF = SIGN (1.0D0, X)
+C
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/slatec-fn/derfc.f
@@ -0,0 +1,226 @@
+*DECK DERFC
+      DOUBLE PRECISION FUNCTION DERFC (X)
+C***BEGIN PROLOGUE  DERFC
+C***PURPOSE  Compute the complementary error function.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C8A, L5A1E
+C***TYPE      DOUBLE PRECISION (ERFC-S, DERFC-D)
+C***KEYWORDS  COMPLEMENTARY ERROR FUNCTION, ERFC, FNLIB,
+C             SPECIAL FUNCTIONS
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C DERFC(X) calculates the double precision complementary error function
+C for double precision argument X.
+C
+C Series for ERF        on the interval  0.          to  1.00000E+00
+C                                        with weighted Error   1.28E-32
+C                                         log weighted Error  31.89
+C                               significant figures required  31.05
+C                                    decimal places required  32.55
+C
+C Series for ERC2       on the interval  2.50000E-01 to  1.00000E+00
+C                                        with weighted Error   2.67E-32
+C                                         log weighted Error  31.57
+C                               significant figures required  30.31
+C                                    decimal places required  32.42
+C
+C Series for ERFC       on the interval  0.          to  2.50000E-01
+C                                        with weighted error   1.53E-31
+C                                         log weighted error  30.82
+C                               significant figures required  29.47
+C                                    decimal places required  31.70
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  D1MACH, DCSEVL, INITDS, XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   770701  DATE WRITTEN
+C   890531  Changed all specific intrinsics to generic.  (WRB)
+C   890531  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+C   920618  Removed space from variable names.  (RWC, WRB)
+C***END PROLOGUE  DERFC
+      DOUBLE PRECISION X, ERFCS(21), ERFCCS(59), ERC2CS(49), SQEPS,
+     1  SQRTPI, XMAX, TXMAX, XSML, Y, D1MACH, DCSEVL
+      LOGICAL FIRST
+      SAVE ERFCS, ERC2CS, ERFCCS, SQRTPI, NTERF,
+     1 NTERFC, NTERC2, XSML, XMAX, SQEPS, FIRST
+      DATA ERFCS(  1) / -.4904612123 4691808039 9845440333 76 D-1     /
+      DATA ERFCS(  2) / -.1422612051 0371364237 8247418996 31 D+0     /
+      DATA ERFCS(  3) / +.1003558218 7599795575 7546767129 33 D-1     /
+      DATA ERFCS(  4) / -.5768764699 7674847650 8270255091 67 D-3     /
+      DATA ERFCS(  5) / +.2741993125 2196061034 4221607914 71 D-4     /
+      DATA ERFCS(  6) / -.1104317550 7344507604 1353812959 05 D-5     /
+      DATA ERFCS(  7) / +.3848875542 0345036949 9613114981 74 D-7     /
+      DATA ERFCS(  8) / -.1180858253 3875466969 6317518015 81 D-8     /
+      DATA ERFCS(  9) / +.3233421582 6050909646 4029309533 54 D-10    /
+      DATA ERFCS( 10) / -.7991015947 0045487581 6073747085 95 D-12    /
+      DATA ERFCS( 11) / +.1799072511 3961455611 9672454866 34 D-13    /
+      DATA ERFCS( 12) / -.3718635487 8186926382 3168282094 93 D-15    /
+      DATA ERFCS( 13) / +.7103599003 7142529711 6899083946 66 D-17    /
+      DATA ERFCS( 14) / -.1261245511 9155225832 4954248533 33 D-18    /
+      DATA ERFCS( 15) / +.2091640694 1769294369 1705002666 66 D-20    /
+      DATA ERFCS( 16) / -.3253973102 9314072982 3641600000 00 D-22    /
+      DATA ERFCS( 17) / +.4766867209 7976748332 3733333333 33 D-24    /
+      DATA ERFCS( 18) / -.6598012078 2851343155 1999999999 99 D-26    /
+      DATA ERFCS( 19) / +.8655011469 9637626197 3333333333 33 D-28    /
+      DATA ERFCS( 20) / -.1078892517 7498064213 3333333333 33 D-29    /
+      DATA ERFCS( 21) / +.1281188399 3017002666 6666666666 66 D-31    /
+      DATA ERC2CS(  1) / -.6960134660 2309501127 3915082619 7 D-1      /
+      DATA ERC2CS(  2) / -.4110133936 2620893489 8221208466 6 D-1      /
+      DATA ERC2CS(  3) / +.3914495866 6896268815 6114370524 4 D-2      /
+      DATA ERC2CS(  4) / -.4906395650 5489791612 8093545077 4 D-3      /
+      DATA ERC2CS(  5) / +.7157479001 3770363807 6089414182 5 D-4      /
+      DATA ERC2CS(  6) / -.1153071634 1312328338 0823284791 2 D-4      /
+      DATA ERC2CS(  7) / +.1994670590 2019976350 5231486770 9 D-5      /
+      DATA ERC2CS(  8) / -.3642666471 5992228739 3611843071 1 D-6      /
+      DATA ERC2CS(  9) / +.6944372610 0050125899 3127721463 3 D-7      /
+      DATA ERC2CS( 10) / -.1371220902 1043660195 3460514121 0 D-7      /
+      DATA ERC2CS( 11) / +.2788389661 0071371319 6386034808 7 D-8      /
+      DATA ERC2CS( 12) / -.5814164724 3311615518 6479105031 6 D-9      /
+      DATA ERC2CS( 13) / +.1238920491 7527531811 8016881795 0 D-9      /
+      DATA ERC2CS( 14) / -.2690639145 3067434323 9042493788 9 D-10     /
+      DATA ERC2CS( 15) / +.5942614350 8479109824 4470968384 0 D-11     /
+      DATA ERC2CS( 16) / -.1332386735 7581195792 8775442057 0 D-11     /
+      DATA ERC2CS( 17) / +.3028046806 1771320171 7369724330 4 D-12     /
+      DATA ERC2CS( 18) / -.6966648814 9410325887 9586758895 4 D-13     /
+      DATA ERC2CS( 19) / +.1620854541 0539229698 1289322762 8 D-13     /
+      DATA ERC2CS( 20) / -.3809934465 2504919998 7691305772 9 D-14     /
+      DATA ERC2CS( 21) / +.9040487815 9788311493 6897101297 5 D-15     /
+      DATA ERC2CS( 22) / -.2164006195 0896073478 0981204700 3 D-15     /
+      DATA ERC2CS( 23) / +.5222102233 9958549846 0798024417 2 D-16     /
+      DATA ERC2CS( 24) / -.1269729602 3645553363 7241552778 0 D-16     /
+      DATA ERC2CS( 25) / +.3109145504 2761975838 3622741295 1 D-17     /
+      DATA ERC2CS( 26) / -.7663762920 3203855240 0956671481 1 D-18     /
+      DATA ERC2CS( 27) / +.1900819251 3627452025 3692973329 0 D-18     /
+      DATA ERC2CS( 28) / -.4742207279 0690395452 2565599996 5 D-19     /
+      DATA ERC2CS( 29) / +.1189649200 0765283828 8068307845 1 D-19     /
+      DATA ERC2CS( 30) / -.3000035590 3257802568 4527131306 6 D-20     /
+      DATA ERC2CS( 31) / +.7602993453 0432461730 1938527709 8 D-21     /
+      DATA ERC2CS( 32) / -.1935909447 6068728815 6981104913 0 D-21     /
+      DATA ERC2CS( 33) / +.4951399124 7733378810 0004238677 3 D-22     /
+      DATA ERC2CS( 34) / -.1271807481 3363718796 0862198988 8 D-22     /
+      DATA ERC2CS( 35) / +.3280049600 4695130433 1584165205 3 D-23     /
+      DATA ERC2CS( 36) / -.8492320176 8228965689 2479242239 9 D-24     /
+      DATA ERC2CS( 37) / +.2206917892 8075602235 1987998719 9 D-24     /
+      DATA ERC2CS( 38) / -.5755617245 6965284983 1281950719 9 D-25     /
+      DATA ERC2CS( 39) / +.1506191533 6392342503 5414405119 9 D-25     /
+      DATA ERC2CS( 40) / -.3954502959 0187969531 0428569599 9 D-26     /
+      DATA ERC2CS( 41) / +.1041529704 1515009799 8464505173 3 D-26     /
+      DATA ERC2CS( 42) / -.2751487795 2787650794 5017890133 3 D-27     /
+      DATA ERC2CS( 43) / +.7290058205 4975574089 9770368000 0 D-28     /
+      DATA ERC2CS( 44) / -.1936939645 9159478040 7750109866 6 D-28     /
+      DATA ERC2CS( 45) / +.5160357112 0514872983 7005482666 6 D-29     /
+      DATA ERC2CS( 46) / -.1378419322 1930940993 8964480000 0 D-29     /
+      DATA ERC2CS( 47) / +.3691326793 1070690422 5109333333 3 D-30     /
+      DATA ERC2CS( 48) / -.9909389590 6243654206 5322666666 6 D-31     /
+      DATA ERC2CS( 49) / +.2666491705 1953884133 2394666666 6 D-31     /
+      DATA ERFCCS(  1) / +.7151793102 0292477450 3697709496 D-1        /
+      DATA ERFCCS(  2) / -.2653243433 7606715755 8893386681 D-1        /
+      DATA ERFCCS(  3) / +.1711153977 9208558833 2699194606 D-2        /
+      DATA ERFCCS(  4) / -.1637516634 5851788416 3746404749 D-3        /
+      DATA ERFCCS(  5) / +.1987129350 0552036499 5974806758 D-4        /
+      DATA ERFCCS(  6) / -.2843712412 7665550875 0175183152 D-5        /
+      DATA ERFCCS(  7) / +.4606161308 9631303696 9379968464 D-6        /
+      DATA ERFCCS(  8) / -.8227753025 8792084205 7766536366 D-7        /
+      DATA ERFCCS(  9) / +.1592141872 7709011298 9358340826 D-7        /
+      DATA ERFCCS( 10) / -.3295071362 2528432148 6631665072 D-8        /
+      DATA ERFCCS( 11) / +.7223439760 4005554658 1261153890 D-9        /
+      DATA ERFCCS( 12) / -.1664855813 3987295934 4695966886 D-9        /
+      DATA ERFCCS( 13) / +.4010392588 2376648207 7671768814 D-10       /
+      DATA ERFCCS( 14) / -.1004816214 4257311327 2170176283 D-10       /
+      DATA ERFCCS( 15) / +.2608275913 3003338085 9341009439 D-11       /
+      DATA ERFCCS( 16) / -.6991110560 4040248655 7697812476 D-12       /
+      DATA ERFCCS( 17) / +.1929492333 2617070862 4205749803 D-12       /
+      DATA ERFCCS( 18) / -.5470131188 7543310649 0125085271 D-13       /
+      DATA ERFCCS( 19) / +.1589663309 7626974483 9084032762 D-13       /
+      DATA ERFCCS( 20) / -.4726893980 1975548392 0369584290 D-14       /
+      DATA ERFCCS( 21) / +.1435873376 7849847867 2873997840 D-14       /
+      DATA ERFCCS( 22) / -.4449510561 8173583941 7250062829 D-15       /
+      DATA ERFCCS( 23) / +.1404810884 7682334373 7305537466 D-15       /
+      DATA ERFCCS( 24) / -.4513818387 7642108962 5963281623 D-16       /
+      DATA ERFCCS( 25) / +.1474521541 0451330778 7018713262 D-16       /
+      DATA ERFCCS( 26) / -.4892621406 9457761543 6841552532 D-17       /
+      DATA ERFCCS( 27) / +.1647612141 4106467389 5301522827 D-17       /
+      DATA ERFCCS( 28) / -.5626817176 3294080929 9928521323 D-18       /
+      DATA ERFCCS( 29) / +.1947443382 2320785142 9197867821 D-18       /
+      DATA ERFCCS( 30) / -.6826305642 9484207295 6664144723 D-19       /
+      DATA ERFCCS( 31) / +.2421988887 2986492401 8301125438 D-19       /
+      DATA ERFCCS( 32) / -.8693414133 5030704256 3800861857 D-20       /
+      DATA ERFCCS( 33) / +.3155180346 2280855712 2363401262 D-20       /
+      DATA ERFCCS( 34) / -.1157372324 0496087426 1239486742 D-20       /
+      DATA ERFCCS( 35) / +.4288947161 6056539462 3737097442 D-21       /
+      DATA ERFCCS( 36) / -.1605030742 0576168500 5737770964 D-21       /
+      DATA ERFCCS( 37) / +.6063298757 4538026449 5069923027 D-22       /
+      DATA ERFCCS( 38) / -.2311404251 6979584909 8840801367 D-22       /
+      DATA ERFCCS( 39) / +.8888778540 6618855255 4702955697 D-23       /
+      DATA ERFCCS( 40) / -.3447260576 6513765223 0718495566 D-23       /
+      DATA ERFCCS( 41) / +.1347865460 2069650682 7582774181 D-23       /
+      DATA ERFCCS( 42) / -.5311794071 1250217364 5873201807 D-24       /
+      DATA ERFCCS( 43) / +.2109341058 6197831682 8954734537 D-24       /
+      DATA ERFCCS( 44) / -.8438365587 9237891159 8133256738 D-25       /
+      DATA ERFCCS( 45) / +.3399982524 9452089062 7359576337 D-25       /
+      DATA ERFCCS( 46) / -.1379452388 0732420900 2238377110 D-25       /
+      DATA ERFCCS( 47) / +.5634490311 8332526151 3392634811 D-26       /
+      DATA ERFCCS( 48) / -.2316490434 4770654482 3427752700 D-26       /
+      DATA ERFCCS( 49) / +.9584462844 6018101526 3158381226 D-27       /
+      DATA ERFCCS( 50) / -.3990722880 3301097262 4224850193 D-27       /
+      DATA ERFCCS( 51) / +.1672129225 9444773601 7228709669 D-27       /
+      DATA ERFCCS( 52) / -.7045991522 7660138563 8803782587 D-28       /
+      DATA ERFCCS( 53) / +.2979768402 8642063541 2357989444 D-28       /
+      DATA ERFCCS( 54) / -.1262522466 4606192972 2422632994 D-28       /
+      DATA ERFCCS( 55) / +.5395438704 5424879398 5299653154 D-29       /
+      DATA ERFCCS( 56) / -.2380992882 5314591867 5346190062 D-29       /
+      DATA ERFCCS( 57) / +.1099052830 1027615735 9726683750 D-29       /
+      DATA ERFCCS( 58) / -.4867713741 6449657273 2518677435 D-30       /
+      DATA ERFCCS( 59) / +.1525877264 1103575676 3200828211 D-30       /
+      DATA SQRTPI / 1.772453850 9055160272 9816748334 115D0 /
+      DATA FIRST /.TRUE./
+C***FIRST EXECUTABLE STATEMENT  DERFC
+      IF (FIRST) THEN
+         ETA = 0.1*REAL(D1MACH(3))
+         NTERF = INITDS (ERFCS, 21, ETA)
+         NTERFC = INITDS (ERFCCS, 59, ETA)
+         NTERC2 = INITDS (ERC2CS, 49, ETA)
+C
+         XSML = -SQRT(-LOG(SQRTPI*D1MACH(3)))
+         TXMAX = SQRT(-LOG(SQRTPI*D1MACH(1)))
+         XMAX = TXMAX - 0.5D0*LOG(TXMAX)/TXMAX - 0.01D0
+         SQEPS = SQRT(2.0D0*D1MACH(3))
+      ENDIF
+      FIRST = .FALSE.
+C
+      IF (X.GT.XSML) GO TO 20
+C
+C ERFC(X) = 1.0 - ERF(X)  FOR  X .LT. XSML
+C
+      DERFC = 2.0D0
+      RETURN
+C
+ 20   IF (X.GT.XMAX) GO TO 40
+      Y = ABS(X)
+      IF (Y.GT.1.0D0) GO TO 30
+C
+C ERFC(X) = 1.0 - ERF(X)  FOR ABS(X) .LE. 1.0
+C
+      IF (Y.LT.SQEPS) DERFC = 1.0D0 - 2.0D0*X/SQRTPI
+      IF (Y.GE.SQEPS) DERFC = 1.0D0 - X*(1.0D0 + DCSEVL (2.D0*X*X-1.D0,
+     1  ERFCS, NTERF))
+      RETURN
+C
+C ERFC(X) = 1.0 - ERF(X)  FOR  1.0 .LT. ABS(X) .LE. XMAX
+C
+ 30   Y = Y*Y
+      IF (Y.LE.4.D0) DERFC = EXP(-Y)/ABS(X) * (0.5D0 + DCSEVL (
+     1  (8.D0/Y-5.D0)/3.D0, ERC2CS, NTERC2) )
+      IF (Y.GT.4.D0) DERFC = EXP(-Y)/ABS(X) * (0.5D0 + DCSEVL (
+     1  8.D0/Y-1.D0, ERFCCS, NTERFC) )
+      IF (X.LT.0.D0) DERFC = 2.0D0 - DERFC
+      RETURN
+C
+ 40   CALL XERMSG ('SLATEC', 'DERFC', 'X SO BIG ERFC UNDERFLOWS', 1, 1)
+      DERFC = 0.D0
+      RETURN
+C
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/slatec-fn/dgamlm.f
@@ -0,0 +1,62 @@
+*DECK DGAMLM
+      SUBROUTINE DGAMLM (XMIN, XMAX)
+C***BEGIN PROLOGUE  DGAMLM
+C***PURPOSE  Compute the minimum and maximum bounds for the argument in
+C            the Gamma function.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C7A, R2
+C***TYPE      DOUBLE PRECISION (GAMLIM-S, DGAMLM-D)
+C***KEYWORDS  COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C Calculate the minimum and maximum legal bounds for X in gamma(X).
+C XMIN and XMAX are not the only bounds, but they are the only non-
+C trivial ones to calculate.
+C
+C             Output Arguments --
+C XMIN   double precision minimum legal value of X in gamma(X).  Any
+C        smaller value of X might result in underflow.
+C XMAX   double precision maximum legal value of X in gamma(X).  Any
+C        larger value of X might cause overflow.
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  D1MACH, XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   770601  DATE WRITTEN
+C   890531  Changed all specific intrinsics to generic.  (WRB)
+C   890531  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+C***END PROLOGUE  DGAMLM
+      DOUBLE PRECISION XMIN, XMAX, ALNBIG, ALNSML, XLN, XOLD, D1MACH
+C***FIRST EXECUTABLE STATEMENT  DGAMLM
+      ALNSML = LOG(D1MACH(1))
+      XMIN = -ALNSML
+      DO 10 I=1,10
+        XOLD = XMIN
+        XLN = LOG(XMIN)
+        XMIN = XMIN - XMIN*((XMIN+0.5D0)*XLN - XMIN - 0.2258D0 + ALNSML)
+     1    / (XMIN*XLN+0.5D0)
+        IF (ABS(XMIN-XOLD).LT.0.005D0) GO TO 20
+ 10   CONTINUE
+      CALL XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMIN', 1, 2)
+C
+ 20   XMIN = -XMIN + 0.01D0
+C
+      ALNBIG = LOG (D1MACH(2))
+      XMAX = ALNBIG
+      DO 30 I=1,10
+        XOLD = XMAX
+        XLN = LOG(XMAX)
+        XMAX = XMAX - XMAX*((XMAX-0.5D0)*XLN - XMAX + 0.9189D0 - ALNBIG)
+     1    / (XMAX*XLN-0.5D0)
+        IF (ABS(XMAX-XOLD).LT.0.005D0) GO TO 40
+ 30   CONTINUE
+      CALL XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMAX', 2, 2)
+C
+ 40   XMAX = XMAX - 0.01D0
+      XMIN = MAX (XMIN, -XMAX+1.D0)
+C
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/slatec-fn/dgamma.f
@@ -0,0 +1,153 @@
+*DECK DGAMMA
+      DOUBLE PRECISION FUNCTION DGAMMA (X)
+C***BEGIN PROLOGUE  DGAMMA
+C***PURPOSE  Compute the complete Gamma function.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C7A
+C***TYPE      DOUBLE PRECISION (GAMMA-S, DGAMMA-D, CGAMMA-C)
+C***KEYWORDS  COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C DGAMMA(X) calculates the double precision complete Gamma function
+C for double precision argument X.
+C
+C Series for GAM        on the interval  0.          to  1.00000E+00
+C                                        with weighted error   5.79E-32
+C                                         log weighted error  31.24
+C                               significant figures required  30.00
+C                                    decimal places required  32.05
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  D1MACH, D9LGMC, DCSEVL, DGAMLM, INITDS, XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   770601  DATE WRITTEN
+C   890531  Changed all specific intrinsics to generic.  (WRB)
+C   890911  Removed unnecessary intrinsics.  (WRB)
+C   890911  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+C   920618  Removed space from variable name.  (RWC, WRB)
+C***END PROLOGUE  DGAMMA
+      DOUBLE PRECISION X, GAMCS(42), DXREL, PI, SINPIY, SQ2PIL, XMAX,
+     1  XMIN, Y, D9LGMC, DCSEVL, D1MACH
+      LOGICAL FIRST
+C
+      SAVE GAMCS, PI, SQ2PIL, NGAM, XMIN, XMAX, DXREL, FIRST
+      DATA GAMCS(  1) / +.8571195590 9893314219 2006239994 2 D-2      /
+      DATA GAMCS(  2) / +.4415381324 8410067571 9131577165 2 D-2      /
+      DATA GAMCS(  3) / +.5685043681 5993633786 3266458878 9 D-1      /
+      DATA GAMCS(  4) / -.4219835396 4185605010 1250018662 4 D-2      /
+      DATA GAMCS(  5) / +.1326808181 2124602205 8400679635 2 D-2      /
+      DATA GAMCS(  6) / -.1893024529 7988804325 2394702388 6 D-3      /
+      DATA GAMCS(  7) / +.3606925327 4412452565 7808221722 5 D-4      /
+      DATA GAMCS(  8) / -.6056761904 4608642184 8554829036 5 D-5      /
+      DATA GAMCS(  9) / +.1055829546 3022833447 3182350909 3 D-5      /
+      DATA GAMCS( 10) / -.1811967365 5423840482 9185589116 6 D-6      /
+      DATA GAMCS( 11) / +.3117724964 7153222777 9025459316 9 D-7      /
+      DATA GAMCS( 12) / -.5354219639 0196871408 7408102434 7 D-8      /
+      DATA GAMCS( 13) / +.9193275519 8595889468 8778682594 0 D-9      /
+      DATA GAMCS( 14) / -.1577941280 2883397617 6742327395 3 D-9      /
+      DATA GAMCS( 15) / +.2707980622 9349545432 6654043308 9 D-10     /
+      DATA GAMCS( 16) / -.4646818653 8257301440 8166105893 3 D-11     /
+      DATA GAMCS( 17) / +.7973350192 0074196564 6076717535 9 D-12     /
+      DATA GAMCS( 18) / -.1368078209 8309160257 9949917230 9 D-12     /
+      DATA GAMCS( 19) / +.2347319486 5638006572 3347177168 8 D-13     /
+      DATA GAMCS( 20) / -.4027432614 9490669327 6657053469 9 D-14     /
+      DATA GAMCS( 21) / +.6910051747 3721009121 3833697525 7 D-15     /
+      DATA GAMCS( 22) / -.1185584500 2219929070 5238712619 2 D-15     /
+      DATA GAMCS( 23) / +.2034148542 4963739552 0102605193 2 D-16     /
+      DATA GAMCS( 24) / -.3490054341 7174058492 7401294910 8 D-17     /
+      DATA GAMCS( 25) / +.5987993856 4853055671 3505106602 6 D-18     /
+      DATA GAMCS( 26) / -.1027378057 8722280744 9006977843 1 D-18     /
+      DATA GAMCS( 27) / +.1762702816 0605298249 4275966074 8 D-19     /
+      DATA GAMCS( 28) / -.3024320653 7353062609 5877211204 2 D-20     /
+      DATA GAMCS( 29) / +.5188914660 2183978397 1783355050 6 D-21     /
+      DATA GAMCS( 30) / -.8902770842 4565766924 4925160106 6 D-22     /
+      DATA GAMCS( 31) / +.1527474068 4933426022 7459689130 6 D-22     /
+      DATA GAMCS( 32) / -.2620731256 1873629002 5732833279 9 D-23     /
+      DATA GAMCS( 33) / +.4496464047 8305386703 3104657066 6 D-24     /
+      DATA GAMCS( 34) / -.7714712731 3368779117 0390152533 3 D-25     /
+      DATA GAMCS( 35) / +.1323635453 1260440364 8657271466 6 D-25     /
+      DATA GAMCS( 36) / -.2270999412 9429288167 0231381333 3 D-26     /
+      DATA GAMCS( 37) / +.3896418998 0039914493 2081663999 9 D-27     /
+      DATA GAMCS( 38) / -.6685198115 1259533277 9212799999 9 D-28     /
+      DATA GAMCS( 39) / +.1146998663 1400243843 4761386666 6 D-28     /
+      DATA GAMCS( 40) / -.1967938586 3451346772 9510399999 9 D-29     /
+      DATA GAMCS( 41) / +.3376448816 5853380903 3489066666 6 D-30     /
+      DATA GAMCS( 42) / -.5793070335 7821357846 2549333333 3 D-31     /
+      DATA PI / 3.1415926535 8979323846 2643383279 50 D0 /
+      DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 /
+      DATA FIRST /.TRUE./
+C***FIRST EXECUTABLE STATEMENT  DGAMMA
+      IF (FIRST) THEN
+         NGAM = INITDS (GAMCS, 42, 0.1*REAL(D1MACH(3)) )
+C
+         CALL DGAMLM (XMIN, XMAX)
+         DXREL = SQRT(D1MACH(4))
+      ENDIF
+      FIRST = .FALSE.
+C
+      Y = ABS(X)
+      IF (Y.GT.10.D0) GO TO 50
+C
+C COMPUTE GAMMA(X) FOR -XBND .LE. X .LE. XBND.  REDUCE INTERVAL AND FIND
+C GAMMA(1+Y) FOR 0.0 .LE. Y .LT. 1.0 FIRST OF ALL.
+C
+      N = X
+      IF (X.LT.0.D0) N = N - 1
+      Y = X - N
+      N = N - 1
+      DGAMMA = 0.9375D0 + DCSEVL (2.D0*Y-1.D0, GAMCS, NGAM)
+      IF (N.EQ.0) RETURN
+C
+      IF (N.GT.0) GO TO 30
+C
+C COMPUTE GAMMA(X) FOR X .LT. 1.0
+C
+      N = -N
+      IF (X .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DGAMMA', 'X IS 0', 4, 2)
+      IF (X .LT. 0.0 .AND. X+N-2 .EQ. 0.D0) CALL XERMSG ('SLATEC',
+     +   'DGAMMA', 'X IS A NEGATIVE INTEGER', 4, 2)
+      IF (X .LT. (-0.5D0) .AND. ABS((X-AINT(X-0.5D0))/X) .LT. DXREL)
+     +   CALL XERMSG ('SLATEC', 'DGAMMA',
+     +   'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER',
+     +   1, 1)
+C
+      DO 20 I=1,N
+        DGAMMA = DGAMMA/(X+I-1 )
+ 20   CONTINUE
+      RETURN
+C
+C GAMMA(X) FOR X .GE. 2.0 AND X .LE. 10.0
+C
+ 30   DO 40 I=1,N
+        DGAMMA = (Y+I) * DGAMMA
+ 40   CONTINUE
+      RETURN
+C
+C GAMMA(X) FOR ABS(X) .GT. 10.0.  RECALL Y = ABS(X).
+C
+ 50   IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DGAMMA',
+     +   'X SO BIG GAMMA OVERFLOWS', 3, 2)
+C
+      DGAMMA = 0.D0
+      IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DGAMMA',
+     +   'X SO SMALL GAMMA UNDERFLOWS', 2, 1)
+      IF (X.LT.XMIN) RETURN
+C
+      DGAMMA = EXP ((Y-0.5D0)*LOG(Y) - Y + SQ2PIL + D9LGMC(Y) )
+      IF (X.GT.0.D0) RETURN
+C
+      IF (ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) CALL XERMSG ('SLATEC',
+     +   'DGAMMA',
+     +   'ANSWER LT HALF PRECISION, X TOO NEAR NEGATIVE INTEGER', 1, 1)
+C
+      SINPIY = SIN (PI*Y)
+      IF (SINPIY .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DGAMMA',
+     +   'X IS A NEGATIVE INTEGER', 4, 2)
+C
+      DGAMMA = -PI/(Y*SINPIY*DGAMMA)
+C
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/slatec-fn/dlgams.f
@@ -0,0 +1,37 @@
+*DECK DLGAMS
+      SUBROUTINE DLGAMS (X, DLGAM, SGNGAM)
+C***BEGIN PROLOGUE  DLGAMS
+C***PURPOSE  Compute the logarithm of the absolute value of the Gamma
+C            function.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C7A
+C***TYPE      DOUBLE PRECISION (ALGAMS-S, DLGAMS-D)
+C***KEYWORDS  ABSOLUTE VALUE OF THE LOGARITHM OF THE GAMMA FUNCTION,
+C             FNLIB, SPECIAL FUNCTIONS
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C DLGAMS(X,DLGAM,SGNGAM) calculates the double precision natural
+C logarithm of the absolute value of the Gamma function for
+C double precision argument X and stores the result in double
+C precision argument DLGAM.
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  DLNGAM
+C***REVISION HISTORY  (YYMMDD)
+C   770701  DATE WRITTEN
+C   890531  Changed all specific intrinsics to generic.  (WRB)
+C   890531  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C***END PROLOGUE  DLGAMS
+      DOUBLE PRECISION X, DLGAM, SGNGAM, DLNGAM
+C***FIRST EXECUTABLE STATEMENT  DLGAMS
+      DLGAM = DLNGAM(X)
+      SGNGAM = 1.0D0
+      IF (X.GT.0.D0) RETURN
+C
+      INT = MOD (-AINT(X), 2.0D0) + 0.1D0
+      IF (INT.EQ.0) SGNGAM = -1.0D0
+C
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/slatec-fn/dlngam.f
@@ -0,0 +1,73 @@
+*DECK DLNGAM
+      DOUBLE PRECISION FUNCTION DLNGAM (X)
+C***BEGIN PROLOGUE  DLNGAM
+C***PURPOSE  Compute the logarithm of the absolute value of the Gamma
+C            function.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C7A
+C***TYPE      DOUBLE PRECISION (ALNGAM-S, DLNGAM-D, CLNGAM-C)
+C***KEYWORDS  ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM,
+C             SPECIAL FUNCTIONS
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C DLNGAM(X) calculates the double precision logarithm of the
+C absolute value of the Gamma function for double precision
+C argument X.
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  D1MACH, D9LGMC, DGAMMA, XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   770601  DATE WRITTEN
+C   890531  Changed all specific intrinsics to generic.  (WRB)
+C   890531  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+C   900727  Added EXTERNAL statement.  (WRB)
+C***END PROLOGUE  DLNGAM
+      DOUBLE PRECISION X, DXREL, PI, SINPIY, SQPI2L, SQ2PIL, XMAX,
+     1  Y, DGAMMA, D9LGMC, D1MACH, TEMP
+      LOGICAL FIRST
+      EXTERNAL DGAMMA
+      SAVE SQ2PIL, SQPI2L, PI, XMAX, DXREL, FIRST
+      DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 /
+      DATA SQPI2L / +.2257913526 4472743236 3097614947 441 D+0    /
+      DATA PI / 3.1415926535 8979323846 2643383279 50 D0 /
+      DATA FIRST /.TRUE./
+C***FIRST EXECUTABLE STATEMENT  DLNGAM
+      IF (FIRST) THEN
+         TEMP = 1.D0/LOG(D1MACH(2))
+         XMAX = TEMP*D1MACH(2)
+         DXREL = SQRT(D1MACH(4))
+      ENDIF
+      FIRST = .FALSE.
+C
+      Y = ABS (X)
+      IF (Y.GT.10.D0) GO TO 20
+C
+C LOG (ABS (DGAMMA(X)) ) FOR ABS(X) .LE. 10.0
+C
+      DLNGAM = LOG (ABS (DGAMMA(X)) )
+      RETURN
+C
+C LOG ( ABS (DGAMMA(X)) ) FOR ABS(X) .GT. 10.0
+C
+ 20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'DLNGAM',
+     +   'ABS(X) SO BIG DLNGAM OVERFLOWS', 2, 2)
+C
+      IF (X.GT.0.D0) DLNGAM = SQ2PIL + (X-0.5D0)*LOG(X) - X + D9LGMC(Y)
+      IF (X.GT.0.D0) RETURN
+C
+      SINPIY = ABS (SIN(PI*Y))
+      IF (SINPIY .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DLNGAM',
+     +   'X IS A NEGATIVE INTEGER', 3, 2)
+C
+      IF (ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) CALL XERMSG ('SLATEC',
+     +   'DLNGAM',
+     +   'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER',
+     +   1, 1)
+C
+      DLNGAM = SQPI2L + (X-0.5D0)*LOG(Y) - X - LOG(SINPIY) - D9LGMC(Y)
+      RETURN
+C
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/slatec-fn/initds.f
@@ -0,0 +1,54 @@
+*DECK INITDS
+      FUNCTION INITDS (OS, NOS, ETA)
+C***BEGIN PROLOGUE  INITDS
+C***PURPOSE  Determine the number of terms needed in an orthogonal
+C            polynomial series so that it meets a specified accuracy.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C3A2
+C***TYPE      DOUBLE PRECISION (INITS-S, INITDS-D)
+C***KEYWORDS  CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL,
+C             ORTHOGONAL SERIES, SPECIAL FUNCTIONS
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C  Initialize the orthogonal series, represented by the array OS, so
+C  that INITDS is the number of terms needed to insure the error is no
+C  larger than ETA.  Ordinarily, ETA will be chosen to be one-tenth
+C  machine precision.
+C
+C             Input Arguments --
+C   OS     double precision array of NOS coefficients in an orthogonal
+C          series.
+C   NOS    number of coefficients in OS.
+C   ETA    single precision scalar containing requested accuracy of
+C          series.
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   770601  DATE WRITTEN
+C   890531  Changed all specific intrinsics to generic.  (WRB)
+C   890831  Modified array declarations.  (WRB)
+C   891115  Modified error message.  (WRB)
+C   891115  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
+C***END PROLOGUE  INITDS
+      DOUBLE PRECISION OS(*)
+C***FIRST EXECUTABLE STATEMENT  INITDS
+      IF (NOS .LT. 1) CALL XERMSG ('SLATEC', 'INITDS',
+     +   'Number of coefficients is less than 1', 2, 1)
+C
+      ERR = 0.
+      DO 10 II = 1,NOS
+        I = NOS + 1 - II
+        ERR = ERR + ABS(REAL(OS(I)))
+        IF (ERR.GT.ETA) GO TO 20
+   10 CONTINUE
+C
+   20 IF (I .EQ. NOS) CALL XERMSG ('SLATEC', 'INITDS',
+     +   'Chebyshev series too short for specified accuracy', 1, 1)
+      INITDS = I
+C
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/villad/dfopr.f
@@ -0,0 +1,176 @@
+      SUBROUTINE DFOPR
+     +  (
+     +  ND, N, N0, N1, I, ID, DIF1, DIF2, DIF3, ROOT, VECT
+     +  )
+      INTEGER           ND, N, N0, N1, I, ID
+      DOUBLE PRECISION  DIF1(ND), DIF2(ND), DIF3(ND), ROOT(ND), VECT(ND)
+C
+C***********************************************************************
+C
+C     VILLADSEN AND MICHELSEN, PAGES 133-134, 419
+C
+C     INPUT PARAMETERS:
+C
+C       ND     : THE DIMENSION OF THE VECTORS DIF1, DIF2, DIF3, AND ROOT
+C
+C       N      : THE DEGREE OF THE JACOBI POLYNOMIAL, (i.e. THE NUMBER
+C                OF INTERIOR INTERPOLATION POINTS)
+C
+C       N0     : DETERMINES WHETHER X = 0 IS INCLUDED AS AN
+C                INTERPOLATION POINT
+C
+C                  N0 = 0  ==>  X = 0 IS NOT INCLUDED
+C                  N0 = 1  ==>  X = 0 IS INCLUDED
+C
+C       N1     : DETERMINES WHETHER X = 1 IS INCLUDED AS AN
+C                INTERPOLATION POINT
+C
+C                  N1 = 0  ==>  X = 1 IS NOT INCLUDED
+C                  N1 = 1  ==>  X = 1 IS INCLUDED
+C
+C       I      : THE INDEX OF THE NODE FOR WHICH THE WEIGHTS ARE TO BE
+C                CALCULATED
+C
+C       ID     : INDICATOR
+C
+C                  ID = 1  ==>  FIRST DERIVATIVE WEIGHTS ARE COMPUTED
+C                  ID = 2  ==>  SECOND DERIVATIVE WEIGHTS ARE COMPUTED
+C                  ID = 3  ==>  GAUSSIAN WEIGHTS ARE COMPUTED (IN THIS
+C                               CASE, THE VALUE OF I IS IRRELEVANT)
+C
+C     OUTPUT PARAMETERS:
+C
+C       DIF1   : ONE DIMENSIONAL VECTOR CONTAINING THE FIRST DERIVATIVE
+C                OF THE NODE POLYNOMIAL AT THE ZEROS
+C
+C       DIF2   : ONE DIMENSIONAL VECTOR CONTAINING THE SECOND DERIVATIVE
+C                OF THE NODE POLYNOMIAL AT THE ZEROS
+C
+C       DIF3   : ONE DIMENSIONAL VECTOR CONTAINING THE THIRD DERIVATIVE
+C                OF THE NODE POLYNOMIAL AT THE ZEROS
+C
+C       VECT   : ONE DIMENSIONAL VECTOR OF COMPUTED WEIGHTS
+C
+C     COMMON BLOCKS:      NONE
+C
+C     REQUIRED ROUTINES:  VILERR
+C
+C***********************************************************************
+C
+      INTEGER           J,NT,IER
+      DOUBLE PRECISION  AX,X,Y
+      DOUBLE PRECISION  ZERO,ONE,TWO,THREE
+      LOGICAL          LSTOP
+C
+      PARAMETER ( ZERO = 0.0D+00, ONE    = 1.0D+00,
+     +            TWO  = 2.0D+00, THREE  = 3.0D+00 )
+C
+C -- ERROR CHECKING
+C
+      IF ((N0 .NE. 0) .AND. (N0 .NE. 1)) THEN
+        IER   = 1
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+      IF ((N1 .NE. 0) .AND. (N1 .NE. 1)) THEN
+        IER   = 2
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+      IF (ND .LT. (N + N0 + N1)) THEN
+        IER   = 3
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+      IF ((ID .NE. 1) .AND. (ID.NE. 2) .AND. (ID .NE. 3)) THEN
+        IER   = 6
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+      IF (ID .NE. 3) THEN
+        IF (I .LT. 1) THEN
+          IER   = 4
+          LSTOP = .TRUE.
+          CALL VILERR(IER,LSTOP)
+        ELSE
+        END IF
+C
+        IF (I .GT. (N + N0 + N1)) THEN
+          IER   = 5
+          LSTOP = .TRUE.
+          CALL VILERR(IER,LSTOP)
+        ELSE
+        END IF
+      ELSE
+      END IF
+C
+      IF ((N + N0 + N1) .LT. 1) THEN
+        IER   = 7
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+C -- EVALUATE DISCRETIZATION MATRICES AND GAUSSIAN QUADRATURE
+C -- WEIGHTS.  QUADRATURE WEIGHTS ARE NORMALIZED TO SUM TO ONE.
+C
+      NT = N + N0 + N1
+C
+      IF (ID .NE. 3) THEN
+        DO 20 J = 1,NT
+C
+          IF (J .EQ. I) THEN
+            IF (ID .EQ. 1) THEN
+              VECT(I) = DIF2(I)/DIF1(I)/TWO
+            ELSE
+              VECT(I) = DIF3(I)/DIF1(I)/THREE
+            END IF
+          ELSE
+            Y       = ROOT(I) - ROOT(J)
+            VECT(J) = DIF1(I)/DIF1(J)/Y
+            IF (ID .EQ. 2) THEN
+              VECT(J) = VECT(J)*(DIF2(I)/DIF1(I) - TWO/Y)
+            ELSE
+            END IF
+          END IF
+C
+   20   CONTINUE
+      ELSE
+        Y = ZERO
+C
+        DO 25 J = 1,NT
+C
+          X  = ROOT(J)
+          AX = X*(ONE - X)
+C
+          IF(N0 .EQ. 0) THEN
+            AX = AX/X/X
+          ELSE
+          END IF
+C
+          IF(N1 .EQ. 0) THEN
+            AX = AX/(ONE - X)/(ONE - X)
+          ELSE
+          END IF
+C
+          VECT(J) = AX/DIF1(J)**2
+          Y       = Y + VECT(J)
+C
+   25   CONTINUE
+C
+        DO 60 J = 1,NT
+          VECT(J) = VECT(J)/Y
+   60   CONTINUE
+C
+      END IF
+C
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/villad/dif.f
@@ -0,0 +1,74 @@
+      SUBROUTINE DIF ( NT, ROOT, DIF1, DIF2, DIF3 )
+C
+      INTEGER           NT
+      DOUBLE PRECISION  ROOT(NT), DIF1(NT), DIF2(NT), DIF3(NT)
+
+C
+C***********************************************************************
+C
+C     SUBROUTINE DIF
+C
+C     THIS ROUTINE IS NOT GIVEN SEPARATELY BY VILLADSEN AND MICHELSEN
+C     BUT AS PART OF JCOBI
+C
+C     DIF COMPUTES THE FIRST THREE DERIVATIVES OF THE NODE POLYNOMIAL
+C
+C                     N0     (ALPHA,BETA)           N1
+C       P  (X)  =  (X)   *  P (X)         *  (1 - X)
+C        NT                   N
+C
+C     AT THE INTERPOLATION POINTS.  EACH OF THE PARAMETERS N0 AND N1
+C     MAY BE GIVEN THE VALUE 0 OR 1.  NT = N + N0 + N1
+C
+C     THE VALUES OF ROOT MUST BE KNOWN BEFORE A CALL TO DIF IS POSSIBLE.
+C     THEY MAY BE COMPUTED USING JCOBI.
+C
+C     PARAMETER LIST:     SEE THE SUBROUTINE JCOBI
+C
+C     COMMON BLOCKS:      NONE
+C
+C     REQUIRED ROUTINES:  VILERR
+C
+C***********************************************************************
+C
+      INTEGER           I,J,IER
+      DOUBLE PRECISION  X,Y
+      DOUBLE PRECISION  ZERO,ONE,TWO,THREE
+      LOGICAL           LSTOP
+C
+      PARAMETER ( ZERO = 0.0D+00, ONE   = 1.0D+00,
+     +            TWO  = 2.0D+00, THREE = 3.0D+00 )
+C
+C -- ERROR CHECKING
+C
+      IF (NT .LT. 1) THEN
+        IER   = 7
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+C -- EVALUATE DERIVATIVES OF NODE POLYNOMIAL USING RECURSION FORMULAS
+C
+      DO 40 I = 1,NT
+C
+        X       = ROOT(I)
+        DIF1(I) = ONE
+        DIF2(I) = ZERO
+        DIF3(I) = ZERO
+C
+        DO 30 J = 1,NT
+C
+          IF (J .NE. I) THEN
+            Y       = X - ROOT(J)
+            DIF3(I) = Y*DIF3(I) + THREE*DIF2(I)
+            DIF2(I) = Y*DIF2(I) + TWO  *DIF1(I)
+            DIF1(I) = Y*DIF1(I)
+          ELSE
+          END IF
+C
+   30   CONTINUE
+   40 CONTINUE
+C
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/villad/intrp.f
@@ -0,0 +1,93 @@
+      SUBROUTINE INTRP ( ND, NT, X, ROOT, DIF1, XINTP )
+C
+      INTEGER           ND, NT
+      DOUBLE PRECISION  ROOT(ND), DIF1(ND), XINTP(ND)
+C
+C***********************************************************************
+C
+C     LAGRANGE INTERPOLATION
+C
+C     VILLADSEN AND MICHELSEN, PAGES 132-133, 420
+C
+C     INPUT PARAMETERS:
+C
+C       NT     : THE TOTAL NUMBER OF INTERPOLATION POINTS FOR WHICH THE
+C                VALUE OF THE DEPENDENT VARIABLE Y IS KNOWN.  NOTE:
+C
+C                  NT = N + N0 + N1
+C
+C       X      : THE ABCISSA X WHERE Y(X) IS DESIRED
+C
+C       ROOT   : ONE DIMENSIONAL VECTOR CONTAINING ON EXIT THE
+C                N + N0 + N1 ZEROS OF THE NODE POLYNOMIAL USED IN THE
+C                INTERPOLATION ROUTINE
+C
+C       DIF1   : ONE DIMENSIONAL VECTOR CONTAINING THE FIRST DERIVATIVE
+C                OF THE NODE POLYNOMIAL AT THE ZEROS
+C
+C     OUTPUT PARAMETERS:
+C
+C       XINTP  : THE VECTOR OF INTERPOLATION WEIGHTS
+C
+C                Y(X) IS GIVEN BY:
+C
+C                            NT
+C                  Y(X)  =  SUM  XINTRP(I) * Y(I)
+C                           I=1
+C
+C     COMMON BLOCKS:      NONE
+C
+C     REQUIRED ROUTINES:  VILERR
+C
+C***********************************************************************
+C
+      INTEGER           I,IER
+      DOUBLE PRECISION  POL,Y,X
+      DOUBLE PRECISION  ZERO,ONE
+      LOGICAL           LSTOP
+C
+      PARAMETER ( ZERO = 0.0D+00, ONE = 1.0D+00 )
+C
+C -- ERROR CHECKING
+C
+      IF (ND .LT. NT) THEN
+        IER   = 3
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+      IF (NT .LT. 1) THEN
+        IER   = 7
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+C -- EVALUATE LAGRANGIAN INTERPOLATION COEFFICIENTS
+C
+      POL = ONE
+C
+      DO 5 I = 1,NT
+C
+        Y        = X - ROOT(I)
+        XINTP(I) = ZERO
+C
+        IF (Y .EQ. ZERO) THEN
+          XINTP(I) = ONE
+        ELSE
+        END IF
+C
+        POL = POL*Y
+C
+    5 CONTINUE
+C
+      IF (POL .NE. ZERO) THEN
+        DO 6 I = 1,NT
+          XINTP(I) = POL/DIF1(I)/(X - ROOT(I))
+    6   CONTINUE
+      ELSE
+      END IF
+C
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/villad/jcobi.f
@@ -0,0 +1,240 @@
+****************************************************************
+*
+*     The following routines (JCOBI, DIF, DFOPR, INTRP, AND RADAU)
+*     are the same as found in Villadsen, J. and M.L. Michelsen,
+*     Solution of Differential Equation Models by Polynomial
+*     Approximation, Prentice-Hall (1978) pages 418-420.
+*
+*     Cosmetic changes (elimination of arithmetic IF statements, most
+*     GO TO statements, and indentation of program blocks) made by:
+*
+*     John W. Eaton
+*     Department of Chemical Engineering
+*     The University of Texas at Austin
+*     Austin, Texas 78712
+*
+*     June 6, 1987
+*
+*     Some error checking additions also made on June 7, 1987
+*
+*     Further cosmetic changes made August 20, 1987
+*
+************************************************************************
+*
+      SUBROUTINE JCOBI
+     +  (
+     +  ND, N, N0, N1, ALPHA, BETA, DIF1, DIF2, DIF3, ROOT
+     +  )
+C
+      INTEGER
+     +
+     +  ND, N, N0, N1
+C 
+      DOUBLE PRECISION
+     +
+     +  ALPHA, BETA, DIF1(ND), DIF2(ND), DIF3(ND), ROOT(ND)
+C
+C***********************************************************************
+C
+C     VILLADSEN AND MICHELSEN, PAGES 131-132, 418
+C
+C     THIS SUBROUTINE COMPUTES THE ZEROS OF THE JACOBI POLYNOMIAL
+C
+C        (ALPHA,BETA)
+C       P  (X)
+C        N
+C
+C     USE DIF (GIVEN BELOW) TO COMPUTE THE DERIVATIVES OF THE NODE
+C     POLYNOMIAL
+C
+C                     N0     (ALPHA,BETA)           N1
+C       P  (X)  =  (X)   *  P (X)         *  (1 - X)
+C        NT                   N
+C
+C     AT THE INTERPOLATION POINTS.
+C
+C     INPUT PARAMETERS:
+C
+C       ND     : THE DIMENSION OF THE VECTORS DIF1, DIF2, DIF3, AND ROOT
+C
+C       N      : THE DEGREE OF THE JACOBI POLYNOMIAL, (i.e. THE NUMBER
+C                OF INTERIOR INTERPOLATION POINTS)
+C
+C       N0     : DETERMINES WHETHER X = 0 IS INCLUDED AS AN
+C                INTERPOLATION POINT
+C
+C                  N0 = 0  ==>  X = 0 IS NOT INCLUDED
+C                  N0 = 1  ==>  X = 0 IS INCLUDED
+C
+C       N1     : DETERMINES WHETHER X = 1 IS INCLUDED AS AN
+C                INTERPOLATION POINT
+C
+C                  N1 = 0  ==>  X = 1 IS NOT INCLUDED
+C                  N1 = 1  ==>  X = 1 IS INCLUDED
+C
+C       ALPHA  : THE VALUE OF ALPHA IN THE DESCRIPTION OF THE JACOBI
+C                POLYNOMIAL
+C
+C       BETA   : THE VALUE OF BETA IN THE DESCRIPTION OF THE JACOBI
+C                POLYNOMIAL
+C
+C       FOR A MORE COMPLETE EXPLANATION OF ALPHA AN BETA, SEE VILLADSEN
+C       AND MICHELSEN, PAGES 57 TO 59
+C
+C     OUTPUT PARAMETERS:
+C
+C       ROOT   : ONE DIMENSIONAL VECTOR CONTAINING ON EXIT THE
+C                N + N0 + N1 ZEROS OF THE NODE POLYNOMIAL USED IN THE
+C                INTERPOLATION ROUTINE
+C
+C       DIF1   : ONE DIMENSIONAL VECTOR CONTAINING THE FIRST DERIVATIVE
+C                OF THE NODE POLYNOMIAL AT THE ZEROS
+C
+C       DIF2   : ONE DIMENSIONAL VECTOR CONTAINING THE SECOND DERIVATIVE
+C                OF THE NODE POLYNOMIAL AT THE ZEROS
+C
+C       DIF3   : ONE DIMENSIONAL VECTOR CONTAINING THE THIRD DERIVATIVE
+C                OF THE NODE POLYNOMIAL AT THE ZEROS
+C
+C     COMMON BLOCKS:      NONE
+C
+C     REQUIRED ROUTINES:  VILERR, DIF
+C
+C***********************************************************************
+C
+      INTEGER           I,J,NT,IER
+      DOUBLE PRECISION  AB,AD,AP,Z1,Z,Y,X,XD,XN,XD1,XN1,XP,XP1,ZC
+      DOUBLE PRECISION  ZERO,ONE,TWO
+      LOGICAL           LSTOP
+C
+      PARAMETER ( ZERO = 0.0D+00, ONE = 1.0D+00, TWO = 2.0D+00 )
+C
+C -- ERROR CHECKING
+C
+      IF ((N0 .NE. 0) .AND. (N0 .NE. 1)) THEN
+        IER   = 1
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+      IF ((N1 .NE. 0) .AND. (N1 .NE. 1)) THEN
+        IER   = 2
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+      IF (ND .LT. (N + N0 + N1)) THEN
+        IER   = 3
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+      IF ((N + N0 + N1) .LT. 1) THEN
+        IER   = 7
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+C -- FIRST EVALUATION OF COEFFICIENTS IN RECURSION FORMULAS.
+C -- RECURSION COEFFICIENTS ARE STORED IN DIF1 AND DIF2.
+C
+      AB      = ALPHA + BETA
+      AD      = BETA - ALPHA
+      AP      = BETA*ALPHA
+      DIF1(1) = (AD/(AB + TWO) + ONE)/TWO
+      DIF2(1) = ZERO
+C
+      IF(N .GE. 2) THEN
+        DO 10 I = 2,N
+C
+          Z1      = DBLE(I) - ONE
+          Z       = AB + 2*Z1
+          DIF1(I) = (AB*AD/Z/(Z + TWO) + ONE)/TWO
+C
+          IF (I .EQ. 2) THEN
+            DIF2(I) = (AB + AP + Z1)/Z/Z/(Z + ONE)
+          ELSE
+            Z       = Z*Z
+            Y       = Z1*(AB + Z1)
+            Y       = Y*(AP + Y)
+            DIF2(I) = Y/Z/(Z - ONE)
+          END IF
+C
+   10   CONTINUE
+      ELSE
+      END IF
+C
+C -- ROOT DETERMINATION BY NEWTON METHOD WITH SUPPRESSION OF
+C -- PREVIOUSLY DETERMINED ROOTS
+C
+      X = ZERO
+C
+      DO 20 I = 1,N
+C
+   25   CONTINUE
+        XD  = ZERO
+        XN  = ONE
+        XD1 = ZERO
+        XN1 = ZERO
+C
+        DO 30 J = 1,N
+          XP  = (DIF1(J) - X)*XN  - DIF2(J)*XD
+          XP1 = (DIF1(J) - X)*XN1 - DIF2(J)*XD1 - XN
+          XD  = XN
+          XD1 = XN1
+          XN  = XP
+          XN1 = XP1
+   30   CONTINUE
+C
+        ZC  = ONE
+        Z   = XN/XN1
+C
+        IF (I .NE. 1) THEN
+          DO 22 J = 2,I
+            ZC = ZC - Z/(X - ROOT(J-1))
+   22     CONTINUE
+        ELSE
+        END IF
+C
+        Z  = Z/ZC
+        X  = X - Z
+C
+        IF (DABS(Z) .GT. 1.D-09) THEN
+C
+C -- BACKWARD BRANCH
+C
+          GO TO 25
+        ELSE
+        END IF
+C
+        ROOT(I) = X
+        X = X + 0.0001D0
+C
+   20 CONTINUE
+C
+C -- ADD INTERPOLATION POINTS AT X = 0 AND/OR X = 1
+C
+      NT = N + N0 + N1
+C
+      IF (N0 .NE. 0) THEN
+        DO 31 I = 1,N
+          J = N + 1 - I
+          ROOT(J+1) = ROOT(J)
+   31   CONTINUE
+        ROOT(1) = ZERO
+      ELSE
+      END IF
+C
+      IF (N1 .EQ. 1) THEN
+        ROOT(NT) = ONE
+      ELSE
+      END IF
+C
+      CALL DIF ( NT, ROOT, DIF1, DIF2, DIF3 )
+C
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/villad/radau.f
@@ -0,0 +1,209 @@
+      SUBROUTINE RADAU
+     +  (
+     +  ND, N, N0, N1, ID, ALPHA, BETA, ROOT, DIF1, VECT
+     +  )
+C
+      INTEGER           ND, N, N0, N1, ID
+      DOUBLE PRECISION  ALPHA, BETA, ROOT(ND), DIF1(ND), VECT(ND)
+C
+C***********************************************************************
+C
+C     RADAU OR LOBATTO QUADRATURE
+C
+C     VILLADSEN AND MICHELSEN, PAGES 133-135, 419
+C
+C     INPUT PARAMETERS:
+C
+C       ND     : THE DIMENSION OF THE VECTORS DIF1, DIF2, DIF3, AND ROOT
+C
+C       N      : THE DEGREE OF THE JACOBI POLYNOMIAL, (i.e. THE NUMBER
+C                OF INTERIOR INTERPOLATION POINTS)
+C
+C       N0     : DETERMINES WHETHER X = 0 IS INCLUDED AS AN
+C                INTERPOLATION POINT
+C
+C                  N0 = 0  ==>  X = 0 IS NOT INCLUDED
+C                  N0 = 1  ==>  X = 0 IS INCLUDED
+C
+C       N1     : DETERMINES WHETHER X = 1 IS INCLUDED AS AN
+C                INTERPOLATION POINT
+C
+C                  N1 = 0  ==>  X = 1 IS NOT INCLUDED
+C                  N1 = 1  ==>  X = 1 IS INCLUDED
+C
+C       ID     : INDICATOR
+C
+C                  ID = 1  ==>  RADAU QUADRATURE WEIGHTS INCLUDING X = 1
+C                  ID = 2  ==>  RADAU QUADRATURE WEIGHTS INCLUDING X = 0
+C                  ID = 3  ==>  LOBATTO QUADRATURE WEIGHTS INCLUDING
+C                               BOTH X = 0 AND X = 1
+C
+C       ALPHA  : THE VALUE OF ALPHA IN THE DESCRIPTION OF THE JACOBI
+C                POLYNOMIAL
+C
+C       BETA   : THE VALUE OF BETA IN THE DESCRIPTION OF THE JACOBI
+C                POLYNOMIAL
+C
+C                FOR A MORE COMPLETE EXPLANATION OF ALPHA AN BETA, SEE
+C                VILLADSEN AND MICHELSEN, PAGES 57 TO 59
+C
+C       ROOT   : ONE DIMENSIONAL VECTOR CONTAINING ON EXIT THE
+C                N + N0 + N1 ZEROS OF THE NODE POLYNOMIAL USED IN THE
+C                INTERPOLATION ROUTINE
+C
+C       DIF1   : ONE DIMENSIONAL VECTOR CONTAINING THE FIRST DERIVATIVE
+C                OF THE NODE POLYNOMIAL AT THE ZEROS
+C
+C       THE NODE POLYNOMIAL IS GIVEN BY
+C
+C                     N0    (ALPHA',BETA')          N1
+C         P  (X)  =  X   * P (X)           * (X - 1)
+C          NT               N
+C
+C       THE ARGUMENTS ALPHA' AND BETA' TO BE USED IN JCOBI FOR
+C       CALCULATION OF ROOT AND DIF1 DEPEND ON WHETHER X = 0 , X = 1 OR
+C       BOTH ARE USED AS EXTRA QUADRATURE POINTS.  THUS:
+C
+C         ID = 1:  ALPHA' = ALPHA + 1, BETA' = BETA
+C         ID = 2:  ALPHA' = ALPHA    , BETA' = BETA + 1
+C         ID = 3:  ALPHA' = ALPHA + 1, BETA' = BETA + 1
+C
+C       NOTE:
+C
+C         ID = 1  REQUIRES THAT N0 = 0 OR 1, N1 = 1
+C         ID = 2  REQUIRES THAT N0 = 1     , N1 = 0 OR 1
+C         ID = 3  REQUIRES THAT N0 = 1     , N1 = 1
+C
+C     OUTPUT PARAMETERS:
+C
+C       VECT   : VECTOR OF THE NT COMPUTED QUADRATURE WEIGHTS,
+C                NORMALIZED SUCH THAT
+C
+C                   NT
+C                  SUM  VECT(I) = 1
+C                  I=1
+C
+C                FOR A MORE COMPLETE EXPLANATION SEE VILLADSEN AND
+C                MICHELSEN, PAGES 133 TO 135
+C
+C     COMMON BLOCKS:      NONE
+C
+C     REQUIRED ROUTINES:  VILERR
+C
+C***********************************************************************
+C
+      INTEGER           I,NT,IER
+      DOUBLE PRECISION  AX,S,X
+      DOUBLE PRECISION  ZERO,ONE
+      LOGICAL           LSTOP
+C
+      PARAMETER ( ZERO = 0.0D+00, ONE = 1.0D+00 )
+C
+C -- ERROR CHECKING
+C
+      IF ((N0 .NE. 0) .AND. (N0 .NE. 1)) THEN
+        IER   = 1
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+      IF ((N1 .NE. 0) .AND. (N1 .NE. 1)) THEN
+        IER   = 2
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+      IF (ND .LT. (N + N0 + N1)) THEN
+        IER   = 3
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+      IF ((N + N0 + N1) .LT. 1) THEN
+        IER   = 7
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+      IF ((ID .NE. 1) .AND. (ID.NE. 2) .AND. (ID .NE. 3)) THEN
+        IER   = 8
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+      IF ((ID .EQ. 1) .AND. (N1 .NE. 1)) THEN
+        IER   = 9
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+      IF ((ID .EQ. 2) .AND. (N0 .NE. 1)) THEN
+        IER   = 10
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+      IF ((ID .EQ. 3) .AND. ((N0 .NE. 1) .OR. (N1 .NE. 1))) THEN
+        IER   = 11
+        LSTOP = .TRUE.
+        CALL VILERR(IER,LSTOP)
+      ELSE
+      END IF
+C
+C -- EVALUATE RADAU OR LOBATTO QUADRATURE WEIGHTS
+C
+      S  = ZERO
+      NT = N + N0 + N1
+C
+      DO 40 I = 1,NT
+C
+        X = ROOT(I)
+C
+        IF      (ID .EQ. 1) THEN
+          AX = X
+          IF (N0 .EQ. 0) THEN
+            AX = ONE/AX
+          ELSE
+          END IF
+        ELSE IF (ID .EQ. 2) THEN
+          AX = ONE - X
+          IF (N1 .EQ. 0) THEN
+            AX = ONE/AX
+          ELSE
+          END IF
+        ELSE IF (ID .EQ. 3) THEN
+          AX = ONE
+        ELSE
+        END IF
+C
+        VECT(I) = AX/DIF1(I)**2
+C
+   40 CONTINUE
+C
+      IF (ID .NE. 2) THEN
+        VECT(NT) = VECT(NT)/(ONE + ALPHA)
+      ELSE
+      END IF
+C
+      IF (ID .GT. 1) THEN
+        VECT(1)  = VECT( 1)/(ONE + BETA)
+      ELSE
+      END IF
+C
+      DO 50 I = 1,NT
+        S = S + VECT(I)
+   50 CONTINUE
+C
+      DO 60 I = 1,NT
+        VECT(I) = VECT(I)/S
+   60 CONTINUE
+C
+      RETURN
+      END
new file mode 100644
--- /dev/null
+++ b/libcruft/villad/vilerr.f
@@ -0,0 +1,89 @@
+      SUBROUTINE VILERR ( IER, LSTOP )
+C
+      INTEGER  IER
+      LOGICAL  LSTOP
+C
+C***********************************************************************
+C
+C     THIS SUBROUTINE HANDLES ERRORS FOR THE SUBROUTINES JCOBI, DFOPR,
+C     INTRP, AND RADAU GIVEN BY VILLADSEN AND MICHELSEN.
+C
+C     PARAMETER LIST:
+C
+C       IER    : ERROR NUMBER
+C       LSTOP  : LOGICAL FLAG
+C
+C                LSTOP = .TRUE.   ==>  FATAL ERROR, PROGRAM TERMINATION
+C                LSTOP = .FALSE.  ==>  WARNING ERROR, NORMAL RETURN
+C
+C     COMMON BLOCKS:      NONE
+C
+C     REQUIRED ROUTINES:  NONE
+C
+C***********************************************************************
+C
+C -- BEGIN
+C
+      IF      ( IER .EQ.  1) THEN
+C
+        WRITE(*,*) '** VILERR : Illegal value for N0 '
+C
+      ELSE IF ( IER .EQ.  2) THEN
+C
+        WRITE(*,*) '** VILERR : Illegal value for N1 '
+C
+      ELSE IF ( IER .EQ.  3 ) THEN
+C
+        WRITE(*,*) '** VILERR : Insufficient dimension for problem '
+C
+      ELSE IF ( IER .EQ.  4 ) THEN
+C
+        WRITE(*,*) '** VILERR : Index less than zero in DFOPR '
+C
+      ELSE IF ( IER .EQ.  5 ) THEN
+C
+        WRITE(*,*) '** VILERR : Index greater than NTOTAL in DFOPR '
+C
+      ELSE IF ( IER .EQ.  6 ) THEN
+C
+        WRITE(*,*) '** VILERR : Illegal ID in DFOPR '
+C
+      ELSE IF ( IER .EQ.  7 ) THEN
+C
+        WRITE(*,*) '** VILERR : Number of interpolation points '
+        WRITE(*,*) '            less than 1 '
+C
+      ELSE IF ( IER .EQ.  8 ) THEN
+C
+        WRITE(*,*) '** VILERR : Illegal ID in RADAU '
+C
+      ELSE IF ( IER .EQ.  9 ) THEN
+C
+        WRITE(*,*) '** VILERR : ID = 1 but N1 not equal to 1 in RADAU '
+C
+      ELSE IF ( IER .EQ. 10 ) THEN
+C
+        WRITE(*,*) '** VILERR : ID = 2 but N0 not equal to 1 in RADAU '
+C
+      ELSE IF ( IER .EQ. 11 ) THEN
+C
+        WRITE(*,*) '** VILERR : ID = 3 but N0 not equal to 1 or '
+        WRITE(*,*) '            N1 not equal to 1 in RADAU '
+C
+      ELSE
+C
+        WRITE(*,*) 'UNRECOGNIZED ERROR FLAG SET FOR VILERR '
+C
+      END IF
+C
+      IF ( LSTOP ) THEN
+C
+C -- PROGRAM EXECUTION TERMINATES HERE
+C
+        CALL XSTOPX (' ')
+C
+      ELSE
+      END IF
+C
+      RETURN
+      END