c \BeginDoc
c
c \Name: dnband
c
c \Description:
c
c  This subroutine returns the converged approximations to eigenvalues
c  of A*z = lambda*B*z and (optionally):
c
c      (1) The corresponding approximate eigenvectors;
c
c      (2) An orthonormal basis for the associated approximate
c          invariant subspace;
c
c      (3) Both.
c
c  Matrices A and B are stored in LAPACK-style banded form.
c
c  There is negligible additional cost to obtain eigenvectors.  An orthonormal
c  basis is always computed.  There is an additional storage cost of n*nev
c  if both are requested (in this case a separate array Z must be supplied).
c
c  The approximate eigenvalues and vectors are commonly called Ritz
c  values and Ritz vectors respectively.  They are referred to as such
c  in the comments that follow.  The computed orthonormal basis for the
c  invariant subspace corresponding to these Ritz values is referred to as a
c  Schur basis.
c
c  dnband can be called with one of the following modes:
c
c  Mode 1:  A*z = lambda*z.
c           ===> OP = A  and  B = I.
c
c  Mode 2:  A*z = lambda*M*z, M symmetric positive definite
c           ===> OP = inv[M]*A  and  B = M.
c
c  Mode 3:  A*z = lambda*M*z, M symmetric semi-definite
c           ===> OP = Real_Part{ inv[A - sigma*M]*M }  and  B = M.
c           ===> shift-and-invert mode (in real arithmetic)
c           If OP*z = amu*z, then
c           amu = 1/2 * [ 1/(lambda-sigma) + 1/(lambda-conjg(sigma)) ].
c           Note: If sigma is real, i.e. imaginary part of sigma is zero;
c                 Real_Part{ inv[A - sigma*M]*M } == inv[A - sigma*M]*M
c                 amu == 1/(lambda-sigma).
c
c  Mode 4:  A*z = lambda*M*z, M symmetric semi-definite
c           ===> OP = Imaginary_Part{ inv[A - sigma*M]*M }  and  B = M.
c           ===> shift-and-invert mode (in real arithmetic)
c           If OP*z = amu*z, then
c           amu = 1/2i * [ 1/(lambda-sigma) - 1/(lambda-conjg(sigma)) ].
c
c
c  The choice of mode must be specified in IPARAM(7) defined below.
c
c \Usage
c   call dnband
c      ( RVEC, HOWMNY, SELECT, DR, DI, Z, LDZ, SIGMAR, SIGMAI,
c        WORKEV, V, N, AB, MB, LDA, RFAC, CFAC, KL, KU, WHICH,
c        BMAT, NEV, TOL, RESID, NCV, V, LDV, IPARAM, WORKD,
c        WORKL, LWORKL, WORKC, IWORK, INFO )
c
c \Arguments
c
c  RVEC    LOGICAL  (INPUT)
c          Specifies whether a basis for the invariant subspace corresponding
c          to the converged Ritz value approximations for the eigenproblem
c          A*z = lambda*B*z is computed.
c
c             RVEC = .FALSE.     Compute Ritz values only.
c
c             RVEC = .TRUE.      Compute the Ritz vectors or Schur vectors.
c                                See Remarks below.
c
c  HOWMNY  Character*1  (INPUT)
c          Specifies the form of the basis for the invariant subspace
c          corresponding to the converged Ritz values that is to be computed.
c
c          = 'A': Compute NEV Ritz vectors;
c          = 'P': Compute NEV Schur vectors;
c          = 'S': compute some of the Ritz vectors, specified
c                 by the logical array SELECT.
c
c  SELECT  Logical array of dimension NCV.  (INPUT)
c          If HOWMNY = 'S', SELECT specifies the Ritz vectors to be
c          computed. To select the Ritz vector corresponding to a
c          Ritz value (DR(j), DI(j)), SELECT(j) must be set to .TRUE..
c          If HOWMNY = 'A' or 'P', SELECT is used as internal workspace.
c
c  DR      Double precision array of dimension NEV+1.  (OUTPUT)
c          On exit, DR contains the real part of the Ritz value approximations
c          to the eigenvalues of A*z = lambda*B*z.
c
c  DI      Double precision array of dimension NEV+1.  (OUTPUT)
c          On exit, DI contains the imaginary part of the Ritz value
c          approximations to the eigenvalues of A*z = lambda*B*z associated
c          with DR.
c
c          NOTE: When Ritz values are complex, they will come in complex
c                conjugate pairs.  If eigenvectors are requested, the
c                corresponding Ritz vectors will also come in conjugate
c                pairs and the real and imaginary parts of these are
c                represented in two consecutive columns of the array Z
c                (see below).
c
c  Z       Real N by NEV+1 array if RVEC = .TRUE. and HOWMNY = 'A'. (OUTPUT)
c          On exit,
c          if RVEC = .TRUE. and HOWMNY = 'A', then the columns of
c          Z represent approximate eigenvectors (Ritz vectors) corresponding
c          to the NCONV=IPARAM(5) Ritz values for eigensystem
c          A*z = lambda*B*z computed by DNAUPD.
c
c          The complex Ritz vector associated with the Ritz value
c          with positive imaginary part is stored in two consecutive
c          columns.  The first column holds the real part of the Ritz
c          vector and the second column holds the imaginary part.  The
c          Ritz vector associated with the Ritz value with negative
c          imaginary part is simply the complex conjugate of the Ritz vector
c          associated with the positive imaginary part.
c
c          If  RVEC = .FALSE. or HOWMNY = 'P', then Z is not referenced.
c
c          NOTE: If if RVEC = .TRUE. and a Schur basis is not required,
c          the array Z may be set equal to first NEV+1 columns of the Arnoldi
c          basis array V computed by DNAUPD.  In this case the Arnoldi basis
c          will be destroyed and overwritten with the eigenvector basis.
c
c  LDZ     Integer.  (INPUT)
c          The leading dimension of the array Z.  If Ritz vectors are
c          desired, then  LDZ >= max( 1, N ).  In any case,  LDZ >= 1.
c
c  SIGMAR  Double precision  (INPUT)
c          If IPARAM(7) = 3 or 4, represents the real part of the shift.
c          Not referenced if IPARAM(7) = 1 or 2.
c
c  SIGMAI  Double precision  (INPUT)
c          If IPARAM(7) = 3 or 4, represents the imaginary part of the
c          shift.
c          Not referenced if IPARAM(7) = 1 or 2.
c
c  WORKEV  Double precision work array of dimension 3*NCV.  (WORKSPACE)
c
c  N       Integer.  (INPUT)
c          Dimension of the eigenproblem.
c
c  AB      Double precision array of dimension LDA by N. (INPUT)
c          The matrix A in band storage, in rows KL+1 to
c          2*KL+KU+1; rows 1 to KL of the array need not be set.
c          The j-th column of A is stored in the j-th column of the
c          array AB as follows:
c          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
c
c  MB      Double precision array of dimension LDA by N. (INPUT)
c          The matrix M in band storage, in rows KL+1 to
c          2*KL+KU+1; rows 1 to KL of the array need not be set.
c          The j-th column of M is stored in the j-th column of the
c          array AB as follows:
c          MB(kl+ku+1+i-j,j) = M(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
c          Not referenced if IPARAM(7) = 1
c
c  LDA     Integer. (INPUT)
c          Leading dimension of AB, MB, RFAC and CFAC.
c
c  RFAC    Double precision array of LDA by N. (WORKSPACE/OUTPUT)
c          RFAC is used to store the LU factors of MB when IPARAM(7) = 2
c          is invoked.  It is used to store the LU factors of
c          (A-sigma*M) when IPARAM(7) = 3 is invoked with a real shift.
c          It is not referenced when IPARAM(7) = 1 or 4.
c
c  CFAC    Complex*16 array of LDA by N. (WORKSPACE/OUTPUT)
c          CFAC is used to store (A-SIGMA*M) and its LU factors
c          when IPARAM(7) = 3 or 4 are used with a complex shift SIGMA.
c          On exit, it contains the LU factors of (A-SIGMA*M).
c          It is not referenced when IPARAM(7) = 1 or 2.
c
c  KL      Integer. (INPUT)
c          Max(number of subdiagonals of A, number of subdiagonals of M)
c
c  KU      Integer. (OUTPUT)
c          Max(number of superdiagonals of A, number of superdiagonals of M)
c
c  WHICH   Character*2.  (INPUT)
c          When IPARAM(7)= 1 or 2,  WHICH can be set to any one of
c          the following.
c
c            'LM' -> want the NEV eigenvalues of largest magnitude.
c            'SM' -> want the NEV eigenvalues of smallest magnitude.
c            'LR' -> want the NEV eigenvalues of largest real part.
c            'SR' -> want the NEV eigenvalues of smallest real part.
c            'LI' -> want the NEV eigenvalues of largest imaginary part.
c            'SI' -> want the NEV eigenvalues of smallest imaginary part.
c
c          When IPARAM(7) = 3 or 4, WHICH should be set to 'LM' only.
c
c  BMAT    Character*1.  (INPUT)
c          BMAT specifies the type of the matrix B that defines the
c          semi-inner product for the operator OP.
c          BMAT = 'I' -> standard eigenvalue problem A*z = lambda*z
c          BMAT = 'G' -> generalized eigenvalue problem A*z = lambda*M*z

c  NEV     Integer. (INPUT)
c          Number of eigenvalues to be computed.
c
c  TOL     Double precision scalar.  (INPUT)
c          Stopping criteria: the relative accuracy of the Ritz value
c          is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)).
c          If TOL .LE. 0. is passed a default is set:
c          DEFAULT = DLAMCH('EPS')  (machine precision as computed
c                    by the LAPACK auxiliary subroutine DLAMCH).
c
c  RESID   Double precision array of length N.  (INPUT/OUTPUT)
c          On INPUT:
c          If INFO .EQ. 0, a random initial residual vector is used.
c          If INFO .NE. 0, RESID contains the initial residual vector,
c                          possibly from a previous run.
c          On OUTPUT:
c          RESID contains the final residual vector.
c
c  NCV     Integer.  (INPUT)
c          Number of columns of the matrix V (less than or equal to N).
c          Represents the dimension of the Arnoldi basis constructed
c          by dnaupd for OP.
c
c  V       Double precision array N by NCV+1.  (OUTPUT)
c          Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns
c                       represent approximate Schur vectors that span the
c                       desired invariant subspace.
c          NOTE: The array Z may be set equal to first NEV+1 columns of the
c          Arnoldi basis vector array V computed by DNAUPD. In this case
c          if RVEC = .TRUE. and HOWMNY='A', then the first NCONV=IPARAM(5)
c          are the desired Ritz vectors.
c
c  LDV     Integer.  (INPUT)
c          Leading dimension of V exactly as declared in the calling
c          program.
c
c  IPARAM  Integer array of length 11.  (INPUT/OUTPUT)
c          IPARAM(1) = ISHIFT:
c          The shifts selected at each iteration are used to restart
c          the Arnoldi iteration in an implicit fashion.
c          It is set to 1 in this subroutine.  The user do not need
c          to set this parameter.
c           ----------------------------------------------------------
c          ISHIFT = 1: exact shift with respect to the current
c                      Hessenberg matrix H.  This is equivalent to
c                      restarting the iteration from the beginning
c                      after updating the starting vector with a linear
c                      combination of Ritz vectors associated with the
c                      "wanted" eigenvalues.
c          -------------------------------------------------------------
c
c          IPARAM(2) = No longer referenced.
c
c          IPARAM(3) = MXITER
c          On INPUT:  max number of Arnoldi update iterations allowed.
c          On OUTPUT: actual number of Arnoldi update iterations taken.
c
c          IPARAM(4) = NB: blocksize to be used in the recurrence.
c          The code currently works only for NB = 1.
c
c          IPARAM(5) = NCONV: number of "converged" eigenvalues.
c
c          IPARAM(6) = IUPD
c          Not referenced. Implicit restarting is ALWAYS used.
c
c          IPARAM(7) = IPARAM(7):
c          On INPUT determines what type of eigenproblem is being solved.
c          Must be 1,2,3,4; See under \Description of dnband for the
c          four modes available.
c
c          IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO,
c          OUTPUT: NUMOP  = total number of OP*z operations,
c                  NUMOPB = total number of B*z operations if BMAT='G',
c                  NUMREO = total number of steps of re-orthogonalization.
c
c WORKD    Double precision work array of length at least 3*n. (WORKSPACE)
c
c WORKL    Double precision work array of length LWORKL. (WORKSPACE)
c
c LWORKL   Integer.  (INPUT)
c          LWORKL must be at least 3*NCV**2 + 6*NCV.
c
c WORKC    Complex*16 array of length N. (WORKSPACE)
c          Workspace used when IPARAM(7) = 3 or 4 for storing a temporary
c          complex vector.
c
c IWORK    Integer array of dimension at least N. (WORKSPACE)
c          Used when IPARAM(7)=2,3,4 to store the pivot information in the
c          factorization of M or (A-SIGMA*M).
c
c INFO     Integer.  (INPUT/OUTPUT)
c          Error flag on output.
c          =  0: Normal exit.
c          =  1: The Schur form computed by LAPACK routine dlahqr
c                could not be reordered by LAPACK routine dtrsen.
c                Re-enter subroutine DNEUPD with IPARAM(5)=NCV and
c                increase the size of the arrays DR and DI to have
c                dimension at least NCV and allocate at least NCV
c                columns for Z. NOTE: Not necessary if Z and V share
c                the same space. Please notify the authors.
c
c          = -1: N must be positive.
c          = -2: NEV must be positive.
c          = -3: NCV-NEV >= 2 and less than or equal to N.
c          = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI'
c          = -6: BMAT must be one of 'I' or 'G'.
c          = -7: Length of private work WORKL array is not sufficient.
c          = -8: Error return from calculation of a real Schur form.
c                Informational error from LAPACK routine dlahqr.
c          = -9: Error return from calculation of eigenvectors.
c                Informational error from LAPACK routine dtrevc.
c          = -10: IPARAM(7) must be 1,2,3,4.
c          = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible.
c          = -12: HOWMNY = 'S' not yet implemented
c          = -13: HOWMNY must be one of 'A' or 'P'
c          = -14: DNAUPD did not find any eigenvalues to sufficient
c                 accuracy.
c          = -15: Overflow occurs when we try to transform the Ritz
c                 values returned from DNAUPD to those of the original
c                 problem using Rayleigh Quotient.
c          = -9999: Could not build an Arnoldi factorization.
c                   IPARAM(5) returns the size of the current
c                   Arnoldi factorization.
c
c \EndDoc
c
c------------------------------------------------------------------------
c
c\BeginLib
c
c\References:
c  1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c     a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c     pp 357-385.
c
c  2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c     Restarted Arnoldi Iteration", Ph.D thesis, TR95-13, Rice Univ,
c     May 1995.
c
c\Routines called:
c     dnaupd  ARPACK reverse communication interface routine.
c     dneupd  ARPACK routine that returns Ritz values and (optionally)
c             Ritz vectors.
c     dgbtrf  LAPACK band matrix factorization routine.
c     dgbtrs  LAPACK band linear system solve routine.
c     zgbtrf  LAPACK complex band matrix factorization routine.
c     zgbtrs  LAPACK complex linear system solve routine.
c     dlacpy  LAPACK matrix copy routine.
c     dlapy2  LAPACK routine to compute sqrt(x**2+y**2) carefully.
c     dlamch  LAPACK routine to compute the underflow threshold.
c     dcopy   Level 1 BLAS that copies one vector to another.
c     ddot    Level 1 BLAS that computes the dot product of two vectors.
c     dnrm2   Level 1 BLAS that computes the norm of a vector.
c     dgbmv   Level 2 BLAS that computes the band matrix vector product.
c
c\Remarks
c
c  1. Currently only HOWMNY = 'A' and 'P' are implemented.
c
c     Let X' denote the transpose of X.
c
c  2. Schur vectors are an orthogonal representation for the basis of
c     Ritz vectors. Thus, their numerical properties are often superior.
c     If RVEC = .TRUE. then the relationship
c             A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and
c     V(:,1:IPARAM(5))' * V(:,1:IPARAM(5)) = I are approximately satisfied.
c     Here T is the leading submatrix of order IPARAM(5) of the real
c     upper quasi-triangular matrix stored workl(ipntr(12)). That is,
c     T is block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;
c     each 2-by-2 diagonal block has its diagonal elements equal and its
c     off-diagonal elements of opposite sign.  Corresponding to each 2-by-2
c     diagonal block is a complex conjugate pair of Ritz values. The real
c     Ritz values are stored on the diagonal of T.
c
c\Author
c     Danny Sorensen
c     Richard Lehoucq
c     Chao Yang
c     Dept. of Computational &
c     Applied Mathematics
c     Rice University
c     Houston, Texas
c
c\SCCS Information: @(#)
c FILE: nband.F   SID: 2.3   DATE OF SID: 10/17/00   RELEASE: 2
c
c\EndLib
c
c---------------------------------------------------------------------
c
      subroutine dnband( rvec, howmny, select, dr, di, z, ldz,  sigmar,
     &           sigmai, workev, n, ab, mb, lda, rfac,  cfac, kl, ku,
     &           which, bmat, nev, tol, resid,  ncv, v, ldv,
     &           iparam, workd, workl, lworkl, workc, iwork, info)
c
c     %------------------%
c     | Scalar Arguments |
c     %------------------%
c
      character        which*2, bmat, howmny
      integer          n, lda, kl, ku, nev, ncv, ldv,
     &                 ldz, lworkl, info
      Double precision
     &                 tol, sigmar, sigmai
c
c     %-----------------%
c     | Array Arguments |
c     %-----------------%
c
      integer          iparam(*), iwork(*)
      logical          select(*)
      Double precision
     &                 dr(*), di(*), resid(*), v(ldv,*), z(ldz,*),
     &                 ab(lda,*), mb(lda,*), rfac(lda,*),
     &                 workd(*), workl(*), workev(*)
      Complex*16
     &                 cfac(lda,*), workc(*)
c
c     %--------------%
c     | Local Arrays |
c     %--------------%
c
      integer          ipntr(14)
c
c     %---------------%
c     | Local Scalars |
c     %---------------%
c
      integer          ido, i, j, type, imid, itop, ibot, ierr
      Double precision
     &                 numr, denr, deni, dmdul, safmin
      logical          rvec, first
c
c     %------------%
c     | Parameters |
c     %------------%
c
      Double precision
     &                  one, zero
      parameter        (one = 1.0D+0, zero = 0.0D+0)
c
c
c     %-----------------------------%
c     | LAPACK & BLAS routines used |
c     %-----------------------------%
c
      Double precision
     &                 ddot, dnrm2, dlapy2, dlamch
      external         ddot, dcopy, dgbmv, zgbtrf, zgbtrs, dgbtrf,
     &                 dgbtrs, dnrm2, dlapy2, dlacpy, dlamch
c
c     %---------------------%
c     | Intrinsic Functions |
c     %---------------------%
c
      Intrinsic        dble, dimag, dcmplx
c
c     %-----------------------%
c     | Executable Statements |
c     %-----------------------%
c
c     %--------------------------------%
c     | safmin = safe minimum is such  |
c     | that 1/sfmin does not overflow |
c     %--------------------------------%
c
      safmin = dlamch('safmin')
c
c     %----------------------------------------------------------------%
c     | Set type of the problem to be solved. Check consistency        |
c     | between BMAT and IPARAM(7).                                    |
c     | type = 1 --> Solving standard problem in regular mode.         |
c     | type = 2 --> Solving standard problem in shift-invert mode.    |
c     | type = 3 --> Solving generalized problem in regular mode.      |
c     | type = 4 --> Solving generalized problem in shift-invert mode. |
c     | type = 5 --> Solving standard problem in shift-invert mode     |
c     |              using iparam(7) = 4 in DNAUPD.                    |
c     | type = 6 --> Solving generalized problem in shift-invert mode. |
c     |              using iparam(7) = 4 in DNAUPD.                    |
c     %----------------------------------------------------------------%
c
      if ( iparam(7) .eq. 1 ) then
         type = 1
      else if ( iparam(7) .eq. 3 .and. bmat .eq. 'I') then
         type = 2
      else if ( iparam(7) .eq. 2 ) then
         type = 3
      else if ( iparam(7) .eq. 3 .and. bmat .eq. 'G') then
         type = 4
      else if ( iparam(7) .eq. 4 .and. bmat .eq. 'I') then
         type = 5
      else if ( iparam(7) .eq. 4 .and. bmat .eq. 'G') then
         type = 6
      else
         print*, ' '
         print*, 'BMAT is inconsistent with IPARAM(7).'
         print*, ' '
         go to 9000
      end if
c
c     %----------------------------------%
c     | When type = 5,6 are used, sigmai |
c     | must be nonzero.                 |
c     %----------------------------------%
c
      if ( type .eq. 5 .or. type .eq. 6 ) then
          if ( sigmai .eq. zero ) then
             print*, ' '
             print*, '_NBAND: sigmai must be nonzero when type 5 or 6
     &                is used. '
             print*, ' '
             go to 9000
          end if
      end if
c
c     %------------------------%
c     | Initialize the reverse |
c     | communication flag.    |
c     %------------------------%
c
      ido   = 0
c
c     %----------------%
c     | Exact shift is |
c     | used.          |
c     %----------------%
c
      iparam(1) = 1
c
c     %-----------------------------------%
c     | Both matrices A and M are stored  |
c     | between rows itop and ibot.  Imid |
c     | is the index of the row that      |
c     | stores the diagonal elements.     |
c     %-----------------------------------%
c
      itop = kl + 1
      imid = kl + ku + 1
      ibot = 2*kl + ku + 1
c
      if ( type .eq. 2 .or. type .eq. 5 ) then
c
c         %-------------------------------%
c         | Solving a standard eigenvalue |
c         | problem in shift-invert mode. |
c         | Factor (A-sigma*I).           |
c         %-------------------------------%
c
          if (sigmai .eq. zero) then
c
c            %-----------------------------------%
c            | Construct (A-sigmar*I) and factor |
c            | in real arithmetic.               |
c            %-----------------------------------%
c
             call dlacpy ('A', ibot, n, ab, lda, rfac, lda )
             do 10 j = 1, n
                rfac(imid,j) =  ab(imid,j) - sigmar
  10         continue
             call dgbtrf(n, n, kl, ku, rfac, lda, iwork, ierr )
             if (ierr .ne. 0) then
                print*, ' '
                print*, ' _NBAND: Error with _gbtrf. '
                print*, ' '
                go to  9000
             end if
c
          else
c
c            %-----------------------------------%
c            | Construct (A-sigmar*I) and factor |
c            | in COMPLEX arithmetic.            |
c            %-----------------------------------%
c
             do 30 j = 1, n
                do 20 i = itop, ibot
                   cfac(i,j) = dcmplx(ab(i,j))
  20            continue
  30         continue
c
             do 40 j = 1, n
                cfac(imid,j) = cfac(imid,j)
     $                         - dcmplx(sigmar, sigmai)
  40         continue
c
             call zgbtrf(n, n, kl, ku, cfac, lda, iwork, ierr )
             if ( ierr .ne. 0) then
                print*, ' '
                print*, ' _NBAND: Error with _gbtrf. '
                print*, ' '
                go to  9000
             end if
c
          end if

      else if ( type .eq. 3 ) then
c
c        %-----------------------------------------------%
c        | Solving generalized eigenvalue problem in     |
c        | regular mode. Copy M to rfac, and call LAPACK |
c        | routine dgbtrf to factor M.                   |
c        %-----------------------------------------------%
c
         call dlacpy ('A', ibot, n, mb, lda, rfac, lda )
         call dgbtrf(n, n, kl, ku, rfac, lda, iwork, ierr)
         if (ierr .ne. 0) then
             print*, ' '
             print*,'_NBAND:  Error with _gbtrf.'
             print*, ' '
             go to 9000
         end if
c
      else if ( type .eq. 4 .or. type .eq. 6 ) then
c
c        %-------------------------------------------%
c        | Solving generalized eigenvalue problem in |
c        | shift-invert mode.                        |
c        %-------------------------------------------%
c
         if ( sigmai .eq. zero ) then
c
c            %--------------------------------------------%
c            | Construct (A - sigma*M) and factor in real |
c            | arithmetic.                                |
c            %--------------------------------------------%
c
             do 60 j = 1,n
                do 50 i = itop, ibot
                   rfac(i,j) = ab(i,j) - sigmar*mb(i,j)
  50            continue
  60         continue
c
             call dgbtrf(n, n, kl, ku, rfac, lda, iwork, ierr)
             if ( ierr .ne. 0 )  then
                 print*, ' '
                 print*, '_NBAND: Error with _gbtrf.'
                 print*, ' '
                 go to 9000
             end if
c
         else
c
c            %-----------------------------------------------%
c            | Construct (A - sigma*M) and factor in complex |
c            | arithmetic.                                   |
c            %-----------------------------------------------%
c
             do 80 j = 1,n
                do 70 i = itop, ibot
                   cfac(i,j) = dcmplx( ab(i,j)-sigmar*mb(i,j),
     &                         -sigmai*mb(i,j) )
  70            continue
  80         continue
c
             call zgbtrf(n, n, kl, ku, cfac, lda, iwork, ierr)
             if ( ierr .NE. 0 )  then
                print*, ' '
                print*, '_NBAND: Error with _gbtrf.'
                print*, ' '
                go to 9000
             end if
c
         end if
c
      end if
c
c     %--------------------------------------------%
c     |  M A I N   L O O P (reverse communication) |
c     %--------------------------------------------%
c
  90  continue
c
      call dnaupd ( ido, bmat, n, which, nev, tol, resid, ncv,
     &              v, ldv, iparam, ipntr, workd, workl, lworkl,
     &              info )
c
      if (ido .eq. -1) then
c
         if ( type .eq. 1) then
c
c           %----------------------------%
c           | Perform  y <--- OP*x = A*x |
c           %----------------------------%
c
            call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1),
     &                 lda, workd(ipntr(1)), 1, zero,
     &                 workd(ipntr(2)), 1)
