! -*- f90 -*-
! file leastsq.f90
! Main Geodesic-Bold-BroydenUpdate-Levenberg-Marquardt routine
! version 1.1

SUBROUTINE geodesiclm(func, jacobian, Avv, &
     & x, fvec, fjac, n, m, &
     & callback, info, &
     & analytic_jac, analytic_Avv, &
     & center_diff, h1, h2,&
     & dtd, damp_mode, &
     & niters, nfev, njev, naev, &
     & maxiter, maxfev, maxjev, maxaev, maxlam, minlam, &
     & artol, Cgoal, gtol, xtol, xrtol, ftol, frtol, &
     & converged, &
     & print_level, print_unit, &
     & imethod, iaccel, ibold, ibroyden, &
     & initialfactor, factoraccept, factorreject, avmax)

!*****************************************************************
!
!    subroutine geodesicLM
!
!    The purpose of geolevmar is to minimize the sum of the squares
!    of m nonlinear functions of n variables by a modification of
!    the Levenberg-Marquardt algorithm that utilizes the geodesic
!    acceleration step correction, bold acceptance criterion, and
!    a Broyden update of the jacobian matrix.  The method employs one
!    of several possible schemes for updating the Levenberg-Marquardt
!    parameter.  The user must provide a subroutine which calcualtes
!    the functions, and optionally the jacobian and a directional
!    derivative of the functions.  The latter two will be estimated
!    by finite differences if not supplied.
!
!    If you use this code, please acknowledge such by referencing one
!    one of the following papers in any published work:
!
!    Transtrum M.K., Machta B.B., and Sethna J.P, Why are nonlinear
!    fits to data so challenging?  Phys. Rev. Lett. 104, 060201 (2010)
!
!    Transtrum M.K., Machta B.B., and Sethna J.P., The geometry of
!    nonlinear least squares with applications to sloppy model and
!    optimization.  Phys. Rev. E. 80, 036701 (2011)
!
!
!    The subroutine statement is:
!
!    geodesicLM(func, jacobian, Avv, x, fvec, fjac, n, m, callback, info,
!              analytic_jac, analytic_Avv, center_diff, h1, h2,
!              dtd, damp_mode, niteres, nfev, njev, naev,
!              maxiters, maxfev, maxjev, maxaev, maxlam, minlam,
!              artol, Cgoal, gtol, xtol, xrtol, ftol, frtol,
!              converged, print_level, print_unit,
!              imethod, iaccel, ibold, ibroyden,
!              initialfactor, factoraccept, factorreject, avmax)
!
!    where
!
!    func is a user supplied subroutine which calculates the functions and
!    should be written as follows:
!
!      subroutine func(m, n, x, fvec)
!      integer m, n
!      double precision x(n), fvec(m)
!      --------------------------------------------------------------------
!      calculates the function at x and returns their values in fvec
!      x, m, and n should be left unchanged
!      --------------------------------------------------------------------
!      end subroutine func
!
!    jacobian is a user supplied subroutine which calculates the jacobian of
!    of the functions if analytic_jac is .TRUE.
!    jacobian should be writen as follows
!
!      subroutine jacobian(m, n, x, fjac)
!      integer m, n
!      double precision x(n), fjac(m,n)
!      --------------------------------------------------------------------
!      calculates the jacobian at x and returns their values in fjac
!      x, m, and n should be left unchanged
!      --------------------------------------------------------------------
!      end subroutine jacobian
!
!    Avv is a user supplied subroutine which calculates the directional
!    second derivative of the functions if analytic_Avv is .TRUE.
!    Avv should be writen as follows
!
!      subroutine Avv(m, n, x, v, acc)
!      integer m, n
!      double precision x(n), v(n), acc(m)
!      --------------------------------------------------------------------
!      calculates the directional second derivative at x in the direction
!      of v and returns the values in acc
!      x, v, m, and n should be left unchanged
!      --------------------------------------------------------------------
!      end subroutine Avv
!
!    x is an array of length n.  On input it contains an initial estimate of
!    the solution.  On exit, it contains the final estimate of the solution.
!
!    fvec is an output array of length m containing the funtion evaluation at
!    the final solution
!
!    fjac is an output array of dimension(m,n) containing the jacobian evaluation
!    the final solution.  The array MATMUL( TRANSPOSE(fjac), fjac) is an estimate
!    of the covariance matrix of parameters at the final solution
!
!    n an input integer set to the number of parameters
!
!    m an input integer set to the number of functions
!
!    callback a user supplied subroutine to be called after each iteration of the
!    algorithm.
!    callback should be written as follows
!
!      subroutine callback(m,n,x,v,a,fvec,fjac,acc,lam,dtd,fvec_new,accepted,info)
!      integer m, n, accepted, info
!      double precision x(n), v(n), a(n), fvec(m), fjac(m,n), acc(m), lam, dtd(n,n), fvec_new(m)
!      --------------------------------------------------------------------
!      m, n, x, v, a, fvec, fjac, acc, lam, dtd, fvec_new, accepted, should be left unchanged
!      On input, info = 0 and should be changed to a nonzero value if the user
!      wishes to terminate calculation
!      --------------------------------------------------------------------
!      end subroutine callback
!
!    info an output integer set to a nonzero value if the user terminated the routine
!    (see callback).
!
!    analytic_jac an input boolean set to .TRUE. if the subroutine jacobian calculates
!    the jacobian.  If .FALSE. then a finite difference estimate will be used.
!
!    analytic_Avv an input boolean set to .TRUE. if the subroutine Avv calculates
!    the directional second derivative.  If .FALSE. then a finite difference estimate
!    will be used.
!
!    center_diff an input boolean.  If finite differences are used to estimate the jacobian
!    then center differences will used if center_diff is .TRUE., otherwise, forward
!    differences will be used.  Note that center differences are more accurate by require
!    more function evaluations.
!
!    h1 an input double precision specifying the step size for the finite difference estimates
!    of the jacobian.
!
!    h2 an input double precision specifying the steps ize for the finite difference estiamtes
!    of the directional second derivative.
!
!    dtd a double precision array of dimension(n,n).  dtd is used as the damping matrix in the
!    Levenberg-Marquardt routine.  It's exact treatment is specified by the damp_mode input.
!
!    damp_mode an input integer specifying the details of the LM damping as follows:
!      damp_mode = 0: dtd is set to the identity.
!      damp_mode = 1: dtd should be a positive definite, diagonal matrix whose entries are dynamically
!                updated based on the elements of the jacobian.
!
!    niters an output integer specifying the number of iterations of the algorithm.
!
!    nfev an output integer specifying the number of calls to func.
!
!    njev an output integer specifying the number of calls to jacobian.
!
!    naev an output integer specifying the number of calls to Avv.
!
!    maxiter an input integer specifying the maximum number of routine iterations.
!
!    maxfev an input integer specifying the maximum number of function calls
!    if maxfev = 0, then there is no limit to the number of function calls.
!
!    maxjev an input integer specifying the maximum number of jacobian calls
!    if maxjev = 0, then there is no limit to the number of jacobian calls.
!
!    maxaev an input integer specifying the maximum number of Avv calls
!    if maxaev = 0, then there is no limit to the number of Avv calls.
!
!    maxlam an input double precision specifying the maximum allowed value of
!    the damping term lambda. If this is negative, then there is no limit.
!
!    minlam an input double precision specifying the minimum allowed value of
!    the damping term lambda. If lambda is smaller than this value for three consecutive steps
!    the routine terminates.  If this is negative, then there is no limit.
!
!    artol an input double precision.  The method will terminate when the cosine of the
!    angle between the residual vector and the range of the jacobian is less than artol.
!
!    Cgoal an input double precision.  The method will terminate when the cost (one half
!    the sum of squares of the function) falls below Cgoal.
!
!    gtol an input double precision.  The method will terminate when norm of Cost gradient
!    falls below gtol.
!
!    xtol an input double precision.  The method will terminate when parameters change by
!    less than xtol.
!
!    xrtol an input double precision.  The method will terminate if the relative change in
!    each of the parameters is less than xrtol.
!
!    ftol an input double precision.  The method will termiante if the Cost fails to decrease
!    by more than ftol for 3 consecutive iterations.
!
!    frtol an input double precision.  The method will terminate if the relative decrease in
!    Cost is less than frtol 3 consecutive iterations.
!
!    converged an output integer indicated the reason for termination:
!      converged = 1: artol
!      converged = 2: Cgoal
!      converged = 3: gtol
!      converged = 4: xtol
!      converged = 5: xrtol
!      converged = 6: ftol
!      converged = 7: frtol
!      converged = -1: maxiters exeeded
!      converged = -2: maxfev exceeded
!      converged = -3: maxjev exceeded
!      converged = -4: maxaev exceeded
!      converged = -10: user requested termination in callback via info
!      converged = -11: Either the initial function evalaution or subsequent jacobian
!                       evaluations produced Nans.
!
!    print_level an input integer specifying the amount of details to be printed.
!    acceptable values range from 0 to 5, with larger number printing more details.
!
!    print_unit an input integer specifying the unit number details should be written to.
!
!    imethod an input integer specifying the method for updating the LM parameter
!      imethod = 0: adjusted by fixed factors after accepted/rejected steps
!      imethod = 1: adjusted as described in Nielson
!      imethod = 2: adjusted according to an unpublished method due to Cyrus Umrigar and Peter Nightingal
!      imethod = 10: step size Delta adjusted by fixed factors after accepted/rejected steps
!      imethod = 11: step size adjusted as described in More'
!
!    initialfactor an input double precision for specifying either the initial LM parameter
!    of the initial step size.
!
!    factoraccept an input double precision (larger than 1.0) specifying the factor by which
!    either the LM parameter or the step size will be adjusted after an accepted step if
!    imethod = 0 or 10
!
!    factorreject an input double precision (larger than 1.0) specifying the factor by which
!    either the LM parameter of the step size will be adjusted after a rejected step if
!    imethod = 0 or 10
!
!    avmax an input double precision specifying the maximum norm of the geodesic acceleration
!    relative to the velocity vector.
!
!*****************************************************************

  IMPLICIT NONE
  !! Passed parameters
  EXTERNAL func, jacobian, Avv, callback

  REAL (KIND=8) x(n), fvec(m), fjac(m,n)
  INTEGER n, m
  LOGICAL analytic_jac, analytic_Avv, center_diff
  REAL (KIND=8) h1, h2
  REAL (KIND=8) dtd(n,n)
  INTEGER damp_mode, info
  INTEGER niters, nfev, njev, naev
  INTEGER maxiter, maxfev, maxaev, maxjev
  REAL (KIND=8) maxlam, minlam, artol, Cgoal, gtol, xtol, xrtol, ftol, frtol
  INTEGER converged
  INTEGER print_level, print_unit
  INTEGER iaccel, ibroyden, ibold, imethod
  REAL (KIND=8) avmax, initialfactor, factoraccept, factorreject

  !! Internal parameters

  REAL (KIND=8) acc(m), v(n), vold(n), a(n), lam, delta, cos_alpha, av
  REAL (KIND=8) fvec_new(m), fvec_best(m), C, Cnew, Cbest, Cold
  REAL (KIND=8) x_new(n), x_best(n)
  REAL (KIND=8) jtj(n,n), g(n,n)
  REAL (KIND=8) temp1, temp2, pred_red, dirder, actred, rho, a_param
  INTEGER i, j, istep, accepted, counter

  character(16) :: converged_info(-11:7)
  LOGICAL jac_uptodate, jac_force_update, valid_result

  ! strings for concluding print statement
  converged_info = '????????'
  converged_info(1) = 'artol reached'
  converged_info(2) = 'Cgoal reached'
  converged_info(3) = 'gtol reached'
  converged_info(4) = 'xtol reached'
  converged_info(5) = 'xrtol reached'
  converged_info(6) = 'ftol reached'
  converged_info(7) = 'frtol reached'
  converged_info(-1) = 'maxiters exeeded'
  converged_info(-2) = 'maxfev exceeded'
  converged_info(-3) = 'maxjev exceeded'
  converged_info(-4) = 'maxaev exceeded'
  converged_info(-10) = 'User Termination '
  converged_info(-11) = 'NaN Produced'

  IF(print_level .GE. 1) THEN
     WRITE(print_unit, *) "Optimizing with Geodesic-Levenberg-Marquardt algorithm, version 1.1"
     WRITE(print_unit, *) "Method Details:"
     WRITE(print_unit, *) "  Update method:   ", imethod
     WRITE(print_unit, *) "  acceleration:    ", iaccel
     WRITE(print_unit, *) "  Bold method:     ", ibold
     WRITE(print_unit, *) "  Broyden updates: ", ibroyden
     FLUSH(print_unit)
  ENDIF

  !! Initialize variables
  niters = 0
  nfev = 0
  naev = 0
  njev = 0
  converged = 0
  v(:) = 0.0d+0
  vold(:) = 0.0d+0
  a(:) = 0.0d+0
  cos_alpha = 1.0d+0
  av = 0.0d+0
  a_param = 0.5

  accepted = 0
  counter = 0
  CALL func(m,n,x,fvec)
  nfev = nfev + 1

  C = 0.5d+0*DOT_PRODUCT(fvec,fvec)
  IF(print_level .GE. 1) THEN
     WRITE(print_unit, *) "  Initial Cost:    ", C
     FLUSH(print_unit)
  ENDIF
  valid_result = .TRUE.
  !! Check for nans in fvec
  checkfvec: DO i = 1,m
     IF(fvec(i) /= fvec(i)) THEN
        valid_result = .FALSE.
        EXIT checkfvec
     END IF
  END DO checkfvec
  IF (.NOT. valid_result) THEN
     converged = -11
     maxiter = 0
  ENDIF
  Cbest = C
  fvec_best = fvec
  x_best = x
  IF(analytic_jac) THEN
     CALL jacobian(m,n,x,fjac)
     njev = njev + 1
  ELSE
     CALL fdjac(m,n,x,fvec,fjac,func,h1,center_diff)
     IF (center_diff) THEN
        nfev = nfev + 2*n
     ELSE
        nfev = nfev + n
     ENDIF
  ENDIF
  jac_uptodate = .TRUE.
  jac_force_update = .FALSE.
  jtj = MATMUL(TRANSPOSE(fjac), fjac)

  !! Check fjac for nans
  valid_result = .TRUE.
  checkfjac_initial: DO i = 1,m
     DO j = 1,n
        IF(fjac(i,j) /= fjac(i,j)) THEN
           valid_result = .FALSE.
           EXIT checkfjac_initial
        END IF
     END DO
  END DO checkfjac_initial
  IF( .NOT. valid_result) THEN
     converged = -11
     maxiter = 0
  ENDIF

  acc(:) = 0.0d+0
  a(:) = 0.0d+0

  !! Initialize scaling matrix
  IF(damp_mode.EQ.0) THEN
     dtd(:,:) = 0.0d+0
     DO i=1,n
        dtd(i,i) = 1.0d+0
     END DO
  ELSEIF(damp_mode.EQ.1) THEN
     DO i = 1,n
        dtd(i,i) = MAX(jtj(i,i),dtd(i,i))
     END DO
  ENDIF

  !! Initialize lambda
  IF(imethod .LT. 10) THEN
     lam = jtj(1,1)
     DO i = 2,n
        lam = MAX(jtj(i,i),lam)
     END DO
     lam = lam * initialfactor
  !! Initialize step bound if using trust region method
  ELSEIF(imethod .GE. 10) THEN
     delta = initialfactor*SQRT(DOT_PRODUCT(x,MATMUL(dtd,x)))
     lam = 1.0d+0
     IF(delta .EQ. 0.0d+0) delta = 100d+0
     IF( converged .EQ. 0) CALL TrustRegion(n,m,fvec,fjac,dtd,delta,lam) !! Do not call this if there were nans in either fvec or fjac
  ENDIF

  !! Main Loop
  main: DO istep=1, maxiter

     info = 0
     CALL callback(m,n,x,v,a,fvec,fjac,acc,lam,dtd,fvec_new,accepted,info)
     IF( info .NE. 0) THEN
        converged = -10
        exit main
     ENDIF
     !! Update Functions

     !! Full or partial Jacobian Update?
     IF (accepted .GT. 0 .AND. ibroyden .LE. 0) jac_force_update = .TRUE.
     IF (accepted + ibroyden .LE. 0 .AND. .NOT. jac_uptodate) jac_force_update = .TRUE.  !Force jac update after too many failed attempts

     IF (accepted .GT. 0 .AND. ibroyden .GT. 0 .AND. .NOT. jac_force_update) THEN !! Rank deficient update of jacobian matrix
        CALL UPDATEJAC(m,n,fjac, fvec, fvec_new, acc, v, a)
        jac_uptodate = .FALSE.
     ENDIF

     IF( accepted .GT. 0) THEN !! Accepted step
        fvec = fvec_new
        x = x_new
        vold = v
        C = Cnew
        IF( C .LE. Cbest) THEN
           x_best = x
           Cbest = C
           fvec_best = fvec
        ENDIF
     ENDIF

     IF( jac_force_update ) THEN !! Full rank update of jacobian
        IF(analytic_jac) THEN
           CALL jacobian(m,n,x,fjac)
           njev = njev + 1
        ELSE
           CALL fdjac(m,n,x,fvec,fjac,func,h1,center_diff)
           IF (center_diff) THEN
              nfev = nfev + 2*n
           ELSE
              nfev = nfev + n
           ENDIF
        ENDIF
        jac_uptodate = .TRUE.
        jac_force_update = .FALSE.
     ENDIF

     !! Check fjac for nans
     valid_result = .TRUE.
     checkfjac: DO i = 1,m
        DO j = 1,n
           IF(fjac(i,j) /= fjac(i,j)) THEN
              valid_result = .FALSE.
              EXIT checkfjac
           END IF
        END DO
     END DO checkfjac

     IF (valid_result) THEN !! If no nans in jacobian

        jtj = MATMUL(TRANSPOSE(fjac), fjac)

        !! Update Scaling/lam/TrustRegion
        IF(istep .GT. 1) THEN !! Only necessary after first step
           IF( damp_mode .EQ. 1) THEN
              DO i = 1,n
                 dtd(i,i) = MAX(jtj(i,i),dtd(i,i))
              END DO
           ENDIF
           !! Can add other lam-delta update methods
           SELECT CASE( imethod )
           CASE( 0 )
              !! Update lam directly by fixed factors
              CALL Updatelam_factor(lam, accepted, factoraccept, factorreject)
           CASE( 1 )
              !! Update lam directly based on Gain Factor rho (see Nielson reference)
              CALL Updatelam_nelson(lam, accepted, factoraccept, factorreject, rho)
           CASE( 2 )
              !! Update lam directly using method of Umrigar and Nightingale [unpublished]
              CALL Updatelam_Umrigar(m,n,lam,accepted, v, vold, fvec, fjac, dtd, a_param, Cold, Cnew)
           CASE(10)
              !! Update delta by fixed factors
              CALL UpdateDelta_factor(delta, accepted, factoraccept, factorreject)
              CALL TrustRegion(n,m,fvec, fjac, dtd, delta, lam)
           CASE(11)
              !! Update delta as described in More' reference
              CALL UpdateDelta_more(delta, lam, n, x, dtd, rho, C, Cnew, dirder, actred, av, avmax)
              CALL TrustRegion(n,m,fvec, fjac, dtd, delta, lam)
           END SELECT
        ENDIF

        !! Propose Step
        !! metric aray
        g = jtj + lam*dtd
        !! Cholesky decomposition
        CALL DPOTRF('U', n, g, n, info)
        !! CALL inv(n, g, info)
     ELSE !! If nans in jacobian
        converged = -11
        exit main
     ENDIF

     IF(info .EQ. 0) THEN  !! If matrix decomposition successful:
        !! v = -1.0d+0*MATMUL(g,MATMUL(fvec,fjac)) ! velocity
        v = -1.0d+0*MATMUL(fvec, fjac)
        CALL DPOTRS('U', n, 1, g, n, v, n, info)

        ! Calcualte the predicted reduction and the directional derivative -- useful for updating lam methods
        temp1 = 0.5d+0*DOT_PRODUCT(v,MATMUL(jtj, v))/C
        temp2 = 0.5d+0*lam*DOT_PRODUCT(v,MATMUL(dtd,v))/C
        pred_red = temp1 + 2.0d+0*temp2
        dirder = -1.0d+0*(temp1 + temp2)
        ! calculate cos_alpha -- cos of angle between step direction (in data space) and residual vector
        cos_alpha = ABS(DOT_PRODUCT(fvec, MATMUL(fjac, v)))
        cos_alpha = cos_alpha/SQRT( DOT_PRODUCT(fvec, fvec)*DOT_PRODUCT(MATMUL(fjac,v), MATMUL(fjac, v)) )
        IF ( imethod .LT. 10) delta = SQRT(DOT_PRODUCT(v, MATMUL(dtd, v)))  !! Update delta if not set directly
        !! update acceleration
        IF(iaccel .GT. 0) THEN
           IF( analytic_Avv ) THEN
              CALL Avv(m,n,x,v,acc)
              naev = naev + 1
           ELSE
              CALL FDAvv(m,n,x,v,fvec, fjac, func, acc, jac_uptodate, h2)
              IF(jac_uptodate) THEN
                 nfev = nfev + 1
              ELSE
                 nfev = nfev + 2 !! we don't use the jacobian if it is not up to date
              ENDIF
           ENDIF
           !! Check accel for nans
           valid_result = .TRUE.
           checkAccel: DO i = 1,m
              IF(acc(i) /= acc(i)) THEN
                 valid_result = .FALSE.
                 EXIT checkAccel
              END IF
           END DO checkAccel
           IF (valid_result ) THEN
              a = -1.0d+0*MATMUL(acc, fjac)
              CALL DPOTRS('U', n, 1, g, n, a, n, info)
              !!a = -1.0d+0*MATMUL(g,MATMUL(acc,fjac))
           ELSE
              a(:) = 0.0d+0 !! If nans in acc, we will ignore the acceleration term
           ENDIF
        ENDIF

        !! Evaluate at proposed step -- only necessary if av <= avmax
        av = SQRT(DOT_PRODUCT(a,MATMUL(dtd, a))/DOT_PRODUCT(v,MATMUL(dtd,v)))
        IF( av .LE. avmax) THEN
           x_new = x + v + 0.5d+0*a
           CALL func(m,n,x_new,fvec_new)
           nfev = nfev + 1
           Cnew = 0.5d+0*DOT_PRODUCT(fvec_new,fvec_new)
           Cold = C
           valid_result = .TRUE.
           !! Check for nans in fvec_new
           checkfvec_new: DO i = 1,m
              IF(fvec_new(i) /= fvec_new(i)) THEN
                 valid_result = .FALSE.
                 EXIT checkfvec_new
              END IF
           END DO checkfvec_new
           IF (valid_result) THEN  !! If no nans, proceed as normal
              ! update rho and actred
              actred = 1.0d+0 - Cnew/C
              rho = 0.0d+0
              IF(pred_red .NE. 0.0d+0) rho = (1.0d+0 - Cnew/C)/pred_red
              !! Accept or Reject proposed step
              CALL Acceptance(n,C, Cnew, Cbest, ibold, accepted, dtd, v, vold)
           ELSE !! If nans in fvec_new, reject step
              actred = 0.0d+0
              rho = 0.0d+0
              accepted = MIN(accepted - 1, -1)
           ENDIF
        ELSE !! If acceleration too large, then reject
           accepted = MIN(accepted - 1, -1)
        ENDIF
     ELSE !! If matrix factorization fails, reject the proposed step
        accepted = MIN(accepted -1, -1)
     ENDIF

     !! Check Convergence
     IF (converged .EQ. 0) THEN
        CALL convergence_check(m, n, converged, accepted, counter, &
             & C, Cnew, x, fvec, fjac, lam, x_new, &
             & nfev, maxfev, njev, maxjev, naev, maxaev, maxlam, minlam, &
             & artol, Cgoal, gtol, xtol, xrtol, ftol, frtol,cos_alpha)
        IF (converged .EQ. 1 .AND. .NOT. jac_uptodate) THEN
           !! If converged by artol with an out of date jacobian, update the jacoban to confirm true convergence
           converged = 0
           jac_force_update = .TRUE.
        END IF
     ENDIF

     !! Print status
     IF (print_level .EQ. 2 .AND. accepted .GT. 0) THEN
        WRITE(print_unit, *) "  istep, nfev, njev, naev, accepted", istep, nfev, njev, naev, accepted
        WRITE(print_unit, *) "  Cost, lam, delta", C, lam, delta
        WRITE(print_unit, *) "  av, cos alpha", av, cos_alpha
        FLUSH(print_unit)
     ELSEIF(print_level .EQ. 3) THEN
        WRITE(print_unit, *) "  istep, nfev, njev, naev, accepted", istep, nfev, njev, naev, accepted
        WRITE(print_unit, *) "  Cost, lam, delta", C, lam, delta
        WRITE(print_unit, *) "  av, cos alpha", av, cos_alpha
        FLUSH(print_unit)
     ENDIF
     IF (print_level .EQ. 4 .AND. accepted .GT. 0) THEN
        WRITE(print_unit, *) "  istep, nfev, njev, naev, accepted", istep, nfev, njev, naev, accepted
        WRITE(print_unit, *) "  Cost, lam, delta", C, lam, delta
        WRITE(print_unit, *) "  av, cos alpha", av, cos_alpha
        WRITE(print_unit, *) "  x = ", x
        WRITE(print_unit, *) "  v = ", v
        WRITE(print_unit, *) "  a = ", a
        FLUSH(print_unit)
     ELSEIF (print_level .EQ. 5) THEN
        WRITE(print_unit, *) "  istep, nfev, njev, naev, accepted", istep, nfev, njev, naev, accepted
        WRITE(print_unit, *) "  Cost, lam, delta", C, lam, delta
        WRITE(print_unit, *) "  av, cos alpha", av, cos_alpha
        WRITE(print_unit, *) "  x = ", x
        WRITE(print_unit, *) "  v = ", v
        WRITE(print_unit, *) "  a = ", a
        FLUSH(print_unit)
     ENDIF

     ! If converged -- return
     IF(converged .NE. 0) THEN
        exit main
     ENDIF

     IF (accepted .GE. 0) jac_uptodate = .FALSE. !jacobian is now out of date

  END DO main
  ! end main loop

  ! If not converged
  IF(converged .EQ. 0) converged = -1
  niters = istep

  ! Return best fit found
  ! If the method converged, but final x is different from x_best -- what to do?
  x = x_best
  fvec = fvec_best

  IF(print_level .GE. 1) THEN
     WRITE(print_unit,*) "Optimization finished"
     WRITE(print_unit,*) "Results:"
     WRITE(print_unit,*) "  Converged:    ", converged_info(converged), converged
     WRITE(print_unit,*) "  Final Cost: ", 0.5d+0*DOT_PRODUCT(fvec,fvec)
     WRITE(print_unit,*) "  Cost/DOF: ", 0.5d+0*DOT_PRODUCT(fvec,fvec)/(m-n)
     WRITE(print_unit,*) "  niters:     ", istep
     WRITE(print_unit,*) "  nfev:       ", nfev
     WRITE(print_unit,*) "  njev:       ", njev
     WRITE(print_unit,*) "  naev:       ", naev
     FLUSH(print_unit)
  ENDIF

