!*==cbdsqr.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022

!> \brief \b CBDSQR
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CBDSQR + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
!                          LDU, C, LDC, RWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          UPLO
!       INTEGER            INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
!       ..
!       .. Array Arguments ..
!       REAL               D( * ), E( * ), RWORK( * )
!       COMPLEX            C( LDC, * ), U( LDU, * ), VT( LDVT, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CBDSQR computes the singular values and, optionally, the right and/or
!> left singular vectors from the singular value decomposition (SVD) of
!> a real N-by-N (upper or lower) bidiagonal matrix B using the implicit
!> zero-shift QR algorithm.  The SVD of B has the form
!>
!>    B = Q * S * P**H
!>
!> where S is the diagonal matrix of singular values, Q is an orthogonal
!> matrix of left singular vectors, and P is an orthogonal matrix of
!> right singular vectors.  If left singular vectors are requested, this
!> subroutine actually returns U*Q instead of Q, and, if right singular
!> vectors are requested, this subroutine returns P**H*VT instead of
!> P**H, for given complex input matrices U and VT.  When U and VT are
!> the unitary matrices that reduce a general matrix A to bidiagonal
!> form: A = U*B*VT, as computed by CGEBRD, then
!>
!>    A = (U*Q) * S * (P**H*VT)
!>
!> is the SVD of A.  Optionally, the subroutine may also compute Q**H*C
!> for a given complex input matrix C.
!>
!> See "Computing  Small Singular Values of Bidiagonal Matrices With
!> Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
!> LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
!> no. 5, pp. 873-912, Sept 1990) and
!> "Accurate singular values and differential qd algorithms," by
!> B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
!> Department, University of California at Berkeley, July 1992
!> for a detailed description of the algorithm.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          = 'U':  B is upper bidiagonal;
!>          = 'L':  B is lower bidiagonal.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix B.  N >= 0.
!> \endverbatim
!>
!> \param[in] NCVT
!> \verbatim
!>          NCVT is INTEGER
!>          The number of columns of the matrix VT. NCVT >= 0.
!> \endverbatim
!>
!> \param[in] NRU
!> \verbatim
!>          NRU is INTEGER
!>          The number of rows of the matrix U. NRU >= 0.
!> \endverbatim
!>
!> \param[in] NCC
!> \verbatim
!>          NCC is INTEGER
!>          The number of columns of the matrix C. NCC >= 0.
!> \endverbatim
!>
!> \param[in,out] D
!> \verbatim
!>          D is REAL array, dimension (N)
!>          On entry, the n diagonal elements of the bidiagonal matrix B.
!>          On exit, if INFO=0, the singular values of B in decreasing
!>          order.
!> \endverbatim
!>
!> \param[in,out] E
!> \verbatim
!>          E is REAL array, dimension (N-1)
!>          On entry, the N-1 offdiagonal elements of the bidiagonal
!>          matrix B.
!>          On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E
!>          will contain the diagonal and superdiagonal elements of a
!>          bidiagonal matrix orthogonally equivalent to the one given
!>          as input.
!> \endverbatim
!>
!> \param[in,out] VT
!> \verbatim
!>          VT is COMPLEX array, dimension (LDVT, NCVT)
!>          On entry, an N-by-NCVT matrix VT.
!>          On exit, VT is overwritten by P**H * VT.
!>          Not referenced if NCVT = 0.
!> \endverbatim
!>
!> \param[in] LDVT
!> \verbatim
!>          LDVT is INTEGER
!>          The leading dimension of the array VT.
!>          LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
!> \endverbatim
!>
!> \param[in,out] U
!> \verbatim
!>          U is COMPLEX array, dimension (LDU, N)
!>          On entry, an NRU-by-N matrix U.
!>          On exit, U is overwritten by U * Q.
!>          Not referenced if NRU = 0.
!> \endverbatim
!>
!> \param[in] LDU
!> \verbatim
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= max(1,NRU).
!> \endverbatim
!>
!> \param[in,out] C
!> \verbatim
!>          C is COMPLEX array, dimension (LDC, NCC)
!>          On entry, an N-by-NCC matrix C.
!>          On exit, C is overwritten by Q**H * C.
!>          Not referenced if NCC = 0.
!> \endverbatim
!>
!> \param[in] LDC
!> \verbatim
!>          LDC is INTEGER
!>          The leading dimension of the array C.
!>          LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is REAL array, dimension (4*N)
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  If INFO = -i, the i-th argument had an illegal value
!>          > 0:  the algorithm did not converge; D and E contain the
!>                elements of a bidiagonal matrix which is orthogonally
!>                similar to the input matrix B;  if INFO = i, i
!>                elements of E have not converged to zero.
!> \endverbatim
!
!> \par Internal Parameters:
!  =========================
!>
!> \verbatim
!>  TOLMUL  REAL, default = max(10,min(100,EPS**(-1/8)))
!>          TOLMUL controls the convergence criterion of the QR loop.
!>          If it is positive, TOLMUL*EPS is the desired relative
!>             precision in the computed singular values.
!>          If it is negative, abs(TOLMUL*EPS*sigma_max) is the
!>             desired absolute accuracy in the computed singular
!>             values (corresponds to relative accuracy
!>             abs(TOLMUL*EPS) in the largest singular value.
!>          abs(TOLMUL) should be between 1 and 1/EPS, and preferably
!>             between 10 (for fast convergence) and .1/EPS
!>             (for there to be some accuracy in the results).
!>          Default is to lose at either one eighth or 2 of the
!>             available decimal digits in each computed singular value
!>             (whichever is smaller).
!>
!>  MAXITR  INTEGER, default = 6
!>          MAXITR controls the maximum number of passes of the
!>          algorithm through its inner loop. The algorithms stops
!>          (and so fails to converge) if the number of passes
!>          through the inner loop exceeds MAXITR*N**2.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexOTHERcomputational
!
!  =====================================================================
      SUBROUTINE CBDSQR(Uplo,N,Ncvt,Nru,Ncc,D,E,Vt,Ldvt,U,Ldu,C,Ldc,    &
     &                  Rwork,Info)
      IMPLICIT NONE
!*--CBDSQR227
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Uplo
      INTEGER Info , Ldc , Ldu , Ldvt , N , Ncc , Ncvt , Nru
!     ..
!     .. Array Arguments ..
      REAL D(*) , E(*) , Rwork(*)
      COMPLEX C(Ldc,*) , U(Ldu,*) , Vt(Ldvt,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO
      PARAMETER (ZERO=0.0E0)
      REAL ONE
      PARAMETER (ONE=1.0E0)
      REAL NEGONE
      PARAMETER (NEGONE=-1.0E0)
      REAL HNDRTH
      PARAMETER (HNDRTH=0.01E0)
      REAL TEN
      PARAMETER (TEN=10.0E0)
      REAL HNDRD
      PARAMETER (HNDRD=100.0E0)
      REAL MEIGTH
      PARAMETER (MEIGTH=-0.125E0)
      INTEGER MAXITR
      PARAMETER (MAXITR=6)
!     ..
!     .. Local Scalars ..
      LOGICAL lower , rotate
      INTEGER i , idir , isub , iter , j , ll , lll , m , maxit , nm1 , &
     &        nm12 , nm13 , oldll , oldm
      REAL abse , abss , cosl , cosr , cs , eps , f , g , h , mu ,      &
     &     oldcs , oldsn , r , shift , sigmn , sigmx , sinl , sinr ,    &
     &     sll , smax , smin , sminl , sminoa , sn , thresh , tol ,     &
     &     tolmul , unfl
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      REAL SLAMCH
      EXTERNAL LSAME , SLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL CLASR , CSROT , CSSCAL , CSWAP , SLARTG , SLAS2 ,        &
     &         SLASQ1 , SLASV2 , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX , MIN , REAL , SIGN , SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      Info = 0
      lower = LSAME(Uplo,'L')
      IF ( .NOT.LSAME(Uplo,'U') .AND. .NOT.lower ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Ncvt<0 ) THEN
         Info = -3
      ELSEIF ( Nru<0 ) THEN
         Info = -4
      ELSEIF ( Ncc<0 ) THEN
         Info = -5
      ELSEIF ( (Ncvt==0 .AND. Ldvt<1) .OR. (Ncvt>0 .AND. Ldvt<MAX(1,N)) &
     &         ) THEN
         Info = -9
      ELSEIF ( Ldu<MAX(1,Nru) ) THEN
         Info = -11
      ELSEIF ( (Ncc==0 .AND. Ldc<1) .OR. (Ncc>0 .AND. Ldc<MAX(1,N)) )   &
     &         THEN
         Info = -13
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('CBDSQR',-Info)
         RETURN
      ENDIF
      IF ( N==0 ) RETURN
      IF ( N==1 ) GOTO 300
!
!     ROTATE is true if any singular vectors desired, false otherwise
!
      rotate = (Ncvt>0) .OR. (Nru>0) .OR. (Ncc>0)
!
!     If no singular vectors desired, use qd algorithm
!
      IF ( .NOT.rotate ) THEN
         CALL SLASQ1(N,D,E,Rwork,Info)
!
!     If INFO equals 2, dqds didn't finish, try to finish
!
         IF ( Info/=2 ) RETURN
         Info = 0
      ENDIF
!
      nm1 = N - 1
      nm12 = nm1 + nm1
      nm13 = nm12 + nm1
      idir = 0
!
!     Get machine constants
!
      eps = SLAMCH('Epsilon')
      unfl = SLAMCH('Safe minimum')
!
!     If matrix lower bidiagonal, rotate to be upper bidiagonal
!     by applying Givens rotations on the left
!
      IF ( lower ) THEN
         DO i = 1 , N - 1
            CALL SLARTG(D(i),E(i),cs,sn,r)
            D(i) = r
            E(i) = sn*D(i+1)
            D(i+1) = cs*D(i+1)
            Rwork(i) = cs
            Rwork(nm1+i) = sn
         ENDDO
!
!        Update singular vectors if desired
!
         IF ( Nru>0 ) CALL CLASR('R','V','F',Nru,N,Rwork(1),Rwork(N),U, &
     &                           Ldu)
         IF ( Ncc>0 ) CALL CLASR('L','V','F',N,Ncc,Rwork(1),Rwork(N),C, &
     &                           Ldc)
      ENDIF
!
!     Compute singular values to relative accuracy TOL
!     (By setting TOL to be negative, algorithm will compute
!     singular values to absolute accuracy ABS(TOL)*norm(input matrix))
!
      tolmul = MAX(TEN,MIN(HNDRD,eps**MEIGTH))
      tol = tolmul*eps
!
!     Compute approximate maximum, minimum singular values
!
      smax = ZERO
      DO i = 1 , N
         smax = MAX(smax,ABS(D(i)))
      ENDDO
      DO i = 1 , N - 1
         smax = MAX(smax,ABS(E(i)))
      ENDDO
      sminl = ZERO
      IF ( tol>=ZERO ) THEN
!
!        Relative accuracy desired
!
         sminoa = ABS(D(1))
         IF ( sminoa/=ZERO ) THEN
            mu = sminoa
            DO i = 2 , N
               mu = ABS(D(i))*(mu/(mu+ABS(E(i-1))))
               sminoa = MIN(sminoa,mu)
               IF ( sminoa==ZERO ) EXIT
            ENDDO
         ENDIF
         sminoa = sminoa/SQRT(REAL(N))
         thresh = MAX(tol*sminoa,MAXITR*N*N*unfl)
      ELSE
!
!        Absolute accuracy desired
!
         thresh = MAX(ABS(tol)*smax,MAXITR*N*N*unfl)
      ENDIF
!
!     Prepare for main iteration loop for the singular values
!     (MAXIT is the maximum number of passes through the inner
!     loop permitted before nonconvergence signalled.)
!
      maxit = MAXITR*N*N
      iter = 0
      oldll = -1
      oldm = -1
!
!     M points to last element of unconverged part of matrix
!
      m = N
!
!     Begin main iteration loop
!
!
!     Check for convergence or exceeding iteration count
!
 100  DO WHILE ( m>1 )
         IF ( iter>maxit ) THEN
!
!     Maximum number of iterations exceeded, failure to converge
!
            Info = 0
            DO i = 1 , N - 1
               IF ( E(i)/=ZERO ) Info = Info + 1
            ENDDO
            GOTO 99999
         ELSE
!
!     Find diagonal block of matrix to work on
!
            IF ( tol<ZERO .AND. ABS(D(m))<=thresh ) D(m) = ZERO
            smax = ABS(D(m))
            smin = smax
            DO lll = 1 , m - 1
               ll = m - lll
               abss = ABS(D(ll))
               abse = ABS(E(ll))
               IF ( tol<ZERO .AND. abss<=thresh ) D(ll) = ZERO
               IF ( abse<=thresh ) GOTO 150
               smin = MIN(smin,abss)
               smax = MAX(smax,abss,abse)
            ENDDO
            ll = 0
            GOTO 200
         ENDIF
 150     E(ll) = ZERO
!
!     Matrix splits since E(LL) = 0
!
         IF ( ll==m-1 ) THEN
!
!        Convergence of bottom singular value, return to top of loop
!
            m = m - 1
            CYCLE
         ENDIF
         GOTO 200
      ENDDO
      GOTO 300
 200  ll = ll + 1
!
!     E(LL) through E(M-1) are nonzero, E(LL-1) is zero
!
      IF ( ll==m-1 ) THEN
!
!        2 by 2 block, handle separately
!
         CALL SLASV2(D(m-1),E(m-1),D(m),sigmn,sigmx,sinr,cosr,sinl,cosl)
         D(m-1) = sigmx
         E(m-1) = ZERO
         D(m) = sigmn
!
!        Compute singular vectors, if desired
!
         IF ( Ncvt>0 ) CALL CSROT(Ncvt,Vt(m-1,1),Ldvt,Vt(m,1),Ldvt,cosr,&
     &                            sinr)
         IF ( Nru>0 ) CALL CSROT(Nru,U(1,m-1),1,U(1,m),1,cosl,sinl)
         IF ( Ncc>0 ) CALL CSROT(Ncc,C(m-1,1),Ldc,C(m,1),Ldc,cosl,sinl)
         m = m - 2
         GOTO 100
      ENDIF
!
!     If working on new submatrix, choose shift direction
!     (from larger end diagonal element towards smaller)
!
      IF ( ll>oldm .OR. m<oldll ) THEN
         IF ( ABS(D(ll))>=ABS(D(m)) ) THEN
!
!           Chase bulge from top (big end) to bottom (small end)
!
            idir = 1
         ELSE
!
!           Chase bulge from bottom (big end) to top (small end)
!
            idir = 2
         ENDIF
      ENDIF
!
!     Apply convergence tests
!
      IF ( idir==1 ) THEN
!
!        Run convergence test in forward direction
!        First apply standard test to bottom of matrix
!
         IF ( ABS(E(m-1))<=ABS(tol)*ABS(D(m)) .OR.                      &
     &        (tol<ZERO .AND. ABS(E(m-1))<=thresh) ) THEN
            E(m-1) = ZERO
            GOTO 100
         ENDIF
!
         IF ( tol>=ZERO ) THEN
!
!           If relative accuracy desired,
!           apply convergence criterion forward
!
            mu = ABS(D(ll))
            sminl = mu
            DO lll = ll , m - 1
               IF ( ABS(E(lll))<=tol*mu ) THEN
                  E(lll) = ZERO
                  GOTO 100
               ENDIF
               mu = ABS(D(lll+1))*(mu/(mu+ABS(E(lll))))
               sminl = MIN(sminl,mu)
            ENDDO
         ENDIF
!
      ELSE
!
!        Run convergence test in backward direction
!        First apply standard test to top of matrix
!
         IF ( ABS(E(ll))<=ABS(tol)*ABS(D(ll)) .OR.                      &
     &        (tol<ZERO .AND. ABS(E(ll))<=thresh) ) THEN
            E(ll) = ZERO
            GOTO 100
         ENDIF
!
         IF ( tol>=ZERO ) THEN
!
!           If relative accuracy desired,
!           apply convergence criterion backward
!
            mu = ABS(D(m))
            sminl = mu
            DO lll = m - 1 , ll , -1
               IF ( ABS(E(lll))<=tol*mu ) THEN
                  E(lll) = ZERO
                  GOTO 100
               ENDIF
               mu = ABS(D(lll))*(mu/(mu+ABS(E(lll))))
               sminl = MIN(sminl,mu)
            ENDDO
         ENDIF
      ENDIF
      oldll = ll
      oldm = m
!
!     Compute shift.  First, test if shifting would ruin relative
!     accuracy, and if so set the shift to zero.
!
      IF ( tol>=ZERO .AND. N*tol*(sminl/smax)<=MAX(eps,HNDRTH*tol) )    &
     &     THEN
!
!        Use a zero shift to avoid loss of relative accuracy
!
         shift = ZERO
      ELSE
!
!        Compute the shift from 2-by-2 block at end of matrix
!
         IF ( idir==1 ) THEN
            sll = ABS(D(ll))
            CALL SLAS2(D(m-1),E(m-1),D(m),shift,r)
         ELSE
            sll = ABS(D(m))
            CALL SLAS2(D(ll),E(ll),D(ll+1),shift,r)
         ENDIF
!
!        Test if shift negligible, and if so set to zero
!
         IF ( sll>ZERO ) THEN
            IF ( (shift/sll)**2<eps ) shift = ZERO
         ENDIF
      ENDIF
!
!     Increment iteration count
!
      iter = iter + m - ll
!
!     If SHIFT = 0, do simplified QR iteration
!
      IF ( shift==ZERO ) THEN
         IF ( idir==1 ) THEN
!
!           Chase bulge from top to bottom
!           Save cosines and sines for later singular vector updates
!
            cs = ONE
            oldcs = ONE
            DO i = ll , m - 1
               CALL SLARTG(D(i)*cs,E(i),cs,sn,r)
               IF ( i>ll ) E(i-1) = oldsn*r
               CALL SLARTG(oldcs*r,D(i+1)*sn,oldcs,oldsn,D(i))
               Rwork(i-ll+1) = cs
               Rwork(i-ll+1+nm1) = sn
               Rwork(i-ll+1+nm12) = oldcs
               Rwork(i-ll+1+nm13) = oldsn
            ENDDO
            h = D(m)*cs
            D(m) = h*oldcs
            E(m-1) = h*oldsn
!
!           Update singular vectors
!
            IF ( Ncvt>0 ) CALL CLASR('L','V','F',m-ll+1,Ncvt,Rwork(1),  &
     &                               Rwork(N),Vt(ll,1),Ldvt)
            IF ( Nru>0 ) CALL CLASR('R','V','F',Nru,m-ll+1,Rwork(nm12+1)&
     &                              ,Rwork(nm13+1),U(1,ll),Ldu)
            IF ( Ncc>0 ) CALL CLASR('L','V','F',m-ll+1,Ncc,Rwork(nm12+1)&
     &                              ,Rwork(nm13+1),C(ll,1),Ldc)
!
!           Test convergence
!
            IF ( ABS(E(m-1))<=thresh ) E(m-1) = ZERO
!
         ELSE
!
!           Chase bulge from bottom to top
!           Save cosines and sines for later singular vector updates
!
            cs = ONE
            oldcs = ONE
            DO i = m , ll + 1 , -1
               CALL SLARTG(D(i)*cs,E(i-1),cs,sn,r)
               IF ( i<m ) E(i) = oldsn*r
               CALL SLARTG(oldcs*r,D(i-1)*sn,oldcs,oldsn,D(i))
               Rwork(i-ll) = cs
               Rwork(i-ll+nm1) = -sn
               Rwork(i-ll+nm12) = oldcs
               Rwork(i-ll+nm13) = -oldsn
            ENDDO
            h = D(ll)*cs
            D(ll) = h*oldcs
            E(ll) = h*oldsn
!
!           Update singular vectors
!
            IF ( Ncvt>0 ) CALL CLASR('L','V','B',m-ll+1,Ncvt,           &
     &                               Rwork(nm12+1),Rwork(nm13+1),       &
     &                               Vt(ll,1),Ldvt)
            IF ( Nru>0 ) CALL CLASR('R','V','B',Nru,m-ll+1,Rwork(1),    &
     &                              Rwork(N),U(1,ll),Ldu)
            IF ( Ncc>0 ) CALL CLASR('L','V','B',m-ll+1,Ncc,Rwork(1),    &
     &                              Rwork(N),C(ll,1),Ldc)
!
!           Test convergence
!
            IF ( ABS(E(ll))<=thresh ) E(ll) = ZERO
         ENDIF
!
!        Use nonzero shift
!
      ELSEIF ( idir==1 ) THEN
!
!           Chase bulge from top to bottom
!           Save cosines and sines for later singular vector updates
!
         f = (ABS(D(ll))-shift)*(SIGN(ONE,D(ll))+shift/D(ll))
         g = E(ll)
         DO i = ll , m - 1
            CALL SLARTG(f,g,cosr,sinr,r)
            IF ( i>ll ) E(i-1) = r
            f = cosr*D(i) + sinr*E(i)
            E(i) = cosr*E(i) - sinr*D(i)
            g = sinr*D(i+1)
            D(i+1) = cosr*D(i+1)
            CALL SLARTG(f,g,cosl,sinl,r)
            D(i) = r
            f = cosl*E(i) + sinl*D(i+1)
            D(i+1) = cosl*D(i+1) - sinl*E(i)
            IF ( i<m-1 ) THEN
               g = sinl*E(i+1)
               E(i+1) = cosl*E(i+1)
            ENDIF
            Rwork(i-ll+1) = cosr
            Rwork(i-ll+1+nm1) = sinr
            Rwork(i-ll+1+nm12) = cosl
            Rwork(i-ll+1+nm13) = sinl
         ENDDO
         E(m-1) = f
!
!           Update singular vectors
!
         IF ( Ncvt>0 ) CALL CLASR('L','V','F',m-ll+1,Ncvt,Rwork(1),     &
     &                            Rwork(N),Vt(ll,1),Ldvt)
         IF ( Nru>0 ) CALL CLASR('R','V','F',Nru,m-ll+1,Rwork(nm12+1),  &
     &                           Rwork(nm13+1),U(1,ll),Ldu)
         IF ( Ncc>0 ) CALL CLASR('L','V','F',m-ll+1,Ncc,Rwork(nm12+1),  &
     &                           Rwork(nm13+1),C(ll,1),Ldc)
!
!           Test convergence
!
         IF ( ABS(E(m-1))<=thresh ) E(m-1) = ZERO
!
      ELSE
!
!           Chase bulge from bottom to top
!           Save cosines and sines for later singular vector updates
!
         f = (ABS(D(m))-shift)*(SIGN(ONE,D(m))+shift/D(m))
         g = E(m-1)
         DO i = m , ll + 1 , -1
            CALL SLARTG(f,g,cosr,sinr,r)
            IF ( i<m ) E(i) = r
            f = cosr*D(i) + sinr*E(i-1)
            E(i-1) = cosr*E(i-1) - sinr*D(i)
            g = sinr*D(i-1)
            D(i-1) = cosr*D(i-1)
            CALL SLARTG(f,g,cosl,sinl,r)
            D(i) = r
            f = cosl*E(i-1) + sinl*D(i-1)
            D(i-1) = cosl*D(i-1) - sinl*E(i-1)
            IF ( i>ll+1 ) THEN
               g = sinl*E(i-2)
               E(i-2) = cosl*E(i-2)
            ENDIF
            Rwork(i-ll) = cosr
            Rwork(i-ll+nm1) = -sinr
            Rwork(i-ll+nm12) = cosl
            Rwork(i-ll+nm13) = -sinl
         ENDDO
         E(ll) = f
!
!           Test convergence
!
         IF ( ABS(E(ll))<=thresh ) E(ll) = ZERO
!
!           Update singular vectors if desired
!
         IF ( Ncvt>0 ) CALL CLASR('L','V','B',m-ll+1,Ncvt,Rwork(nm12+1),&
     &                            Rwork(nm13+1),Vt(ll,1),Ldvt)
         IF ( Nru>0 ) CALL CLASR('R','V','B',Nru,m-ll+1,Rwork(1),       &
     &                           Rwork(N),U(1,ll),Ldu)
         IF ( Ncc>0 ) CALL CLASR('L','V','B',m-ll+1,Ncc,Rwork(1),       &
     &                           Rwork(N),C(ll,1),Ldc)
      ENDIF
!
!     QR iteration finished, go back and check convergence
!
      GOTO 100
!
!     All singular values converged, so make them positive
!
 300  DO i = 1 , N
         IF ( D(i)<ZERO ) THEN
            D(i) = -D(i)
!
!           Change sign of singular vectors, if desired
!
            IF ( Ncvt>0 ) CALL CSSCAL(Ncvt,NEGONE,Vt(i,1),Ldvt)
         ENDIF
      ENDDO
!
!     Sort the singular values into decreasing order (insertion sort on
!     singular values, but only one transposition per singular vector)
!
      DO i = 1 , N - 1
!
!        Scan for smallest D(I)
!
         isub = 1
         smin = D(1)
         DO j = 2 , N + 1 - i
            IF ( D(j)<=smin ) THEN
               isub = j
               smin = D(j)
            ENDIF
         ENDDO
         IF ( isub/=N+1-i ) THEN
!
!           Swap singular values and vectors
!
            D(isub) = D(N+1-i)
            D(N+1-i) = smin
            IF ( Ncvt>0 ) CALL CSWAP(Ncvt,Vt(isub,1),Ldvt,Vt(N+1-i,1),  &
     &                               Ldvt)
            IF ( Nru>0 ) CALL CSWAP(Nru,U(1,isub),1,U(1,N+1-i),1)
            IF ( Ncc>0 ) CALL CSWAP(Ncc,C(isub,1),Ldc,C(N+1-i,1),Ldc)
         ENDIF
      ENDDO
!
!     End of CBDSQR
!
99999 END SUBROUTINE CBDSQR


! { dg-do run }
! { dg-options "-ffrontend-optimize -fdump-tree-original" }
! Test that reduction optimization doesn't break with a function expression
! in an array constructor.
program main
  implicit none
  integer, parameter :: dp=selected_real_kind(15)
  real(kind=dp), dimension(2,2) :: a
  real(kind=dp) thirteen

  data a /2._dp,3._dp,5._dp,7._dp/
  thirteen = 13._dp
  if (abs (product([[sum([eleven_ones()]), thirteen], a]) - 30030._dp) > 1e-8) STOP 1
 contains
  function eleven_ones()
    real(kind=dp) :: eleven_ones(11)
    integer       :: i

    eleven_ones = [ (1._dp, i=1,11) ]
  end function eleven_ones
end program main
! { dg-final { scan-tree-dump-times "while" 4 "original" } }


      module rrlw_con

      !use parkind, only : rb => kind_rb
      !JOY use c_double from iso_c_binding
      !instead of kind_rb
      use iso_c_binding

      implicit none
      save

!------------------------------------------------------------------
! rrtmg_lw constants

! Initial version: MJIacono, AER, jun2006
! Revised: MJIacono, AER, aug2008
!------------------------------------------------------------------

!  name     type     purpose
! -----  :  ----   : ----------------------------------------------
! fluxfac:  real   : radiance to flux conversion factor
! heatfac:  real   : flux to heating rate conversion factor
!oneminus:  real   : 1.-1.e-6
! pi     :  real   : pi
! grav   :  real   : acceleration of gravity
! planck :  real   : planck constant
! boltz  :  real   : boltzmann constant
! clight :  real   : speed of light
! avogad :  real   : avogadro constant
! alosmt :  real   : loschmidt constant
! gascon :  real   : molar gas constant
! radcn1 :  real   : first radiation constant
! radcn2 :  real   : second radiation constant
! sbcnst :  real   : stefan-boltzmann constant
!  secdy :  real   : seconds per day
!------------------------------------------------------------------

      real(kind=c_double) :: fluxfac, heatfac
      real(kind=c_double) :: oneminus, pi, grav
      real(kind=c_double) :: planck, boltz, clight
      real(kind=c_double) :: avogad, alosmt, gascon
      real(kind=c_double) :: radcn1, radcn2
      real(kind=c_double) :: sbcnst, secdy

      contains

          subroutine set_rrtm_constants(py_pi, py_grav, py_planck, &
                  py_boltz, py_clight, py_avogad, py_alosmt, &
                  py_gascon, py_sbcnst,&
                  py_secdy)bind(c, name='rrtmg_set_constants')

              real(kind=c_double) :: py_pi, py_grav, py_planck
              real(kind=c_double) :: py_boltz, py_clight, py_avogad
              real(kind=c_double) :: py_alosmt, py_gascon, py_sbcnst
              real(kind=c_double) :: py_secdy

              pi = py_pi
              grav = py_grav
              planck = py_planck
              boltz = py_boltz
              clight = py_clight
              avogad = py_avogad
              alosmt = py_alosmt
              gascon = py_gascon

              radcn1 = 2.*planck*clight*clight*1.e-07
              radcn2 = planck*clight/boltz

              sbcnst = py_sbcnst
              secdy = py_secdy

          end subroutine set_rrtm_constants

      end module rrlw_con


C      SUBROUTINE NNLS - SEE LAWSON AND HANSON'S TEXT ON SOLVING
C      LEAST SQUARES (pp. 304-307).  THIS IS THE SUBROUTINE USED
C      IN MATLAB.
C
C      GIVEN AN M BY N MATRIX A, AND AN M BY 1 VECTOR B, COMPUTE
C      AN N BY 1 VECTOR X, WHICH SOLVES THE LEAST SQUARES PROBLEM
C
C                A * X = B SUBJECT TO X .GE. 0
C
C      A(),MDA,M,N      MDA IS THE FIRST DIMENSIONING PARAMETER
C                       FOR THE ARRAY, A().  ON ENTRY A() CONTAINS
C                       THE M BY N MATRIX A.  ON EXIT A() CONTAINS
C                       THE PRODUCT MATRIX Q*A, WHERE Q IS AN
C                       M BY M ORTHOGONAL MATRIX GENERATED
C                       IMPLICITLY BY THE SUBROUTINE.
C      B()       ON ENTRY B() CONTAINS THE VECTOR B AND ON EXIT
C                IT CONTAINS Q*B.
C      X()       ON ENTRY X() NEED NOT BE INITIALIZED.  ON EXIT
C                THIS WILL BE THE SOLUTION VECTOR.
C      RESNORM   ON EXIT RESNORM CONTAINS THE EUCLIDEAN NORM OF THE
C                RESIDUAL VECTOR.
C      W()       AN N-ARRAY OF WORKING SPACE.  ON EXIT W() CONTAINS
C                THE DUAL SOLUTION VECTOR.  W WILL SATISFY W(I)=0
C                FOR ALL I IN SET P AND W(I) .LE. 0 FOR AL I IN SET Z.
C      ZZ()      AN M-ARRAY FOR WORKING SPACE
C      INDX()    AN INTEGER WORKING ARRAY OF LENGTH AT LEAST N.
C                ON EXIT THE CONTENTS OF THIS ARRAY DEFINE THE SETS
C                P AND Z AS FOLLOWS.
C
C                    INDX(1) THRU INDX(NSETP)=SET P.
C                    INDX(IZ1) THRU INDX(IZ2)=SET Z.
C                    IZ1=NSETP+1=NPP1
C                    IZ2=N
C      MDE      THIS IS A SUCCESS-FAILURE FLAG WITH THE FOLLOWING
C                MEANINGS.
C                1     THE SOLUTION HAS BEEN COMPUTED SUCCESSFULLY
C                2     THE DIMESNIONS OF THE PROBLEM ARE BAD
C                      EITHER M .LE. 0 OR N .LE 0
C                3     ITERATION COUNT EXCEEDED
C
      SUBROUTINE NNLS (A,MDA,M, N,B,X,RESNORM,W,ZZ,INDX,MDE)
      DIMENSION A(MDA,N), B(M), X(N), W(N), ZZ(M)
      REAL A,B,X,RESNORM,W,ZZ
      INTEGER INDX(N),ITER,NSETP
      ZERO=0.
      ONE=1.
      TWO=2.
      FACTOR=0.01
      MDE=1
      IF (M.GT.0 .AND. N.GT.0) GO TO 10
      MDE=2
      RETURN
 10   ITER=0
      ITMAX=3*N
C
C     INITIALIZE THE ARRAYS  INDX() AND X()
C
         DO 20 I=1,N
         X(I)=ZERO
 20      INDX(I)=I
C
      IZ2=N
      IZ1=1
      NSETP=0
      NPP1=1
C
C     ********MAIN LOOP BEGINS HERE***********
 30   CONTINUE
C
C     QUIT IF ALL COEFFICIENTS ARE ALREADY IN THE SOLUTION
C     OR IF M COLS OF A HAVE BEEN TRIANGULARIZED.
C
      IF (IZ1.GT.IZ2 .OR. NSETP.GE.M) GO TO 350
C
C     COMPUTE COMPONENTS OF THE DUAL (NEGATIVE GRADIENT) VECTOR W()
C
          DO 50 IZ=IZ1,IZ2
          J=INDX(IZ)
          SM=ZERO
                DO 40 L=NPP1,M
 40             SM=SM+A(L,J)*B(L)
 50       W(J)=SM
C
C         FIND LARGEST POSITIVE W(J)
C
 60   WMAX=ZERO
          DO 70 IZ=IZ1,IZ2
          J=INDX(IZ)
          IF (W(J).LE.WMAX) GO TO 70
          WMAX=W(J)
          IZMAX=IZ
 70       CONTINUE
C
C     IF WMAX .LE. O GO TO TERMINATION
C     THIS INDICATES SATISFACTION OF THE KUHN-TUCKER CONDITIONS
C
      IF (WMAX) 350,350,80
 80   IZ=IZMAX
      J=INDX(IZ)
C
C     THE SIGN OF W(J) IS OK FOR J TO BE MOVED TO SET P
C     BEGIN THE TRANSFORMATION AND CHECK NEW DIAGONAL ELEMENT TO
C     AVOID NEAR LINEAR DEPENDENCE.
C
      ASAVE=A(NPP1,J)
      CALL H12 (1,NPP1,NPP1+1,M,A(1,J),1,UP,DUMMY,1,1,0)
      UNORM=ZERO
      IF (NSETP.EQ.0) GO TO 100
           DO 90 L=1,NSETP
 90        UNORM=UNORM+A(L,J)**2
 100  UNORM=SQRT(UNORM)
      IF (DIFF(UNORM+ABS(A(NPP1,J))*FACTOR,UNORM)) 130,130,110

C
C     COL J IS SUFFICIENTLY INDEPENDENT.  COPY B INTO ZZ. UPDATE ZZ
C     AND SOLVE FOR ZTEST (=PROPOSED NEW VALUE FOR X(J)).
C
 110       DO 120 L=1,M
 120       ZZ(L)=B(L)
      CALL H12(2,NPP1,NPP1+1,M,A(1,J),1,UP,ZZ,1,1,1)
      ZTEST=ZZ(NPP1)/A(NPP1,J)
C
C      SEE IF ZTEST IS POSITIVE
C
      IF (ZTEST) 130,130,140
C
C     REJECT J AS A CANDIDATE TO BE MOVED FROM SET Z TO SET P.
C     RESTORE A(NPP1,J), SET W(J)=0., AND LOOP BACK TO TEST DUAL
C     COEFFS AGAIN.
C
 130  A(NPP1,J)=ASAVE
      W(J)=ZERO
      GO TO 60
C
C     THE INDEX J=INDX(IZ) HAS BEEN SELECTED TO BE MOVED FROM
C     SET Z TO SET P.  UPDATE B. UPDATE INDICES. APPLY HOUSEHOLDER
C     TRANSFORMATIONS TO COLS IN NEW SET Z.  ZERO SUBDIAGONAL ELTS IN
C     COL J, SET W(J)=0.
C
 140      DO 150 L=1,M
 150      B(L)=ZZ(L)
C
      INDX(IZ)=INDX(IZ1)
      INDX(IZ1)=J
      IZ1=IZ1+1
      NSETP=NPP1
      NPP1=NPP1+1
C
      IF (IZ1.GT.IZ2) GO TO 170
          DO 160 JZ=IZ1,IZ2
          JJ=INDX(JZ)
 160      CALL H12 (2,NSETP,NPP1,M,A(1,J),1,UP,A(1,JJ),1,MDA,1)
 170  CONTINUE
C
      IF (NSETP.EQ.M) GO TO 190
          DO 180 L=NPP1,M
 180      A(L,J)=ZERO
 190  CONTINUE
C
      W(J)=ZERO
C
C     SOLVE THE TRIANGULAR SYSTEM, AND STORE THE SOLUTION
C     TEMPORARILY IN ZZ()
      TEST=-4.
      GO TO 400
 200  CONTINUE
C
C     ***********SECONDARY LOOP BEGINS HERE*************
C
C                    ITERATION COUNTER
C
 210  ITER=ITER+1
      IF (ITER.LE.ITMAX) GO TO 220
      MDE=3
      GO TO 350
 220  CONTINUE
C
C     SEE IF ALL NEW CONSTRAINED COEFFS ARE FEASIBLE
C     IF NOT, COMPUTE ALPHA
C
      ALPHA=TWO
          DO 240 IP=1,NSETP
          L=INDX(IP)
          IF(ZZ(IP)) 230,230,240
C
 230      T=-X(L)/(ZZ(IP)-X(L))
          IF (ALPHA.LE.T) GO TO 240
          ALPHA=T
          JJ=IP
 240      CONTINUE

C
C      IF ALL NEW CONSTRAINED COEFFS ARE FEASIBLE THEN ALPHA WILL
C      STILL = 2.  IF SO EXIT FROM SECONDARY LOOP TO MAIN LOOP
C
      IF (ALPHA.EQ.TWO) GO TO 330
C
C      OTHERWISE USE ALPHA, WHICH WILL BE BETWEEN 0. AND 1. TO
C      INTERPOLATE BETWEEN THE OLD X AND THE NEW ZZ
C
          DO 250 IP=1,NSETP
          L=INDX(IP)
       X(L)=X(L)+ALPHA*(ZZ(IP)-X(L))
 250   CONTINUE
C
C      MODIFY A AND B AND THE INDX ARRAYS TO MOVE COEFF 1
C      FROM SET P TO SET Z
C
      I=INDX(JJ)
 260  X(I)=ZERO
C
      IF (JJ.EQ.NSETP) GO TO 290
      JJ=JJ+1
          DO 280 J=JJ,NSETP
          II=INDX(J)
          INDX(J-1)=II
          CALL G1 (A(J-1,II),A(J,II),CC,SS,A(J-1,II))
          A(J,II)=ZERO
                DO 270 L=1,N
                IF (L.NE.II) CALL G2 (CC,SS,A(J-1,L),A(J,L))
 270            CONTINUE
 280      CALL G2 (CC,SS,B(J-1),B(J))
 290  NPP1=NSETP
      NSETP=NSETP-1
      IZ1=IZ1-1
      INDX(IZ1)=I
C
C     SEE IF THE REMAINING COEFFS IN SET P ARE FEASIBLE.  THEY
C     SHOULD BE BECAUSE OF THE WAY ALPHA WAS DETERMINED.
C     IF ANY ARE INFEASIBLE IT IS DUE TO ROUND-OFF ERROR.  ANY
C     THAT ARE NONPOSITIVE WILL BE SET TO ZERO
C     AND MOVED FROM SET P TO SET Z
C
           DO 300 JJ=1,NSETP
           I=INDX(JJ)
           IF (X(I)) 260,260,300
 300       CONTINUE
C
C     COPY B() INTO ZZ().  THEN SOLVE AGAIN AND LOOP BACK.
C
           DO 310 I=1,M
 310       ZZ(I)=B(I)
      TEST=4.
      GO TO 400
 320  CONTINUE
      GO TO 210
C
C      ******************END OF SECONDARY LOOP***************
C
 330        DO 340 IP=1,NSETP
            I=INDX(IP)
 340        X(I)=ZZ(IP)
C
C       ALL NEW COEFFS ARE POSITIVE.  LOOP BACK TO THE BEGINNING
C
      GO TO 30
C
C   *********************END OF MAIN LOOP*********************
C
C    COME TO HERE FOR TERMINATION
C    COMPUTE THE NORM OF THE RESIDUAL VECTOR
 350  SM=ZERO
      IF (NPP1.GT.M) GO TO 370
         DO 360 I=NPP1,M
 360     SM=SM+B(I)**2
      GO TO 390
 370     DO 380 J=1,N
 380     W(J)=ZERO
 390  RESNORM=SQRT(SM)
      RETURN
C
C     THE FOLLOWING BLOCK OF CODE IS USED AS AN INTERNAL
C     SUBPROGRAM TO SOLVE THE TRIANGULAR SYSTEM, PUTTING
C     THE SOLUTION IN ZZ()
 400      DO 430 L=1,NSETP
          IP=NSETP+1-L
          IF (L.EQ.1) GO TO 420
              DO 410 II=1,IP
 410          ZZ(II)=ZZ(II)-A(II,JJ)*ZZ(IP+1)
 420      JJ=INDX(IP)
 430      ZZ(IP)=ZZ(IP)/A(IP,JJ)
       IF (TEST) 200,200,320
       END


C     ----------------------------------------------------------------------
C     This file contains the LBFGS algorithm and supporting routines
C
C     ****************
C     LBFGS SUBROUTINE
C     ****************
C
      SUBROUTINE LBFGS(N,M,X,F,G,DIAGCO,DIAG,IPRINT,EPS,XTOL,W,IFLAG)
C
      INTEGER N,M,IPRINT(2),IFLAG
      DOUBLE PRECISION X(N),G(N),DIAG(N),W(N*(2*M+1)+2*M)
      DOUBLE PRECISION F,EPS,XTOL
      INTEGER DIAGCO
C
C        LIMITED MEMORY BFGS METHOD FOR LARGE SCALE OPTIMIZATION
C                          JORGE NOCEDAL
C                        *** July 1990 ***
C
C
C     This subroutine solves the unconstrained minimization problem
C
C                      min F(x),    x= (x1,x2,...,xN),
C
C      using the limited memory BFGS method. The routine is especially
C      effective on problems involving a large number of variables. In
C      a typical iteration of this method an approximation Hk to the
C      inverse of the Hessian is obtained by applying M BFGS updates to
C      a diagonal matrix Hk0, using information from the previous M steps.
C      The user specifies the number M, which determines the amount of
C      storage required by the routine. The user may also provide the
C      diagonal matrices Hk0 if not satisfied with the default choice.
C      The algorithm is described in "On the limited memory BFGS method
C      for large scale optimization", by D. Liu and J. Nocedal,
C      Mathematical Programming B 45 (1989) 503-528.
C
C      The user is required to calculate the function value F and its
C      gradient G. In order to allow the user complete control over
C      these computations, reverse  communication is used. The routine
C      must be called repeatedly under the control of the parameter
C      IFLAG.
C
C      The steplength is determined at each iteration by means of the
C      line search routine MCVSRCH, which is a slight modification of
C      the routine CSRCH written by More' and Thuente.
C
C      The calling statement is
C
C          CALL LBFGS(N,M,X,F,G,DIAGCO,DIAG,IPRINT,EPS,XTOL,W,IFLAG)
C
C      where
C
C     N       is an INTEGER variable that must be set by the user to the
C             number of variables. It is not altered by the routine.
C             Restriction: N>0.
C
C     M       is an INTEGER variable that must be set by the user to
C             the number of corrections used in the BFGS update. It
C             is not altered by the routine. Values of M less than 3 are
C             not recommended; large values of M will result in excessive
C             computing time. 3<= M <=7 is recommended. Restriction: M>0.
C
C     X       is a DOUBLE PRECISION array of length N. On initial entry
C             it must be set by the user to the values of the initial
C             estimate of the solution vector. On exit with IFLAG=0, it
C             contains the values of the variables at the best point
C             found (usually a solution).
C
C     F       is a DOUBLE PRECISION variable. Before initial entry and on
C             a re-entry with IFLAG=1, it must be set by the user to
C             contain the value of the function F at the point X.
C
C     G       is a DOUBLE PRECISION array of length N. Before initial
C             entry and on a re-entry with IFLAG=1, it must be set by
C             the user to contain the components of the gradient G at
C             the point X.
C
C     DIAGCO  is a LOGICAL variable that must be set to .TRUE. if the
C             user  wishes to provide the diagonal matrix Hk0 at each
C             iteration. Otherwise it should be set to .FALSE., in which
C             case  LBFGS will use a default value described below. If
C             DIAGCO is set to .TRUE. the routine will return at each
C             iteration of the algorithm with IFLAG=2, and the diagonal
C              matrix Hk0  must be provided in the array DIAG.
C
C
C     DIAG    is a DOUBLE PRECISION array of length N. If DIAGCO=.TRUE.,
C             then on initial entry or on re-entry with IFLAG=2, DIAG
C             it must be set by the user to contain the values of the
C             diagonal matrix Hk0.  Restriction: all elements of DIAG
C             must be positive.
C
C     IPRINT  is an INTEGER array of length two which must be set by the
C             user.
C
C             IPRINT(1) specifies the frequency of the output:
C                IPRINT(1) < 0 : no output is generated,
C                IPRINT(1) = 0 : output only at first and last iteration,
C                IPRINT(1) > 0 : output every IPRINT(1) iterations.
C
C             IPRINT(2) specifies the type of output generated:
C                IPRINT(2) = 0 : iteration count, number of function
C                                evaluations, function value, norm of the
C                                gradient, and steplength,
C                IPRINT(2) = 1 : same as IPRINT(2)=0, plus vector of
C                                variables and  gradient vector at the
C                                initial point,
C                IPRINT(2) = 2 : same as IPRINT(2)=1, plus vector of
C                                variables,
C                IPRINT(2) = 3 : same as IPRINT(2)=2, plus gradient vector.
C
C
C     EPS     is a positive DOUBLE PRECISION variable that must be set by
C             the user, and determines the accuracy with which the solution
C             is to be found. The subroutine terminates when
C
C                         ||G|| < EPS max(1,||X||),
C
C             where ||.|| denotes the Euclidean norm.
C
C     XTOL    is a  positive DOUBLE PRECISION variable that must be set by
C             the user to an estimate of the machine precision (e.g.
C             10**(-16) on a SUN station 3/60). The line search routine will
C             terminate if the relative width of the interval of uncertainty
C             is less than XTOL.
C
C     W       is a DOUBLE PRECISION array of length N(2M+1)+2M used as
C             workspace for LBFGS. This array must not be altered by the
C             user.
C
C     IFLAG   is an INTEGER variable that must be set to 0 on initial entry
C             to the subroutine. A return with IFLAG<0 indicates an error,
C             and IFLAG=0 indicates that the routine has terminated without
C             detecting errors. On a return with IFLAG=1, the user must
C             evaluate the function F and gradient G. On a return with
C             IFLAG=2, the user must provide the diagonal matrix Hk0.
C
C             The following negative values of IFLAG, detecting an error,
C             are possible:
C
C              IFLAG=-1  The line search routine MCSRCH failed. The
C                        parameter INFO provides more detailed information
C                        (see also the documentation of MCSRCH):
C
C                       INFO = 0  IMPROPER INPUT PARAMETERS.
C
C                       INFO = 2  RELATIVE WIDTH OF THE INTERVAL OF
C                                 UNCERTAINTY IS AT MOST XTOL.
C
C                       INFO = 3  MORE THAN 20 FUNCTION EVALUATIONS WERE
C                                 REQUIRED AT THE PRESENT ITERATION.
C
C                       INFO = 4  THE STEP IS TOO SMALL.
C
C                       INFO = 5  THE STEP IS TOO LARGE.
C
C                       INFO = 6  ROUNDING ERRORS PREVENT FURTHER PROGRESS.
C                                 THERE MAY NOT BE A STEP WHICH SATISFIES
C                                 THE SUFFICIENT DECREASE AND CURVATURE
C                                 CONDITIONS. TOLERANCES MAY BE TOO SMALL.
C
C
C              IFLAG=-2  The i-th diagonal element of the diagonal inverse
C                        Hessian approximation, given in DIAG, is not
C                        positive.
C
C              IFLAG=-3  Improper input parameters for LBFGS (N or M are
C                        not positive).
C
C
C
C    ON THE DRIVER:
C
C    The program that calls LBFGS must contain the declaration:
C
C                       EXTERNAL LB2
C
C    LB2 is a BLOCK DATA that defines the default values of several
C    parameters described in the COMMON section.
C
C
C
C    COMMON:
C
C     The subroutine contains one common area, which the user may wish to
C    reference:
C
         COMMON /LB3/MP,LP,GTOL,STPMIN,STPMAX
C
C    MP  is an INTEGER variable with default value 6. It is used as the
C        unit number for the printing of the monitoring information
C        controlled by IPRINT.
C
C    LP  is an INTEGER variable with default value 6. It is used as the
C        unit number for the printing of error messages. This printing
C        may be suppressed by setting LP to a non-positive value.
C
C    GTOL is a DOUBLE PRECISION variable with default value 0.9, which
C        controls the accuracy of the line search routine MCSRCH. If the
C        function and gradient evaluations are inexpensive with respect
C        to the cost of the iteration (which is sometimes the case when
C        solving very large problems) it may be advantageous to set GTOL
C        to a small value. A typical small value is 0.1.  Restriction:
C        GTOL should be greater than 1.D-04.
C
C    STPMIN and STPMAX are non-negative DOUBLE PRECISION variables which
C        specify lower and uper bounds for the step in the line search.
C        Their default values are 1.D-20 and 1.D+20, respectively. These
C        values need not be modified unless the exponents are too large
C        for the machine being used, or unless the problem is extremely
C        badly scaled (in which case the exponents should be increased).
C
C
C  MACHINE DEPENDENCIES
C
C        The only variables that are machine-dependent are XTOL,
C        STPMIN and STPMAX.
C
C
C  GENERAL INFORMATION
C
C    Other routines called directly:  DAXPY, DDOT, LB1, MCSRCH
C
C    Input/Output  :  No input; diagnostic messages on unit MP and
C                     error messages on unit LP.
C
C
C     - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
      DOUBLE PRECISION GTOL,ONE,ZERO,GNORM,DDOT,STP1,FTOL,STPMIN,
     .                 STPMAX,STP,YS,YY,SQ,YR,BETA,XNORM
      INTEGER MP,LP,ITER,NFUN,POINT,ISPT,IYPT,MAXFEV,INFO,
     .        BOUND,NPT,CP,I,NFEV,INMC,IYCN,ISCN
      LOGICAL FINISH
C
      SAVE
      DATA ONE,ZERO/1.0D+0,0.0D+0/
C
C     INITIALIZE
C     ----------
C
      IF(IFLAG.EQ.0) GO TO 10
      GO TO (172,100) IFLAG
  10  ITER= 0
      IF(N.LE.0.OR.M.LE.0) GO TO 196
      IF(GTOL.LE.1.D-04) THEN
        IF(LP.GT.0) WRITE(LP,245)
        GTOL=9.D-01
      ENDIF
      NFUN= 1
      POINT= 0
      FINISH= .FALSE.
      IF(DIAGCO.NE.0) THEN
         DO 30 I=1,N
 30      IF (DIAG(I).LE.ZERO) GO TO 195
      ELSE
         DO 40 I=1,N
 40      DIAG(I)= 1.0D0
      ENDIF
C
C     THE WORK VECTOR W IS DIVIDED AS FOLLOWS:
C     ---------------------------------------
C     THE FIRST N LOCATIONS ARE USED TO STORE THE GRADIENT AND
C         OTHER TEMPORARY INFORMATION.
C     LOCATIONS (N+1)...(N+M) STORE THE SCALARS RHO.
C     LOCATIONS (N+M+1)...(N+2M) STORE THE NUMBERS ALPHA USED
C         IN THE FORMULA THAT COMPUTES H*G.
C     LOCATIONS (N+2M+1)...(N+2M+NM) STORE THE LAST M SEARCH
C         STEPS.
C     LOCATIONS (N+2M+NM+1)...(N+2M+2NM) STORE THE LAST M
C         GRADIENT DIFFERENCES.
C
C     THE SEARCH STEPS AND GRADIENT DIFFERENCES ARE STORED IN A
C     CIRCULAR ORDER CONTROLLED BY THE PARAMETER POINT.
C
      ISPT= N+2*M
      IYPT= ISPT+N*M
      DO 50 I=1,N
 50   W(ISPT+I)= -G(I)*DIAG(I)
      GNORM= DSQRT(DDOT(N,G,1,G,1))
      STP1= ONE/GNORM
C
C     PARAMETERS FOR LINE SEARCH ROUTINE
C
      FTOL= 1.0D-4
      MAXFEV= 20
C
      IF(IPRINT(1).GE.0) CALL LB1(IPRINT,ITER,NFUN,
     *                     GNORM,N,M,X,F,G,STP,FINISH)
C
C    --------------------
C     MAIN ITERATION LOOP
C    --------------------
C
 80   ITER= ITER+1
      INFO=0
      BOUND=ITER-1
      IF(ITER.EQ.1) GO TO 165
      IF (ITER .GT. M)BOUND=M
C
         YS= DDOT(N,W(IYPT+NPT+1),1,W(ISPT+NPT+1),1)
      IF(DIAGCO.EQ.0) THEN
         YY= DDOT(N,W(IYPT+NPT+1),1,W(IYPT+NPT+1),1)
         DO 90 I=1,N
   90    DIAG(I)= YS/YY
      ELSE
         IFLAG=2
         RETURN
      ENDIF
 100  CONTINUE
      IF(DIAGCO.NE.0) THEN
        DO 110 I=1,N
 110    IF (DIAG(I).LE.ZERO) GO TO 195
      ENDIF
C
C     COMPUTE -H*G USING THE FORMULA GIVEN IN: Nocedal, J. 1980,
C     "Updating quasi-Newton matrices with limited storage",
C     Mathematics of Computation, Vol.24, No.151, pp. 773-782.
C     ---------------------------------------------------------
C
      CP= POINT
      IF (POINT.EQ.0) CP=M
      W(N+CP)= ONE/YS
      DO 112 I=1,N
 112  W(I)= -G(I)
      CP= POINT
      DO 125 I= 1,BOUND
         CP=CP-1
         IF (CP.EQ. -1)CP=M-1
         SQ= DDOT(N,W(ISPT+CP*N+1),1,W,1)
         INMC=N+M+CP+1
         IYCN=IYPT+CP*N
         W(INMC)= W(N+CP+1)*SQ
         CALL DAXPY(N,-W(INMC),W(IYCN+1),1,W,1)
 125  CONTINUE
C
      DO 130 I=1,N
 130  W(I)=DIAG(I)*W(I)
C
      DO 145 I=1,BOUND
         YR= DDOT(N,W(IYPT+CP*N+1),1,W,1)
         BETA= W(N+CP+1)*YR
         INMC=N+M+CP+1
         BETA= W(INMC)-BETA
         ISCN=ISPT+CP*N
         CALL DAXPY(N,BETA,W(ISCN+1),1,W,1)
         CP=CP+1
         IF (CP.EQ.M)CP=0
 145  CONTINUE
C
C     STORE THE NEW SEARCH DIRECTION
C     ------------------------------
C
       DO 160 I=1,N
 160   W(ISPT+POINT*N+I)= W(I)
C
C     OBTAIN THE ONE-DIMENSIONAL MINIMIZER OF THE FUNCTION
C     BY USING THE LINE SEARCH ROUTINE MCSRCH
C     ----------------------------------------------------
 165  NFEV=0
      STP=ONE
      IF (ITER.EQ.1) STP=STP1
      DO 170 I=1,N
 170  W(I)=G(I)
 172  CONTINUE
      CALL MCSRCH(N,X,F,G,W(ISPT+POINT*N+1),STP,FTOL,
     *            XTOL,MAXFEV,INFO,NFEV,DIAG)
      IF (INFO .EQ. -1) THEN
        IFLAG=1
        RETURN
      ENDIF
      IF (INFO .NE. 1) GO TO 190
      NFUN= NFUN + NFEV
C
C     COMPUTE THE NEW STEP AND GRADIENT CHANGE
C     -----------------------------------------
C
      NPT=POINT*N
      DO 175 I=1,N
      W(ISPT+NPT+I)= STP*W(ISPT+NPT+I)
 175  W(IYPT+NPT+I)= G(I)-W(I)
      POINT=POINT+1
      IF (POINT.EQ.M)POINT=0
C
C     TERMINATION TEST
C     ----------------
C
      GNORM= DSQRT(DDOT(N,G,1,G,1))
      XNORM= DSQRT(DDOT(N,X,1,X,1))
      XNORM= DMAX1(1.0D0,XNORM)
      IF (GNORM/XNORM .LE. EPS) FINISH=.TRUE.
C
      IF(IPRINT(1).GE.0) CALL LB1(IPRINT,ITER,NFUN,
     *               GNORM,N,M,X,F,G,STP,FINISH)
      IF (FINISH) THEN
         IFLAG=0
         RETURN
      ENDIF
      GO TO 80
C
C     ------------------------------------------------------------
C     END OF MAIN ITERATION LOOP. ERROR EXITS.
C     ------------------------------------------------------------
C
 190  IFLAG=-1
      IF(LP.GT.0) WRITE(LP,200) INFO
      RETURN
 195  IFLAG=-2
      IF(LP.GT.0) WRITE(LP,235) I
      RETURN
 196  IFLAG= -3
      IF(LP.GT.0) WRITE(LP,240)
C
C     FORMATS
C     -------
C
 200  FORMAT(/' IFLAG= -1 ',/' LINE SEARCH FAILED. SEE'
     .          ' DOCUMENTATION OF ROUTINE MCSRCH',/' ERROR RETURN'
     .          ' OF LINE SEARCH: INFO= ',I2,/
     .          ' POSSIBLE CAUSES: FUNCTION OR GRADIENT ARE INCORRECT',/,
     .          ' OR INCORRECT TOLERANCES')
 235  FORMAT(/' IFLAG= -2',/' THE',I5,'-TH DIAGONAL ELEMENT OF THE',/,
     .       ' INVERSE HESSIAN APPROXIMATION IS NOT POSITIVE')
 240  FORMAT(/' IFLAG= -3',/' IMPROPER INPUT PARAMETERS (N OR M',
     .       ' ARE NOT POSITIVE)')
 245  FORMAT(/'  GTOL IS LESS THAN OR EQUAL TO 1.D-04',
     .       / ' IT HAS BEEN RESET TO 9.D-01')
      RETURN
      END
C
C     LAST LINE OF SUBROUTINE LBFGS
C
C
      SUBROUTINE LB1(IPRINT,ITER,NFUN,
     *                     GNORM,N,M,X,F,G,STP,FINISH)
C
C     -------------------------------------------------------------
C     THIS ROUTINE PRINTS MONITORING INFORMATION. THE FREQUENCY AND
C     AMOUNT OF OUTPUT ARE CONTROLLED BY IPRINT.
C     -------------------------------------------------------------
C
      INTEGER IPRINT(2),ITER,NFUN,LP,MP,N,M
      DOUBLE PRECISION X(N),G(N),F,GNORM,STP,GTOL,STPMIN,STPMAX
      LOGICAL FINISH
      COMMON /LB3/MP,LP,GTOL,STPMIN,STPMAX
C
      IF (ITER.EQ.0)THEN
           WRITE(MP,10)
           WRITE(MP,20) N,M
           WRITE(MP,30)F,GNORM
                 IF (IPRINT(2).GE.1)THEN
                     WRITE(MP,40)
                     WRITE(MP,50) (X(I),I=1,N)
                     WRITE(MP,60)
                     WRITE(MP,50) (G(I),I=1,N)
                  ENDIF
           WRITE(MP,10)
           WRITE(MP,70)
      ELSE
          IF ((IPRINT(1).EQ.0).AND.(ITER.NE.1.AND..NOT.FINISH))RETURN
              IF (IPRINT(1).NE.0)THEN
                   IF(MOD(ITER-1,IPRINT(1)).EQ.0.OR.FINISH)THEN
                         IF(IPRINT(2).GT.1.AND.ITER.GT.1) WRITE(MP,70)
                         WRITE(MP,80)ITER,NFUN,F,GNORM,STP
                   ELSE
                         RETURN
                   ENDIF
              ELSE
                   IF( IPRINT(2).GT.1.AND.FINISH) WRITE(MP,70)
                   WRITE(MP,80)ITER,NFUN,F,GNORM,STP
              ENDIF
              IF (IPRINT(2).EQ.2.OR.IPRINT(2).EQ.3)THEN
                    IF (FINISH)THEN
                        WRITE(MP,90)
                    ELSE
                        WRITE(MP,40)
                    ENDIF
                      WRITE(MP,50)(X(I),I=1,N)
                  IF (IPRINT(2).EQ.3)THEN
                      WRITE(MP,60)
                      WRITE(MP,50)(G(I),I=1,N)
                  ENDIF
              ENDIF
            IF (FINISH) WRITE(MP,100)
      ENDIF
C
 10   FORMAT('*************************************************')
 20   FORMAT('  N=',I5,'   NUMBER OF CORRECTIONS=',I2,
     .       /,  '       INITIAL VALUES')
 30   FORMAT(' F= ',1PD10.3,'   GNORM= ',1PD10.3)
 40   FORMAT(' VECTOR X= ')
 50   FORMAT(6(2X,1PD10.3))
 60   FORMAT(' GRADIENT VECTOR G= ')
 70   FORMAT(/'   I   NFN',4X,'FUNC',8X,'GNORM',7X,'STEPLENGTH'/)
 80   FORMAT(2(I4,1X),3X,3(1PD10.3,2X))
 90   FORMAT(' FINAL POINT X= ')
 100  FORMAT(/' THE MINIMIZATION TERMINATED WITHOUT DETECTING ERRORS.',
     .       /' IFLAG = 0')
C
      RETURN
      END
C     ******
C
C
C   ----------------------------------------------------------
C     DATA
C   ----------------------------------------------------------
C
      BLOCK DATA LB2
      INTEGER LP,MP
      DOUBLE PRECISION GTOL,STPMIN,STPMAX
      COMMON /LB3/MP,LP,GTOL,STPMIN,STPMAX
      DATA MP,LP,GTOL,STPMIN,STPMAX/6,6,9.0D-01,1.0D-20,1.0D+20/
      END
C
C
C   ----------------------------------------------------------
C
      subroutine daxpy(n,da,dx,incx,dy,incy)
c
c     constant times a vector plus a vector.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(1),dy(1),da
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if (da .eq. 0.0d0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dy(iy) + da*dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dy(i) = dy(i) + da*dx(i)
   30 continue
      if( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,4
        dy(i) = dy(i) + da*dx(i)
        dy(i + 1) = dy(i + 1) + da*dx(i + 1)
        dy(i + 2) = dy(i + 2) + da*dx(i + 2)
        dy(i + 3) = dy(i + 3) + da*dx(i + 3)
   50 continue
      return
      end
C
C
C   ----------------------------------------------------------
C
      double precision function ddot(n,dx,incx,dy,incy)
c
c     forms the dot product of two vectors.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(1),dy(1),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      ddot = 0.0d0
      dtemp = 0.0d0
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dtemp + dx(ix)*dy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      ddot = dtemp
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dtemp + dx(i)*dy(i)
   30 continue
      if( n .lt. 5 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) +
     *   dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4)
   50 continue
   60 ddot = dtemp
      return
      end
C    ------------------------------------------------------------------
C
C     **************************
C     LINE SEARCH ROUTINE MCSRCH
C     **************************
C
      SUBROUTINE MCSRCH(N,X,F,G,S,STP,FTOL,XTOL,MAXFEV,INFO,NFEV,WA)
      INTEGER N,MAXFEV,INFO,NFEV
      DOUBLE PRECISION F,STP,FTOL,GTOL,XTOL,STPMIN,STPMAX
      DOUBLE PRECISION X(N),G(N),S(N),WA(N)
      COMMON /LB3/MP,LP,GTOL,STPMIN,STPMAX
      SAVE
C
C                     SUBROUTINE MCSRCH
C
C     A slight modification of the subroutine CSRCH of More' and Thuente.
C     The changes are to allow reverse communication, and do not affect
C     the performance of the routine.
C
C     THE PURPOSE OF MCSRCH IS TO FIND A STEP WHICH SATISFIES
C     A SUFFICIENT DECREASE CONDITION AND A CURVATURE CONDITION.
C
C     AT EACH STAGE THE SUBROUTINE UPDATES AN INTERVAL OF
C     UNCERTAINTY WITH ENDPOINTS STX AND STY. THE INTERVAL OF
C     UNCERTAINTY IS INITIALLY CHOSEN SO THAT IT CONTAINS A
C     MINIMIZER OF THE MODIFIED FUNCTION
C
C          F(X+STP*S) - F(X) - FTOL*STP*(GRADF(X)'S).
C
C     IF A STEP IS OBTAINED FOR WHICH THE MODIFIED FUNCTION
C     HAS A NONPOSITIVE FUNCTION VALUE AND NONNEGATIVE DERIVATIVE,
C     THEN THE INTERVAL OF UNCERTAINTY IS CHOSEN SO THAT IT
C     CONTAINS A MINIMIZER OF F(X+STP*S).
C
C     THE ALGORITHM IS DESIGNED TO FIND A STEP WHICH SATISFIES
C     THE SUFFICIENT DECREASE CONDITION
C
C           F(X+STP*S) .LE. F(X) + FTOL*STP*(GRADF(X)'S),
C
C     AND THE CURVATURE CONDITION
C
C           ABS(GRADF(X+STP*S)'S)) .LE. GTOL*ABS(GRADF(X)'S).
C
C     IF FTOL IS LESS THAN GTOL AND IF, FOR EXAMPLE, THE FUNCTION
C     IS BOUNDED BELOW, THEN THERE IS ALWAYS A STEP WHICH SATISFIES
C     BOTH CONDITIONS. IF NO STEP CAN BE FOUND WHICH SATISFIES BOTH
C     CONDITIONS, THEN THE ALGORITHM USUALLY STOPS WHEN ROUNDING
C     ERRORS PREVENT FURTHER PROGRESS. IN THIS CASE STP ONLY
C     SATISFIES THE SUFFICIENT DECREASE CONDITION.
C
C     THE SUBROUTINE STATEMENT IS
C
C        SUBROUTINE MCSRCH(N,X,F,G,S,STP,FTOL,XTOL, MAXFEV,INFO,NFEV,WA)
C     WHERE
C
C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C         OF VARIABLES.
C
C       X IS AN ARRAY OF LENGTH N. ON INPUT IT MUST CONTAIN THE
C         BASE POINT FOR THE LINE SEARCH. ON OUTPUT IT CONTAINS
C         X + STP*S.
C
C       F IS A VARIABLE. ON INPUT IT MUST CONTAIN THE VALUE OF F
C         AT X. ON OUTPUT IT CONTAINS THE VALUE OF F AT X + STP*S.
C
C       G IS AN ARRAY OF LENGTH N. ON INPUT IT MUST CONTAIN THE
C         GRADIENT OF F AT X. ON OUTPUT IT CONTAINS THE GRADIENT
C         OF F AT X + STP*S.
C
C       S IS AN INPUT ARRAY OF LENGTH N WHICH SPECIFIES THE
C         SEARCH DIRECTION.
C
C       STP IS A NONNEGATIVE VARIABLE. ON INPUT STP CONTAINS AN
C         INITIAL ESTIMATE OF A SATISFACTORY STEP. ON OUTPUT
C         STP CONTAINS THE FINAL ESTIMATE.
C
C       FTOL AND GTOL ARE NONNEGATIVE INPUT VARIABLES. (In this reverse
C         communication implementation GTOL is defined in a COMMON
C         statement.) TERMINATION OCCURS WHEN THE SUFFICIENT DECREASE
C         CONDITION AND THE DIRECTIONAL DERIVATIVE CONDITION ARE
C         SATISFIED.
C
C       XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS
C         WHEN THE RELATIVE WIDTH OF THE INTERVAL OF UNCERTAINTY
C         IS AT MOST XTOL.
C
C       STPMIN AND STPMAX ARE NONNEGATIVE INPUT VARIABLES WHICH
C         SPECIFY LOWER AND UPPER BOUNDS FOR THE STEP. (In this reverse
C         communication implementatin they are defined in a COMMON
C         statement).
C
C       MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION
C         OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST
C         MAXFEV BY THE END OF AN ITERATION.
C
C       INFO IS AN INTEGER OUTPUT VARIABLE SET AS FOLLOWS:
C
C         INFO = 0  IMPROPER INPUT PARAMETERS.
C
C         INFO =-1  A RETURN IS MADE TO COMPUTE THE FUNCTION AND GRADIENT.
C
C         INFO = 1  THE SUFFICIENT DECREASE CONDITION AND THE
C                   DIRECTIONAL DERIVATIVE CONDITION HOLD.
C
C         INFO = 2  RELATIVE WIDTH OF THE INTERVAL OF UNCERTAINTY
C                   IS AT MOST XTOL.
C
C         INFO = 3  NUMBER OF CALLS TO FCN HAS REACHED MAXFEV.
C
C         INFO = 4  THE STEP IS AT THE LOWER BOUND STPMIN.
C
C         INFO = 5  THE STEP IS AT THE UPPER BOUND STPMAX.
C
C         INFO = 6  ROUNDING ERRORS PREVENT FURTHER PROGRESS.
C                   THERE MAY NOT BE A STEP WHICH SATISFIES THE
C                   SUFFICIENT DECREASE AND CURVATURE CONDITIONS.
C                   TOLERANCES MAY BE TOO SMALL.
C
C       NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
C         CALLS TO FCN.
C
C       WA IS A WORK ARRAY OF LENGTH N.
C
C     SUBPROGRAMS CALLED
C
C       MCSTEP
C
C       FORTRAN-SUPPLIED...ABS,MAX,MIN
C
C     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1983
C     JORGE J. MORE', DAVID J. THUENTE
C
C     **********
      INTEGER INFOC,J
      LOGICAL BRACKT,STAGE1
      DOUBLE PRECISION DG,DGM,DGINIT,DGTEST,DGX,DGXM,DGY,DGYM,
     *       FINIT,FTEST1,FM,FX,FXM,FY,FYM,P5,P66,STX,STY,
     *       STMIN,STMAX,WIDTH,WIDTH1,XTRAPF,ZERO
      DATA P5,P66,XTRAPF,ZERO /0.5D0,0.66D0,4.0D0,0.0D0/
      IF(INFO.EQ.-1) GO TO 45
      INFOC = 1
C
C     CHECK THE INPUT PARAMETERS FOR ERRORS.
C
      IF (N .LE. 0 .OR. STP .LE. ZERO .OR. FTOL .LT. ZERO .OR.
     *    GTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. STPMIN .LT. ZERO
     *    .OR. STPMAX .LT. STPMIN .OR. MAXFEV .LE. 0) RETURN
C
C     COMPUTE THE INITIAL GRADIENT IN THE SEARCH DIRECTION
C     AND CHECK THAT S IS A DESCENT DIRECTION.
C
      DGINIT = ZERO
      DO 10 J = 1, N
         DGINIT = DGINIT + G(J)*S(J)
   10    CONTINUE
      IF (DGINIT .GE. ZERO) then
         write(LP,15)
   15    FORMAT(/'  THE SEARCH DIRECTION IS NOT A DESCENT DIRECTION')
         RETURN
         ENDIF
C
C     INITIALIZE LOCAL VARIABLES.
C
      BRACKT = .FALSE.
      STAGE1 = .TRUE.
      NFEV = 0
      FINIT = F
      DGTEST = FTOL*DGINIT
      WIDTH = STPMAX - STPMIN
      WIDTH1 = WIDTH/P5
      DO 20 J = 1, N
         WA(J) = X(J)
   20    CONTINUE
C
C     THE VARIABLES STX, FX, DGX CONTAIN THE VALUES OF THE STEP,
C     FUNCTION, AND DIRECTIONAL DERIVATIVE AT THE BEST STEP.
C     THE VARIABLES STY, FY, DGY CONTAIN THE VALUE OF THE STEP,
C     FUNCTION, AND DERIVATIVE AT THE OTHER ENDPOINT OF
C     THE INTERVAL OF UNCERTAINTY.
C     THE VARIABLES STP, F, DG CONTAIN THE VALUES OF THE STEP,
C     FUNCTION, AND DERIVATIVE AT THE CURRENT STEP.
C
      STX = ZERO
      FX = FINIT
      DGX = DGINIT
      STY = ZERO
      FY = FINIT
      DGY = DGINIT
C
C     START OF ITERATION.
C
   30 CONTINUE
C
C        SET THE MINIMUM AND MAXIMUM STEPS TO CORRESPOND
C        TO THE PRESENT INTERVAL OF UNCERTAINTY.
C
         IF (BRACKT) THEN
            STMIN = MIN(STX,STY)
            STMAX = MAX(STX,STY)
         ELSE
            STMIN = STX
            STMAX = STP + XTRAPF*(STP - STX)
            END IF
C
C        FORCE THE STEP TO BE WITHIN THE BOUNDS STPMAX AND STPMIN.
C
         STP = MAX(STP,STPMIN)
         STP = MIN(STP,STPMAX)
C
C        IF AN UNUSUAL TERMINATION IS TO OCCUR THEN LET
C        STP BE THE LOWEST POINT OBTAINED SO FAR.
C
         IF ((BRACKT .AND. (STP .LE. STMIN .OR. STP .GE. STMAX))
     *      .OR. NFEV .GE. MAXFEV-1 .OR. INFOC .EQ. 0
     *      .OR. (BRACKT .AND. STMAX-STMIN .LE. XTOL*STMAX)) STP = STX
C
C        EVALUATE THE FUNCTION AND GRADIENT AT STP
C        AND COMPUTE THE DIRECTIONAL DERIVATIVE.
C        We return to main program to obtain F and G.
C
         DO 40 J = 1, N
            X(J) = WA(J) + STP*S(J)
   40       CONTINUE
         INFO=-1
         RETURN
C
   45    INFO=0
         NFEV = NFEV + 1
         DG = ZERO
         DO 50 J = 1, N
            DG = DG + G(J)*S(J)
   50       CONTINUE
         FTEST1 = FINIT + STP*DGTEST
C
C        TEST FOR CONVERGENCE.
C
         IF ((BRACKT .AND. (STP .LE. STMIN .OR. STP .GE. STMAX))
     *      .OR. INFOC .EQ. 0) INFO = 6
         IF (STP .EQ. STPMAX .AND.
     *       F .LE. FTEST1 .AND. DG .LE. DGTEST) INFO = 5
         IF (STP .EQ. STPMIN .AND.
     *       (F .GT. FTEST1 .OR. DG .GE. DGTEST)) INFO = 4
         IF (NFEV .GE. MAXFEV) INFO = 3
         IF (BRACKT .AND. STMAX-STMIN .LE. XTOL*STMAX) INFO = 2
         IF (F .LE. FTEST1 .AND. ABS(DG) .LE. GTOL*(-DGINIT)) INFO = 1
C
C        CHECK FOR TERMINATION.
C
         IF (INFO .NE. 0) RETURN
C
C        IN THE FIRST STAGE WE SEEK A STEP FOR WHICH THE MODIFIED
C        FUNCTION HAS A NONPOSITIVE VALUE AND NONNEGATIVE DERIVATIVE.
C
         IF (STAGE1 .AND. F .LE. FTEST1 .AND.
     *       DG .GE. MIN(FTOL,GTOL)*DGINIT) STAGE1 = .FALSE.
C
C        A MODIFIED FUNCTION IS USED TO PREDICT THE STEP ONLY IF
C        WE HAVE NOT OBTAINED A STEP FOR WHICH THE MODIFIED
C        FUNCTION HAS A NONPOSITIVE FUNCTION VALUE AND NONNEGATIVE
C        DERIVATIVE, AND IF A LOWER FUNCTION VALUE HAS BEEN
C        OBTAINED BUT THE DECREASE IS NOT SUFFICIENT.
C
         IF (STAGE1 .AND. F .LE. FX .AND. F .GT. FTEST1) THEN
C
C           DEFINE THE MODIFIED FUNCTION AND DERIVATIVE VALUES.
C
            FM = F - STP*DGTEST
            FXM = FX - STX*DGTEST
            FYM = FY - STY*DGTEST
            DGM = DG - DGTEST
            DGXM = DGX - DGTEST
            DGYM = DGY - DGTEST
C
C           CALL CSTEP TO UPDATE THE INTERVAL OF UNCERTAINTY
C           AND TO COMPUTE THE NEW STEP.
C
            CALL MCSTEP(STX,FXM,DGXM,STY,FYM,DGYM,STP,FM,DGM,
     *                 BRACKT,STMIN,STMAX,INFOC)
C
C           RESET THE FUNCTION AND GRADIENT VALUES FOR F.
C
            FX = FXM + STX*DGTEST
            FY = FYM + STY*DGTEST
            DGX = DGXM + DGTEST
            DGY = DGYM + DGTEST
         ELSE
C
C           CALL MCSTEP TO UPDATE THE INTERVAL OF UNCERTAINTY
C           AND TO COMPUTE THE NEW STEP.
C
            CALL MCSTEP(STX,FX,DGX,STY,FY,DGY,STP,F,DG,
     *                 BRACKT,STMIN,STMAX,INFOC)
            END IF
C
C        FORCE A SUFFICIENT DECREASE IN THE SIZE OF THE
C        INTERVAL OF UNCERTAINTY.
C
         IF (BRACKT) THEN
            IF (ABS(STY-STX) .GE. P66*WIDTH1)
     *         STP = STX + P5*(STY - STX)
            WIDTH1 = WIDTH
            WIDTH = ABS(STY-STX)
            END IF
C
C        END OF ITERATION.
C
         GO TO 30
C
C     LAST LINE OF SUBROUTINE MCSRCH.
C
      END
      SUBROUTINE MCSTEP(STX,FX,DX,STY,FY,DY,STP,FP,DP,BRACKT,
     *                 STPMIN,STPMAX,INFO)
      INTEGER INFO
      DOUBLE PRECISION STX,FX,DX,STY,FY,DY,STP,FP,DP,STPMIN,STPMAX
      LOGICAL BRACKT,BOUND
C
C     SUBROUTINE MCSTEP
C
C     THE PURPOSE OF MCSTEP IS TO COMPUTE A SAFEGUARDED STEP FOR
C     A LINESEARCH AND TO UPDATE AN INTERVAL OF UNCERTAINTY FOR
C     A MINIMIZER OF THE FUNCTION.
C
C     THE PARAMETER STX CONTAINS THE STEP WITH THE LEAST FUNCTION
C     VALUE. THE PARAMETER STP CONTAINS THE CURRENT STEP. IT IS
C     ASSUMED THAT THE DERIVATIVE AT STX IS NEGATIVE IN THE
C     DIRECTION OF THE STEP. IF BRACKT IS SET TRUE THEN A
C     MINIMIZER HAS BEEN BRACKETED IN AN INTERVAL OF UNCERTAINTY
C     WITH ENDPOINTS STX AND STY.
C
C     THE SUBROUTINE STATEMENT IS
C
C       SUBROUTINE MCSTEP(STX,FX,DX,STY,FY,DY,STP,FP,DP,BRACKT,
C                        STPMIN,STPMAX,INFO)
C
C     WHERE
C
C       STX, FX, AND DX ARE VARIABLES WHICH SPECIFY THE STEP,
C         THE FUNCTION, AND THE DERIVATIVE AT THE BEST STEP OBTAINED
C         SO FAR. THE DERIVATIVE MUST BE NEGATIVE IN THE DIRECTION
C         OF THE STEP, THAT IS, DX AND STP-STX MUST HAVE OPPOSITE
C         SIGNS. ON OUTPUT THESE PARAMETERS ARE UPDATED APPROPRIATELY.
C
C       STY, FY, AND DY ARE VARIABLES WHICH SPECIFY THE STEP,
C         THE FUNCTION, AND THE DERIVATIVE AT THE OTHER ENDPOINT OF
C         THE INTERVAL OF UNCERTAINTY. ON OUTPUT THESE PARAMETERS ARE
C         UPDATED APPROPRIATELY.
C
C       STP, FP, AND DP ARE VARIABLES WHICH SPECIFY THE STEP,
C         THE FUNCTION, AND THE DERIVATIVE AT THE CURRENT STEP.
C         IF BRACKT IS SET TRUE THEN ON INPUT STP MUST BE
C         BETWEEN STX AND STY. ON OUTPUT STP IS SET TO THE NEW STEP.
C
C       BRACKT IS A LOGICAL VARIABLE WHICH SPECIFIES IF A MINIMIZER
C         HAS BEEN BRACKETED. IF THE MINIMIZER HAS NOT BEEN BRACKETED
C         THEN ON INPUT BRACKT MUST BE SET FALSE. IF THE MINIMIZER
C         IS BRACKETED THEN ON OUTPUT BRACKT IS SET TRUE.
C
C       STPMIN AND STPMAX ARE INPUT VARIABLES WHICH SPECIFY LOWER
C         AND UPPER BOUNDS FOR THE STEP.
C
C       INFO IS AN INTEGER OUTPUT VARIABLE SET AS FOLLOWS:
C         IF INFO = 1,2,3,4,5, THEN THE STEP HAS BEEN COMPUTED
C         ACCORDING TO ONE OF THE FIVE CASES BELOW. OTHERWISE
C         INFO = 0, AND THIS INDICATES IMPROPER INPUT PARAMETERS.
C
C     SUBPROGRAMS CALLED
C
C       FORTRAN-SUPPLIED ... ABS,MAX,MIN,SQRT
C
C     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1983
C     JORGE J. MORE', DAVID J. THUENTE
C
      DOUBLE PRECISION GAMMA,P,Q,R,S,SGND,STPC,STPF,STPQ,THETA
      INFO = 0
C
C     CHECK THE INPUT PARAMETERS FOR ERRORS.
C
      IF ((BRACKT .AND. (STP .LE. MIN(STX,STY) .OR.
     *    STP .GE. MAX(STX,STY))) .OR.
     *    DX*(STP-STX) .GE. 0.0 .OR. STPMAX .LT. STPMIN) RETURN
C
C     DETERMINE IF THE DERIVATIVES HAVE OPPOSITE SIGN.
C
      SGND = DP*(DX/ABS(DX))
C
C     FIRST CASE. A HIGHER FUNCTION VALUE.
C     THE MINIMUM IS BRACKETED. IF THE CUBIC STEP IS CLOSER
C     TO STX THAN THE QUADRATIC STEP, THE CUBIC STEP IS TAKEN,
C     ELSE THE AVERAGE OF THE CUBIC AND QUADRATIC STEPS IS TAKEN.
C
      IF (FP .GT. FX) THEN
         INFO = 1
         BOUND = .TRUE.
         THETA = 3*(FX - FP)/(STP - STX) + DX + DP
         S = MAX(ABS(THETA),ABS(DX),ABS(DP))
         GAMMA = S*SQRT((THETA/S)**2 - (DX/S)*(DP/S))
         IF (STP .LT. STX) GAMMA = -GAMMA
         P = (GAMMA - DX) + THETA
         Q = ((GAMMA - DX) + GAMMA) + DP
         R = P/Q
         STPC = STX + R*(STP - STX)
         STPQ = STX + ((DX/((FX-FP)/(STP-STX)+DX))/2)*(STP - STX)
         IF (ABS(STPC-STX) .LT. ABS(STPQ-STX)) THEN
            STPF = STPC
         ELSE
           STPF = STPC + (STPQ - STPC)/2
           END IF
         BRACKT = .TRUE.
C
C     SECOND CASE. A LOWER FUNCTION VALUE AND DERIVATIVES OF
C     OPPOSITE SIGN. THE MINIMUM IS BRACKETED. IF THE CUBIC
C     STEP IS CLOSER TO STX THAN THE QUADRATIC (SECANT) STEP,
C     THE CUBIC STEP IS TAKEN, ELSE THE QUADRATIC STEP IS TAKEN.
C
      ELSE IF (SGND .LT. 0.0) THEN
         INFO = 2
         BOUND = .FALSE.
         THETA = 3*(FX - FP)/(STP - STX) + DX + DP
         S = MAX(ABS(THETA),ABS(DX),ABS(DP))
         GAMMA = S*SQRT((THETA/S)**2 - (DX/S)*(DP/S))
         IF (STP .GT. STX) GAMMA = -GAMMA
         P = (GAMMA - DP) + THETA
         Q = ((GAMMA - DP) + GAMMA) + DX
         R = P/Q
         STPC = STP + R*(STX - STP)
         STPQ = STP + (DP/(DP-DX))*(STX - STP)
         IF (ABS(STPC-STP) .GT. ABS(STPQ-STP)) THEN
            STPF = STPC
         ELSE
            STPF = STPQ
            END IF
         BRACKT = .TRUE.
C
C     THIRD CASE. A LOWER FUNCTION VALUE, DERIVATIVES OF THE
C     SAME SIGN, AND THE MAGNITUDE OF THE DERIVATIVE DECREASES.
C     THE CUBIC STEP IS ONLY USED IF THE CUBIC TENDS TO INFINITY
C     IN THE DIRECTION OF THE STEP OR IF THE MINIMUM OF THE CUBIC
C     IS BEYOND STP. OTHERWISE THE CUBIC STEP IS DEFINED TO BE
C     EITHER STPMIN OR STPMAX. THE QUADRATIC (SECANT) STEP IS ALSO
C     COMPUTED AND IF THE MINIMUM IS BRACKETED THEN THE THE STEP
C     CLOSEST TO STX IS TAKEN, ELSE THE STEP FARTHEST AWAY IS TAKEN.
C
      ELSE IF (ABS(DP) .LT. ABS(DX)) THEN
         INFO = 3
         BOUND = .TRUE.
         THETA = 3*(FX - FP)/(STP - STX) + DX + DP
         S = MAX(ABS(THETA),ABS(DX),ABS(DP))
C
C        THE CASE GAMMA = 0 ONLY ARISES IF THE CUBIC DOES NOT TEND
C        TO INFINITY IN THE DIRECTION OF THE STEP.
C
         GAMMA = S*SQRT(MAX(0.0D0,(THETA/S)**2 - (DX/S)*(DP/S)))
         IF (STP .GT. STX) GAMMA = -GAMMA
         P = (GAMMA - DP) + THETA
         Q = (GAMMA + (DX - DP)) + GAMMA
         R = P/Q
         IF (R .LT. 0.0 .AND. GAMMA .NE. 0.0) THEN
            STPC = STP + R*(STX - STP)
         ELSE IF (STP .GT. STX) THEN
            STPC = STPMAX
         ELSE
            STPC = STPMIN
            END IF
         STPQ = STP + (DP/(DP-DX))*(STX - STP)
         IF (BRACKT) THEN
            IF (ABS(STP-STPC) .LT. ABS(STP-STPQ)) THEN
               STPF = STPC
            ELSE
               STPF = STPQ
               END IF
         ELSE
            IF (ABS(STP-STPC) .GT. ABS(STP-STPQ)) THEN
               STPF = STPC
            ELSE
               STPF = STPQ
               END IF
            END IF
C
C     FOURTH CASE. A LOWER FUNCTION VALUE, DERIVATIVES OF THE
C     SAME SIGN, AND THE MAGNITUDE OF THE DERIVATIVE DOES
C     NOT DECREASE. IF THE MINIMUM IS NOT BRACKETED, THE STEP
C     IS EITHER STPMIN OR STPMAX, ELSE THE CUBIC STEP IS TAKEN.
C
      ELSE
         INFO = 4
         BOUND = .FALSE.
         IF (BRACKT) THEN
            THETA = 3*(FP - FY)/(STY - STP) + DY + DP
            S = MAX(ABS(THETA),ABS(DY),ABS(DP))
            GAMMA = S*SQRT((THETA/S)**2 - (DY/S)*(DP/S))
            IF (STP .GT. STY) GAMMA = -GAMMA
            P = (GAMMA - DP) + THETA
            Q = ((GAMMA - DP) + GAMMA) + DY
            R = P/Q
            STPC = STP + R*(STY - STP)
            STPF = STPC
         ELSE IF (STP .GT. STX) THEN
            STPF = STPMAX
         ELSE
            STPF = STPMIN
            END IF
         END IF
C
C     UPDATE THE INTERVAL OF UNCERTAINTY. THIS UPDATE DOES NOT
C     DEPEND ON THE NEW STEP OR THE CASE ANALYSIS ABOVE.
C
      IF (FP .GT. FX) THEN
         STY = STP
         FY = FP
         DY = DP
      ELSE
         IF (SGND .LT. 0.0) THEN
            STY = STX
            FY = FX
            DY = DX
            END IF
         STX = STP
         FX = FP
         DX = DP
         END IF
C
C     COMPUTE THE NEW STEP AND SAFEGUARD IT.
C
      STPF = MIN(STPMAX,STPF)
      STPF = MAX(STPMIN,STPF)
      STP = STPF
      IF (BRACKT .AND. BOUND) THEN
         IF (STY .GT. STX) THEN
            STP = MIN(STX+0.66*(STY-STX),STP)
         ELSE
            STP = MAX(STX+0.66*(STY-STX),STP)
            END IF
         END IF
      RETURN
C
C     LAST LINE OF SUBROUTINE MCSTEP.
C
      END


c      program prove_erf
c      real*8 x,y,wx,wy
c
c      x=1.d0
c      y=2.d0

c      call ERRF(x, y, WX, WY)
c      write(*,*) 'x=',x,'y=',y,'wx=',wx,'wy=',wy

c      end program

      SUBROUTINE ERRF(XX, YY, WX, WY)
Cf2py intent(in)  XX
Cf2py intent(in)  YY
Cf2py intent(out) WX
Cf2py intent(out) WY
*----------------------------------------------------------------------*
* Purpose:                                                             *
*   Modification of WWERF, double precision complex error function,    *
*   written at CERN by K. Koelbig.                                     *
* Input:                                                               *
*   XX, YY    (real)    Argument to CERF.                              *
* Output:                                                              *
*   WX, WY    (real)    Function result.                               *
*----------------------------------------------------------------------*

*---- Double precision version.
      IMPLICIT DOUBLE PRECISION (A-H,O-Z), INTEGER (I-N)
      PARAMETER         (MWFLT = 2, MREAL = 4)
      PARAMETER         (MCWRD = 4)
      PARAMETER         (MCNAM = 16, MWNAM = MCNAM / MCWRD)
      PARAMETER         (MCFIL = 80, MCRNG = 40, MCSTR = 80)

      PARAMETER         (CC     = 1.12837 91670 9551D0)
      PARAMETER         (ONE    = 1.D0)
      PARAMETER         (TWO    = 2.D0)
      PARAMETER         (XLIM   = 5.33D0)
      PARAMETER         (YLIM   = 4.29D0)
      DIMENSION         RX(33), RY(33)

      X = ABS(XX)
      Y = ABS(YY)

      IF (Y .LT. YLIM  .AND.  X .LT. XLIM) THEN
        Q  = (ONE - Y / YLIM) * SQRT(ONE - (X/XLIM)**2)
        H  = ONE / (3.2D0 * Q)
        NC = 7 + INT(23.0*Q)
        XL = H**(1 - NC)
        XH = Y + 0.5D0/H
        YH = X
        NU = 10 + INT(21.0*Q)
        RX(NU+1) = 0.
        RY(NU+1) = 0.

        DO 10 N = NU, 1, -1
          TX = XH + N * RX(N+1)
          TY = YH - N * RY(N+1)
          TN = TX*TX + TY*TY
          RX(N) = 0.5D0 * TX / TN
          RY(N) = 0.5D0 * TY / TN
   10   CONTINUE

        SX = 0.
        SY = 0.

        DO 20 N = NC, 1, -1
          SAUX = SX + XL
          SX = RX(N) * SAUX - RY(N) * SY
          SY = RX(N) * SY + RY(N) * SAUX
          XL = H * XL
   20   CONTINUE

        WX = CC * SX
        WY = CC * SY
      ELSE
        XH = Y
        YH = X
        RX(1) = 0.
        RY(1) = 0.

        DO 30 N = 9, 1, -1
          TX = XH + N * RX(1)
          TY = YH - N * RY(1)
          TN = TX*TX + TY*TY
          RX(1) = 0.5D0 * TX / TN
          RY(1) = 0.5D0 * TY / TN
   30   CONTINUE

        WX = CC * RX(1)
        WY = CC * RY(1)
      ENDIF

      IF(Y .EQ. 0.) WX = EXP(-X**2)
      IF(YY .LT. 0.) THEN
        WX =   TWO * EXP(Y*Y-X*X) * COS(TWO*X*Y) - WX
        WY = - TWO * EXP(Y*Y-X*X) * SIN(TWO*X*Y) - WY
        IF(XX .GT. 0.) WY = -WY
      ELSE
        IF(XX .LT. 0.) WY = -WY
      ENDIF

      END


c
c     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine inwhnk(invp,nmax,rg,rf,rv,r,en,c,drg,drf,
     >                  dk,dm,nws,imm,iprpts,ipdeq)
c     ================================================================
      implicit   none
c
!     include   'atom_param.h'
c
c     ****************************************************************
c     drg,drf:   derivative of dp and dq times r;
c     c      :   speed of light.
c
c     free solutions ....... riccati-hankel functions
c     ****************************************************************
c
      integer    iprpts,ipdeq
      integer    invp
      integer    nmax
      integer    nws
      integer    imm
      real*8    kappa
      integer    l
      integer    ll
      integer    lp
      integer    n
c
      real*8     rg(iprpts)
      real*8     rf(iprpts)
      real*8     rv(iprpts)
      real*8     r(iprpts)
      real*8     en
      real*8     c
      real*8     drf(2*ipdeq)
      real*8     drg(2*ipdeq)
      real*8     dk
      real*8     dm
c
      real*8     mass
      real*8     zero
      real*8     cinv
      real*8     c2inv
      real*8     ak
      real*8     sgnk
      real*8     factor
c
      complex*16 bh(10)
      complex*16 dh(10)
      complex*16 x
      complex*16 p
      complex*16 mil
      complex*16 sqrtm1
      complex*16 mi
c
      parameter (sqrtm1=(0.d0,1.d0))
      parameter (mi=(0.d0,-1.d0))
      parameter (zero=0.d0)
c
      cinv=1.d0/c
      c2inv=cinv*cinv
      mass=(1.d0 + en*c2inv)
      p=sqrt(dcmplx(en*mass,zero) )
c
      kappa=dk
      ak=abs(dk)
      sgnk=dk/ak
      factor= sgnk*sqrt( -en/mass )*cinv
c
c     ================================================================
c     officially this is L+1
c     ================================================================
      l = ak + (1+sgnk)/2
      lp=l - sgnk
      mil=sqrtm1**(l-1)
c
c     ================================================================
c     maximum l needed for this kappa
c     ================================================================
      ll=max(l,lp)
c
      do n=iprpts,invp,-1
         x=p*r(n)
c        -------------------------------------------------------------
         call richnk(ll,x,bh,dh)
c        -------------------------------------------------------------
c
c        =============================================================
c        NOTE: working on log-mesh so need extra factor of r for rdg
c              and drf.
c        =============================================================
         rg(n)=-mi*mil*bh(l)
         rf(n)=-factor*mil*bh(lp)
      enddo
c
      drg(ipdeq)=-x*(mi*mil*dh(l))
      drf(ipdeq)=-x*factor*mil*dh(lp)
c
      return
      end


!*==slae2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SLAE2 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SLAE2( A, B, C, RT1, RT2 )
!
!       .. Scalar Arguments ..
!       REAL               A, B, C, RT1, RT2
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SLAE2  computes the eigenvalues of a 2-by-2 symmetric matrix
!>    [  A   B  ]
!>    [  B   C  ].
!> On return, RT1 is the eigenvalue of larger absolute value, and RT2
!> is the eigenvalue of smaller absolute value.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] A
!> \verbatim
!>          A is REAL
!>          The (1,1) element of the 2-by-2 matrix.
!> \endverbatim
!>
!> \param[in] B
!> \verbatim
!>          B is REAL
!>          The (1,2) and (2,1) elements of the 2-by-2 matrix.
!> \endverbatim
!>
!> \param[in] C
!> \verbatim
!>          C is REAL
!>          The (2,2) element of the 2-by-2 matrix.
!> \endverbatim
!>
!> \param[out] RT1
!> \verbatim
!>          RT1 is REAL
!>          The eigenvalue of larger absolute value.
!> \endverbatim
!>
!> \param[out] RT2
!> \verbatim
!>          RT2 is REAL
!>          The eigenvalue of smaller absolute value.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup OTHERauxiliary
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  RT1 is accurate to a few ulps barring over/underflow.
!>
!>  RT2 may be inaccurate if there is massive cancellation in the
!>  determinant A*C-B*B; higher precision or correctly rounded or
!>  correctly truncated arithmetic would be needed to compute RT2
!>  accurately in all cases.
!>
!>  Overflow is possible only if RT1 is within a factor of 5 of overflow.
!>  Underflow is harmless if the input data is 0 or exceeds
!>     underflow_threshold / macheps.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE SLAE2(A,B,C,Rt1,Rt2)
      IMPLICIT NONE
!*--SLAE2106
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      REAL A , B , C , Rt1 , Rt2
!     ..
!
! =====================================================================
!
!     .. Parameters ..
      REAL ONE
      PARAMETER (ONE=1.0E0)
      REAL TWO
      PARAMETER (TWO=2.0E0)
      REAL ZERO
      PARAMETER (ZERO=0.0E0)
      REAL HALF
      PARAMETER (HALF=0.5E0)
!     ..
!     .. Local Scalars ..
      REAL ab , acmn , acmx , adf , df , rt , sm , tb
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , SQRT
!     ..
!     .. Executable Statements ..
!
!     Compute the eigenvalues
!
      sm = A + C
      df = A - C
      adf = ABS(df)
      tb = B + B
      ab = ABS(tb)
      IF ( ABS(A)>ABS(C) ) THEN
         acmx = A
         acmn = C
      ELSE
         acmx = C
         acmn = A
      ENDIF
      IF ( adf>ab ) THEN
         rt = adf*SQRT(ONE+(ab/adf)**2)
      ELSEIF ( adf<ab ) THEN
         rt = ab*SQRT(ONE+(adf/ab)**2)
      ELSE
!
!        Includes case AB=ADF=0
!
         rt = ab*SQRT(TWO)
      ENDIF
      IF ( sm<ZERO ) THEN
         Rt1 = HALF*(sm-rt)
!
!        Order of execution important.
!        To get fully accurate smaller eigenvalue,
!        next line needs to be executed in higher precision.
!
         Rt2 = (acmx/Rt1)*acmn - (B/Rt1)*B
      ELSEIF ( sm>ZERO ) THEN
         Rt1 = HALF*(sm+rt)
!
!        Order of execution important.
!        To get fully accurate smaller eigenvalue,
!        next line needs to be executed in higher precision.
!
         Rt2 = (acmx/Rt1)*acmn - (B/Rt1)*B
      ELSE
!
!        Includes case RT1 = RT2 = 0
!
         Rt1 = HALF*rt
         Rt2 = -HALF*rt
      ENDIF
!
!     End of SLAE2
!
      END SUBROUTINE SLAE2