c
         else if ( type .eq. 2 ) then
c
            if (sigmai .eq. zero) then
c
c              %----------------------------------%
c              | Shift is real.  Perform          |
c              | y <--- OP*x = inv[A-sigmar*I]*x  |
c              | to force the starting vector     |
c              | into the range of OP.            |
c              %----------------------------------%
c
               call dcopy (n, workd(ipntr(1)), 1, workd(ipntr(2)), 1)
               call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda,
     &                       iwork, workd(ipntr(2)), n, ierr)
               if ( ierr .ne. 0 ) then
                  print*, ' '
                  print*, ' _NBAND: Error with _bgtrs. '
                  print*, ' '
                  go to 9000
               end if
c
            else
c
c              %--------------------------------------------%
c              | Shift is COMPLEX. Perform                  |
c              | y <--- OP*x = Real_Part{inv[A-sigma*I]*x}  |
c              | to force the starting vector into the      |
c              | range of OP.                               |
c              %--------------------------------------------%
c
               do 100 j = 1, n
                  workc(j) = dcmplx(workd(ipntr(1)+j-1))
  100          continue
c
               call zgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda,
     &                       iwork, workc, n, ierr)
               if ( ierr .ne. 0 ) then
                  print*, ' '
                  print*, ' _NBAND: Error with _gbtrs. '
                  print*, ' '
                  go to 9000
               end if