END SUBROUTINE geodesiclm


*DECK DSOSSL
      SUBROUTINE DSOSSL (K, N, L, X, C, B, M)
C***BEGIN PROLOGUE  DSOSSL
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSOS
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SOSSOL-S, DSOSSL-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     DSOSSL solves an upper triangular type of linear system by back
C     substitution.
C
C     The matrix C is upper trapezoidal and stored as a linear array by
C     rows. The equations have been normalized so that the diagonal
C     entries of C are understood to be unity. The off diagonal entries
C     and the elements of the constant right hand side vector B have
C     already been stored as the negatives of the corresponding equation
C     values.
C     With each call to DSOSSL a (K-1) by (K-1) triangular system is
C     resolved. For L greater than K, column L of C is included in the
C     right hand side vector.
C
C***SEE ALSO  DSOS
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DSOSSL
C
C
      INTEGER J, JKM, K, KJ, KM, KM1, KMM1, KN, L, LK, M, N, NP1
      DOUBLE PRECISION B(*), C(*), X(*), XMAX
C
C***FIRST EXECUTABLE STATEMENT  DSOSSL
      NP1 = N + 1
      KM1 = K - 1
      LK = KM1
      IF (L .EQ. K) LK = K
      KN = M
C
C
      DO 40 KJ = 1, KM1
         KMM1 = K - KJ
         KM = KMM1 + 1
         XMAX = 0.0D0
         KN = KN - NP1 + KMM1
         IF (KM .GT. LK) GO TO 20
            JKM = KN
C
            DO 10 J = KM, LK
               JKM = JKM + 1
               XMAX = XMAX + C(JKM)*X(J)
   10       CONTINUE
   20    CONTINUE
C
         IF (L .LE. K) GO TO 30
            JKM = KN + L - KMM1
            XMAX = XMAX + C(JKM)*X(L)
   30    CONTINUE
         X(KMM1) = XMAX + B(KMM1)
   40 CONTINUE
C
      RETURN
      END


CC=================================================================CC
CC                                                                 CC
CC  Subroutine CTFFTSR(X,Y,M,CT1,CT3,ST1,ST3,ITAB):                CC
CC      An in-place, split-radix complex FFT program               CC
CC      Decimation-in-frequency, cos/sin in third loop             CC
CC      and is looked-up in table. Tables CT1,CT3,ST1,ST3          CC
CC      have to have length>=N/8-1. The bit reverser uses partly   CC
CC      table lookup.                                              CC
CC                                                                 CC
CC  Input/output                                                   CC
CC      X    Array of real part of input/output (length >= N)      CC
CC      Y    Array of imaginary part of input/output (length >= N) CC
CC      M    Transform length is N=2**M                            CC
CC      CT1  Array of cos() table (length >= N/8-1)                CC
CC      CT3  Array of cos() table (length >= N/8-1)                CC
CC      ST1  Array of sin() table (length >= N/8-1)                CC
CC      ST3  Array of sin() table (length >= N/8-1)                CC
CC      ITAB Array of bitreversal indices (length >= sqrt(2*N)     CC
CC                                                                 CC
CC  Calls:                                                         CC
CC      CTSTAG                                                     CC
CC      and TINIT has to be called before this program!!           CC
CC                                                                 CC
CC  Author:                                                        CC
CC      H.V. Sorensen,   University of Pennsylvania,  Dec. 1984    CC
CC                       Arpa address: hvs@ee.upenn.edu            CC
CC  Modified:                                                      CC
CC      H.V. Sorensen,   University of Pennsylvania,  Jul. 1987    CC
CC                                                                 CC
CC  Reference:                                                     CC
CC      Sorensen, Heideman, Burrus :"On computing the split-radix  CC
CC      FFT", IEEE Tran. ASSP, Vol. ASSP-34, No. 1, pp. 152-156    CC
CC      Feb. 1986                                                  CC
CC      Mitra&Kaiser: "Digital Signal Processing Handbook, Chap.   CC
CC      8, page 491-610, John Wiley&Sons, 1993                     CC
CC                                                                 CC
CC      This program may be used and distributed freely as long    CC
CC      as this header is included                                 CC
CC                                                                 CC
CC=================================================================CC
	SUBROUTINE CTFFTSR(X,Y,M,CT1,CT3,ST1,ST3,ITAB)
	REAL X(1),Y(1),CT1(1),CT3(1),ST1(1),ST3(1)
        INTEGER ITAB(1)
	N = 2**M
C-------L shaped butterflies----------------------------------------C
        ITS = 1
	N2 = 2*N
	DO  10 K = 1, M-1
	    N2 = N2/2
	    N4 = N2/4
	    CALL CTSTAG(N,N2,N4,ITS,X(1),X(N4+1),X(2*N4+1),X(3*N4+1),
     $                              Y(1),Y(N4+1),Y(2*N4+1),Y(3*N4+1),
     $                              CT1,CT3,ST1,ST3)
            ITS = 2 * ITS
 10     CONTINUE
C-------Length two butterflies--------------------------------------C
	IS = 1
	ID = 4
 20         DO  30 I1 = IS,N,ID
		T1      = X(I1)
		X(I1)   = T1 + X(I1+1)
		X(I1+1) = T1 - X(I1+1)
		T1      = Y(I1)
		Y(I1)   = T1 + Y(I1+1)
		Y(I1+1) = T1 - Y(I1+1)
 30         CONTINUE
	    IS = 2*ID - 1
	    ID = 4*ID
	IF (IS.LT.N) GOTO 20
C-------Digit reverse counter---------------------------------------C
        M2 = M/2
        NBIT = 2**M2
	DO  50 K = 2, NBIT
            J0 = NBIT * ITAB(K) + 1
            I = K
            J = J0
            DO  40 L = 2, ITAB(K)+1
                T1   = X(I)
                X(I) = X(J)
                X(J) = T1
                T1   = Y(I)
                Y(I) = Y(J)
                Y(J) = T1
                I = I + NBIT
                J = J0 + ITAB(L)
 40         CONTINUE
 50     CONTINUE
	RETURN
	END
C===================================================================C
C   Subroutine CTSTAG - the work-horse of CTFFTSR                   C
C       Computes a stage of a length N split-radix transform        C
C   Author:                                                         C
C       H.V. Sorensen,   University of Pennsylvania,  Jul. 1987     C
C===================================================================C
        SUBROUTINE CTSTAG(N,N2,N4,ITS,X1,X2,X3,X4,Y1,Y2,Y3,Y4,
     $                    CT1,CT3,ST1,ST3)
	REAL X1(1),X2(1),X3(1),X4(1),Y1(1),Y2(1),Y3(1),Y4(1)
        REAL CT1(1),CT3(1),ST1(1),ST3(1)
	N8 = N4/2
C-------Zero butterfly----------------------------------------------C
	IS = 0
	ID = 2*N2
 10         DO  20  I1 = IS+1,N,ID
		T1     = X1(I1) - X3(I1)
		X1(I1) = X1(I1) + X3(I1)
                T2     = Y2(I1) - Y4(I1)
                Y2(I1) = Y2(I1) + Y4(I1)
                X3(I1) = T1     + T2
                T2     = T1     - T2
                T1     = X2(I1) - X4(I1)
                X2(I1) = X2(I1) + X4(I1)
                X4(I1) = T2
		T2     = Y1(I1) - Y3(I1)
                Y1(I1) = Y1(I1) + Y3(I1)
		Y3(I1) = T2     - T1
		Y4(I1) = T2     + T1
 20         CONTINUE
	    IS = 2*ID - N2
	    ID = 4*ID
	IF (IS .LT. N) GOTO 10
C
	IF  (N4-1) 100,100,30
C-------N/8 butterfly-----------------------------------------------C
 30     IS = 0
	ID = 2*N2
 40         DO  50 I1 = IS+1+N8,N,ID
                T1     = X1(I1) - X3(I1)
                X1(I1) = X1(I1) + X3(I1)
                T2     = X2(I1) - X4(I1)
                X2(I1) = X2(I1) + X4(I1)
                T3     = Y1(I1) - Y3(I1)
                Y1(I1) = Y1(I1) + Y3(I1)
                T4     = Y2(I1) - Y4(I1)
                Y2(I1) = Y2(I1) + Y4(I1)
                T5     = (T4 - T1)*0.707106778
                T1     = (T4 + T1)*0.707106778
                T4     = (T3 - T2)*0.707106778
                T2     = (T3 + T2)*0.707106778
		X3(I1) = T4 + T1
		Y3(I1) = T4 - T1
		X4(I1) = T5 + T2
		Y4(I1) = T5 - T2
 50         CONTINUE
	    IS = 2*ID - N2
	    ID = 4*ID
	IF (IS .LT. N-1) GOTO 40
C
	IF  (N8-1) 100,100,60
C-------General butterfly. Two at a time----------------------------C
 60     IS = 1
        ID = N2*2
 70         DO  90  I = IS, N, ID
                IT = 0
                JN = I + N4
		DO  80 J=1, N8-1
                    IT = IT+ITS
                    I1 = I+J
		    T1     = X1(I1) - X3(I1)
		    X1(I1) = X1(I1) + X3(I1)
		    T2     = X2(I1) - X4(I1)
		    X2(I1) = X2(I1) + X4(I1)
		    T3     = Y1(I1) - Y3(I1)
		    Y1(I1) = Y1(I1) + Y3(I1)
		    T4     = Y2(I1) - Y4(I1)
		    Y2(I1) = Y2(I1) + Y4(I1)
		    T5 = T1 - T4
		    T1 = T1 + T4
		    T4 = T2 - T3
		    T2 = T2 + T3
		    X3(I1) =  T1*CT1(IT) - T4*ST1(IT)
		    Y3(I1) = -T4*CT1(IT) - T1*ST1(IT)
		    X4(I1) =  T5*CT3(IT) + T2*ST3(IT)
		    Y4(I1) =  T2*CT3(IT) - T5*ST3(IT)
		    I2 = JN - J
		    T1     = X1(I2) - X3(I2)
		    X1(I2) = X1(I2) + X3(I2)
		    T2     = X2(I2) - X4(I2)
		    X2(I2) = X2(I2) + X4(I2)
		    T3     = Y1(I2) - Y3(I2)
		    Y1(I2) = Y1(I2) + Y3(I2)
		    T4     = Y2(I2) - Y4(I2)
		    Y2(I2) = Y2(I2) + Y4(I2)
		    T5 = T1 - T4
		    T1 = T1 + T4
		    T4 = T2 - T3
		    T2 = T2 + T3
		    X3(I2) =  T1*ST1(IT) - T4*CT1(IT)
		    Y3(I2) = -T4*ST1(IT) - T1*CT1(IT)
		    X4(I2) = -T5*ST3(IT) - T2*CT3(IT)
		    Y4(I2) = -T2*ST3(IT) + T5*CT3(IT)
 80             CONTINUE
 90         CONTINUE
            IS = 2*ID - N2 +1
            ID = 4*ID
	IF (IS .LT. N) GOTO 70
 100    RETURN
	END
CC=================================================================CC
CC  Subroutine TINIT:                                              CC
CC      Initialize SIN/COS and bit reversal tables                 CC
CC  Author:                                                        CC
CC      H.V. Sorensen,   University of Pennsylvania,  Jul. 1987    CC
CC=================================================================CC
	SUBROUTINE TINIT(M,CT1,CT3,ST1,ST3,ITAB)
	REAL CT1(1),CT3(1),ST1(1),ST3(1)
        INTEGER ITAB(1)
C-------Sin/Cos table-----------------------------------------------C
        N = 2**M
	ANG = 6.283185307179586/N
	DO  10 I=1,N/8-1
	    CT1(I) = COS(ANG*I)
	    CT3(I) = COS(ANG*I*3)
	    ST1(I) = SIN(ANG*I)
	    ST3(I) = SIN(ANG*I*3)
 10     CONTINUE
C-------Bit reversal table------------------------------------------C
        M2 = M/2
        NBIT = 2**M2
        IF (2*M2.NE.M) M2 = M2 + 1
	ITAB(1) = 0
	ITAB(2) = 1
        IMAX = 1
	DO  30 LBSS = 2, M2
            IMAX = 2 * IMAX
            DO  20 I = 1, IMAX
                ITAB(I)      = 2 * ITAB(I)
                ITAB(I+IMAX) = 1 + ITAB(I)
 20         CONTINUE
 30     CONTINUE
	RETURN
	END


!
! bps_rate_cab_mass: returns the rate C_ab, the corresponding Coulomb
! logarithm, and the function Delta (C_reg = -1/2 + Delta) for a
! general electron mass. While Delta -> 0 as me -> 0, this limit is
! not assumed in this subroutine.
!
!
! ROUTINES: bps_rate_cab_mass(nni, betab, zb, mb, nb, delta ...)
!           bps_rate_cei_mass(nni, betab, zb, mb, nb, cei, delta ...)
!
! Assume a plasma composed of several species b, each separately in
! thermal equilibrium with themselves but not necessarily with each
! other[1]. This routine returns several useful components of the
! corresponding rate C-coefficients.  introduced in Note [2] below (BPS).
!
! The rate of change of energy density is given by
!
!  dE_{ab}
!  -------- = -C_{ab} (T_a - T_b)
!    dt
!
! with C_{ab} = ( C_{ab}_reg + C_{ab}_sing ) + C_{ab}_qm
!
!
! UNITS: C_{ab} has units of [1/cm^2*s]
!
! INPUT: nni, betab, zb, mb, nb
!
! plasma input quantities:
! nni  : Number of total plasma species = number ion species + 1
! zb   : Charges of the plasma species. By convention zp(1) is the
!      : electron plasma component. [dimensionless, Array]
! betab: Inverse temperatures of the plasma components. For an
!        electron-ion plasma, set betab(1)=1/T_e and all other
!        values of the array to 1/T_I [keV^-1].
! mb   : Masses of the plasma species [keV].
! nb   : Number densities of the plasma species [cm^-3].
!
!
! OUTPUT: ln_bps, delta, cab(1:nni+1,1:nni+1), cab_sing(:,:), cab_reg(:,:), cab_sqm(:,:)
!                   |
!                   -----> 0  as  me --> 0
!
! Each plasma component b makes a linear contribution A_b to the total
! A-coefficient, i.e. A = sum_b A_b [5]. Each A_b in turn can be be
! decomposed into a classical-quantum or electron-ion contributions.
!
! Coulomb logarithm     : ln_bps
! General rate coeff    : cei = \sum_i c_{ei} [cm^-3 s^-1]
! classical total       : delta --> 0  as  me --> 0
! Singular contribution : cei_sing
! Regular  contribution : cei_reg
! Quantum  contribution : cei_qm
!
! NOTES:
! [1] The temperatures T_b may therefore all differ. By convention
!     I take b=1 for the electron component of the plasma. A very
!     useful and interesting parameter regime is the one in which
!     the ions have a common temperature T_I and the electron have
!     a temperature T_e, usually with T_e =/= T_I.  See also USAGE
!     and note [3] below.
!
! [2] L. Brown, D. Preston, and R. Singleton~Jr.,
!     "Charged Particle Motion in a Highly Ionized Plasma",
!     Physics Reports, 410 (2005) 237
!     [arXiv:physics/0501084]
!
!
      SUBROUTINE bps_rate_cab_mass(nni, ia, ib, betab, zb, mb, nb, &
        c_ab, c_ab_sing, c_ab_reg, c_ab_qm)
      USE mathvars
      USE physvars
        IMPLICIT NONE
        INTEGER,                             INTENT(IN)  :: nni     !  Number of ions
        INTEGER,                             INTENT(IN)  :: ia      !  Species number
        INTEGER,                             INTENT(IN)  :: ib      !  Species number
        REAL,    DIMENSION(1:nni+1),         INTENT(IN)  :: betab   !  Temperature array    [1/keV]
        REAL,    DIMENSION(1:nni+1),         INTENT(IN)  :: zb      !  Charge array
        REAL,    DIMENSION(1:nni+1),         INTENT(IN)  :: mb      !  Mass array [keV]
        REAL,    DIMENSION(1:nni+1),         INTENT(IN)  :: nb      !  Number density array [cm^-3]
        REAL,                                INTENT(OUT) :: c_ab
        REAL,                                INTENT(OUT) :: c_ab_sing
        REAL,                                INTENT(OUT) :: c_ab_reg
        REAL,                                INTENT(OUT) :: c_ab_qm
        REAL,    DIMENSION(1:nni+1)  :: kb2, ob2
        REAL    ::  c_s, c_r, c_q
        REAL    :: kia2, kib2, bmia, bmib, nab, omi2, nab_reg
        INTEGER :: ibmax

        ibmax=nni+1
!
! initialize components of rate-coefficients
!
!
! construct plasma quantities: kb^2
!
        ob2=8*PI*A0CM*BEKEV*zb*zb*nb*CC2/mb
        kb2=8*PI*A0CM*BEKEV*zb*zb*nb*betab
        omi2=SUM(ob2(2:ibmax))

        kia2  =kb2(ia)
        bmia  =betab(ia)*mb(ia)
        kib2=kb2(ib)
        bmib=betab(ib)*mb(ib)
        nab=kia2*kib2*CC*SQRT(bmia*bmib)/(bmia + bmib)**1.5   !
        nab=nab/TWOPI**1.5                                    ! normalization
!
! C_{ab}-classical-singular
!
        CALL cab_sing_mass(nni,ia,ib,betab,zb,mb,nb,c_s)
        c_ab_sing=nab*c_s
!
! C_{ab}-classical-regular
!
        CALL cab_reg_mass(nni,ia,ib,betab,zb,mb,nb,c_r)
        nab_reg=kb2(ia)*omi2/TWOPI
        nab_reg=nab_reg*SQRT(betab(ia)*mb(ia)/TWOPI)/CC
        c_ab_reg=nab_reg*c_r
!
! C_{ab}-quantum
!
        CALL cab_qm_mass(nni,ia,ib,betab,zb,mb,c_q)
        c_ab_qm=nab*c_q
!
! C_{ab}-total
!
        c_ab=c_ab_sing + c_ab_reg + c_ab_qm
      END SUBROUTINE bps_rate_cab_mass
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Assembles the matrix C_{ab} of the rate coefficients
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!

      SUBROUTINE bps_rate_cab_matrix(nni, betab, zb, mb, nb,    &
        c_ab, c_ab_sing, c_ab_reg, c_ab_qm, c_tot, c_i, c_e, cc_tot, &
        cc_i, cc_e, cq_tot, cq_i, cq_e, cc_s_i, cc_s_e, cc_r_i, cc_r_e)
      USE physvars
      USE mathvars
        IMPLICIT NONE                                             ! Plasma:
        INTEGER,                            INTENT(IN)  :: nni    !  number of ions
        REAL,    DIMENSION(1:nni+1),        INTENT(IN)  :: betab  !  temp array [1/keV]
        REAL,    DIMENSION(1:nni+1),        INTENT(IN)  :: zb     !  charge array
        REAL,    DIMENSION(1:nni+1),        INTENT(IN)  :: mb     !  mass array [keV]
        REAL,    DIMENSION(1:nni+1),        INTENT(IN)  :: nb     !  density [1/cc]
                                                                  !
                                                                  ! A-coeffs [MeV/micron]
        REAL,    DIMENSION(1:nni+1,1:nni+1),INTENT(OUT) :: c_ab
        REAL,    DIMENSION(1:nni+1,1:nni+1),INTENT(OUT) :: c_ab_sing
        REAL,    DIMENSION(1:nni+1,1:nni+1),INTENT(OUT) :: c_ab_reg
        REAL,    DIMENSION(1:nni+1,1:nni+1),INTENT(OUT) :: c_ab_qm
        REAL,    DIMENSION(1:nni+1),        INTENT(OUT) :: c_tot
        REAL,    DIMENSION(1:nni+1),        INTENT(OUT) :: c_i
        REAL,    DIMENSION(1:nni+1),        INTENT(OUT) :: c_e
        REAL,    DIMENSION(1:nni+1),        INTENT(OUT) :: cc_tot
        REAL,    DIMENSION(1:nni+1),        INTENT(OUT) :: cc_i
        REAL,    DIMENSION(1:nni+1),        INTENT(OUT) :: cc_e
        REAL,    DIMENSION(1:nni+1),        INTENT(OUT) :: cq_tot
        REAL,    DIMENSION(1:nni+1),        INTENT(OUT) :: cq_i
        REAL,    DIMENSION(1:nni+1),        INTENT(OUT) :: cq_e
        REAL,    DIMENSION(1:nni+1),        INTENT(OUT) :: cc_s_i
        REAL,    DIMENSION(1:nni+1),        INTENT(OUT) :: cc_s_e
        REAL,    DIMENSION(1:nni+1),        INTENT(OUT) :: cc_r_i
        REAL,    DIMENSION(1:nni+1),        INTENT(OUT) :: cc_r_e

        REAL    :: cab, cab_sing, cab_reg, cab_qm
        REAL    :: mp, zp
        INTEGER :: ia, ib

        c_i   = 0
        cc_s_i= 0
        cc_r_i= 0
        cc_i  = 0
        cq_i  = 0
        DO ia=1,nni+1
          mp=mb(ia)
          zp=zb(ia)
          DO ib=1,nni+1
            CALL bps_rate_cab_mass(nni, ia, ib, betab, zb, mb, nb, &
              cab, cab_sing, cab_reg, cab_qm)
            c_ab(ia,ib)     =cab
            c_ab_sing(ia,ib)=cab_sing
            c_ab_reg(ia,ib) =cab_reg
            c_ab_qm(ia,ib)  =cab_qm
            IF (ib == 1) THEN
               c_e(ia)   = cab
               cc_s_e(ia)= cab_sing
               cc_r_e(ia)= cab_reg
               cc_e(ia)  = cab_sing + cab_reg
               cq_e(ia)  = cab_qm
            ELSE
               c_i(ia)   = c_i(ia)    + cab
               cc_s_i(ia)= cc_s_i(ia) + cab_sing
               cc_r_i(ia)= cc_r_i(ia) + cab_reg
               cc_i(ia)  = cc_i(ia)   + cab_sing + cab_reg
               cq_i(ia)  = cq_i(ia)   + cab_qm
            ENDIF
          ENDDO
          c_tot(ia) = c_e(ia)  + c_i(ia)
          cc_tot(ia)= cc_e(ia) + cc_i(ia)
          cq_tot(ia)= cq_e(ia) + cq_i(ia)
        ENDDO
      END SUBROUTINE bps_rate_cab_matrix
!
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Returns C_{e I} = \sum_i C_{e i} for backward compatibility
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE bps_rate_cei_mass(nni, betab, zb, mb, nb, ln_bps,      &
      delta, cei_tot, cei_i, cei_e, ceic_tot, ceic_i, ceic_e, ceiq_tot, &
      ceiq_i, ceiq_e, ceic_s_i, ceic_s_e, ceic_r_i , ceic_r_e, ceib)
      USE physvars
      USE mathvars
        IMPLICIT NONE
        INTEGER,                     INTENT(IN)  :: nni     !  Number of ions
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: betab   !  Temperature array    [1/keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: zb      !  Charge array
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: mb      !  Mass array [keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: nb      !  Number density array [cm^-3]
        REAL,                        INTENT(OUT) :: ln_bps  !  Coulomb logarithm
        REAL,                        INTENT(OUT) :: delta   !  C_reg =-1/2+delta
        REAL,                        INTENT(OUT) :: cei_tot ! [cm^-3 s^-1]
        REAL,                        INTENT(OUT) :: cei_i   !
        REAL,                        INTENT(OUT) :: cei_e   !
        REAL,                        INTENT(OUT) :: ceic_tot!
        REAL,                        INTENT(OUT) :: ceic_i  !
        REAL,                        INTENT(OUT) :: ceic_e  !
        REAL,                        INTENT(OUT) :: ceiq_tot!
        REAL,                        INTENT(OUT) :: ceiq_i  !
        REAL,                        INTENT(OUT) :: ceiq_e  !
        REAL,                        INTENT(OUT) :: ceic_s_i!
        REAL,                        INTENT(OUT) :: ceic_s_e!
        REAL,                        INTENT(OUT) :: ceic_r_i!
        REAL,                        INTENT(OUT) :: ceic_r_e!
        REAL,    DIMENSION(1:nni+1), INTENT(OUT) :: ceib    !
        REAL,    DIMENSION(1:nni+1)  :: ob2
        REAL     :: omi2, cn, kb2e
        REAL     :: cab, c_ab_sing, c_ab_reg, c_ab_qm
        INTEGER  :: ia, ib, nnb
!
! initialize components of A-coefficients
!
        delta=0
        cei_tot =0  ! electron + ion
        cei_i   =0  ! ion contribution
        cei_e   =0  ! electron contribution
        ceic_tot=0  ! classical total
        ceic_e  =0  ! classical electron
        ceic_i  =0  ! classical ion
        ceiq_tot=0  ! quantum total
        ceiq_e  =0  ! quantum electron
        ceiq_i  =0  ! quantum ion
        ceic_s_i=0
        ceic_s_e=0
        ceic_r_i=0
        ceic_r_e=0
        ceib=0

        kb2e=8*PI*A0CM*BEKEV*zb(1)*zb(1)*nb(1)*betab(1)
        ob2=8*PI*A0CM*BEKEV*zb*zb*nb*CC2/mb
        omi2=SUM(ob2(2:nni+1))
        cn=kb2e*omi2/TWOPI
        cn=cn*SQRT(betab(1)*mb(1)/TWOPI)/CC

        ia=1
        NNB = nni+1    ! number of ions + electrons
        DO ib=1,nni+1  ! loop over electrons to calculate cei_e
           CALL bps_rate_cab_mass(nni, ia, ib, betab, zb, mb, nb, &
           cab, c_ab_sing, c_ab_reg, c_ab_qm)
           IF (ib .NE. 1) delta=delta+c_ab_reg/cn
           ceib(ib)=c_ab_sing + c_ab_reg + c_ab_qm
           CALL x_collect(ib, NNB, c_ab_sing, c_ab_reg, c_ab_qm,      &
           cei_tot, cei_i, cei_e, ceic_tot, ceic_i, ceic_e, ceiq_tot, &
           ceiq_i, ceiq_e, ceic_s_i, ceic_s_e, ceic_r_i, ceic_r_e)
        ENDDO
        delta=0.5+delta
        ln_bps=cei_i/cn
      END SUBROUTINE bps_rate_cei_mass
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! singular contribution c_s for non-zero electron mass
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! Returns the rate coefficient C_{ia ib, sing}
!
      SUBROUTINE cab_sing_mass(nni, ia, ib, betab, zb, mb, nb, cab_sing)
      USE mathvars
      USE physvars
        IMPLICIT NONE
        INTEGER,                     INTENT(IN)  :: nni  !Number of ion species
        INTEGER,                     INTENT(IN)  :: ia
        INTEGER,                     INTENT(IN)  :: ib
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: zb   !Charge array
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: betab!Temperature array [1/keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: mb   !Mass array [keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: nb   !density array [1/cm^3]
        REAL,                        INTENT(OUT) :: cab_sing

        REAL    :: betae, ne, ge, mabc2, zia, zib, vab2
!
! note: om_b=(1.32155E+3)*SQRT(zb*zb*nb*AMUKEV/mb) ! Plasma frequency [1/s]
!       ge=(6.1260E-15)*SQRT(ne)/te**1.5

        betae=betab(1)
        ne=nb(1)
        ge=GECOEFF*SQRT(ne)*betae**1.5
        zia=zb(ia)
        zib=zb(ib)
        mabc2=mb(ia)*mb(ib)/(mb(ia) + mb(ib)) ! [keV]
        vab2=1./(betab(ia)*mb(ia)) + 1./(betab(ib)*mb(ib)) ! [dimensionless]
        cab_sing=-LOG(0.25*ge*ABS(zia*zib)/(mabc2*betae*vab2)) - 2*GAMMA
      END SUBROUTINE cab_sing_mass
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! regular contribution for non-zero electron mass: normalization cei_reg(me=0)=-1/2
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      FUNCTION dcab_reg(x, nni, ia, ib, betab, zb, mb, nb)
      USE physvars
      USE mathvars
      IMPLICIT NONE
      REAL,                        INTENT(IN)  :: x
      INTEGER,                     INTENT(IN)  :: nni    !  Number of ion species
      INTEGER,                     INTENT(IN)  :: ia     !  Species type
      INTEGER,                     INTENT(IN)  :: ib     !  Species type
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: zb     !  Charge array
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: betab  !  Temperature array [1/keV]
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: mb     !  Mass array [keV]
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: nb     !  density array [1/cm^3]
      REAL                                     :: dcab_reg
      REAL,    DIMENSION(1:nni+1) :: betamb, kbar2b
      REAL                        :: fr, fi, fabs, farg
      REAL                        :: mu, mu2, x2, rx, hx, kaic, rxic
!     REAL                        :: abca2, kaia
      INTEGER                     :: ic
!
! construct parameters
!
      mu=SUM(SQRT(betab(2:nni+1)*mb(2:nni+1)))  ! inverse thermal velocity
      mu2=mu*mu                                 ! mu^2
      betamb=SQRT(betab*mb)/mu                  !
      kbar2b=zb*zb*betab*nb/(betab(1)*nb(1))    ! kbar=k_b/k_e
!
! construct H(x)*x from  F_re, F_im, |F|, arg(F)
!
      CALL frfi(x,nni,kbar2b,betamb,fr,fi,fabs,farg)! F(x)
      hx=2*(fi*LOG(fabs) + fr*farg)*x           ! H(x)*x
!
! construct spectral weight ratio R_ab(x)

!*!
!      rxic=0
!      DO ic=1,nni+1
!         kaic=kbar2b(ic)*betamb(ic)
!         IF (ic == ib) kaia=kaic*EXP(-betamb(ib)*betamb(ib)*x*x)
!         abca2 =betamb(ic)**2 - betamb(ia)**2
!         rxic = rxic + kaic*EXP(-abca2*x*x)
!      ENDDO
!      rx=kaia/rxic
!*!
      x2=x*x
      rxic=0
      kaic=EXP(-(betamb(ia)*betamb(ia)+betamb(ib)*betamb(ib))*x2)
      DO ic=1,nni+1
         rxic=rxic + kbar2b(ic)*betamb(ic)*EXP(-betamb(ic)*betamb(ic)*x2)
      ENDDO
      rx=kaic*kbar2b(ib)*betamb(ib)/rxic
!
! construct un-normalized rate integrand: normalization in cab_reg_mass
!
      dcab_reg=rx*hx
!
      END FUNCTION dcab_reg
      SUBROUTINE cab_reg_mass(nni, ia, ib, betab, zb, mb, nb, c_r)
      USE mathvars
        IMPLICIT NONE
        INTEGER,                     INTENT(IN)  :: nni    !  Number of ion species
        INTEGER,                     INTENT(IN)  :: ia     !
        INTEGER,                     INTENT(IN)  :: ib     !
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: zb     !  Charge array
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: betab  !  Temperature array [1/keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: mb     !  Mass array [keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: nb     !  density array [1/cm^3]
        REAL,                        INTENT(OUT) :: c_r

        REAL,    PARAMETER :: UPM=0.7745966692E0
        REAL,    PARAMETER :: W13=0.5555555556E0, W2=0.8888888889E0

        REAL    :: y, dcab_reg
        REAL    :: xmin, xmax, x, dx, xm, xc
        REAL    :: cn, ne, betae
        INTEGER :: nmax, ic

        REAL,    DIMENSION(1:nni+1) :: ab
        REAL    :: mu, mu2
!
! integration cutoff determined by thermal velocity of ions

        mu=SUM(SQRT(betab(2:nni+1)*mb(2:nni+1)))  ! inverse thermal velocity
        mu2=mu*mu                                 ! mu^2
        ab=SQRT(betab*mb)/mu                      !
!
        xc=5 ! ti=1, te=0.01, 0.1, 1, 10, 100
        xc=1./MIN(ab(ia),ab(ib))
        xmin=0.
        xmax=5*xc
        nmax=1000
        dx=(xmax-xmin)/nmax
        x=xmin-dx
        c_r=0
        DO ic=1,nmax,2
!
           x=x+2.E0*dx
           y=dcab_reg(x,nni,ia,ib,betab,zb,mb,nb)
           c_r=c_r + W2*y
!
           xm=x-dx*UPM
           y=dcab_reg(xm,nni,ia,ib,betab,zb,mb,nb)
           c_r=c_r + W13*y
!
           xm=x+dx*UPM
           y=dcab_reg(xm,nni,ia,ib,betab,zb,mb,nb)
           c_r=c_r + W13*y
        ENDDO
        c_r=c_r*dx
!
! construct normalization coefficient
!
        ne=nb(1)                                  !
        betae=betab(1)                            !
        cn=0
        DO ic=2,nni+1                                            !
           cn = cn + zb(ic)*zb(ic)*nb(ic)/(mb(ic)*ne*betae)      ! omega_I^2/kappa_e^2
        ENDDO                                                    !
        cn=-1./(PI*mu2*cn)                                       ! ke^2/(PI*mu^2 omI^2)
        c_r=c_r*cn
      END SUBROUTINE cab_reg_mass

!
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! quantum contribution for non-zero electron mass
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!
      SUBROUTINE cab_qm_mass(nni, ia, ib, betab, zb, mb, qm)
      USE physvars
      USE mathvars
        IMPLICIT NONE
        INTEGER,                     INTENT(IN)  :: nni    !  Number of ion species
        INTEGER,                     INTENT(IN)  :: ia     !
        INTEGER,                     INTENT(IN)  :: ib     !
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: zb     !  Charge array
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: betab  !  Temperature array [1/keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: mb     !  Mass array [keV]
        REAL,                        INTENT(OUT) :: qm

        REAL,    PARAMETER :: UPM=0.7745966692E0
        REAL,    PARAMETER :: W13=0.5555555556E0, W2=0.8888888889E0
        INTEGER, PARAMETER :: NMAX=1000
        REAL    :: xmin, xmax, dx, x, xm, y, dcei_qm, eta_ab, vab
        INTEGER :: ix

        vab=SQRT(1./(betab(ia)*mb(ia)) + 1./(betab(ib)*mb(ib)))
        eta_ab=ABS(zb(ia)*zb(ib))*2*BEKEV*A0CM/HBARC/vab

        xmin=0.
        xmax=15
        dx=(xmax-xmin)/NMAX
        x=xmin-dx
        qm=0
        DO ix=1,NMAX,2
!
           x=x+2*dx
           y=dcei_qm(x, eta_ab)
           qm=qm + W2*y
!
           xm=x-dx*UPM
           y=dcei_qm(xm,eta_ab)
           qm=qm + W13*y
!
           xm=x+dx*UPM
           y=dcei_qm(xm,eta_ab)
           qm=qm + W13*y
        ENDDO
        qm=-0.5*qm*dx
      END SUBROUTINE cab_qm_mass

!
      FUNCTION dcei_qm(x, eta)
      IMPLICIT NONE
      REAL  :: x       ! xi
      REAL  :: eta     ! quantum parameter
      REAL  :: dcei_qm ! quantum integrand
      REAL  :: xh, repsilog
      xh=eta/SQRT(x)
      dcei_qm=EXP(-x/2)*repsilog(xh)
      END FUNCTION dcei_qm
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Rate coefficient in extreme quantum limit with light electrons:
! eta --> 0 and me -->0
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! bps_rate_cei_born: returns the rate C_eI for me --> 0 in the extreme
! quantum limit (the Born approximation to the two-body scattering).
!
! ROUTINE: bps_rate_cei_born(nni, betab, zb, mb, nb, ln_bps_born, cei_born)
!
! The rate of change of energy density is given by
!
!  dE_{eI}
!  -------- = -C_{eI} (T_e - T_I)
!    dt
!                k_e^2    [ betae me]^1/2
! with C_{eI} = ------- * [ --------]      * Omega_I^2 * ln_BPS
!                 2pi     [    2 pi ]
!
!                                            Omega_I^2 = \sum_i omega_i^2
!
!                 1  [   [      8 T_e^2     ]               ]
!       ln_BPS = --- [ ln[ ---------------- ]  - gamma - 1  ]
!                 2  [   [ hbar^2 omega_e^2 ]               ]
!
!
! UNITS: C_{eI} has units of [1/cm^2*s]
!
! INPUT: nni, betab, zb, mb, nb
!
! plasma input quantities:
! nni  : Number of total plasma species = number ion species + 1
! zb   : Charges of the plasma species. By convention zp(1) is the
!      : electron plasma component. [dimensionless, Array]
! betab: Inverse temperatures of the plasma components. For an
!        electron-ion plasma, set betab(1)=1/T_e and all other
!        values of the array to 1/T_I [keV^-1].
! mb   : Masses of the plasma species [keV].
! nb   : Number densities of the plasma species [cm^-3].
!
! OUTPUT: ln_bps_born, cei_born
!
      SUBROUTINE bps_rate_cei_born(nni, betab, zb, mb, nb, ln_bps_born, cei_born)
      USE bpsvars
      USE mathvars
      USE physvars
        IMPLICIT NONE
        INTEGER,                     INTENT(IN)  :: nni     !  Number of ions
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: betab   !  Temperature array    [1/keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: zb      !  Charge array
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: mb      !  Mass array [keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: nb      !  Number density array [cm^-3]

        REAL                       , INTENT(OUT) :: ln_bps_born! BPS Coulomb log
        REAL                       , INTENT(OUT) :: cei_born   ! equilibration rate

        REAL,    PARAMETER :: UPM=0.7745966692E0
        REAL,    PARAMETER :: W13=0.5555555556E0, W2=0.8888888889E0

        REAL    :: mi, ni, zi, omi2, ome2, cn
        REAL    :: me, ne, betae, te2, ke2
        INTEGER :: ib
!
! construct plasma quantities: k_e^2, omega_I^2
!
        ne=nb(1)
        me=mb(1)
        betae=betab(1)
        te2 =1/betae**2
        ke2 =8*PI*A0CM*BEKEV*ne*betae
        ome2=8*PI*A0CM*BEKEV*ne*CC2/me
        omi2=0
        DO ib=2,nni+1
           ni=nb(ib)
           mi=mb(ib)
           zi=zb(ib)
           omi2=omi2 + 8*PI*A0CM*BEKEV*ni*zi*zi*CC2/mi
        ENDDO
!
!                           om_I^2*k_e^2    [ beta_e m_e*c^2 ]^1/2    1
! construct prefactor: cn = ------------  * |--------------- |     * ---
!                               2 pi        [   2 pi         ]        c
!
        cn=omi2*ke2/TWOPI
        cn=cn*SQRT(betae*me/TWOPI)/CC
!
!                                          1   [   [    8 T_e^2    ]             ]
! construct BPS Coulomb log: ln_bps_born = --- [ ln[ ------------- ] - GAMMA -1  ]
!                                          2   [   [  hbar^2 ome^2 ]             ]

        ln_bps_born=0.5*(LOG(8*te2*CC2/(HBARC2*ome2)) -GAMMA - 1)
!
! construct rate: cei_born
!
        cei_born=cn*ln_bps_born
      END SUBROUTINE bps_rate_cei_born
!
!=============== extraneous subroutines [we may need them] ====================
!
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Old code segments for bps_cei_* [sum over i]
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! Returns the rate coefficient C_{e ib, sing}
!
      SUBROUTINE bps_cei_sing(nni, ib, betab, zb, mb, nb, cei_sing)
      USE mathvars
      USE physvars
       IMPLICIT NONE
        INTEGER,                     INTENT(IN):: nni  !Number of ion species
        INTEGER,                     INTENT(IN):: ib
        REAL,    DIMENSION(1:nni+1), INTENT(IN):: zb   !Charge array
        REAL,    DIMENSION(1:nni+1), INTENT(IN):: betab!Temperature array [1/keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN):: mb   !Mass array [keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN):: nb   !density array [1/cm^3]
        REAL,                        INTENT(OUT) :: cei_sing
        REAL    :: betae, me, ne, zi, ni, mi, betai
        REAL    :: mui, deli, ge, oib2, sing
!
! note: om_b=(1.32155E+3)*SQRT(zb*zb*nb*AMUKEV/mb) ! Plasma frequency [1/s]
!       ge=(6.1260E-15)*SQRT(ne)/te**1.5

        betae=betab(1)
        me=mb(1)
        ne=nb(1)

        cei_sing=0
        ge=GECOEFF*SQRT(ne)*betae**1.5
        zi=zb(ib)
        ni=nb(ib)
        mi=mb(ib)
        betai=betab(ib)

        mui =me/mi                  ! mu_i
        deli=mui*betae/betai        ! del_i
        mui =1 + mui                ! 1 + mu_i
        deli=1 + deli               ! 1 + delta_i

        oib2=8*PI*A0CM*CC2*ni*zi*zi*BEKEV/mi
        sing=-LOG(0.25*ge*ABS(zi)*mui/deli) - 2*GAMMA
        sing=oib2*sing/deli**1.5
        cei_sing = cei_sing + sing
      END SUBROUTINE bps_cei_sing
!
!Returns the rate coefficient C_{e ib, reg}
!
      SUBROUTINE bps_cei_reg(nni, ib, betab, zb, mb, nb, c_r)
        IMPLICIT NONE
        INTEGER,                     INTENT(IN)  :: nni    !  Number of ion species
        INTEGER,                     INTENT(IN)  :: ib     !
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: zb     !  Charge array
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: betab  !  Temperature array [1/keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: mb     !  Mass array [keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: nb     !  density array [1/cm^3]
        REAL,                        INTENT(OUT) :: c_r

        REAL,    PARAMETER :: UPM=0.7745966692E0
        REAL,    PARAMETER :: W13=0.5555555556E0, W2=0.8888888889E0

        REAL    :: y, dcei_reg
        REAL    :: xmin, xmax, x, dx, xm, xc
        INTEGER :: nmax, ic
!
! integration cutoff determined by thermal velocity of ions
!
        xc=2. ! ti=1, te=0.01, 0.1, 1, 10, 100

        xmin=0.
        xmax=5*xc ! automate this choice later.
        nmax=1000
        dx=(xmax-xmin)/nmax
        x=xmin-dx
        c_r=0
        DO ic=1,nmax,2
!
           x=x+2.E0*dx
           y=dcei_reg(x,nni,ib,betab,zb,mb,nb)
           c_r=c_r + W2*y
!
           xm=x-dx*UPM
           y=dcei_reg(xm,nni,ib,betab,zb,mb,nb)
           c_r=c_r + W13*y
!
           xm=x+dx*UPM
           y=dcei_reg(xm,nni,ib,betab,zb,mb,nb)
           c_r=c_r + W13*y
        ENDDO
        c_r=c_r*dx
      END SUBROUTINE bps_cei_reg

      FUNCTION dcei_reg(x, nni, ib, betab, zb, mb, nb)
      USE physvars
      USE mathvars
      IMPLICIT NONE
      REAL,                        INTENT(IN)  :: x
      INTEGER,                     INTENT(IN)  :: nni    !  Number of ion species
      INTEGER,                     INTENT(IN)  :: ib     !  Species type
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: zb     !  Charge array
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: betab  !  Temperature array [1/keV]
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: mb     !  Mass array [keV]
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: nb     !  density array [1/cm^3]
      REAL                                     :: dcei_reg
      REAL,    DIMENSION(1:nni+1) :: ab, kbar2b
      REAL                        :: fr, fi, fabs, farg
      REAL                        :: mu, mu2, rx, hx, ae, ne, betae
      REAL                        :: kaic, kaib, rxic, abe2, cn
      INTEGER                     :: ic
!
! construct parameters
!
      ne=nb(1)                                  !
      betae=betab(1)                            !
      kbar2b=zb*zb*betab*nb/(betae*ne)          ! kbar=k_b/k_e
      mu=SUM(SQRT(betab(2:nni+1)*mb(2:nni+1)))  ! inverse thermal velocity
      mu2=mu*mu                                 ! mu^2
      ab=SQRT(betab*mb)/mu                      ! a_b=beta_b m_b/sum_i beta_i m_i
      ae=ab(1)                                  !
!
! construct H(x)*x from  F_re, F_im, |F|, arg(F)
!
      CALL frfi(x,nni,kbar2b,ab,fr,fi,fabs,farg)! F(x)
      hx=2*(fi*LOG(fabs) + fr*farg)*x ! H(x)*x
!
! construct spectral weight ratio R_b(x)
! R_b(x)=exp(- ab^2 x^2) rho_b(x)/rho_tot(x)
!
      rxic=0
      DO ic=1,nni+1
         kaic=kbar2b(ic)*ab(ic)
         IF (ic == ib) kaib=kaic*EXP(-ab(ib)*ab(ib)*x*x)
         abe2 =ab(ic)**2 - ae**2
         rxic = rxic + kaic*EXP(-abe2*x*x)
      ENDDO
      rx=kaib/rxic
!
! construct un-normalized rate integrand
!
      dcei_reg=rx*hx
!
! construct normalization coefficient
!
      cn=0
      DO ic=2,nni+1                                            !
         cn = cn + zb(ic)*zb(ic)*nb(ic)/(mb(ic)*ne*betae)      ! omega_I^2/kappa_e^2
      ENDDO                                                    !
      cn=-1./(PI*mu2*cn)                                       ! ke^2/(PI*mu^2 omI^2)
!
      dcei_reg=dcei_reg*cn
      END FUNCTION dcei_reg

      SUBROUTINE bps_cei_qm(nni, ib, betab, zb, mb, nb, qm)
      USE physvars
      USE mathvars
      IMPLICIT NONE
      INTEGER,                     INTENT(IN)  :: nni    !  Number of ion species
      INTEGER,                     INTENT(IN)  :: ib     !
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: zb     !  Charge array
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: betab  !  Temperature array [1/keV]
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: mb     !  Mass array [keV]
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: nb     !  density array [1/cm^3]
      REAL,                        INTENT(OUT) :: qm

      REAL,    PARAMETER :: UPM=0.7745966692E0
      REAL,    PARAMETER :: W13=0.5555555556E0, W2=0.8888888889E0
      INTEGER, PARAMETER :: NMAX=1000

      REAL    :: betae, betai, me, mi, ne, ni, zi
      REAL    :: deli, deli3, mui, oi2, eta_ei
      REAL    :: xmin, xmax, dx, x, xm, y, dcei_qm
      REAL    :: vei, ve2, vi2
      INTEGER :: ix
      qm=0
      betae=betab(1)
      me=mb(1)
      ne=nb(1)
      ve2=1./(me*betae)
         zi    =zb(ib)
         ni    =nb(ib)
         mi    =mb(ib)
         betai =betab(ib)
         vi2   =1./(mi*betai)
         vei   =CC*SQRT(ve2 + vi2)
         eta_ei=2*BEKEV*A0CM*CC*ABS(zi)/(HBARC*vei)
!        oi2   =OMEGI2*zi*zi*ni*AMUKEV/mi
         oi2   =8*PI*A0CM*BEKEV*ABS(zi)*ni*CC2/mi

         mui  =me/mi                  ! mu_i
         deli =mui*betae/betai        ! del_i
         mui  =1 + mui                ! 1 + mu_i
         deli =1 + deli               ! 1 + delta_i
         deli3=deli**1.5

         xmin=0.
         xmax=15
         dx=(xmax-xmin)/NMAX
         x=xmin-dx
         qm=0
         DO ix=1,NMAX,2
!
            x=x+2*dx
            y=dcei_qm(x, eta_ei)
            qm=qm + W2*y
!
            xm=x-dx*UPM
            y=dcei_qm(xm,eta_ei)
            qm=qm + W13*y
!
            xm=x+dx*UPM
            y=dcei_qm(xm,eta_ei)
            qm=qm + W13*y
         ENDDO
         qm=-0.5*qm*dx
         qm=oi2*qm/deli3
      END SUBROUTINE bps_cei_qm

!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! bps_rate_el: Calculates the *classical* electron-ion temperature equilibration
! rate for the physical mass of the electron (i.e. heavy ions and a light electron).
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE bps_rate_el(nni, betab, zb, mb, nb, clog, cei)
      USE bpsvars
      USE mathvars
      USE physvars
      IMPLICIT NONE
      INTEGER,                     INTENT(IN)  :: nni    !  Number of ions
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: betab  !  Temperature array    [1/keV]
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: zb     !  Charge array
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: mb     !  Mass array [keV]
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: nb     !  Number density array [cm^-3]

      REAL                       , INTENT(OUT) :: clog   ! BPS Coulomb log
      REAL                       , INTENT(OUT) :: cei    ! equilibration rate

!     REAL,    PARAMETER :: DEBYE=4.2539E-5      ! Used for Debye wave number
!     REAL,    PARAMETER :: OMEGI=1.32155E+3     ! Used For plasma frequency
!     REAL,    PARAMETER :: AMUKEV=0.931494012E6 ! 1 AMU [keV]

      REAL    :: ge, omi2, oi2, ke2, cn
      INTEGER :: ib
!
! construct om_I^2
!
      omi2=0
      DO ib=2,nni+1 ! Plasma frequency om_I^2 [1/s^2]
         omi2=omi2 + OMEGI*OMEGI*zb(ib)*zb(ib)*nb(ib)*AMUKEV/mb(ib)
      ENDDO
!
! calculate cei
!
!     clog=LOG(4./(zb(2)*ge))-2*GAMMA-0.5

      ge=(6.1260E-15)*SQRT(nb(1))*betab(1)**1.5
      cei=0
      DO ib=2,nni+1 ! Plasma frequency om_i^2 [1/s^2]
         oi2=OMEGI*OMEGI*zb(ib)*zb(ib)*nb(ib)*AMUKEV/mb(ib)
         cei=cei - oi2*LOG(0.25*zb(ib)*ge)
      ENDDO
      clog=cei/omi2 - (2*GAMMA + 0.5)
      cei=cei - omi2*(2*GAMMA + 0.5)
!
! construct prefactor
!
      ke2=DEBYE*DEBYE*zb(1)*zb(1)*nb(1)*betab(1) ! Electron Debye wave number [1/cm^2]
      cn=ke2/(2*PI)
      cn=cn*SQRT(betab(1)*mb(1)/(2*PI))/CC
      cei=cei*cn
      END SUBROUTINE bps_rate_el

!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! single ion species for C_{eI, reg}. Used for debugging full bps_cei_reg_mass()
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE bps_cei_reg_ep(nni, zb, betab, mb, y_ep) ! returns \Delta for Cei_R
      IMPLICIT NONE
      INTEGER,                     INTENT(IN)  :: nni    !  Number of ion species
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: zb     !  Charge array
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: betab  !  Temperature array [1/keV]
      REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: mb     !  Mass array [keV]
      REAL,                        INTENT(OUT) :: y_ep
      REAL,    PARAMETER :: DEBYE=4.2539E-5   ! Used for Debye wave number
      REAL,    PARAMETER :: OMEGI=1.32155E+3  ! Used For plasma frequency
      REAL,    DIMENSION(:), ALLOCATABLE :: ob2, kb2

      REAL,    PARAMETER :: AMUKEV=0.931494012E6 ! 1 AMU [keV]
      REAL,    PARAMETER :: PI   =3.141592654    ! pi
      REAL,    PARAMETER :: CC=2.998E10          ! speed of light [cm/s]

      REAL,    PARAMETER :: UPM=0.7745966692E0
      REAL,    PARAMETER :: W13=0.5555555556E0, W2=0.8888888889E0

      REAL    :: xmin, xmax, x, dx, xm
      INTEGER :: nmax, ix
      REAL    :: hi_ep, te, ti, alpha, delta

      ALLOCATE(ob2(1:nni+1),kb2(1:nni+1))
      xmin=0.
      xmax=10.
      nmax=1000
      dx=(xmax-xmin)/nmax
      te=1./betab(1)
      ti=1./betab(2)
      alpha=zb(2)**2*te/ti
      delta=SQRT(betab(1)*mb(1))/SQRT(betab(2)*mb(2))
      y_ep=0
      x=xmin-dx
      DO ix=1,nmax,2
!
         x=x+2.E0*dx
         CALL di2_ep(x,alpha,delta,hi_ep)
         y_ep=y_ep+W2*hi_ep
!
         xm=x-dx*UPM
         CALL di2_ep(xm,alpha,delta,hi_ep)
         y_ep=y_ep+W13*hi_ep
!
         xm=x+dx*UPM
         CALL di2_ep(xm,alpha,delta,hi_ep)
         y_ep=y_ep+W13*hi_ep
      ENDDO
      y_ep=y_ep*dx
      END SUBROUTINE bps_cei_reg_ep

      SUBROUTINE di2_ep(x, alpha, delta, dint2)
      IMPLICIT NONE
      REAL,    INTENT(IN) :: x, alpha, delta
      REAL,    INTENT(OUT):: dint2
      REAL                :: delta1, x2
      REAL                :: fr_ep, fi_ep, fabs_ep, farg_ep
      REAL,    PARAMETER  :: PI   =3.141592654    ! pi
      CALL frfi_ep(x,alpha,delta,fr_ep,fi_ep,fabs_ep,farg_ep)
      dint2=2*(fi_ep*LOG(fabs_ep) + fr_ep*farg_ep)*x
      x2=x*x
      dint2=dint2*EXP(-x2)
      delta1=1-delta*delta
      dint2=dint2/(delta + alpha*EXP(-delta1*x2))
      dint2=dint2*(2./PI)
      END SUBROUTINE di2_ep

      SUBROUTINE frfi_ep(x, alpha, delta, fr, fi, fabs, farg)
      IMPLICIT NONE
      REAL,    INTENT(IN) :: x, alpha, delta
      REAL                :: fr, fi, fabs, farg
      REAL                :: daw, y
      REAL,    PARAMETER  :: SQPI =1.772453851    ! sqrt(pi)
      REAL,    PARAMETER  :: PI   =3.141592654    ! pi
      y=x*delta
      fr=1 - 2*y*daw(y)            ! electrons
      fr=fr + alpha*(1-2*x*daw(x)) ! plus ions
      fi=y*Exp(-y*y)               ! electrons
      fi=fi + alpha*x*EXP(-x*x)    ! plus ions
      fi=fi*SQRT(PI)
      fabs=SQRT(fr*fr + fi*fi)
      farg=ATAN2(fi,fr)
      END SUBROUTINE frfi_ep


*DECK PSI
      FUNCTION PSI (X)
C***BEGIN PROLOGUE  PSI
C***PURPOSE  Compute the Psi (or Digamma) function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7C
C***TYPE      SINGLE PRECISION (PSI-S, DPSI-D, CPSI-C)
C***KEYWORDS  DIGAMMA FUNCTION, FNLIB, PSI FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C PSI(X) calculates the psi (or digamma) function for real argument X.
C PSI(X) is the logarithmic derivative of the gamma function of X.
C
C Series for PSI        on the interval  0.          to  1.00000D+00
C                                        with weighted error   2.03E-17
C                                         log weighted error  16.69
C                               significant figures required  16.39
C                                    decimal places required  17.37
C
C Series for APSI       on the interval  0.          to  2.50000D-01
C                                        with weighted error   5.54E-17
C                                         log weighted error  16.26
C                               significant figures required  14.42
C                                    decimal places required  16.86
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  COT, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900727  Added EXTERNAL statement.  (WRB)
C   920618  Removed space from variable names.  (RWC, WRB)
C***END PROLOGUE  PSI
      DIMENSION PSICS(23), APSICS(16)
      LOGICAL FIRST
      EXTERNAL COT
      SAVE PSICS, APSICS, PI, NTPSI, NTAPSI, XBIG, DXREL, FIRST
      DATA PSICS( 1) /   -.0380570808 35217922E0 /
      DATA PSICS( 2) /    .4914153930 2938713E0 /
      DATA PSICS( 3) /   -.0568157478 21244730E0 /
      DATA PSICS( 4) /    .0083578212 25914313E0 /
      DATA PSICS( 5) /   -.0013332328 57994342E0 /
      DATA PSICS( 6) /    .0002203132 87069308E0 /
      DATA PSICS( 7) /   -.0000370402 38178456E0 /
      DATA PSICS( 8) /    .0000062837 93654854E0 /
      DATA PSICS( 9) /   -.0000010712 63908506E0 /
      DATA PSICS(10) /    .0000001831 28394654E0 /
      DATA PSICS(11) /   -.0000000313 53509361E0 /
      DATA PSICS(12) /    .0000000053 72808776E0 /
      DATA PSICS(13) /   -.0000000009 21168141E0 /
      DATA PSICS(14) /    .0000000001 57981265E0 /
      DATA PSICS(15) /   -.0000000000 27098646E0 /
      DATA PSICS(16) /    .0000000000 04648722E0 /
      DATA PSICS(17) /   -.0000000000 00797527E0 /
      DATA PSICS(18) /    .0000000000 00136827E0 /
      DATA PSICS(19) /   -.0000000000 00023475E0 /
      DATA PSICS(20) /    .0000000000 00004027E0 /
      DATA PSICS(21) /   -.0000000000 00000691E0 /
      DATA PSICS(22) /    .0000000000 00000118E0 /
      DATA PSICS(23) /   -.0000000000 00000020E0 /
      DATA APSICS( 1) /   -.0204749044 678185E0 /
      DATA APSICS( 2) /   -.0101801271 534859E0 /
      DATA APSICS( 3) /    .0000559718 725387E0 /
      DATA APSICS( 4) /   -.0000012917 176570E0 /
      DATA APSICS( 5) /    .0000000572 858606E0 /
      DATA APSICS( 6) /   -.0000000038 213539E0 /
      DATA APSICS( 7) /    .0000000003 397434E0 /
      DATA APSICS( 8) /   -.0000000000 374838E0 /
      DATA APSICS( 9) /    .0000000000 048990E0 /
      DATA APSICS(10) /   -.0000000000 007344E0 /
      DATA APSICS(11) /    .0000000000 001233E0 /
      DATA APSICS(12) /   -.0000000000 000228E0 /
      DATA APSICS(13) /    .0000000000 000045E0 /
      DATA APSICS(14) /   -.0000000000 000009E0 /
      DATA APSICS(15) /    .0000000000 000002E0 /
      DATA APSICS(16) /   -.0000000000 000000E0 /
      DATA PI     / 3.1415926535 8979324E0/
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  PSI
      IF (FIRST) THEN
         NTPSI = INITS (PSICS, 23, 0.1*R1MACH(3))
         NTAPSI = INITS (APSICS, 16, 0.1*R1MACH(3))
C
         XBIG = 1.0/SQRT(R1MACH(3))
         DXREL = SQRT (R1MACH(4))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GE.2.0) GO TO 30
C
C PSI(X) FOR -2. .LT. X .LT. 2.
C
      N = X
      IF (X.LT.0.) N = N - 1
      Y = X - N
      N = N - 1
      PSI = CSEVL (2.*Y-1., PSICS, NTPSI)
      IF (N.EQ.0) RETURN
C
      N = -N
      IF (X .EQ. 0.) CALL XERMSG ('SLATEC', 'PSI', 'X IS 0', 2, 2)
      IF (X .LT. 0. .AND. X+N-2 .EQ. 0.) CALL XERMSG ('SLATEC', 'PSI',
     +   'X IS A NEGATIVE INTEGER', 3, 2)
      IF (X .LT. (-0.5) .AND. ABS((X-AINT(X-0.5))/X) .LT. DXREL)
     +   CALL XERMSG ('SLATEC', 'PSI',
     +   'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER',
     +   1, 1)
C
      DO 20 I=1,N
        PSI = PSI - 1.0/(X+I-1)
 20   CONTINUE
      RETURN
C
C PSI(X) FOR ABS(X) .GE. 2.
C
 30   AUX = 0.
      IF (Y.LT.XBIG) AUX = CSEVL (8./Y**2-1., APSICS, NTAPSI)
      IF (X.LT.0.) PSI = LOG(ABS(X)) - 0.5/X + AUX - PI*COT(PI*X)
      IF (X.GT.0.) PSI = LOG(X) - 0.5/X + AUX
      RETURN
C
      END


C
C**************************  INTERPNEW *********************************
C
C  use the lookup table to interpolate moisture curve values
C  (Newton case)
C
C***********************************************************************
C
      SUBROUTINE INTERPNEW(NLKP,ISTR,MTYPE,PAVG,SSAVG,FIAVG,
     1                     KRLOC,ETALOC,SWLOC,DKRLOC,DETALOC)
C
      IMPLICIT NONE
      INCLUDE 'CATHY.H'
      INTEGER  I
      INTEGER  NLKP,ISTR,MTYPE
      REAL*8   PCAPDIFF,PAVGDIFF,DSWDP,DDSWDP2
      REAL*8   PAVG,SSAVG,FIAVG,KRLOC,ETALOC,SWLOC,DKRLOC,DETALOC
      INCLUDE 'SOILCHAR.H'
C
      IF (PAVG .GT. -1.0D-14) THEN
         KRLOC=1.0D0
         DKRLOC=0.0D0
         SWLOC=1.0D0
         ETALOC=SSAVG
         DETALOC=0.0D0
      ELSE IF (PAVG .LE. PCAP(ISTR,MTYPE,1)) THEN
         PCAPDIFF=PCAP(ISTR,MTYPE,2) - PCAP(ISTR,MTYPE,1)
         KRLOC=KRWC(ISTR,MTYPE,1)
         DKRLOC=(KRWC(ISTR,MTYPE,2) - KRLOC)/PCAPDIFF
         SWLOC=SATC(ISTR,MTYPE,1)
         DSWDP=(SATC(ISTR,MTYPE,2) - SWLOC)/PCAPDIFF
         ETALOC=SSAVG*SWLOC + FIAVG*DSWDP
         DDSWDP2=(SATC(ISTR,MTYPE,3) - 2.0D0*SATC(ISTR,MTYPE,2) + SWLOC)
     1           /((PCAP(ISTR,MTYPE,3) - PCAP(ISTR,MTYPE,2)) * PCAPDIFF)
         DETALOC=SSAVG*DSWDP + FIAVG*DDSWDP2
      ELSE IF (PAVG .GE. PCAP(ISTR,MTYPE,NLKP)) THEN
         PCAPDIFF=PCAP(ISTR,MTYPE,NLKP) - PCAP(ISTR,MTYPE,NLKP-1)
         KRLOC=KRWC(ISTR,MTYPE,NLKP)
         DKRLOC=(KRLOC - KRWC(ISTR,MTYPE,NLKP-1))/PCAPDIFF
         SWLOC=SATC(ISTR,MTYPE,NLKP)
         DSWDP=(SWLOC - SATC(ISTR,MTYPE,NLKP-1))/PCAPDIFF
         ETALOC=SSAVG*SWLOC + FIAVG*DSWDP
         DDSWDP2=(SWLOC - 2.0D0*SATC(ISTR,MTYPE,NLKP-1) +
     1            SATC(ISTR,MTYPE,NLKP-2))
     2           /(PCAPDIFF * (PCAP(ISTR,MTYPE,NLKP-1) -
     3                         PCAP(ISTR,MTYPE,NLKP-2)))
         DETALOC=SSAVG*DSWDP + FIAVG*DDSWDP2
      ELSE
         I=1
         DO WHILE ((PAVG .LT. PCAP(ISTR,MTYPE,I))  .OR.
     1             (PAVG .GE. PCAP(ISTR,MTYPE,I+1)))
            I=I+1
         END DO
         PCAPDIFF=PCAP(ISTR,MTYPE,I+1) - PCAP(ISTR,MTYPE,I)
         PAVGDIFF=PAVG - PCAP(ISTR,MTYPE,I)
         KRLOC=KRWC(ISTR,MTYPE,I) +
     1         (KRWC(ISTR,MTYPE,I+1) - KRWC(ISTR,MTYPE,I))/PCAPDIFF *
     2         PAVGDIFF
         DKRLOC=(KRLOC - KRWC(ISTR,MTYPE,I))/PAVGDIFF
         SWLOC=SATC(ISTR,MTYPE,I) +
     1         (SATC(ISTR,MTYPE,I+1) - SATC(ISTR,MTYPE,I))/PCAPDIFF *
     2         PAVGDIFF
         DSWDP=(SWLOC - SATC(ISTR,MTYPE,I))/PAVGDIFF
         ETALOC=SSAVG*SWLOC + FIAVG*DSWDP
         IF (I .EQ. 1) I=2
         DDSWDP2=(SATC(ISTR,MTYPE,I+1) - 2.0D0*SATC(ISTR,MTYPE,I) +
     1            SATC(ISTR,MTYPE,I-1))
     2           /((PCAP(ISTR,MTYPE,I+1) - PCAP(ISTR,MTYPE,I)) *
     3             (PCAP(ISTR,MTYPE,I) - PCAP(ISTR,MTYPE,I-1)))
         DETALOC=SSAVG*DSWDP + FIAVG*DDSWDP2
      END IF
C
      RETURN
      END


      real*8 function sqdist(x1,y1,z1,x2,y2,z2,ind,MAXROT,rotmat)
c-----------------------------------------------------------------------
c
c    Squared Anisotropic Distance Calculation Given Matrix Indicator
c    ***************************************************************
c
c This routine calculates the anisotropic distance between two points
c  given the coordinates of each point and a definition of the
c  anisotropy.
c
c
c INPUT VARIABLES:
c
c   x1,y1,z1         Coordinates of first point
c   x2,y2,z2         Coordinates of second point
c   ind              The rotation matrix to use
c   MAXROT           The maximum number of rotation matrices dimensioned
c   rotmat           The rotation matrices
c
c
c
c OUTPUT VARIABLES:
c
c   sqdist           The squared distance accounting for the anisotropy
c                      and the rotation of coordinates (if any).
c
c
c NO EXTERNAL REFERENCES
c
c
c-----------------------------------------------------------------------

      implicit integer (i-n)
      implicit double precision (a-h,o-z)

      real*8 rotmat(MAXROT,3,3),cont,dx,dy,dz
c
c Compute component distance vectors and the squared distance:
c
      dx = dble(x1 - x2)
      dy = dble(y1 - y2)
      dz = dble(z1 - z2)
      sqdist = 0.d0
      do i=1,3
            cont   = rotmat(ind,i,1) * dx
     +             + rotmat(ind,i,2) * dy
     +             + rotmat(ind,i,3) * dz
            sqdist = sqdist + cont * cont
      end do
      return
      end


      SUBROUTINE MRQCOF(X,Y,SIG,NDATA,A,MA,LISTA,MFIT,ALPHA,BETA,NALP,
     *CHISQ,FUNCS)
      PARAMETER (MMAX=20)
      DIMENSION X(NDATA),Y(NDATA),SIG(NDATA),ALPHA(NALP,NALP),BETA(MA),
     *    DYDA(MMAX),LISTA(MFIT),A(MA)
      DO 12 J=1,MFIT
        DO 11 K=1,J
          ALPHA(J,K)=0.
11      CONTINUE
        BETA(J)=0.
12    CONTINUE
      CHISQ=0.
      DO 15 I=1,NDATA
        CALL FUNCS(X(I),A,YMOD,DYDA,MA)
        SIG2I=1./(SIG(I)*SIG(I))
        DY=Y(I)-YMOD
        DO 14 J=1,MFIT
          WT=DYDA(LISTA(J))*SIG2I
          DO 13 K=1,J
            ALPHA(J,K)=ALPHA(J,K)+WT*DYDA(LISTA(K))
13        CONTINUE
          BETA(J)=BETA(J)+DY*WT
14      CONTINUE
        CHISQ=CHISQ+DY*DY*SIG2I
15    CONTINUE
      DO 17 J=2,MFIT
        DO 16 K=1,J-1
          ALPHA(K,J)=ALPHA(J,K)
16      CONTINUE
17    CONTINUE
      RETURN
      END


      program N3X3
      real t,co,f,q,d1,d2,n
      complex e1,e2,e3
      parameter(pi=3.1415926)
      common f,d1,d2,q,e1,e2
      data h1,h2,a1,a2/2*0.001,2*0.0001/
      write(*,*) 'Input e1,e2/*.,-*./'
      read(*,*) e1,e2
      open(2,file="N3X3.dat")
      write(2,334)
      write(*,*) 'Input wave length Q'
      read(*,*) q
      write(*,*) 'Input layer thicknesses d1 and d2'
      read(*,*) d1,d2
 55   write(*,*) 'Input angle of incidence F'
      read(*,*)FF
      write(*,*) 'Input experimental data COS and TAN'
      read(*,*)co,t
 56   write(*,*) 'Input approximate values N0,X0'
      read(*,*)n,x
      ff=ff*pi/180
      i=1
 10   continue
      e3=cmplx(n,-x)
      call FZU(z0,u0,e3)
      if(ABS(t-z0).le.a1.and.ABS(co-u0).le.a2) goto 20
!     *****************************************
      e3=cmplx(n+h1,-x)
      call FZU(dz1,du1,e3)
      e3=cmplx(n-h1,-x)
      call FZU(dz2,du2,e3)
      dz=(dz1-dz2)/2./h1
      du=(du1-du2)/2./h2
      e3=cmplx(n,-x-h2)
!     *****************************************
      call FZU(dz1,du1,e3)
      e3=cmplx(n,-x+h2)
      call FZU(dz2,du2,e3)
      xz=(dz1-dz2)/2./h2
      xu=(du1-du2)/2./h2
!     ****Calculation of determinants**********
      det0=dz*xu-xz*du
      det1=(t-z0)*xu-(co-u0)*xz
      det2=dz*(co-u0)-(t-z0)*du
      dd1=det1/det0
      dd2=det2/det0
!     *****************************************
      n=n+dd1
      n=x+dd2
!     *****************************************
      if(n.lt.0) goto 25
      if(x.lt.0) goto 25
      i=i+1
      if(i.eq.20) goto 25
      goto 10
 25   write(*,*) 'No solution !!! n3=',n,'x3=',x,'i=',i
!     **********Deriving of results***********
 20   continue
      write(*,333)
      write(2,100)ff,co,t,n,x,i
      write(*,100)ff,co,t,n,x,i
 333  format(3x,'F',10x,'COS(^)',8x,'TAN(ksi)',6x,'N',10x,'X',6x,'i')
 334  format(3x,'F',12x,'COS(^)',11x,'TAN(ksi)',9x,'N2',12x,'X2',8x,'i')
 100  format(1x,f5.2,2(2x,f12.5),2(2x,f9.4),2x,i3)
      write(*,*) "Continue? 1, new approxim. values N0 and X0 2, stop 0"
      read(*,*)j
      if(j.eq.2) goto 56
      if(j.eq.1) goto 55
      stop
      end program N3X3
!     ***********Calculation of ellipsometric parameters***********
            SUBROUTINE FZU(z,u,e3)
      real f,q,d1,d2,ksi,delta
      complex dl1,dl2,e1,e2,e3,cf1,cf2,cf3
      complex r01p,r12p,r23p,r01s,r12s,r23s
      complex r,rs,rp,ex1,ex2,ex3
      parameter (pi=3.1415926)
      common f,d1,d2,q,e1,e2
      cf1=CSQRT(1-sin(f)**2/(e1*e1))
      cf2=CSQRT(1-sin(f)**2/(e2*e2))
      cf3=CSQRT(1-sin(f)**2/(e3*e3))
      r01p=(e1*cos(f)-cf1)/(e1*cos(f)+cf1)
      r12p=(e2*cf1-e1*cf2)/(e2*cf1+e1*cf2)
      r23p=(e3*cf2-e2*cf3)/(e3*cf2+e2*cf3)
      r01s=(cos(f)-e1*cf1)/(cos(f)+e1*cf1)
      r12s=(e1*cf1-e2*cf2)/(e1*cf1+e2*cf2)
      r23s=(e2*cf2-e3*cf3)/(e2*cf3+e3*cf3)
      dl1=2*pi/q*d1*CSQRT(e1*e1-sin(f)**2)
      ex1=CEXP(2*(0.,-1.)*dl1)
      dl2=2*pi/q*d2*CSQRT(e2*e2-sin(f)**2)
      ex2=CEXP(2*(0.,-1.)*dl2)
      ex3=CEXP(2*(0.,-1.)*(dl1+dl2))
!     ---------------------------------------------------------------
      rp=r01p+r12p*ex1+r01p*r12p*r23p*ex2+r23p*ex3
      rp=rp/(1+r01p*r12p*ex1+r12p*r23p*ex2+r01p*r23p*ex3)
      rs=r01s+r12s*ex1+r01s*r12s*r23s*ex2+r23s*ex3
      rs=rs/(1+r01s*r12s*ex1+r12s*r23s*ex2+r01s*r23s*ex3)
      r=rp/rs
      z=CABS(r)
      u=REAL(r)/z
      ksi=ATAN(z)*180/pi
      delta=ACOS(u)*180/pi
      end SUBROUTINE FZU


      MODULE m_radsra
      use m_juDFT
c*********************************************************************
c     calculates the scalar relativistic wavefuction for energy e and
c     angular momentum l for the potential vr by integrating outward.
c     the large (small) component is returned in p (q). for non-
c     relativistic case, set cin=0.        based on code by m. weinert
c*********************************************************************
      CONTAINS
      SUBROUTINE radsra(
     >                  e,l,vr,r0,h,jri,c,
     <                  us,dus,nodes,p,q)

      USE m_intgr, ONLY : intgr0
      IMPLICIT NONE
C     ..
C     .. Scalar Arguments ..
      INTEGER, INTENT (IN) :: l
      INTEGER, INTENT (IN) :: jri
      INTEGER, INTENT (OUT):: nodes
      REAL,    INTENT (IN) :: e,h,r0
      REAL,    INTENT (IN) :: c
      REAL,    INTENT (OUT):: dus,us
C     ..
C     .. Array Arguments ..
      REAL,    INTENT (IN) :: vr(:)
      REAL,    INTENT (OUT):: p(:),q(:)
C     ..
C     .. Local Scalars ..
      REAL dr,drh,erp,erq,fl1,p0,p1,p1p,q0,q1,q1p,r,rh,rh2,rm,rve,s,
     +     sk1,sk2,sk3,sk4,sl1,sl2,sl3,sl4,t,yn,zn,cin,cin2
      INTEGER i,it
C     ..
C     .. Local Arrays ..
      REAL pp(jri),qp(jri)
C     ..
C     .. Data statements ..
      REAL,PARAMETER  :: eps=1.e-06
C     ..
      cin = 1.0/c
      cin2 = cin*cin

      IF (jri>SIZE(vr).OR.jri>SIZE(p))  CALL juDFT_error
     +    ("BUG: data dimension in radsra too small",calledby ="radsra")

c--->    set up initial conditions
      fl1 = l* (l+1)
      s = sqrt(fl1+1-cin2*vr(1)*vr(1)) - 1.
      rm = 2.*r0 + cin2* (r0*e-vr(1))
      p(1) = r0** (l+1)
      q(1) = s*p(1)/rm
      pp(1) = rm*q(1) + p(1)
      qp(1) = (fl1/rm+vr(1)-r0*e)*p(1) - q(1)
c--->    use 4th order runge-kutta to get first few mesh points
      dr = exp(h)
      drh = sqrt(dr)
      r = r0
      DO i = 1,5
         rh2 = drh*r
         rh = dr*r
         sk1 = h*pp(i)
         sl1 = h*qp(i)
         rve = 0.5* (vr(i)+vr(i+1)) - rh2*e
         rm = 2.*rh2 - cin2*rve
         yn = p(i) + 0.5*sk1
         zn = q(i) + 0.5*sl1
         sk2 = h* (rm*zn+yn)
         sl2 = h* ((fl1/rm+rve)*yn-zn)
         yn = p(i) + 0.5*sk2
         zn = q(i) + 0.5*sl2
         sk3 = h* (rm*zn+yn)
         sl3 = h* ((fl1/rm+rve)*yn-zn)
         rve = vr(i+1) - rh*e
         rm = 2.*rh - cin2*rve
         yn = p(i) + sk3
         zn = q(i) + sl3
         sk4 = h* (rm*zn+yn)
         sl4 = h* ((fl1/rm+rve)*yn-zn)
         p(i+1) = p(i) + (sk1+2.*sk2+2.*sk3+sk4)/6.
         q(i+1) = q(i) + (sl1+2.*sl2+2.*sl3+sl4)/6.
         pp(i+1) = rm*q(i+1) + p(i+1)
         qp(i+1) = (fl1/rm+rve)*p(i+1) - q(i+1)
         r = rh
      ENDDO
      nodes = 0
c--->    adams-bashforth-moulton predictor-corrector
      predictor: DO i = 6,jri - 1
         r = r*dr
c--->    predictor
         p0 = p(i) + h* (4277.*pp(i)-7923.*pp(i-1)+9982.*pp(i-2)-
     +        7298.*pp(i-3)+2877.*pp(i-4)-475.*pp(i-5))/1440.
         q0 = q(i) + h* (4277.*qp(i)-7923.*qp(i-1)+9982.*qp(i-2)-
     +        7298.*qp(i-3)+2877.*qp(i-4)-475.*qp(i-5))/1440.
c--->    evaluate derivatives at next point
         rve = vr(i+1) - r*e
         rm = 2.*r - cin2*rve
         p1p = rm*q0 + p0
         q1p = (fl1/rm+rve)*p0 - q0
c--->    corrector
         corrector: DO it = 1,5
            p1 = p(i) + h* (475.*p1p+1427.*pp(i)-798.*pp(i-1)+
     +           482.*pp(i-2)-173.*pp(i-3)+27.*pp(i-4))/1440.
            q1 = q(i) + h* (475.*q1p+1427.*qp(i)-798.*qp(i-1)+
     +           482.*qp(i-2)-173.*qp(i-3)+27.*qp(i-4))/1440.
c--->       final evaluation
            p1p = rm*q1 + p1
            q1p = (fl1/rm+rve)*p1 - q1
c--->       test quality of corrector and iterate if necessary
            erp = abs(p1-p0)/ (abs(p1)+abs(h*p1p))
            erq = abs(q1-q0)/ (abs(q1)+abs(h*p1p))
            IF (erp.LT.eps .AND. erq.LT.eps) EXIT corrector
            p0 = p1
            q0 = q1
         ENDDO corrector
c--->    store values
         p(i+1) = p1
         q(i+1) = q1
         pp(i+1) = p1p
         qp(i+1) = q1p
         nodes = nodes + 0.501*abs(sign(1.0,p(i+1))-sign(1.0,p(i)))
      ENDDO predictor

c--->    normalize function
      DO i = 1,jri
         q(i) = cin*q(i)
      ENDDO
      DO i = 1,jri
         qp(i) = p(i)*p(i) + q(i)*q(i)
      ENDDO
      CALL intgr0(qp,r0,h,jri,t)
      t = 1.0/sqrt(t)
      us = t*p(jri)/r
      dus = t* (pp(jri)-p(jri))/ (r*r)
      DO i = 1,jri
         p(i) = t*p(i)
         q(i) = t*q(i)
      ENDDO

      END SUBROUTINE radsra
      END MODULE m_radsra