c
               do 110 j = 1, n
                  workd(ipntr(2)+j-1) = dble(workc(j))
  110          continue
c
            end if
c
         else if ( type .eq. 3 ) then
c
c           %-----------------------------------%
c           | Perform  y <--- OP*x = inv[M]*A*x |
c           | to force the starting vector into |
c           | the range of OP.                  |
c           %-----------------------------------%
c
            call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1),
     &                  lda, workd(ipntr(1)), 1, zero,
     &                  workd(ipntr(2)), 1)
c
            call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda,
     &                    iwork, workd(ipntr(2)), n, ierr)
            if (ierr .ne. 0) then
               print*, ' '
               print*, '_NBAND: Error with _bgtrs.'
               print*, ' '
               go to 9000
            end if
c
         else if ( type .eq. 4 ) then
c
c           %-----------------------------------------%
c           | Perform y <-- OP*x                      |
c           |         = Real_part{inv[A-SIGMA*M]*M}*x |
c           | to force the starting vector into the   |
c           | range of OP.                            |
c           %-----------------------------------------%
c
            call dgbmv('Notranspose', n, n, kl, ku, one, mb(itop,1),
     &                 lda, workd(ipntr(1)), 1, zero,
     &                 workd(ipntr(2)), 1)
c
            if ( sigmai .eq. zero ) then
c
c              %---------------------%
c              | Shift is real, stay |
c              | in real arithmetic. |
c              %---------------------%
c
               call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda,
     &                      iwork, workd(ipntr(2)), n, ierr)
               if (ierr .ne. 0) then
                  print*, ' '
                  print*, '_NBAND: Error with _gbtrs.'
                  print*, ' '
                  go to 9000
               end if
c
            else
c
c              %--------------------------%
c              | Goto complex arithmetic. |
c              %--------------------------%
c
               do 120 i = 1,n
                  workc(i) = dcmplx(workd(ipntr(2)+i-1))
  120           continue
c
               call zgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda,
     &                      iwork, workc, n, ierr)
               if (ierr .ne. 0) then
                  print*, ' '
                  print*, '_NBAND: Error with _gbtrs.'
                  print*, ' '
                  go to 9000
               end if
c
               do  130 i = 1, n
                  workd(ipntr(2)+i-1) = dble(workc(i))
  130          continue
c
            end if
c
         else if ( type .eq. 5) then
c
c           %---------------------------------------%
c           | Perform y <-- OP*x                    |
c           |    = Imaginary_part{inv[A-SIGMA*I]}*x |
c           | to force the starting vector into the |
c           | range of OP.                          |
c           %---------------------------------------%
c
            do 140 j = 1, n
                  workc(j) = dcmplx(workd(ipntr(1)+j-1))
  140       continue
c
            call zgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda,
     &                    iwork, workc, n, ierr)
            if ( ierr .ne. 0 ) then
               print*, ' '
               print*, ' _NBAND: Error with _gbtrs. '
               print*, ' '
               go to 9000
            end if
c
            do 150 j = 1, n
               workd(ipntr(2)+j-1) = dimag(workc(j))
  150       continue
c
         else if ( type .eq. 6 ) then
c
c           %----------------------------------------%
c           | Perform y <-- OP*x                     |
c           |       Imaginary_part{inv[A-SIGMA*M]*M} |
c           | to force the starting vector into the  |
c           | range of OP.                           |
c           %----------------------------------------%
c
            call dgbmv('Notranspose', n, n, kl, ku, one, mb(itop,1),
     &                 lda, workd(ipntr(1)), 1, zero,
     &                 workd(ipntr(2)), 1)
c
            do 160 i = 1,n
               workc(i) = dcmplx(workd(ipntr(2)+i-1))
  160       continue
c
            call zgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda,
     &                   iwork, workc, n, ierr)
            if (ierr .ne. 0) then
               print*, ' '
               print*, '_NBAND: Error with _gbtrs.'
               print*, ' '
               go to 9000
            end if
c
            do  170 i = 1, n
               workd(ipntr(2)+i-1) = dimag(workc(i))
  170       continue
c
         end if
c
      else if (ido .eq. 1) then
c
         if ( type .eq. 1) then
c
c           %----------------------------%
c           | Perform  y <--- OP*x = A*x |
c           %----------------------------%
c
            call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1),
     &                 lda, workd(ipntr(1)), 1, zero,
     &                 workd(ipntr(2)), 1)
c
         else if ( type .eq. 2) then
c
            if ( sigmai .eq. zero) then
c
c              %----------------------------------%
c              | Shift is real.  Perform          |
c              | y <--- OP*x = inv[A-sigmar*I]*x. |
c              %----------------------------------%
c
               call dcopy (n, workd(ipntr(1)), 1, workd(ipntr(2)), 1)
               call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda,
     &                       iwork, workd(ipntr(2)), n, ierr)
            else
c
c              %------------------------------------------%
c              | Shift is COMPLEX. Perform                |
c              | y <-- OP*x = Real_Part{inv[A-sigma*I]*x} |
c              | in COMPLEX arithmetic.                   |
c              %------------------------------------------%
c
               do 180 j = 1, n
                  workc(j) = dcmplx(workd(ipntr(1)+j-1))
  180          continue
c
               call zgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda,
     &                       iwork, workc, n, ierr)
               if ( ierr .ne. 0 ) then
                  print*, ' '
                  print*, '_NBAND: Error with _gbtrs.'
                  print*, ' '
                  go to 9000
               end if
c
               do 190 j = 1, n
                  workd(ipntr(2)+j-1) = dble(workc(j))
  190          continue
c
            end if
c
         else if ( type .eq. 3 ) then
c
c           %-----------------------------------%
c           | Perform  y <--- OP*x = inv[M]*A*x |
c           %-----------------------------------%
c
            call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1),
     &                  lda, workd(ipntr(1)), 1, zero,
     &                  workd(ipntr(2)), 1)
c
            call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda,
     &                    iwork, workd(ipntr(2)), n, ierr)
            if (ierr .ne. 0) then
               print*, ' '
               print*, '_NBAND: Error with _bgtrs.'
               print*, ' '
               go to 9000
            end if
c
         else if ( type .eq. 4 ) then
c
c           %--------------------------------------%
c           | Perform  y <-- inv(A-sigma*M)*(M*x). |
c           | (M*x) has been computed and stored   |
c           | in workd(ipntr(3)).                  |
c           %--------------------------------------%
c
            if ( sigmai .eq. zero ) then
c
c              %------------------------%
c              | Shift is real, stay in |
c              | real arithmetic.       |
c              %------------------------%
c
               call dcopy(n, workd(ipntr(3)), 1, workd(ipntr(2)), 1)
               call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda,
     &                       iwork, workd(ipntr(2)), n, ierr)
               if (ierr .ne. 0) then
                  print*, ' '
                  print*, '_NBAND: Error with _gbtrs.'
                  print*, ' '
                  go to 9000
               end if
c
            else
c
c              %---------------------------%
c              | Go to COMPLEX arithmetic. |
c              %---------------------------%
c
               do 200 i = 1,n
                  workc(i) = dcmplx(workd(ipntr(3)+i-1))
  200          continue
c
               call zgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda,
     &                       iwork, workc, n, ierr)
               if (ierr .ne. 0) then
                  print*, ' '
                  print*, '_NBAND: Error in _gbtrs.'
                  print*, ' '
                  go to 9000
               end if
c
               do 210 i = 1,n
                  workd(ipntr(2)+i-1) = dble(workc(i))
  210          continue
c
            end if
c
         else if ( type .eq. 5 ) then
c
c           %---------------------------------------%
c           | Perform y <-- OP*x                    |
c           |    = Imaginary_part{inv[A-SIGMA*I]*x} |
c           %---------------------------------------%
c
            do 220 j = 1, n
                  workc(j) = dcmplx(workd(ipntr(1)+j-1))
  220       continue
c
            call zgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda,
     &                    iwork, workc, n, ierr)
            if ( ierr .ne. 0 ) then
               print*, ' '
               print*, ' _NBAND: Error with _gbtrs. '
               print*, ' '
               go to 9000
            end if
c
            do 230 j = 1, n
               workd(ipntr(2)+j-1) = dimag(workc(j))
  230       continue
c
         else if ( type .eq. 6) then
c
c           %-----------------------------------------%
c           | Perform y <-- OP*x                      |
c           |   = Imaginary_part{inv[A-SIGMA*M]*M}*x. |
c           %-----------------------------------------%
c
            do 240 i = 1,n
               workc(i) = dcmplx(workd(ipntr(3)+i-1))
  240       continue
c
            call zgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda,
     &                   iwork, workc, n, ierr)
            if (ierr .ne. 0) then
               print*, ' '
               print*, '_NBAND: Error with _gbtrs.'
               print*, ' '
               go to 9000
            end if
c
            do  250 i = 1, n
               workd(ipntr(2)+i-1) = dimag(workc(i))
  250       continue
c
         end if
c
      else if (ido .eq. 2) then
c
c        %--------------------%
c        | Perform y <-- M*x  |
c        | Not used when      |
c        | type = 1,2.        |
c        %--------------------%
c
          call dgbmv('Notranspose', n, n, kl, ku, one, mb(itop,1),
     &                lda, workd(ipntr(1)), 1, zero,
     &                workd(ipntr(2)), 1)
c
      else
c
c        %-----------------------------------------%
c        | Either we have convergence, or there is |
c        | error.                                  |
c        %-----------------------------------------%
c
         if ( info .lt. 0) then
c
c           %--------------------------%
c           | Error message, check the |
c           | documentation in DNAUPD  |
c           %--------------------------%
c
            print *, ' '
            print *, ' Error with _naupd info = ',info
            print *, ' Check the documentation of _naupd '
            print *, ' '
            go to 9000
c
         else
c
            if ( info .eq. 1) then
               print *, ' '
               print *, ' Maximum number of iterations reached.'
               print *, ' '
            else if ( info .eq. 3) then
               print *, ' '
               print *, ' No shifts could be applied during implicit',
     &                  ' Arnoldi update, try increasing NCV.'
               print *, ' '
            end if
c
            if (iparam(5) .gt. 0) then
c
               call dneupd ( rvec, 'A', select, dr, di, z, ldz,
     &                 sigmar, sigmai, workev, bmat, n, which,
     &                 nev, tol, resid, ncv, v, ldv, iparam,
     &                 ipntr, workd, workl, lworkl, info )
c
               if ( info .ne. 0) then
c
c                 %------------------------------------%
c                 | Check the documentation of DNEUPD. |
c                 %------------------------------------%
c
                  print *, ' '
                  print *, ' Error with _neupd = ', info
                  print *, ' Check the documentation of _neupd '
                  print *, ' '
                  go to 9000
c
               else if ( sigmai .ne. zero ) then
c
                  if ( type .eq. 4 .or. type .eq. 6 ) then
c
                     first = .true.
                     do 270 j = 1, iparam(5)
c
c                    %----------------------------------%
c                    | Use Rayleigh Quotient to recover |
c                    | eigenvalues of the original      |
c                    | generalized eigenvalue problem.  |
c                    %----------------------------------%
c
                     if ( di(j) .eq. zero ) then
c
c                       %--------------------------------------%
c                       | Eigenvalue is real. Compute          |
c                       | d = (x'*inv[A-sigma*M]*M*x) / (x'*x) |
c                       %--------------------------------------%
c
                        call dgbmv('Nontranspose', n, n, kl, ku, one,
     $                     mb(itop,1), lda, z(1,j), 1, zero,
     $                     workd, 1)
                        do i = 1, n
                           workc(i) = dcmplx(workd(i))
                        end do
                        call zgbtrs ('Notranspose', n, kl, ku, 1,
     $                        cfac, lda, iwork, workc, n, info)
                        do i = 1, n
                           workd(i) = dble(workc(i))
                           workd(i+n) = dimag(workc(i))
                        end do
                        denr = ddot(n, z(1,j), 1, workd, 1)
                        deni = ddot(n, z(1,j), 1, workd(n+1), 1)
                        numr  = dnrm2(n, z(1,j), 1)**2
                        dmdul = dlapy2(denr,deni)**2
                        if ( dmdul .ge. safmin ) then
                           dr(j) = sigmar + numr*denr / dmdul
                        else
c
c                          %---------------------%
c                          | dmdul is too small. |
c                          | Exit to avoid       |
c                          | overflow.           |
c                          %---------------------%
c
                           info = -15
                           go to 9000
                        end if
c
                     else if (first) then
c
c                       %------------------------%
c                       | Eigenvalue is complex. |
c                       | Compute the first one  |
c                       | of the conjugate pair. |
c                       %------------------------%
c
c                       %-------------%
c                       | Compute M*x |
c                       %-------------%
c
                        call dgbmv('Nontranspose', n, n, kl, ku,
     $                      one, mb(itop,1), lda, z(1,j), 1, zero,
     $                      workd, 1)
                        call dgbmv('Nontranspose', n, n, kl, ku,
     $                       one, mb(itop,1), lda, z(1,j+1), 1,
     $                       zero, workd(n+1), 1)
                        do i = 1, n
                           workc(i) = dcmplx(workd(i),workd(i+n))
                        end do
c
c                       %----------------------------%
c                       | Compute inv(A-sigma*M)*M*x |
c                       %----------------------------%
c
                        call zgbtrs('Notranspose',n,kl,ku,1,cfac,
     $                     lda, iwork, workc, n, info)
c
c                       %-------------------------------%
c                       | Compute x'*inv(A-sigma*M)*M*x |
c                       %-------------------------------%
c
                        do i = 1, n
                           workd(i) = dble(workc(i))
                           workd(i+n) = dimag(workc(i))
                        end do
                        denr = ddot(n,z(1,j),1,workd,1)
                        denr = denr+ddot(n,z(1,j+1),1,workd(n+1),1)
                        deni = ddot(n,z(1,j),1,workd(n+1),1)
                        deni = deni - ddot(n,z(1,j+1),1,workd,1)
c
c                       %----------------%
c                       | Compute (x'*x) |
c                       %----------------%
c
                        numr = dlapy2( dnrm2(n, z(1,j), 1),
     &                         dnrm2(n, z(1, j+1), 1) )**2
c
c                       %----------------------------------------%
c                       | Compute (x'x) / (x'*inv(A-sigma*M)*Mx) |
c                       %----------------------------------------%
c
                        dmdul = dlapy2(denr,deni)**2
                        if ( dmdul .ge. safmin ) then
                           dr(j) = sigmar+numr*denr / dmdul
                           di(j) = sigmai-numr*deni / dmdul
                           first = .false.
                        else
c
c                          %---------------------%
c                          | dmdul is too small. |
c                          | Exit to avoid       |
c                          | overflow.           |
c                          %---------------------%
c
                           info = -15
                           go to 9000
c
                        end if
c
                     else
c
c                       %---------------------------%
c                       | Get the second eigenvalue |
c                       | of the conjugate pair by  |
c                       | taking the conjugate of   |
c                       | previous one.             |
c                       %---------------------------%
c
                        dr(j) = dr(j-1)
                        di(j) = -di(j-1)
                        first = .true.
c
                     end if
c
  270                continue
c
                  else if ( type .eq. 2 .or. type .eq. 5) then
c
                     first = .true.
                     do 280 j = 1, iparam(5)
c
c                    %----------------------------------%
c                    | Use Rayleigh Quotient to recover |
c                    | eigenvalues of the original      |
c                    | standard eigenvalue problem.     |
c                    %----------------------------------%
c
                     if ( di(j) .eq. zero ) then
c
c                       %-------------------------------------%
c                       | Eigenvalue is real. Compute         |
c                       | d = (x'*inv[A-sigma*I]*x) / (x'*x). |
c                       %-------------------------------------%
c
                        do i = 1, n
                           workc(i) = dcmplx(z(i,j))
                        end do
                        call zgbtrs ('Notranspose', n, kl, ku, 1,
     $                        cfac, lda, iwork, workc, n, info)
                        do i = 1, n
                           workd(i) = dble(workc(i))
                           workd(i+n) = dimag(workc(i))
                        end do
                        denr = ddot(n,z(1,j),1,workd,1)
                        deni = ddot(n,z(1,j),1,workd(n+1),1)
                        numr  = dnrm2(n, z(1,j), 1)**2
                        dmdul = dlapy2(denr,deni)**2
                        if ( dmdul .ge. safmin ) then
                           dr(j) = sigmar + numr*denr / dmdul
                        else
c
c                          %---------------------%
c                          | dmdul is too small. |
c                          | Exit to avoid       |
c                          | overflow.           |
c                          %---------------------%
c
                           info = -15
                           go to 9000
c
                        end if
c
                     else if (first) then
c
c                       %------------------------%
c                       | Eigenvalue is complex. |
c                       | Compute the first one  |
c                       | of the conjugate pair. |
c                       %------------------------%
c
                        do i = 1, n
                           workc(i) = dcmplx( z(i,j), z(i,j+1) )
                        end do
c
c                       %---------------------------%
c                       | Compute inv[A-sigma*I]*x. |
c                       %---------------------------%
c
                        call zgbtrs('Notranspose',n,kl,ku,1,cfac,
     $                       lda, iwork, workc, n, info)
c
c                       %-----------------------------%
c                       | Compute x'*inv(A-sigma*I)*x |
c                       %-----------------------------%
c
                        do i = 1, n
                           workd(i) = dble(workc(i))
                           workd(i+n) = dimag(workc(i))
                        end do
                        denr = ddot(n,z(1,j),1,workd,1)
                        denr = denr+ddot(n,z(1,j+1),1,workd(n+1),1)
                        deni = ddot(n,z(1,j),1,workd(n+1),1)
                        deni = deni - ddot(n,z(1,j+1),1,workd,1)
c
c                       %----------------%
c                       | Compute (x'*x) |
c                       %----------------%
c
                        numr = dlapy2( dnrm2(n, z(1,j), 1),
     &                         dnrm2(n, z(1,j+1), 1))**2
c
c                       %----------------------------------------%
c                       | Compute (x'x) / (x'*inv(A-sigma*I)*x). |
c                       %----------------------------------------%
c
                        dmdul = dlapy2(denr,deni)**2
                        if (dmdul .ge. safmin) then
                           dr(j) = sigmar+numr*denr / dmdul
                           di(j) = sigmai-numr*deni / dmdul
                           first = .false.
                        else
c
c                          %---------------------%
c                          | dmdul is too small. |
c                          | Exit to avoid       |
c                          | overflow.           |
c                          %---------------------%
c
                           info = -15
                           go to 9000
                        end if
c
                     else
c
c                       %---------------------------%
c                       | Get the second eigenvalue |
c                       | of the conjugate pair by  |
c                       | taking the conjugate of   |
c                       | previous one.             |
c                       %---------------------------%
c
                        dr(j) = dr(j-1)
                        di(j) = -di(j-1)
                        first = .true.
c
                     end if
c
  280                continue
c
                  end if
c
               end if
c
            end if
c
         end if
c
         go to 9000
c
      end if
c
c     %----------------------------------------%
c     | L O O P  B A C K to call DNAUPD again. |
c     %----------------------------------------%
c
      go to 90
c
 9000 continue
c
      end


program generate_indices
implicit none

real(kind=8) :: a, b, c, d, a1, b1, c1, a2, b2, c2, interv1, interv2, interv3
integer:: ia, ib, ic

!a program to generate indices for ./top_grid

write(*,*) 'origin?'
read(*,*) a1, b1, c1
write(*,*) 'axes?'
read(*,*) a2, b2, c2

a = a2 - a1
b = b2 - b1
c = c2 - c1

write(*,*) 'd          a              b              c'

d = 10.1
do while (d .gt. 0)
 d = d - 0.1
  interv1 = a*d
    ia = nint(interv1)
  interv2 = b*d
    ib = nint(interv2)
  interv3 = c*d
    ic = nint(interv3)
  write(*,*) d, ia, ib, ic
end do

end program generate_indices


module numerics
    use numerics_type
    implicit none
    private
    public find_pos, poly_int, tridiagonal, zeroin,assert_eq, r1mach, d1mach, &
        dfsid1, erfinv, vode_integrate, xsetf, dvode, fmin, assert_eq2, assert_eq3, &
        assert_eq4, assert_eqn, imaxloc, iminloc, numerics_error, &
        quad2d_qgaus, quad2d_romb, gammainc, gammainc_scal, invgammainc, &
        LN2, &
        A0, A1, A2, A3, A4, A5, A6, A7, &
        B0, B1, B2, B3, B4, B5, B6, B7, &
        C0, C1, C2, C3, C4, C5, C6, C7, &
        D0, D1, D2, D3, D4, D5, D6, D7, &
        E0, E1, E2, E3, E4, E5, E6, E7, &
        F0, F1, F2, F3, F4, F5, F6, F7
    real(wp) :: xsav

    integer(i4b), parameter :: npar_arith=16,npar_arith2=8
    real(wp), parameter :: LN2 = 6.931471805599453094172321214581e-1_wp
    real(wp), parameter :: A0 = 1.1975323115670912564578e0_wp
    real(wp), parameter :: A1 = 4.7072688112383978012285e1_wp
    real(wp), parameter :: A2 = 6.9706266534389598238465e2_wp
    real(wp), parameter :: A3 = 4.8548868893843886794648e3_wp
    real(wp), parameter :: A4 = 1.6235862515167575384252e4_wp
    real(wp), parameter :: A5 = 2.3782041382114385731252e4_wp
    real(wp), parameter :: A6 = 1.1819493347062294404278e4_wp
    real(wp), parameter :: A7 = 8.8709406962545514830200e2_wp
    real(wp), parameter :: B0 = 1.0000000000000000000e0_wp
    real(wp), parameter :: B1 = 4.2313330701600911252e1_wp
    real(wp), parameter :: B2 = 6.8718700749205790830e2_wp
    real(wp), parameter :: B3 = 5.3941960214247511077e3_wp
    real(wp), parameter :: B4 = 2.1213794301586595867e4_wp
    real(wp), parameter :: B5 = 3.9307895800092710610e4_wp
    real(wp), parameter :: B6 = 2.8729085735721942674e4_wp
    real(wp), parameter :: B7 = 5.2264952788528545610e3_wp
    real(wp), parameter :: C0 = 1.42343711074968357734e0_wp
    real(wp), parameter :: C1 = 4.63033784615654529590e0_wp
    real(wp), parameter :: C2 = 5.76949722146069140550e0_wp
    real(wp), parameter :: C3 = 3.64784832476320460504e0_wp
    real(wp), parameter :: C4 = 1.27045825245236838258e0_wp
    real(wp), parameter :: C5 = 2.41780725177450611770e-1_wp
    real(wp), parameter :: C6 = 2.27238449892691845833e-2_wp
    real(wp), parameter :: C7 = 7.74545014278341407640e-4_wp
    real(wp), parameter :: D0 = 1.4142135623730950488016887e0_wp
    real(wp), parameter :: D1 = 2.9036514445419946173133295e0_wp
    real(wp), parameter :: D2 = 2.3707661626024532365971225e0_wp
    real(wp), parameter :: D3 = 9.7547832001787427186894837e-1_wp
    real(wp), parameter :: D4 = 2.0945065210512749128288442e-1_wp
    real(wp), parameter :: D5 = 2.1494160384252876777097297e-2_wp
    real(wp), parameter :: D6 = 7.7441459065157709165577218e-4_wp
    real(wp), parameter :: D7 = 1.4859850019840355905497876e-9_wp
    real(wp), parameter :: E0 = 6.65790464350110377720e0_wp
    real(wp), parameter :: E1 = 5.46378491116411436990e0_wp
    real(wp), parameter :: E2 = 1.78482653991729133580e0_wp
    real(wp), parameter :: E3 = 2.96560571828504891230e-1_wp
    real(wp), parameter :: E4 = 2.65321895265761230930e-2_wp
    real(wp), parameter :: E5 = 1.24266094738807843860e-3_wp
    real(wp), parameter :: E6 = 2.71155556874348757815e-5_wp
    real(wp), parameter :: E7 = 2.01033439929228813265e-7_wp
    real(wp), parameter :: F0 = 1.414213562373095048801689e0_wp
    real(wp), parameter :: F1 = 8.482908416595164588112026e-1_wp
    real(wp), parameter :: F2 = 1.936480946950659106176712e-1_wp
    real(wp), parameter :: F3 = 2.103693768272068968719679e-2_wp
    real(wp), parameter :: F4 = 1.112800997078859844711555e-3_wp
    real(wp), parameter :: F5 = 2.611088405080593625138020e-5_wp
    real(wp), parameter :: F6 = 2.010321207683943062279931e-7_wp
    real(wp), parameter :: F7 = 2.891024605872965461538222e-15_wp
	interface
		function find_pos(xarr,x)
		    use numerics_type
            real(wp), dimension(:), intent(in) :: xarr
            real(wp), intent(in) :: x
            integer(i4b) :: find_pos
		end function find_pos
	end interface
!
	interface
		subroutine poly_int(xarr,yarr,x,y,dy)
		use numerics_type
		real(wp), dimension(:), intent(in) :: xarr,yarr
		real(wp), intent(in) :: x
		real(wp), intent(out) :: y,dy
		end subroutine poly_int
	end interface
!
    interface
        subroutine tridiagonal(a,b,c,r,x)
            use numerics_type
            implicit none
            real(wp), dimension(:), intent(in) :: a,b,c,r
            real(wp), dimension(:), intent(inout) :: x
        end subroutine tridiagonal
    end interface
!
	interface
		function zeroin(ax,bx,f,tol)
		use numerics_type
		real(wp), intent(in) :: ax,bx,tol
		real(wp) :: zeroin
		interface
		    function f(x)
		    use numerics_type
		    real(wp), intent(in) :: x
		    real(wp) :: f
		    end function f
		end interface
		end function zeroin
	end interface
!
	interface assert_eq
		module procedure assert_eq2,assert_eq3,assert_eq4,assert_eqn
	end interface
	interface imaxloc
		module procedure imaxloc_r,imaxloc_i
	end interface
!
    interface
        function r1mach(I)
            use numerics_type
            real(sp) :: r1mach
            integer :: I
        end function r1mach
    end interface
!
    interface
        function d1mach(I)
            use numerics_type
            real(dp) :: d1mach
            integer :: I
        end function d1mach
    end interface
!
    interface
      function dfsid1(func,x,h0,delta,err)
	    use numerics_type
        implicit none
        real(wp), intent(in) :: x,h0,delta
        real(wp), intent(inout) :: err
        real(wp) :: dfsid1
        interface
            function func(x)
            use numerics_type
            real(wp), intent(in) :: x
            real(wp) :: func
            end function func
        end interface
      end function dfsid1
    end interface
!
    interface
        subroutine erfinv(x,ans)
            use, intrinsic :: IEEE_ARITHMETIC
            use numerics_type
            implicit none
            real(wp), intent(in) :: x
            real(wp), intent(inout) :: ans
        end subroutine erfinv
    end interface
!
    interface
        subroutine vode_integrate(ystart,x1,x2,eps,h1,hmin,fdash)
            use numerics_type
            real(wp), intent(in) :: x1,x2,eps,h1,hmin
            real(wp), intent(inout), dimension(:) :: ystart
            interface
                subroutine fdash(p,z,dzdp)
                    use numerics_type
                    implicit none
                    real(wp), intent(in) :: p
                    real(wp), dimension(:), intent(in) :: z
                    real(wp), dimension(:), intent(out) :: dzdp
                end subroutine fdash
            end interface
    	end subroutine vode_integrate
    end interface
!
    interface
          subroutine xsetf (mflag)
            integer mflag
          end subroutine xsetf
    end interface
!
	interface dvode
    	! single precision version
        subroutine svode (f, neq, y, t, tout, itol, rtol, atol, itask, &
                 istate, iopt, rwork, lrw, iwork, liw, jac, mf,&
                 rpar, ipar)
        external f, jac
        real y, t, tout, rtol, atol, rwork, rpar
        integer neq, itol, itask, istate, iopt, lrw, iwork, liw,&
             mf, ipar
        dimension y(*), rtol(*), atol(*), rwork(lrw), iwork(liw),&
               rpar(*), ipar(*)
        end subroutine svode

        ! double precision version
        subroutine dvode (f, neq, y, t, tout, itol, rtol, atol, itask, &
                 istate, iopt, rwork, lrw, iwork, liw, jac, mf,&
                 rpar, ipar)
        external f, jac
        double precision y, t, tout, rtol, atol, rwork, rpar
        integer neq, itol, itask, istate, iopt, lrw, iwork, liw,&
             mf, ipar
        dimension y(*), rtol(*), atol(*), rwork(lrw), iwork(liw),&
               rpar(*), ipar(*)
        end subroutine dvode
	end interface
!
	interface fmin
    	! single precision version
        real function sfmin(ax,bx,f,tol)
        real ax,bx,f,tol
        external f
        end function sfmin

        ! double precision version
        double precision function fmin(ax,bx,f,tol)
        double precision ax,bx,f,tol
        external f
        end function fmin
	end interface
!

    interface gammainc
        module procedure gammainc_scal, gammainc_vec
    end interface

    interface gcf
        module procedure gcf_scal, gcf_vec
    end interface
    interface gser
        module procedure gser_scal, gser_vec
    end interface

    contains
    ! series solutions for the incomplete gamma function
	function gser_scal(a,x,gln)
	implicit none
	real(wp), intent(in) :: a,x
	real(wp), optional, intent(out) :: gln
	real(wp) :: gser_scal
	integer(i4b), parameter :: itmax=100
	real(wp), parameter :: eps=epsilon(x)
	integer(i4b) :: n
	real(wp) :: ap,del,summ
	if (x == 0.0_wp) then
		gser_scal=0.0_wp
		return
	end if
	ap=a
	summ=1.0_wp/a
	del=summ
	do n=1,itmax
		ap=ap+1.0_wp
		del=del*x/ap
		summ=summ+del
		if (abs(del) < abs(summ)*eps) exit
	end do
	if (n > itmax) call numerics_error('a too large, itmax too small in gser_scal')
	if (present(gln)) then
		gln=log_gamma(a)
		gser_scal=summ*exp(-x+a*log(x)-gln)
	else
		gser_scal=summ*exp(-x+a*log(x)-log_gamma(a))
	end if
	end function gser_scal

    ! series solutions for the incomplete gamma function
	function gser_vec(a,x,gln)
	implicit none
	real(wp), dimension(:), intent(in) :: a,x
	real(wp), dimension(:), optional, intent(out) :: gln
	real(wp), dimension(size(a)) :: gser_vec
	integer(i4b), parameter :: itmax=100
	real(wp), parameter :: eps=epsilon(x)
	integer(i4b) :: n
	real(wp), dimension(size(a)) :: ap,del,summ
	logical(lgt), dimension(size(a)) :: converged,zero
	n=assert_eq2(size(a),size(x),'gser_vec')
	zero=(x == 0.0_wp)
	where (zero) gser_vec=0.0_wp
	ap=a
	summ=1.0_wp/a
	del=summ
	converged=zero
	do n=1,itmax
		where (.not. converged)
			ap=ap+1.0_wp
			del=del*x/ap
			summ=summ+del
			converged = (abs(del) < abs(summ)*eps)
		end where
		if (all(converged)) exit
	end do
	if (n > itmax) call numerics_error('a too large, itmax too small in gser_vec')
	if (present(gln)) then
		if (size(gln) < size(a)) call &
			numerics_error('gser: not enough space for gln')
		gln=log_gamma(a)
		where (.not. zero) gser_vec=summ*exp(-x+a*log(x)-gln)
	else
		where (.not. zero) gser_vec=summ*exp(-x+a*log(x)-log_gamma(a))
	end if
	end function gser_vec

    ! continued fraction solution of incomplete gamma
	function gcf_scal(a,x,gln)
	implicit none
	real(wp), intent(in) :: a,x
	real(wp), optional, intent(out) :: gln
	real(wp) :: gcf_scal
	integer(i4b), parameter :: itmax=100
	real(wp), parameter :: eps=epsilon(x),fpmin=tiny(x)/eps
	integer(i4b) :: i
	real(wp) :: an,b,c,d,del,h
	if (x == 0.0_wp) then
		gcf_scal=1.0_wp
		return
	end if
	b=x+1.0_wp-a
	c=1.0_wp/fpmin
	d=1.0_wp/b
	h=d
	do i=1,itmax
		an=-i*(i-a)
		b=b+2.0_wp
		d=an*d+b
		if (abs(d) < fpmin) d=fpmin
		c=b+an/c
		if (abs(c) < fpmin) c=fpmin
		d=1.0_wp/d
		del=d*c
		h=h*del
		if (abs(del-1.0_wp) <= eps) exit
	end do
	if (i > itmax) call numerics_error('a too large, itmax too small in gcf_scal')
	if (present(gln)) then
		gln=log_gamma(a)
		gcf_scal=exp(-x+a*log(x)-gln)*h
	else
		gcf_scal=exp(-x+a*log(x)-log_gamma(a))*h
	end if
	end function gcf_scal

    ! continued fraction solution of incomplete gamma
	function gcf_vec(a,x,gln)
	implicit none
	real(wp), dimension(:), intent(in) :: a,x
	real(wp), dimension(:), optional, intent(out) :: gln
	real(wp), dimension(size(a)) :: gcf_vec
	integer(i4b), parameter :: itmax=100
	real(wp), parameter :: eps=epsilon(x),fpmin=tiny(x)/eps
	integer(i4b) :: i
	real(wp), dimension(size(a)) :: an,b,c,d,del,h
	logical(lgt), dimension(size(a)) :: converged,zero
	i=assert_eq2(size(a),size(x),'gcf_vec')
	zero=(x == 0.0_wp)
	where (zero)
		gcf_vec=1.0_wp
	elsewhere
		b=x+1.0_wp-a
		c=1.0_wp/fpmin
		d=1.0_wp/b
		h=d
	end where
	converged=zero
	do i=1,itmax
		where (.not. converged)
			an=-i*(i-a)
			b=b+2.0_wp
			d=an*d+b
			d=merge(fpmin,d, abs(d)<fpmin )
			c=b+an/c
			c=merge(fpmin,c, abs(c)<fpmin )
			d=1.0_wp/d
			del=d*c
			h=h*del
			converged = (abs(del-1.0_wp)<=eps)
		end where
		if (all(converged)) exit
	end do
	if (i > itmax) call numerics_error('a too large, itmax too small in gcf_vec')
	if (present(gln)) then
		if (size(gln) < size(a)) call &
			numerics_error('gser: not enough space for gln')
		gln=log_gamma(a)
		where (.not. zero) gcf_vec=exp(-x+a*log(x)-gln)*h
	else
		where (.not. zero) gcf_vec=exp(-x+a*log(x)-log_gamma(a))*h
	end if
	end function gcf_vec

    ! calculates this incomplete gamma function
	function gammainc_scal(a,x)
	implicit none
	real(wp), intent(in) :: a,x
	real(wp) :: gammainc_scal
	call assert1( x >= 0.0_wp,  a > 0.0_wp, 'gamminc_scal args')
	if (x<a+1.0_wp) then
		gammainc_scal=gser(a,x)
	else
		gammainc_scal=1.0_wp-gcf(a,x)
	end if
	end function gammainc_scal

	function gammainc_vec(a,x)
	implicit none
	real(wp), dimension(:), intent(in) :: a,x
	real(wp), dimension(size(x)) :: gammainc_vec
	logical(lgt), dimension(size(x)) :: mask
	integer(i4b) :: ndum
	ndum=assert_eq2(size(a),size(x),'gamminc_vec')
	call assert1( all(x >= 0.0_wp),  all(a > 0.0_wp), 'gamminc_vec args')
	mask = (x<a+1.0_wp)
	gammainc_vec=merge(gser(a,merge(x,0.0_wp,mask)), &
		1.0_wp-gcf(a,merge(x,0.0_wp,.not. mask)),mask)
	end function gammainc_vec

    function invgammainc(p,a)
        implicit none
        real(wp), intent(in) :: a
        real(wp), intent(in) :: p
        real(wp) :: invgammainc

        integer(i4b) :: j
        real(wp) :: x,err,t,u,pp,lna1,afac,gln,a1
        real(wp), parameter :: eps=1.e-8_wp

        a1=a-1.0_wp
        gln=log_gamma(a)
        if(a<=0.0_wp) print *, "a must be positive"
        if(p>=1.0_wp) then
            invgammainc=max(100._wp,a+100._wp*sqrt(a))
            return
        endif
        if(p<=0.0_wp) then
            invgammainc=0.0_wp
            return
        endif
        if(a>1.0_wp) then
            lna1=log(a1)
            afac=exp(a1*(lna1-1._wp)-gln)
            if(p<0.5_wp) then
                pp=p
            else
                pp=1._wp-p
            endif
            t=sqrt(-2._wp*log(pp))
            x=(2.30753_wp+t*0.27061_wp)/(1._wp+t*(0.99229_wp+t*0.04481_wp))-t
            if(p<0.5_wp) x=-x
            x=max(1.e-3_wp,a*(1._wp-1._wp/(9._wp*a)-x/(3._wp*sqrt(a)))**3)
        else
            t=1.0_wp-a*(0.253_wp+a*0.12_wp)
            if(p<t) then
                x=(p/t)**(1._wp/a)
            else
                x=1._wp-log(1._wp-(p-t)/(1._wp-t))
            endif

        endif

        do j=0,11
            if(x<=0.0_wp) then
                invgammainc=0.0_wp
                return
            endif
            err=gammainc(a,x)-p
            if(a>1.) then
                t=afac*exp(-(x-a1)+a1*(log(x)-lna1))
            else
                t=exp(-x+a1*log(x)-gln)
            endif
            u=err/t
            t=u/(1._wp-0.5_wp*min(1._wp,u*((a-1._wp)/x-1._wp)))
            x=x-t
            if(x<=0._wp) x=0.5_wp*(x+t)
            if(abs(t) < eps*x) exit
        enddo

        invgammainc=x
        return
    end function invgammainc

	recursive function romb(func1,a,b)
		use numerics_type

	implicit none
	real(wp), intent(in) :: a,b
	real(wp) :: romb
	interface
		function func1(x)
		use numerics_type
		real(wp), dimension(:), intent(in) :: x
		real(wp), dimension(size(x)) :: func1
		end function func1
	end interface
	integer(i4b), parameter :: jmax=20,jmaxp=jmax+1,k=5,km=k-1
	real(wp), parameter :: eps=3.0e-6_wp
	real(wp), dimension(jmaxp) :: h,s
	real(wp) :: dromb
	integer(i4b) :: j
	h(1)=1.0_wp
	do j=1,jmax
		call trapezoid(func1,a,b,s(j),j)
		if (j >= k) then
			call poly_int(h(j-km:j),s(j-km:j),0.0_wp,romb,dromb)
			if (abs(dromb) <= eps*abs(romb)) return
		end if
		s(j+1)=s(j)
		h(j+1)=0.25_wp*h(j)
	end do
	call numerics_error('romb: too many steps')
	end function romb

	recursive subroutine trapezoid(func1,a,b,s,n)
	use numerics_type
	implicit none
	real(wp), intent(in) :: a,b
	real(wp), intent(inout) :: s
	integer(i4b), intent(in) :: n
	interface
		function func1(x)
		use numerics_type
		real(wp), dimension(:), intent(in) :: x
		real(wp), dimension(size(x)) :: func1
		end function func1
	end interface
	real(wp) :: del,fsum
	integer(i4b) :: it
	if (n == 1) then
		s=0.5_wp*(b-a)*sum(func1( (/ a,b /) ))
	else
		it=2**(n-2)
		del=(b-a)/it
		fsum=sum(func1(arithmetic_prog(a+0.5_wp*del,del,it)))
		s=0.5_wp*(s+del*fsum)
	end if
	end subroutine trapezoid

	recursive function qgaus(func1,a,b)
		use numerics_type

	implicit none
	real(wp), intent(in) :: a,b
	real(wp) :: qgaus
	interface
		function func1(x)
		use numerics_type
		real(wp), dimension(:), intent(in) :: x
		real(wp), dimension(size(x)) :: func1
		end function func1
	end interface
	real(wp) :: xm,xr
	real(wp), dimension(5) :: dx, w = (/ 0.2955242247_wp,0.2692667193_wp,&
		0.2190863625_wp,0.1494513491_wp,0.0666713443_wp /),&
		x = (/ 0.1488743389_wp,0.4333953941_wp,0.6794095682_wp,&
		0.8650633666_wp,0.9739065285_wp /)
	xm=0.5_wp*(b+a)
	xr=0.5_wp*(b-a)
	dx(:)=xr*x(:)
	qgaus=xr*sum(w(:)*(func1(xm+dx)+func1(xm-dx)))
	end function qgaus

	subroutine quad2d_qgaus(func1,y1,y2,x1,x2,ss)
		use numerics_type
	implicit none
	real(wp), intent(in) :: x1,x2
	real(wp), intent(out) :: ss

	interface
		function func1(x,y)
		use numerics_type, only : wp
		implicit none
		real(wp), intent(in) :: x
		real(wp), dimension(:), intent(in) :: y
		real(wp), dimension(size(y)) :: func1
		end function func1
!

		function y1(x)
        use numerics_type, only : wp
        implicit none
		real(wp), intent(in) :: x
		real(wp) :: y1
		end function y1
!
		function y2(x)
        use numerics_type, only : wp
        implicit none
		real(wp), intent(in) :: x
		real(wp) :: y2
		end function y2

    end interface

	ss=qgaus(h,x1,x2)

    ! internal routine
    contains
         function f(y)
        use numerics_type, only : wp
        implicit none
         real(wp), dimension(:), intent(in) :: y
         real(wp), dimension(size(y)) :: f
         f=func1(xsav,y)
         end function f
        !bl
        function h(x)
        use numerics_type, only : wp
        implicit none
        real(wp), dimension(:), intent(in) :: x
        real(wp), dimension(size(x)) :: h
        integer(i4b) :: i
        do i=1,size(x)
            xsav=x(i)
            h(i)=qgaus(f,y1(xsav),y2(xsav))
        end do
        end function h

	end subroutine quad2d_qgaus

	subroutine quad2d_romb(func1,y1,y2,x1,x2,ss)
		use numerics_type
	implicit none
	real(wp), intent(in) :: x1,x2
	real(wp), intent(out) :: ss

	interface
		function func1(x,y)
		use numerics_type, only : wp
		implicit none
		real(wp), intent(in) :: x
		real(wp), dimension(:), intent(in) :: y
		real(wp), dimension(size(y)) :: func1
		end function func1
!

		function y1(x)
        use numerics_type, only : wp
        implicit none
		real(wp), intent(in) :: x
		real(wp) :: y1
		end function y1
!
		function y2(x)
        use numerics_type, only : wp
        implicit none
		real(wp), intent(in) :: x
		real(wp) :: y2
		end function y2

    end interface

	ss=romb(h,x1,x2)

    ! internal routine
    contains
         function f(y)
        use numerics_type, only : wp
        implicit none
         real(wp), dimension(:), intent(in) :: y
         real(wp), dimension(size(y)) :: f
         f=func1(xsav,y)
         end function f
        !bl
        function h(x)
        use numerics_type, only : wp
        implicit none
        real(wp), dimension(:), intent(in) :: x
        real(wp), dimension(size(x)) :: h
        integer(i4b) :: i
        do i=1,size(x)
            xsav=x(i)
            h(i)=romb(f,y1(xsav),y2(xsav))
        end do
        end function h

	end subroutine quad2d_romb

    function arithmetic_prog(first,increment,n)
    real(wp), intent(in) :: first,increment
    integer(i4b), intent(in) :: n
    real(wp), dimension(n) :: arithmetic_prog
    integer(i4b) :: k,k2
    real(wp) :: temp
    if (n > 0) arithmetic_prog(1)=first
    if (n <= npar_arith) then
        do k=2,n
            arithmetic_prog(k)=arithmetic_prog(k-1)+increment
        end do
    else ! if it is greater than 16, we do the first 8 as usual
        do k=2,npar_arith2
            arithmetic_prog(k)=arithmetic_prog(k-1)+increment
        end do
        ! then replicate in sizes of 8, 16, 32, and so on
        temp=increment*npar_arith2
        k=npar_arith2
        do
            if (k >= n) exit
            k2=k+k
            arithmetic_prog(k+1:min(k2,n))=temp+arithmetic_prog(1:min(k,n-k))
            temp=temp+temp
            k=k2
        end do
    end if
    end function arithmetic_prog

	subroutine assert1(l1,l2,string)
        character(len=*), intent(in) :: string
        logical, intent(in) :: l1,l2
        if (.not.((l1).and.(l2)) ) then
            write (*,*) 'numerics: an assert1 failed:', &
                string
            stop 'program terminated by assert1'
        end if
	end subroutine assert1
!
	function assert_eq2(n1,n2,string)
        character(len=*), intent(in) :: string
        integer, intent(in) :: n1,n2
        integer :: assert_eq2
        if (n1 == n2) then
            assert_eq2=n1
        else
            write (*,*) 'numerics: an assert_eq failed:', &
                string
            stop 'program terminated by assert_eq2'
        end if
	end function assert_eq2
!
	function assert_eq3(n1,n2,n3,string)
        character(len=*), intent(in) :: string
        integer, intent(in) :: n1,n2,n3
        integer :: assert_eq3
        if (n1 == n2 .and. n2 == n3) then
            assert_eq3=n1
        else
            write (*,*) 'numerics: an assert_eq failed:', &
                string
            stop 'program terminated by assert_eq3'
        end if
	end function assert_eq3
!
	function assert_eq4(n1,n2,n3,n4,string)
        character(len=*), intent(in) :: string
        integer, intent(in) :: n1,n2,n3,n4
        integer :: assert_eq4
        if (n1 == n2 .and. n2 == n3 .and. n3 == n4) then
            assert_eq4=n1
        else
            write (*,*) 'numerics: an assert_eq failed:', &
                string
            stop 'program terminated by assert_eq4'
        end if
	end function assert_eq4
!
	function assert_eqn(nn,string)
        character(len=*), intent(in) :: string
        integer, dimension(:), intent(in) :: nn
        integer :: assert_eqn
        if (all(nn(2:) == nn(1))) then
            assert_eqn=nn(1)
        else
            write (*,*) 'numerics: an assert_eq failed:', &
                string
            stop 'program terminated by assert_eqn'
        end if
	end function assert_eqn
!
	function imaxloc_r(arr)
	    use numerics_type
        real(wp), dimension(:), intent(in) :: arr
        integer(i4b) :: imaxloc_r
        integer(i4b), dimension(1) :: imax
        imax=maxloc(arr(:))
        imaxloc_r=imax(1)
	end function imaxloc_r
!
	function imaxloc_i(iarr)
	    use numerics_type
        integer(i4b), dimension(:), intent(in) :: iarr
        integer(i4b), dimension(1) :: imax
        integer(i4b) :: imaxloc_i
        imax=maxloc(iarr(:))
        imaxloc_i=imax(1)
	end function imaxloc_i
!
	function iminloc(arr)
	    use numerics_type
        real(wp), dimension(:), intent(in) :: arr
        integer(i4b), dimension(1) :: imin
        integer(i4b) :: iminloc
        imin=minloc(arr(:))
        iminloc=imin(1)
	end function iminloc
!
	subroutine numerics_error(string)
        character(len=*), intent(in) :: string
        write (*,*) 'numerics_error: ',string
        stop 'program terminated by numerics_error'
	end subroutine numerics_error

end module numerics


!==========================================================================
elemental function gsw_kappa_const_t_ice (t, p)
!==========================================================================
!
!  Calculates isothermal compressibility of ice.
!  Note. This is the compressibility of ice AT CONSTANT IN-SITU
!    TEMPERATURE
!
!  t  =  in-situ temperature (ITS-90)                             [ deg C ]
!  p  =  sea pressure                                              [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  kappa_const_t_ice  =  isothermal compressibility                [ 1/Pa ]
!   Note. The output units are 1/Pa not 1/dbar.
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_gibbs_ice

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: t, p

real (r8) :: gsw_kappa_const_t_ice

gsw_kappa_const_t_ice = -gsw_gibbs_ice(0,2,t,p)/gsw_gibbs_ice(0,1,t,p)

return
end function

!--------------------------------------------------------------------------


	SUBROUTINE FANDBW(SPS,ICHANN,DBX,DBY,NPEAK,F,BW,AMP)
C
	REAL DBX(1025),DBY(1025)
	REAL F(5),BW(5),AMP(5)
	REAL X(25)
	INTEGER HPEAK
C
C	FINDS FREQUENCY OF HIGHEST PEAK AND ITS BANDWIDTH
C
C	FIRST FIND THE MAXIMUM IN THE SPECTRUM.
C	THEN TRACE EACH SIDE DOWN TO:
C		(1) HALFWAY TO BACKG
C		(2) SIGNAL STARTS TO GO UP AGAIN (REQUIRE 3 UP POINTS)
C	THEN FIT A/((W-W0)**2 + DW**2) TO THESE POINTS IF THERE
C		ARE AT LEAST 3 POINTS
C	THEN LOOK FOR POSSIBLE SECOND PEAK.  IF THE HIGHEST PEAK IS
C	    IN THE CENTER, THEN IT CAN FIND 3 PEAKS
C
C	  FIND MAXIMUM IN SPECTRUM
C
	SMAX = -1000.
	DO N = 10,1022
	    IF(DBX(N).GT.SMAX) THEN
	      SMAX = DBX(N)
	      NSPMAX1 = N
	    ENDIF
	ENDDO
	PRINT*,'X SPEC. MAX:N,F,SMAX',NSPMAX1,(NSPMAX1-1)*SPS/2048.,SMAX
	FREQMAX1 = (NSPMAX1-1)*SPS/2048.
	NPEAK = 1
C
C	GO DOWN LOW SIDE
C
	SLIM = .5*(SMAX - 80.)
	LCOUNT = 0
	SSAVE = SMAX
	LPEAK = 0
	DO N = NSPMAX1-1,10,-1
	    NSVL = N
	    IF(DBX(N).GT.SSAVE) THEN
	      LCOUNT = LCOUNT+1
	      IF(LCOUNT.GE.3) THEN
		LPEAK = 1
		GO TO 20
	      ENDIF
	    ENDIF
	    IF(DBX(N).LT.SLIM) GO TO 20
	    SSAVE = DBX(N)
	ENDDO
C
C	GO DOWN HIGH SIDE
C
 20	CONTINUE
	LCOUNT = 0
	SSAVE = SMAX
	HPEAK = 0
	DO N = NSPMAX1+1,1024
	    NSVH = N
	    IF(DBX(N).GT.SSAVE) THEN
	      LCOUNT = LCOUNT+1
	      IF(LCOUNT.GE.3) THEN
		HPEAK = 1
		GO TO 30
	      ENDIF
	    ENDIF
	    IF(DBX(N).LT.SLIM) GO TO 30
	    SSAVE = DBX(N)
	ENDDO
C
 30	CONTINUE
C
C	DETERMINE SECOND AND MAYBE THIRD PEAK
C
	IF(LPEAK.NE.0) THEN
	  NPEAK = NPEAK + 1
	  SMAX = -1000.
	  DO N = NSVL+2,10,-1
	    IF(DBX(N).GT.SMAX) THEN
	      SMAX = DBX(N)
	      NSPMAX3 = N
	    ENDIF
	  ENDDO
	  FREQMAX3 = (NSPMAX3-1)*SPS/2048.
	  PRINT*,'2ND PK. MAX:N,F,SMAX',NSPMAX3,FREQMAX3,SMAX
	ENDIF
C
	IF(HPEAK.NE.0) THEN
	  NPEAK = NPEAK + 1
	  SMAX = -1000.
	  DO N = NSVH-2,1024
	    IF(DBX(N).GT.SMAX) THEN
	      SMAX = DBX(N)
	      NSPMAX4 = N
	    ENDIF
	  ENDDO
	  FREQMAX4 = (NSPMAX4-1)*SPS/2048.
	  PRINT*,'2ND PK. MAX:N,F,SMAX',NSPMAX4,FREQMAX4,SMAX
	ENDIF
C
C	ESTIMATES FOR FITTING SPECTRUM(F) = A DF^2/((F-F0)^2 + DF^2)
C
	A = 10.**(.1*DBX(NSPMAX1))
	X(1) = 1./A
	F0 = (NSPMAX1-1)*SPS/2048.
	X(3) = F0
	DELF = (NSVH-1)*SPS/2048. - F0
	SFAR = 	10.**(.1*DBX(NSVH))
	print*,'A',A
	print*,'f0,delf,sfar',f0,delf,sfar
	ADF21 = 10.**(.1*DBX(NSVH))*DELF**2/(1. - SFAR/A)
	DELF = (NSVL-1)*SPS/2048. - F0
	SFAR = 	10.**(.1*DBX(NSVL))
	print*,'f0,delf,sfar',f0,delf,sfar
	ADF22 = 10.**(.1*DBX(NSVL))*DELF**2/(1. - SFAR/A)
	ADF2 = .5*(ADF21+ADF22)
	X(2) = 1./ADF2
	print*,'nspmax1,nsvl,nsvh',nspmax1,nsvl,nsvh
	print*,'adf21,adf22,adf2',adf21,adf22,adf2
	AMP(1) = 1./X(1)
	F(1) = X(3)
	BW(1) = X(1)/X(2)
C
C	FIT SPECTRUM(F) = A DF^2/((F-F0)^2 + DF^2) TO HIGHEST 3 POINTS
C
	SINV1 = 10.**(-DBX(NSPMAX1-1))
	SINV2 = 10.**(-DBX(NSPMAX1))
	SINV3 = 10.**(-DBX(NSPMAX1+1))
	DELF = 	SPS/2048.
	TEMP = SINV1 - 2.*SINV2 + SINV3
	ADF2 = 2.*DELF**2/TEMP
	TEMP = ADF2*(SINV3 - SINV1) - 4.*FREQMAX1*DELF
	F0 = -.25*TEMP/DELF
	AINV = SINV2 - (FREQMAX1-F0)**2/ADF2
	AMP(1) = 1./AINV
	BW2 = ADF2*AINV
	BW(1) = SQRT(BW2)
	PRINT*,'A,F0,BW',AMP(1),F0,BW(1)
	RETURN
	END


      SUBROUTINE SCHOL (A, NDA, N, B, S, TOL, IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2006-04-10 SCHOL Krogh  Fix for out of range unused subscript.
c>> 2001-10-25 SCHOL Snyder & Krogh Added c$OMP PARALLEL DO, etc.
c>> 2001-05-25 SCHOL Snyder & Krogh Compute inner products using SDOT
c>> 1996-03-30 SCHOL Krogh  Added external statement.
c>> 1994-10-20 SCHOL Krogh  Changes to use M77CON
c>> 1991-06-26 SCHOL Krogh  Initial MATH77 version.

c     C. L. Lawson, JPL, 1970 April 30
c     Extensively modified by F. T. Krogh, JPL, 1991, September 23.

c Solution of positive definite system using Cholesky decomposition.

c Suppose the overdetermined system to be solved in the sense of least
c squares is   C*X = D

c Suppose normal equations are formed and stored as follows.

c                    A = (C**T)*C
c                    B = (C**T)*D
c                    S = (D**T)*D

c Given B and the upper triangle of A this subroutine computes the
c solution vector X, storing it in place of B.

c On input S should either = (D**T)D, or be zero.  If the former, then
c on return it is the euclidean norm of (CX - D).  Else the zero value
c is returned.

c The upper triangle of A is replaced by the upper triangular Cholesky
c matrix, R, satisfying  (R**T)*R = A.

c The value of TOL should be 10**(-k-1) where k is the minimum number of
c significant digits in A and B.   If TOL is < the relative precision in
c the computer's arithmetic, it is effectively replaced by that relative
c precision.  If some R(I,I)**2 is < TOL * (corresponding diagonal of
c A), then IERR is set to the value of I for the algebraically smallest
c value of R(I,I).  If R(I,I)**2 is .le. zero, then everything in the
c I-th row of R is set to zero, as is the I-th component of the
c solution, and IERR is replaced by -IERR to flag that this occured.

c--S replaces "?": ?CHOL, ?DOT

c ********************* Variable definitions ***************************

c A      Input matrix, only upper triangle is used.  Replace by factor.
c B      Input right hand side, output solution.
c R1MACH Library routine to get characteristics of floating point
c  numbers.  R1MACH(4) = smallest number, x, such that 1.0 + x .ne. 1.0.
c SDOT   Compute dot products.
c G      Temporary for accumulating sums.
c GMIN   Smallest value seen for G when working on a diagonal entry.
c I      Index used to access matrix entries.
c IERR   Used to return status, see above.
c J      Index used to access matrix entries.
c K      Index used to access matrix entries.
c N      Order of matrix.
c NDA    Declared first dimension for A.
c S      Formal argument, see above.
c TOL    Input value for the tolerance, see above.
c TOLI   Internal value for the tolerance.
c TOLM   Machine tolerance, lower limit for TOLI.
c TSQ    TOLI**2.

c ******************** Variable declarations ***************************

      external         R1MACH, SDOT
      integer          NDA, N, IERR
      real             A(NDA, N), B(N), S, TOL
      integer          I, J, K
      real             G, TSQ, GMIN, TOLI, TOLM
      real             R1MACH, SDOT
      save TOLM
      data TOLM /0.E0/

c ******************** Start of executable code ************************
      if (N .le. 0) return
      if (TOLM .le. 0.E0) TOLM = R1MACH(4)
      TOLI = max(TOL, TOLM)
      TSQ = TOLI**2
      GMIN = A(1, 1)
      IERR = 0
      DO 50 I = 1, N
         G = A(I, I) - SDOT( I-1, A(1, I), 1, A(1, I), 1 )
         if ( G .lt. TSQ * abs(A(I, I)) ) then
            if (G .le. GMIN) then
               GMIN = G
               IERR = I
               if (G .le. 0.E0) IERR = -I
            end if
            if (G .le. 0.E0) then
               do 20 K = I, N
                  A(I, K) = 0.E0
   20          continue
               B(I) = 0.E0
               go to 50
            end if
         end if
         A(I, I) = sqrt(G)

c$OMP PARALLEL DO
         DO 30 J = I + 1, N
            A(I,J) = (A(I,J) - SDOT(I-1, A(1,I), 1, A(1,J), 1)) / A(I,I)
   30    continue
c$OMP END PARALLEL DO
c                        Solve next row of first lower triangular system
         B(I) = (B(I) - SDOT( I-1, A(1, I), 1, B, 1 )) / A(I, I)
   50 continue
c                        Get the solution norm
      if ( S .gt. 0.E0 ) S = sqrt( max(0.E0,S-SDOT(N,B,1,B,1)) )
c                        Solve the second lower triangular system.
      if (A(N,N) .gt. 0.E0) B(N) = B(N) / A(N,N)
      DO 80  I = N-1, 1, -1
        if (A(I, I) .gt. 0.E0) then
          B(I) = (B(I) - SDOT(N-I, A(I,I+1), NDA, B(I+1), 1) ) / A(I, I)
        end if
   80 continue
      end


************************************************************************
*   this subroutine generates random values between 0.0 and 1.0 using
*   an integer seed
*   it is based on the imsl routine ggubs.
************************************************************************

      DOUBLE PRECISION FUNCTION USRAN(IR)

      IMPLICIT NONE

      INTEGER IR

      DOUBLE PRECISION DA,DB,DC

      PARAMETER(DA=16807.D0,DB=2147483647.D0,DC=2147483648.D0)

      IR=ABS(MOD(DA*IR,DB)+0.5D0)
      USRAN=DFLOAT(IR)/DC

      END


      SUBROUTINE MB02XD( FORM, STOR, UPLO, F, M, N, NRHS, IPAR, LIPAR,
     $                   DPAR, LDPAR, A, LDA, B, LDB, ATA, LDATA, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve a set of systems of linear equations, A'*A*X = B, or,
C     in the implicit form, f(A)*X = B, with A'*A or f(A) positive
C     definite, using symmetric Gaussian elimination.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     FORM    CHARACTER*1
C             Specifies the form in which the matrix A is provided, as
C             follows:
C             = 'S' :  standard form, the matrix A is given;
C             = 'F' :  the implicit, function form f(A) is provided.
C             If FORM = 'F', then the routine F is called to compute the
C             matrix A'*A.
C
C     STOR    CHARACTER*1
C             Specifies the storage scheme for the symmetric
C             matrix A'*A, as follows:
C             = 'F' :  full storage is used;
C             = 'P' :  packed storage is used.
C
C     UPLO    CHARACTER*1
C             Specifies which part of the matrix A'*A is stored, as
C             follows:
C             = 'U' :  the upper triagular part is stored;
C             = 'L' :  the lower triagular part is stored.
C
C     Function Parameters
C
C     F       EXTERNAL
C             If FORM = 'F', then F is a subroutine which calculates the
C             value of f(A) = A'*A, for given A.
C             If FORM = 'S', then F is not called.
C
C             F must have the following interface:
C
C             SUBROUTINE F( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, A,
C            $              LDA, ATA, LDATA, DWORK, LDWORK, INFO )
C
C             where
C
C             STOR    (input) CHARACTER*1
C                     Specifies the storage scheme for the symmetric
C                     matrix A'*A, as follows:
C                     = 'F' :  full storage is used;
C                     = 'P' :  packed storage is used.
C
C             UPLO    (input) CHARACTER*1
C                     Specifies which part of the matrix A'*A is stored,
C                     as follows:
C                     = 'U' :  the upper triagular part is stored;
C                     = 'L' :  the lower triagular part is stored.
C
C             N       (input) INTEGER
C                     The order of the matrix A'*A.  N >= 0.
C
C             IPAR    (input) INTEGER array, dimension (LIPAR)
C                     The integer parameters describing the structure of
C                     the matrix A.
C
C             LIPAR   (input) INTEGER
C                     The length of the array IPAR.  LIPAR >= 0.
C
C             DPAR    (input) DOUBLE PRECISION array, dimension (LDPAR)
C                     The real parameters needed for solving the
C                     problem.
C
C             LDPAR   (input) INTEGER
C                     The length of the array DPAR.  LDPAR >= 0.
C
C             A       (input) DOUBLE PRECISION array, dimension
C                     (LDA, NC), where NC is the number of columns.
C                     The leading NR-by-NC part of this array must
C                     contain the (compressed) representation of the
C                     matrix A, where NR is the number of rows of A
C                     (function of IPAR entries).
C
C             LDA     (input) INTEGER
C                     The leading dimension of the array A.
C                     LDA >= MAX(1,NR).
C
C             ATA     (output) DOUBLE PRECISION array,
C                              dimension (LDATA,N),    if STOR = 'F',
C                              dimension (N*(N+1)/2),  if STOR = 'P'.
C                     The leading N-by-N (if STOR = 'F'), or N*(N+1)/2
C                     (if STOR = 'P') part of this array contains the
C                     upper or lower triangle of the matrix A'*A,
C                     depending on UPLO = 'U', or UPLO = 'L',
C                     respectively, stored either as a two-dimensional,
C                     or one-dimensional array, depending on STOR.
C
C             LDATA   (input) INTEGER
C                     The leading dimension of the array ATA.
C                     LDATA >= MAX(1,N), if STOR = 'F'.
C                     LDATA >= 1,        if STOR = 'P'.
C
C             DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C                     The workspace array for subroutine F.
C
C             LDWORK  (input) INTEGER
C                     The size of the array DWORK (as large as needed
C                     in the subroutine F).
C
C             INFO    INTEGER
C                     Error indicator, set to a negative value if an
C                     input scalar argument is erroneous, and to
C                     positive values for other possible errors in the
C                     subroutine F. The LAPACK Library routine XERBLA
C                     should be used in conjunction with negative INFO.
C                     INFO must be zero if the subroutine finished
C                     successfully.
C
C             Parameters marked with "(input)" must not be changed.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix A.  M >= 0.
C
C     N       (input) INTEGER
C             The order of the matrix A'*A, the number of columns of the
C             matrix A, and the number of rows of the matrix X.  N >= 0.
C
C     NRHS    (input) INTEGER
C             The number of columns of the matrices B and X.  NRHS >= 0.
C
C     IPAR    (input) INTEGER array, dimension (LIPAR)
C             If FORM = 'F', the integer parameters describing the
C             structure of the matrix A.
C             This parameter is ignored if FORM = 'S'.
C
C     LIPAR   (input) INTEGER
C             The length of the array IPAR.  LIPAR >= 0.
C
C     DPAR    (input) DOUBLE PRECISION array, dimension (LDPAR)
C             If FORM = 'F', the real parameters needed for solving
C             the problem.
C             This parameter is ignored if FORM = 'S'.
C
C     LDPAR   (input) INTEGER
C             The length of the array DPAR.  LDPAR >= 0.
C
C     A       (input) DOUBLE PRECISION array,
C                     dimension (LDA, N),  if FORM = 'S',
C                     dimension (LDA, NC), if FORM = 'F', where NC is
C                     the number of columns.
C             If FORM = 'S', the leading M-by-N part of this array
C             must contain the matrix A.
C             If FORM = 'F', the leading NR-by-NC part of this array
C             must contain an appropriate representation of matrix A,
C             where NR is the number of rows.
C             If FORM = 'F', this array is not referenced by this
C             routine itself, except in the call to the routine F.
C
C     LDA     INTEGER
C             The leading dimension of array A.
C             LDA >= MAX(1,M),  if FORM = 'S';
C             LDA >= MAX(1,NR), if FORM = 'F'.
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C             (LDB, NRHS)
C             On entry, the leading N-by-NRHS part of this array must
C             contain the right hand side matrix B.
C             On exit, if INFO = 0 and M (or NR) is nonzero, the leading
C             N-by-NRHS part of this array contains the solution X of
C             the set of systems of linear equations A'*A*X = B or
C             f(A)*X = B. If M (or NR) is zero, then B is unchanged.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     ATA     (output) DOUBLE PRECISION array,
C                      dimension (LDATA,N),    if STOR = 'F',
C                      dimension (N*(N+1)/2),  if STOR = 'P'.
C             The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if
C             STOR = 'P') part of this array contains the upper or lower
C             triangular Cholesky factor of the matrix A'*A, depending
C             on UPLO = 'U', or UPLO = 'L', respectively, stored either
C             as a two-dimensional, or one-dimensional array, depending
C             on STOR.
C
C     LDATA   INTEGER
C             The leading dimension of the array ATA.
C             LDATA >= MAX(1,N), if STOR = 'F'.
C             LDATA >= 1,        if STOR = 'P'.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  if INFO = i, then the (i,i) element of the
C                   triangular factor of the matrix A'*A is exactly
C                   zero (the matrix A'*A is exactly singular);
C                   if INFO = j > n, then F returned with INFO = j-n.
C
C     METHOD
C
C     The matrix A'*A is built either directly (if FORM = 'S'), or
C     implicitly, by calling the routine F. Then, A'*A is Cholesky
C     factored and its factor is used to solve the set of systems of
C     linear equations, A'*A*X = B.
C
C     REFERENCES
C
C     [1] Golub, G.H. and van Loan, C.F.
C         Matrix Computations. Third Edition.
C         M. D. Johns Hopkins University Press, Baltimore, 1996.
C
C     [2] Anderson, E., Bai, Z., Bischof, C., Blackford, Demmel, J.,
C         Dongarra, J., Du Croz, J., Greenbaum, A., Hammarling, S.,
C         McKenney, A., Sorensen, D.
C         LAPACK Users' Guide: Third Edition, SIAM, Philadelphia, 1999.
C
C     NUMERICAL ASPECTS
C
C     For speed, this routine does not check for near singularity of the
C     matrix A'*A. If the matrix A is nearly rank deficient, then the
C     computed X could be inaccurate. Estimates of the reciprocal
C     condition numbers of the matrices A and A'*A can be obtained
C     using LAPACK routines DGECON and DPOCON (DPPCON), respectively.
C
C     The approximate number of floating point operations is
C        (M+3)*N**2/2 + N**3/6 + NRHS*N**2, if FORM = 'S',
C        f + N**3/6 + NRHS*N**2,            if FORM = 'F',
C     where M is the number of rows of A, and f is the number of
C     floating point operations required by the subroutine F.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001.
C
C     REVISIONS
C
C     V. Sima, Mar. 2002.
C
C     KEYWORDS
C
C     Linear system of equations, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         FORM, STOR, UPLO
      INTEGER           INFO, LDA, LDATA, LDB, LDPAR, LDWORK, LIPAR, M,
     $                  N, NRHS
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), ATA(*), B(LDB,*), DPAR(*), DWORK(*)
      INTEGER           IPAR(*)
C     .. Local Scalars ..
      INTEGER           IERR, J, J1
      LOGICAL           FULL, MAT, UPPER
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DGEMV, DPOTRF, DPOTRS, DPPTRF, DPPTRS, DSYRK, F,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     ..
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      MAT   = LSAME( FORM, 'S' )
      FULL  = LSAME( STOR, 'F' )
      UPPER = LSAME( UPLO, 'U' )
C
C     Check the scalar input parameters.
C
      INFO = 0
      IF( .NOT.( MAT .OR. LSAME( FORM, 'F' ) ) ) THEN
         INFO = -1
      ELSEIF ( .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN
         INFO = -2
      ELSEIF ( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -3
      ELSEIF ( M.LT.0 ) THEN
         INFO = -5
      ELSEIF ( N.LT.0 ) THEN
         INFO = -6
      ELSEIF ( NRHS.LT.0 ) THEN
         INFO = -7
      ELSEIF ( .NOT. MAT .AND. LIPAR.LT.0 ) THEN
         INFO = -9
      ELSEIF ( .NOT. MAT .AND. LDPAR.LT.0 ) THEN
         INFO = -11
      ELSEIF ( LDA.LT.1 .OR. ( MAT .AND. LDA.LT.M ) ) THEN
         INFO = -13
      ELSEIF ( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSEIF ( LDATA.LT.1 .OR. ( FULL .AND. LDATA.LT.N ) ) THEN
         INFO = -17
      ENDIF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02XD', -INFO )
         RETURN
      ENDIF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 .OR. ( MAT .AND. M.EQ.0 ) )
     $   RETURN
C
C     Build a triangle of the matrix A'*A.
C
      IF ( MAT ) THEN
C
C        Matrix A is given in the usual form.
C
         IF ( FULL ) THEN
            CALL DSYRK( UPLO, 'Transpose', N, M, ONE, A, LDA, ZERO,
     $                  ATA, LDATA )
         ELSEIF ( UPPER ) THEN
            J1 = 1
C
            DO 10 J = 1, N
               CALL DGEMV( 'Transpose', M, J, ONE, A, LDA, A(1,J), 1,
     $                     ZERO, ATA(J1), 1 )
               J1 = J1 + J
   10       CONTINUE
C
         ELSE
            J1 = 1
C
            DO 20 J = 1, N
               CALL DGEMV( 'Transpose', M, N-J+1, ONE, A(1,J), LDA,
     $                     A(1,J), 1, ZERO, ATA(J1), 1 )
               J1 = J1 + N - J + 1
   20       CONTINUE
C
         ENDIF
C
      ELSE
C
C        Implicit form, A'*A = f(A).
C
         CALL F( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, ATA,
     $           LDATA, DWORK, LDWORK, IERR )
         IF ( IERR.NE.0 ) THEN
            INFO = N + IERR
            RETURN
         ENDIF
C
      ENDIF
C
C     Factor the matrix A'*A.
C
      IF ( FULL ) THEN
         CALL DPOTRF( UPLO, N, ATA, LDATA, IERR )
      ELSE
         CALL DPPTRF( UPLO, N, ATA, IERR )
      ENDIF
C
      IF ( IERR.NE.0 ) THEN
         INFO = IERR
         RETURN
      ENDIF
C
C     Solve the set of linear systems.
C
      IF ( FULL ) THEN
         CALL DPOTRS( UPLO, N, NRHS, ATA, LDATA, B, LDB, IERR )
      ELSE
         CALL DPPTRS( UPLO, N, NRHS, ATA, B, LDB, IERR )
      ENDIF
C
C *** Last line of MB02XD ***
      END


Function pyw1au(eps, ireim)
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Save /ludat1/
  acosh(x) = log(x+sqrt(x**2-1.))
  If (eps<0.) Then
    w1re = 2.*sqrt(1.-eps)*asinh(sqrt(-1./eps))
    w1im = 0.
  Else If (eps<1.) Then
    w1re = 2.*sqrt(1.-eps)*acosh(sqrt(1./eps))
    w1im = -paru(1)*sqrt(1.-eps)
  Else
    w1re = 2.*sqrt(eps-1.)*asin(sqrt(1./eps))
    w1im = 0.
  End If
  If (ireim==1) pyw1au = w1re
  If (ireim==2) pyw1au = w1im
  Return
End Function pyw1au