       double precision function ppchi2(p, v, g, ifault)
c
c        Algorithm AS 91   Appl. Statist. (1975) Vol.24, P.35
c
c        To evaluate the percentage points of the chi-squared
c        probability distribution function.
c
c        p must lie in the range 0.000002 to 0.999998,
c        v must be positive,
c        g must be supplied and should be equal to
c          ln(gamma(v/2.0))
c
c     Incorporates the suggested changes in AS R85 (vol.40(1),
c     pp.233-5, 1991) which should eliminate the need for the limited
c     range for p above, though these limits have not been removed
c     from the routine.
c     If IFAULT = 4 is returned, the result is probably as accurate as
c     the machine will allow.
c
c     Auxiliary routines required: PPND = AS 111 (or AS 241) and
c     GAMMAD = AS 239.
c
      integer maxit
      parameter (maxit = 20)
      double precision p, v, g, gammad, ppnd, aa, e, zero, half, one,
     $   two, three, six, pmin, pmax, c1, c2, c3, c4, c5, c6, c7,
     $   c8, c9, c10, c11, c12, c13, c14, c15, c16, c17, c18, c19,
     $   c20, c21, c22, c23, c24, c25, c26, c27, c28, c29, c30,
     $   c31, c32, c33, c34, c35, c36, c37, c38, a, b, c, ch, p1, p2,
     $   q, s1, s2, s3, s4, s5, s6, t, x, xx
c
      data             aa,       e,    pmin,     pmax
     $     /0.6931471806d0, 0.5d-6, 0.000002d0, 0.999998d0/
      data zero, half, one, two, three, six
     $     /0.0d0, 0.5d0, 1.0d0, 2.0d0, 3.0d0, 6.0d0/
      data        c1,     c2,     c3,     c4,     c5,     c6,
     $            c7,     c8,     c9,    c10,    c11,    c12,
     $           c13,    c14,    c15,    c16,    c17,    c18,
     $           c19,    c20,    c21,    c22,    c23,    c24,
     $           c25,    c26,    c27,    c28,    c29,    c30,
     $           c31,    c32,    c33,    c34,    c35,    c36,
     $           c37,    c38/
     $         0.01d0, 0.222222d0, 0.32d0, 0.4d0, 1.24d0, 2.2d0,
     $         4.67d0, 6.66d0, 6.73d0, 13.32d0, 60.0d0, 70.0d0,
     $         84.0d0, 105.0d0, 120.0d0, 127.0d0, 140.0d0, 175.0d0,
     $        210.0d0, 252.0d0, 264.0d0, 294.0d0, 346.0d0, 420.0d0,
     $        462.0d0, 606.0d0, 672.0d0, 707.0d0, 735.0d0, 889.0d0,
     $        932.0d0, 966.0d0, 1141.0d0, 1182.0d0, 1278.0d0, 1740.0d0,
     $       2520.0d0, 5040.0d0/
c
c        test arguments and initialise
c
      ppchi2 = -one
      ifault = 1
      if (p .lt. pmin .or. p .gt. pmax) return
      ifault = 2
      if (v .le. zero) return
      ifault = 0
      xx = half * v
      c = xx - one
c
c        starting approximation for small chi-squared
c
      if (v .ge. -c5 * log(p)) goto 1
      ch = (p * xx * exp(g + xx * aa)) ** (one/xx)
      if (ch .lt. e) goto 6
      goto 4
c
c        starting approximation for v less than or equal to 0.32
c
    1 if (v .gt. c3) goto 3
      ch = c4
      a = log(one-p)
    2 q = ch
      p1 = one + ch * (c7+ch)
      p2 = ch * (c9 + ch * (c8 + ch))
      t = -half + (c7 + two * ch) / p1 - (c9 + ch * (c10 +
     $  three * ch)) / p2
      ch = ch - (one - exp(a + g + half * ch + c * aa) *
     $  p2 / p1) / t
      if (abs(q / ch - one) .gt. c1) goto 2
      goto 4
c
c        call to algorithm AS 111 - note that p has been tested above.
c	 AS 241 could be used as an alternative.
c
    3 x = ppnd(p, if1)
c
c        starting approximation using Wilson and Hilferty estimate
c
      p1 = c2 / v
      ch = v * (x * sqrt(p1) + one - p1) ** 3
c
c        starting approximation for p tending to 1
c
      if (ch .gt. c6 * v + six)
     $   ch = -two * (log(one-p) - c * log(half * ch) + g)
c
c
c        call to algorithm AS 239 and calculation of seven term
c        Taylor series
c
    4 do 7 i = 1, maxit
      q = ch
      p1 = half * ch
      p2 = p - gammad(p1, xx, if1)
      if (if1 .eq. 0) goto 5
c
      ifault = 3
      return
    5 t = p2 * exp(xx * aa + g + p1 - c * log(ch))
      b = t / ch
      a = half * t - b * c
      s1 = (c19 + a * (c17 + a * (c14 + a * (c13 + a * (c12 +
     $  c11 * a))))) / c24
      s2 = (c24 + a * (c29 + a * (c32 + a * (c33 + c35 *
     $  a)))) / c37
      s3 = (c19 + a * (c25 + a * (c28 + c31 * a))) / c37
      s4 = (c20 + a * (c27 + c34 * a) + c * (c22 + a * (c30 +
     $  c36 * a))) / c38
      s5 = (c13 + c21 * a + c * (c18 + c26 * a)) / c37
      s6 = (c15 + c * (c23 + c16 * c)) / c38
      ch = ch + t * (one + half * t * s1 - b * c * (s1 - b *
     $  (s2 - b * (s3 - b * (s4 - b * (s5 - b * s6))))))
      if (abs(q / ch - one) .gt. e) goto 6
    7 continue
      ifault = 4
c
    6 ppchi2 = ch
      return
      end


!> \file fftw_tools.f90
!! @brief general tools for Fourier transform
!! @author Innocent Souopgui
!! \details
!!
!<
MODULE fftw_tools
  USE, intrinsic :: iso_c_binding
  USE general_constant
  USE debug_tools
IMPLICIT NONE
  include 'fftw3.f03'
  INTEGER, PARAMETER :: FFTW_REAL = C_DOUBLE
  INTEGER, PARAMETER :: FFTW_CPLX = C_DOUBLE_COMPLEX
  INTERFACE init_fftw_engine
    MODULE PROCEDURE init_fftw_1d_engine!> init 1D engine
    !MODULE PROCEDURE init_fftw_2d_engine!> init 2D engine
    !MODULE PROCEDURE init_fftw_3d_engine!> init 3D engine
  END INTERFACE

  INTERFACE fftw_trans
    MODULE PROCEDURE fftw_1d_r2r!> run 1D direct transform
    !MODULE PROCEDURE fftw_2d_r2r!> run 2D direct transform
    !MODULE PROCEDURE fftw_3d_r2r!> run 3D direct transform
  END INTERFACE

  INTERFACE ifftw_trans
    MODULE PROCEDURE ifftw_1d_r2r!> run 1D inverse transform
    !MODULE PROCEDURE ifftw_2d_r2r!> run 2D inverse transform
    !MODULE PROCEDURE ifftw_3d_r2r!> run 3D inverse transform
  END INTERFACE

  !>@brief engine for 1D fftw transform
  TYPE, PRIVATE :: fftw_1d_engine
    INTEGER :: i_size = -1 !> size of the transform supported by the engine
    INTEGER(C_INT) :: i_kind
    INTEGER(C_INT) :: i_flags
    TYPE(C_PTR) :: t_plan !> fftw plan
    REAL(FFTW_REAL), DIMENSION(:), POINTER :: ra_in =>NULL()!>  real input vector for fftw transform
    REAL(FFTW_REAL), DIMENSION(:), POINTER :: ra_out=>NULL()!> real output vector for fftw transform
    !> complex input vector for fftw transform
    !<
    COMPLEX(FFTW_CPLX), DIMENSION(:), POINTER :: ca_in =>NULL()
    !> complex output vector for fftw transform
    !<
    COMPLEX(FFTW_CPLX), DIMENSION(:), POINTER :: ca_out=>NULL()
  END TYPE fftw_1d_engine

  TYPE(fftw_1d_engine), PRIVATE, SAVE :: &
    tm_r2r_1d_feng,& !> forward engine for r2r transform (R2HC)
    tm_r2r_1d_beng   !> backward engine for r2r transform (HC2R)
CONTAINS

  !>@brief Initializes environment for fftw transform
  !!@details This routine does nothing. Only the associated routine finalize_fftw is usefull. For conformance, it should be used so that the use of finalize make logical sense
  !<
  SUBROUTINE init_fftw()
  END SUBROUTINE init_fftw

  !>@brief Terminates the fftw environment
  !!@details This routine clean the environment: destroy plans and free dynamically allocated spaces for fftw transform
  !<
  SUBROUTINE finalize_fftw()
    !reset engines for 1D fftw transform
    CALL reset_fftw_1d_engine(tm_r2r_1d_feng)
    CALL reset_fftw_1d_engine(tm_r2r_1d_beng)
  END SUBROUTINE finalize_fftw

  !>@brief initialises engine for 1D fftw transform
  !!@param [in,out] td_eng Engine for fftw transform
  !!@param [in] id_size size of the transform
  !!@param [in] id_kind king of the transform
  !!@param [in] id_flags flags for fftw plan
  !<
  SUBROUTINE init_fftw_1d_engine(td_eng, id_size, id_kind, id_flags)
    TYPE(fftw_1d_engine), INTENT(INOUT) :: td_eng
    INTEGER, INTENT(IN) :: id_size
    INTEGER(C_INT), INTENT(IN) :: id_kind
    INTEGER(C_INT), INTENT(IN), OPTIONAL :: id_flags
    !local variables
    INTEGER(C_INT)::il_flags

    IF(PRESENT(id_flags) )THEN
      il_flags = id_flags
    ELSE
      il_flags = FFTW_ESTIMATE
    END IF

    CALL reset_fftw_1d_engine(td_eng)!FFTW_HC2R
    !memory allocation
    SELECT CASE(id_kind)
      CASE (FFTW_R2HC, FFTW_HC2R)
        ALLOCATE( td_eng%ra_in(id_size), td_eng%ra_out(id_size) )
      CASE DEFAULT
        CALL stop_progam(id_kind, 'In init_fftw_1d_engine; unknown fftw kind: ')
    END SELECT
    !creating plan
    SELECT CASE(id_kind)
      CASE (FFTW_R2HC)
        td_eng%t_plan  = fftw_plan_r2r_1d(id_size, td_eng%ra_in , td_eng%ra_out, id_kind, il_flags)
      CASE (FFTW_HC2R)
        td_eng%t_plan  = fftw_plan_r2r_1d(id_size, td_eng%ra_in , td_eng%ra_out, id_kind, il_flags)
      CASE DEFAULT
        CALL stop_progam(id_kind, 'In init_fftw_1d_engine; unknown fftw kind: ')
    END SELECT
    td_eng%i_size = id_size
    td_eng%i_kind = id_kind
    td_eng%i_flags= il_flags
  END SUBROUTINE init_fftw_1d_engine

  !>@brief reset a 1D fftw transform engine
  SUBROUTINE reset_fftw_1d_engine(td_eng)
    TYPE(fftw_1d_engine), INTENT(INOUT) :: td_eng
    IF(td_eng%i_size > 0)THEN
      SELECT CASE(td_eng%i_kind)
        CASE (FFTW_R2HC, FFTW_HC2R)
          CALL fftw_destroy_plan(td_eng%t_plan)
          DEALLOCATE( td_eng%ra_in, td_eng%ra_out )
        CASE DEFAULT
          CALL stop_progam(td_eng%i_kind, 'In reset_fftw_1d_engine; unknown fftw kind: ')
      END SELECT
      td_eng%i_size = -1
      td_eng%i_kind = -999
      td_eng%i_flags= -999
    END IF
  END SUBROUTINE reset_fftw_1d_engine

  !>@brief fftw direct r2r 1D transform
  !! @param [in] rda_signal signal to be transform
  !! @param [out] rda_fft_coef Fourier coefficient of the signal
  !<
  SUBROUTINE fftw_1d_r2r(rda_signal, rda_fft_coef)
    REAL(FFTW_REAL), DIMENSION(:), INTENT(IN)  :: rda_signal
    REAL(FFTW_REAL), DIMENSION(:), INTENT(OUT) :: rda_fft_coef
    !local variables
    INTEGER :: il_size

    il_size = SIZE(rda_signal)
    IF(tm_r2r_1d_feng%i_size /= il_size) THEN
      CALL init_fftw_1d_engine(tm_r2r_1d_feng, il_size, FFTW_R2HC)
    END IF
    tm_r2r_1d_feng%ra_in = rda_signal
    CALL fftw_execute_r2r(tm_r2r_1d_feng%t_plan, tm_r2r_1d_feng%ra_in, tm_r2r_1d_feng%ra_out)
    rda_fft_coef = tm_r2r_1d_feng%ra_out/SQRT(tm_r2r_1d_feng%i_size*1.0_cp)
  END SUBROUTINE fftw_1d_r2r

  !>@brief fftw inverse r2r 1D transform
  !! @param [in] rda_fft_coef Fourier coefficient of the signal
  !! @param [out] rda_signal computed signal
  !<
  SUBROUTINE ifftw_1d_r2r(rda_fft_coef, rda_signal)
    REAL(FFTW_REAL), DIMENSION(:), INTENT(IN) :: rda_fft_coef
    REAL(FFTW_REAL), DIMENSION(:), INTENT(OUT):: rda_signal
    !local variables
    INTEGER :: il_size

    il_size = SIZE(rda_signal)
    IF(tm_r2r_1d_beng%i_size /= il_size) THEN
      CALL init_fftw_1d_engine(tm_r2r_1d_beng, il_size, FFTW_HC2R)
    END IF
    tm_r2r_1d_beng%ra_in = rda_fft_coef
    CALL fftw_execute_r2r(tm_r2r_1d_beng%t_plan, tm_r2r_1d_beng%ra_in, tm_r2r_1d_beng%ra_out)
    rda_signal = tm_r2r_1d_beng%ra_out/SQRT(tm_r2r_1d_beng%i_size*1.0_cp)
  END SUBROUTINE ifftw_1d_r2r

END MODULE fftw_tools


module rkf45_module

    use rkf45_kinds, only: rk
    implicit none
    private

    public :: rkf45, rk

    abstract interface

        !> `fcn` evaluates the derivative for the ODE.
        subroutine fcn(t, y, yp)
            import rk
            real(rk), intent(in) :: t
            real(rk), intent(in) :: y(:)
            real(rk), intent(out) :: yp(:)
        end subroutine fcn

    end interface

contains

    !> rkf45 is primarily designed to solve non-stiff and mildly stiff
    !> differential equations when derivative evaluations are inexpensive.
    !> rkf45 should generally not be used when the user is demanding
    !> high accuracy.
    subroutine rkf45(f, neqn, y, t, tout, relerr, abserr, iflag, work, iwork)

        !     fehlberg fourth-fifth order runge-kutta method

        !     written by h.a.watts and l.f.shampine
        !                   sandia laboratories
        !                  albuquerque,new mexico

        ! abstract

        !    subroutine  rkf45  integrates a system of neqn first order
        !    ordinary differential equations of the form
        !             dy(i)/dt = f(t,y(1),y(2),...,y(neqn))
        !              where the y(i) are given at t .
        !    typically the subroutine is used to integrate from t to tout but it
        !    can be used as a one-step integrator to advance the solution a
        !    single step in the direction of tout.  on return the parameters in
        !    the call list are set for continuing the integration. the user has
        !    only to call rkf45 again (and perhaps define a new value for tout).
        !    actually, rkf45 is an interfacing routine which calls subroutine
        !    rkfs for the solution.  rkfs in turn calls subroutine  fehl which
        !    computes an approximate solution over one step.

        !    rkf45  uses the runge-kutta-fehlberg (4,5)  method described
        !    in the reference
        !    e.fehlberg , low-order classical runge-kutta formulas with stepsize
        !                 control , nasa tr r-315

        !    the performance of rkf45 is illustrated in the reference
        !    l.f.shampine,h.a.watts,s.davenport, solving non-stiff ordinary
        !                 differential equations-the state of the art ,
        !                 sandia laboratories report sand75-0182 ,
        !                 to appear in siam review.

        !    the parameters represent-
        !      f -- subroutine f(t,y,yp) to evaluate derivatives yp(i)=dy(i)/dt
        !      neqn -- number of equations to be integrated
        !      y(*) -- solution vector at t
        !      t -- independent variable
        !      tout -- output point at which solution is desired
        !      relerr,abserr -- relative and absolute error tolerances for local
        !            error test. at each step the code requires that
        !                 abs(local error) .le. relerr*abs(y) + abserr
        !            for each component of the local error and solution vectors
        !      iflag -- indicator for status of integration
        !      work(*) -- array to hold information internal to rkf45 which is
        !            necessary for subsequent calls. must be dimensioned
        !            at least  3+6*neqn
        !      iwork(*) -- integer array used to hold information internal to
        !            rkf45 which is necessary for subsequent calls. must be
        !            dimensioned at least  5

        !  first call to rkf45

        !    the user must provide storage in his calling program for the arrays
        !    in the call list  -      y(neqn) , work(3+6*neqn) , iwork(5)  ,
        !    declare f in an external statement, supply subroutine f(t,y,yp) and
        !    initialize the following parameters-

        !      neqn -- number of equations to be integrated.  (neqn .ge. 1)
        !      y(*) -- vector of initial conditions
        !      t -- starting point of integration , must be a variable
        !      tout -- output point at which solution is desired.
        !            t=tout is allowed on the first call only, in which case
        !            rkf45 returns with iflag=2 if continuation is possible.
        !      relerr,abserr -- relative and absolute local error tolerances
        !            which must be non-negative. relerr must be a variable while
        !            abserr may be a constant. the code should normally not be
        !            used with relative error control smaller than about 1.e-8 .
        !            to avoid limiting precision difficulties the code requires
        !            relerr to be larger than an internally computed relative
        !            error parameter which is machine dependent. in particular,
        !            pure absolute error is not permitted. if a smaller than
        !            allowable value of relerr is attempted, rkf45 increases
        !            relerr appropriately and returns control to the user before
        !            continuing the integration.
        !      iflag -- +1,-1  indicator to initialize the code for each new
        !            problem. normal input is +1. the user should set iflag=-1
        !            only when one-step integrator control is essential. in this
        !            case, rkf45 attempts to advance the solution a single step
        !            in the direction of tout each time it is called. since this
        !            mode of operation results in extra computing overhead, it
        !            should be avoided unless needed.

        !  output from rkf45

        !      y(*) -- solution at t
        !      t -- last point reached in integration.
        !      iflag = 2 -- integration reached tout. indicates successful retur
        !                   and is the normal mode for continuing integration.
        !            =-2 -- a single successful step in the direction of tout
        !                   has been taken. normal mode for continuing
        !                   integration one step at a time.
        !            = 3 -- integration was not completed because relative error
        !                   tolerance was too small. relerr has been increased
        !                   appropriately for continuing.
        !            = 4 -- integration was not completed because more than
        !                   3000 derivative evaluations were needed. this
        !                   is approximately 500 steps.
        !            = 5 -- integration was not completed because solution
        !                   vanished making a pure relative error test
        !                   impossible. must use non-zero abserr to continue.
        !                   using the one-step integration mode for one step
        !                   is a good way to proceed.
        !            = 6 -- integration was not completed because requested
        !                   accuracy could not be achieved using smallest
        !                   allowable stepsize. user must increase the error
        !                   tolerance before continued integration can be
        !                   attempted.
        !            = 7 -- it is likely that rkf45 is inefficient for solving
        !                   this problem. too much output is restricting the
        !                   natural stepsize choice. use the one-step integrator
        !                   mode.
        !            = 8 -- invalid input parameters
        !                   this indicator occurs if any of the following is
        !                   satisfied -   neqn .le. 0
        !                                 t=tout  and  iflag .ne. +1 or -1
        !                                 relerr or abserr .lt. 0.
        !                                 iflag .eq. 0  or  .lt. -2  or  .gt. 8
        !      work(*),iwork(*) -- information which is usually of no interest
        !                   to the user but necessary for subsequent calls.
        !                   work(1),...,work(neqn) contain the first derivatives
        !                   of the solution vector y at t. work(neqn+1) contains
        !                   the stepsize h to be attempted on the next step.
        !                   iwork(1) contains the derivative evaluation counter.

        !  subsequent calls to rkf45

        !    subroutine rkf45 returns with all information needed to continue
        !    the integration. if the integration reached tout, the user need onl
        !    define a new tout and call rkf45 again. in the one-step integrator
        !    mode (iflag=-2) the user must keep in mind that each step taken is
        !    in the direction of the current tout. upon reaching tout (indicated
        !    by changing iflag to 2),the user must then define a new tout and
        !    reset iflag to -2 to continue in the one-step integrator mode.

        !    if the integration was not completed but the user still wants to
        !    continue (iflag=3,4 cases), he just calls rkf45 again. with iflag=3
        !    the relerr parameter has been adjusted appropriately for continuing
        !    the integration. in the case of iflag=4 the function counter will
        !    be reset to 0 and another 3000 function evaluations are allowed.

        !    however,in the case iflag=5, the user must first alter the error
        !    criterion to use a positive value of abserr before integration can
        !    proceed. if he does not,execution is terminated.

        !    also,in the case iflag=6, it is necessary for the user to reset
        !    iflag to 2 (or -2 when the one-step integration mode is being used)
        !    as well as increasing either abserr,relerr or both before the
        !    integration can be continued. if this is not done, execution will
        !    be terminated. the occurrence of iflag=6 indicates a trouble spot
        !    (solution is changing rapidly,singularity may be present) and it
        !    often is inadvisable to continue.

        !    if iflag=7 is encountered, the user should use the one-step
        !    integration mode with the stepsize determined by the code or
        !    consider switching to the adams codes de/step,intrp. if the user
        !    insists upon continuing the integration with rkf45, he must reset
        !    iflag to 2 before calling rkf45 again. otherwise,execution will be
        !    terminated.

        !    if iflag=8 is obtained, integration can not be continued unless
        !    the invalid input parameters are corrected.

        !    it should be noted that the arrays work,iwork contain information
        !    required for subsequent integration. accordingly, work and iwork
        !    should not be altered.

        integer, intent(in) :: neqn
        real(rk), intent(inout) :: y(neqn)
        real(rk), intent(inout) :: t
        real(rk), intent(in) :: tout
        integer, intent(inout) :: iflag, iwork(5)
        real(rk), intent(inout) :: relerr, work(*)
        real(rk), intent(in) :: abserr

        procedure(fcn) :: f

        integer :: k1, k2, k3, k4, k5, k6, k1m

        !     compute indices for the splitting of the work array

        k1m = neqn + 1
        k1 = k1m + 1
        k2 = k1 + neqn
        k3 = k2 + neqn
        k4 = k3 + neqn
        k5 = k4 + neqn
        k6 = k5 + neqn

        !     this interfacing routine merely relieves the user of a long
        !     calling list via the splitting apart of two working storage
        !     arrays. if this is not compatible with the users compiler,
        !     he must use rkfs directly.

        call rkfs(f, neqn, y, t, tout, relerr, abserr, iflag, &
                  work(1), work(k1m), work(k1), work(k2), work(k3), work(k4), work(k5), work(k6), work(k6 + 1), &
                  iwork(1), iwork(2), iwork(3), iwork(4), iwork(5))

        return
    end subroutine rkf45

    !> rkfs integrates a system of first order ordinary differential
    !> equations as described in the comments for rkf45 .
    subroutine rkfs(f, neqn, y, t, tout, relerr, abserr, iflag, &
                    yp, h, f1, f2, f3, f4, f5, savre, savae, &
                    nfe, kop, init, jflag, kflag)

        !     rkfs integrates a system of first order ordinary differential
        !     equations as described in the comments for rkf45 .
        !     the arrays yp,f1,f2,f3,f4,and f5 (of dimension at least neqn) and
        !     the variables h,savre,savae,nfe,kop,init,jflag,and kflag are used
        !     internally by the code and appear in the call list to eliminate
        !     local retention of variables between calls. accordingly, they
        !     should not be altered. items of possible interest are
        !         yp - derivative of solution vector at t
        !         h  - an appropriate stepsize to be used for the next step
        !         nfe- counter on the number of derivative function evaluations

        logical :: hfaild, output

        integer, intent(in) :: neqn
        real(rk), intent(inout) :: y(neqn)
        real(rk), intent(inout) :: t
        real(rk), intent(in) :: tout
        integer, intent(inout) :: iflag
        real(rk), intent(inout) :: relerr

        integer :: nfe, kop, init, jflag, kflag
        real(rk) :: abserr, h, yp(neqn), f1(neqn), f2(neqn), f3(neqn), f4(neqn), f5(neqn), savre, savae

        procedure(fcn) :: f

        real(rk) a, ae, dt, ee, eeoet, esttol, et, hmin, remin, rer, s, scale, tol, toln, twoeps, u26, ypk

        integer :: k, maxnfe, mflag

        !  remin is the minimum acceptable value of relerr.  attempts
        !  to obtain higher accuracy with this subroutine are usually
        !  very expensive and often unsuccessful.

        data remin/1.e-12_rk/

        !     the expense is controlled by restricting the number
        !     of function evaluations to be approximately maxnfe.
        !     as set, this corresponds to about 500 steps.

        data maxnfe/3000/

        !   here two constants emboding the machine epsilon is present
        !   twoesp is set to twice the machine epsilon while u26 is set
        !   to 26 times the machine epsilon

        data twoeps, u26/4.4e-16, 5.72e-15/

        !> Check input parameters
        if (neqn < 1 .or. relerr < 0.0_rk .or. abserr < 0.0_rk) goto 10
        mflag = abs(iflag)
        if ((mflag >= 1) .and. (mflag <= 8)) goto 20

        !     invalid input
10      iflag = 8
        return

        !     is this the first call
20      if (mflag == 1) goto 50

        !     check continuation possibilities

        if ((abs(t - tout) <= twoeps) .and. (kflag /= 3)) goto 10
        if (mflag /= 2) goto 25

        !     iflag = +2 or -2
        if (kflag == 3) goto 45
        if (init == 0) goto 45
        if (kflag == 4) goto 40
        if ((kflag == 5) .and. (abserr == 0.0_rk)) goto 30
        if ((kflag == 6) .and. (relerr <= savre) .and. (abserr <= savae)) goto 30
        goto 50

        !     iflag = 3,4,5,6,7 or 8
25      if (iflag == 3) goto 45
        if (iflag == 4) goto 40
        if ((iflag == 5) .and. (abserr > 0.0_rk)) goto 45

        !     integration cannot be continued since user did not respond to
        !     the instructions pertaining to iflag=5,6,7 or 8
30      stop

        !     reset function evaluation counter
40      nfe = 0
        if (mflag == 2) goto 50

        !     reset flag value from previous call
45      iflag = jflag
        if (kflag == 3) mflag = abs(iflag)

        !     save input iflag and set continuation flag value for subsequent
        !     input checking
50      jflag = iflag
        kflag = 0

        !     save relerr and abserr for checking input on subsequent calls
        savre = relerr
        savae = abserr

        !     restrict relative error tolerance to be at least as large as
        !     2*eps+remin to avoid limiting precision difficulties arising
        !     from impossible accuracy requests

        rer = twoeps + remin
        if (relerr >= rer) goto 55

        !     relative error tolerance too small
        relerr = rer
        iflag = 3
        kflag = 3
        return

55      dt = tout - t

        if (mflag == 1) goto 60
        if (init == 0) goto 65
        goto 80

        !     initialization --
        !                       set initialization completion indicator,init
        !                       set indicator for too many output points,kop
        !                       evaluate initial derivatives
        !                       set counter for function evaluations,nfe
        !                       evaluate initial derivatives
        !                       set counter for function evaluations,nfe
        !                       estimate starting stepsize

60      init = 0
        kop = 0

        a = t
        call f(a, y, yp)
        nfe = 1
        if (t /= tout) goto 65
        iflag = 2
        return

65      init = 1
        h = abs(dt)
        toln = 0.
        do k = 1, neqn
            tol = relerr*abs(y(k)) + abserr
            if (tol <= 0.) goto 70
            toln = tol
            ypk = abs(yp(k))
            if (ypk*h**5 > tol) h = (tol/ypk)**0.2_rk
70      end do
        if (toln <= 0.0_rk) h = 0.0_rk
        h = max(h, u26*max(abs(t), abs(dt)))
        jflag = sign(2, iflag)

        !     set stepsize for integration in the direction from t to tout

80      h = sign(h, dt)

        !     test to see if rkf45 is being severely impacted by too many
        !     output points

        if (abs(h) >= 2.0_rk*abs(dt)) kop = kop + 1
        if (kop /= 100) goto 85

        !     unnecessary frequency of output
        kop = 0
        iflag = 7
        return

85      if (abs(dt) > u26*abs(t)) goto 95

        !     if too close to output point,extrapolate and return

        do k = 1, neqn
            y(k) = y(k) + dt*yp(k)
        end do
        a = tout
        call f(a, y, yp)
        nfe = nfe + 1
        goto 300

        !     initialize output point indicator

95      output = .false.

        !     to avoid premature underflow in the error tolerance function,
        !     scale the error tolerances

        scale = 2.0_rk/relerr
        ae = scale*abserr

        !     step by step integration

100     hfaild = .false.

        !     set smallest allowable stepsize

        hmin = u26*abs(t)

        !     adjust stepsize if necessary to hit the output point.
        !     look ahead two steps to avoid drastic changes in the stepsize and
        !     thus lessen the impact of output points on the code.

        dt = tout - t
        if (abs(dt) >= 2.0_rk*abs(h)) goto 200
        if (abs(dt) > abs(h)) goto 150

        !     the next successful step will complete the integration to the
        !     output point

        output = .true.
        h = dt
        goto 200

150     h = 0.5_rk*dt

        !     core integrator for taking a single step

        !     the tolerances have been scaled to avoid premature underflow in
        !     computing the error tolerance function et.
        !     to avoid problems with zero crossings,relative error is measured
        !     using the average of the magnitudes of the solution at the
        !     beginning and end of a step.
        !     the error estimate formula has been grouped to control loss of
        !     significance.
        !     to distinguish the various arguments, h is not permitted
        !     to become smaller than 26 units of roundoff in t.
        !     practical limits on the change in the stepsize are enforced to
        !     smooth the stepsize selection process and to avoid excessive
        !     chattering on problems having discontinuities.
        !     to prevent unnecessary failures, the code uses 9/10 the stepsize
        !     it estimates will succeed.
        !     after a step failure, the stepsize is not allowed to increase for
        !     the next attempted step. this makes the code more efficient on
        !     problems having discontinuities and more effective in general
        !     since local extrapolation is being used and extra caution seems
        !     warranted.

        !     test number of derivative function evaluations.
        !     if okay,try to advance the integration from t to t+h

200     if (nfe <= maxnfe) goto 220

        !     too much work
        iflag = 4
        kflag = 4
        return

        !     advance an approximate solution over one step of length h

220     call fehl(f, neqn, y, t, h, yp, f1, f2, f3, f4, f5, f1)
        nfe = nfe + 5

        !     compute and test allowable tolerances versus local error estimates
        !     and remove scaling of tolerances. note that relative error is
        !     measured with respect to the average of the magnitudes of the
        !     solution at the beginning and end of the step.

        eeoet = 0.0_rk
        do k = 1, neqn
            et = abs(y(k)) + abs(f1(k)) + ae
            if (et > 0.0_rk) goto 240

            !       inappropriate error tolerance
            iflag = 5
            return

240         ee = abs((-2090.0_rk*yp(k) + (21970.0_rk*f3(k) - 15048.0_rk*f4(k))) + (22528.0_rk*f2(k) - 27360.0_rk*f5(k)))
            eeoet = max(eeoet, ee/et)
        end do

        esttol = abs(h)*eeoet*scale/752400.0_rk

        if (esttol <= 1.0_rk) goto 260

        !     unsuccessful step
        !                       reduce the stepsize , try again
        !                       the decrease is limited to a factor of 1/10

        hfaild = .true.
        output = .false.
        s = 0.1_rk
        if (esttol < 59049.0_rk) s = 0.9_rk/esttol**0.2_rk
        h = s*h
        if (abs(h) > hmin) goto 200

        !     requested error unattainable at smallest allowable stepsize
        iflag = 6
        kflag = 6
        return

        !     successful step
        !                        store solution at t+h
        !                        and evaluate derivatives there

260     t = t + h
        do k = 1, neqn
            y(k) = f1(k)
        end do
        a = t
        call f(a, y, yp)
        nfe = nfe + 1

        !                       choose next stepsize
        !                       the increase is limited to a factor of 5
        !                       if step failure has just occurred, next
        !                          stepsize is not allowed to increase

        s = 5.0_rk
        if (esttol > 1.889568e-4_rk) s = 0.9_rk/esttol**0.2_rk
        if (hfaild) s = min(s, 1.0_rk)
        h = sign(max(s*abs(h), hmin), h)

        !     end of core integrator

        !     should we take another step

        if (output) goto 300
        if (iflag > 0) goto 100

        !     integration successfully completed

        !     one-step mode
        iflag = -2
        return

        !     interval mode
300     t = tout
        iflag = 2
        return

    end subroutine rkfs

    !> fehl integrates a system of neqn first order
    !> ordinary differential equations of the form
    !>          dy(i)/dt=f(t,y(1),---,y(neqn))
    !> where the initial values y(i) and the initial derivatives
    !> yp(i) are specified at the starting point t.
    subroutine fehl(f, neqn, y, t, h, yp, f1, f2, f3, f4, f5, s)

        !    fehl advances the solution over the fixed step h and returns
        !    the fifth order (sixth order accurate locally) solution
        !    approximation at t+h in array s(i).
        !    f1,---,f5 are arrays of dimension neqn which are needed
        !    for internal storage.
        !    the formulas have been grouped to control loss of significance.
        !    fehl should be called with an h not smaller than 13 units of
        !    roundoff in t so that the various independent arguments can be
        !    distinguished.

        procedure(fcn) :: f
        integer, intent(in) :: neqn
        real(rk) y(neqn), t, h, yp(neqn), f1(neqn), f2(neqn), f3(neqn), f4(neqn), f5(neqn), s(neqn)

        real(rk) ch
        integer k

        ch = h/4.0_rk
        do k = 1, neqn
            f5(k) = y(k) + ch*yp(k)
        end do
        call f(t + ch, f5, f1)

        ch = 3.0_rk*h/32.0_rk
        do k = 1, neqn
            f5(k) = y(k) + ch*(yp(k) + 3.0_rk*f1(k))
        end do
        call f(t + 3.0_rk*h/8.0_rk, f5, f2)

        ch = h/2197.0_rk
        do k = 1, neqn
            f5(k) = y(k) + ch*(1932.0_rk*yp(k) + (7296.0_rk*f2(k) - 7200.0_rk*f1(k)))
        end do
        call f(t + 12.0_rk*h/13.0_rk, f5, f3)

        ch = h/4104.0_rk
        do k = 1, neqn
            f5(k) = y(k) + ch*((8341.0_rk*yp(k) - 845.0_rk*f3(k)) + (29440.0_rk*f2(k) - 32832.0_rk*f1(k)))
        end do
        call f(t + h, f5, f4)

        ch = h/20520.0_rk
        do k = 1, neqn
            f1(k) = y(k) + ch*((-6080.0_rk*yp(k) + (9295.0_rk*f3(k) - 5643.0_rk*f4(k))) &
                               + (41040.0_rk*f1(k) - 28352.0_rk*f2(k)))
        end do
        call f(t + h/2.0_rk, f1, f5)

        !> compute approximate solution at t+h

        ch = h/7618050.0_rk
        do k = 1, neqn
            s(k) = y(k) + ch*((902880.0_rk*yp(k) + (3855735.0_rk*f3(k) - 1371249.0_rk*f4(k))) &
                              + (3953664.0_rk*f2(k) + 277020.0_rk*f5(k)))
        end do

        return
    end subroutine fehl

end module rkf45_module


c
c
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c       This is the end of the debugging code and the beginning of the
c       evaluation code for the Legendre functions
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c       This file contains a set of subroutines for the handling of
c       Legendre functions. It contains 10 subroutines that
c       are user-callable. Following is a brief description of these
c       subroutines.
c
c
c
c       ylgndr - evaluate normalized Legendre functions
c
c       ylgndr2 - evaluate normalized Legendre functions and their derivatives
c
c       ylgndr2s - evaluate normalized Legendre functions and their
c            derivatives. Ynm(x), m>0 values are scaled by 1/sqrt(1-x^2),
c            Ynm(x), m>0 derivatives with respect to are scaled by
c            sqrt(1-x^2).
c
c       ylgndrini - precompute the recursion coefficients.
c
c       ylgndrf - evaluate normalized Legendre functions. Fast version,
c            the recursion coefficients are precomputed with ylgndrini.
c
c       ylgndr2f - evaluate normalized Legendre functions and their
c            derivatives. Fast version, the recursion coefficients are
c            precomputed with ylgndrini.
c
c       ylgndr2sf - evaluate normalized Legendre functions and their
c            derivatives. Ynm(x), m>0 values are scaled by 1/sqrt(1-x^2),
c            Ynm(x), m>0 derivatives with respect to are scaled by
c            sqrt(1-x^2).  Fast version, the recursion coefficients are
c            precomputed with ylgndrini.
c
c       zylgndr - evaluate normalized Legendre functions of a complex argument
c
c       zylgndr2 - evaluate normalized Legendre functions of a complex argument
c            and their derivatives
c
c       zylgndrsc - evaluate normalized Legendre functions of a complex
c            argument. Scaled version to prevent overflows for large z values.
c
c       Added 03/08/09
c
c       ylgndr2s_trunc - evaluate normalized Legendre functions and their
c            derivatives (with scaling). Same as ylgndr2s,
c            but recursion carried out only to m = m2 rather than nmax.
c
c       ylgndrf_trunc - evaluate normalized Legendre functions. Same as ylgndrf
c            but recursion carried out only to m = m2 rather than nmax.
c
c       ylgndr2f_trunc - evaluate normalized Legendre functions and their
c            derivatives. Same as ylgndr2f,
c            but recursion carried out only to m = m2 rather than nmax.
c
c       ylgndr2sf_trunc - evaluate normalized Legendre functions and their
c            derivatives (with scaling). Same as ylgndr2sf,
c            but recursion carried out only to m = m2 rather than nmax.
c
c
      subroutine ylgndr(nmax, x, y)
      implicit real *8 (a-h,o-z)
c
c     Evaluate normalized Legendre function
c
c      Ynm(x) = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) Pnm(x)
c
c     for n = 0, 1, 2,..., nmax
c     and  m = 0, 1,..., n.
c
c     Parameters:
c     nmax                      must be non-negative
c     x                         -1 <= x <= 1
c     y(0:nmax,0:nmax)      resulting function values
c
c     Upon return, y(n,m) will contain the function value Ynm(x)
c     for 0 <= n <= nmax  and  0 <= m <= n.  Other elements of y
c     will contain undefined values.
c
      integer nmax, m
      real *8 x, y(0:nmax,0:nmax), u, v, w
      u=-sqrt(1-x*x)
      y(0,0)=1
      do 10 m=0, nmax
	 if (m.gt.0)  y(m,m)=y(m-1,m-1)*u*sqrt((2*m-1.0d0)/(2*m))
	 if (m.lt.nmax)  y(m+1,m)=x*y(m,m)*sqrt(2*m+1.0d0)
	 do 20 n=m+2, nmax
	    y(n,m)=((2*n-1)*x*y(n-1,m) -
     1               sqrt((n+m-1.0d0)*(n-m-1.0d0))*y(n-2,m))
     2               /sqrt((n-m+0.0d0)*(n+m))
 20      continue
 10   continue
      do n=0, nmax
	 do m=0, n
	    y(n,m)=y(n,m)*sqrt(2*n+1.0d0)
         enddo
      enddo
      return
      end
c
c
c
c
c
      subroutine ylgndr2(nmax, x, y, d)
      implicit real *8 (a-h,o-z)
c
c     Evaluate normalized Legendre functions and their derivatives
c
c      Ynm(x) = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) Pnm(x)
c
c      d Ynm(x) / dx = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) d Pnm(x) / dx
c
c     for n = 0, 1, 2,..., nmax
c     and  m = 0, 1,..., n.
c
c     Parameters:
c     nmax                      must be non-negative
c     x                         -1 <= x <= 1
c     y(0:nmax,0:nmax)      resulting function values
c     d(0:nmax,0:nmax)      resulting derivative values
c
c     Upon return, y(n,m) will contain the function value Ynm(x) for 0
c     <= n <= nmax and 0 <= m <= n.  Other elements of y will contain
c     undefined values. The same convention for the derivatives.
c
      integer nmax, m
      real *8 x, y(0:nmax,0:nmax), d(0:nmax,0:nmax), u, du, v, w
      u=-sqrt(1-x*x)
      du=x/sqrt(1-x*x)
      y(0,0)=1
      d(0,0)=0
      do 10 m=0, nmax
	 if (m.gt.0)  y(m,m)=y(m-1,m-1)*u*sqrt((2*m-1.0d0)/(2*m))
	 if (m.gt.0)  d(m,m)=y(m,m)*(-m*x)/u**2
	 if (m.lt.nmax)  y(m+1,m)=x*y(m,m)*sqrt(2*m+1.0d0)
	 if (m.lt.nmax)  d(m+1,m)=(x*d(m,m)+y(m,m))*sqrt(2*m+1.0d0)
	 do 20 n=m+2, nmax
	    y(n,m)=((2*n-1)*x*y(n-1,m) -
     1               sqrt((n+m-1.0d0)*(n-m-1.0d0))*y(n-2,m))
     2               /sqrt((n-m+0.0d0)*(n+m))
	    d(n,m)=((2*n-1)*(x*d(n-1,m)+y(n-1,m)) -
     1               sqrt((n+m-1.0d0)*(n-m-1.0d0))*d(n-2,m))
     2               /sqrt((n-m+0.0d0)*(n+m))
 20      continue
 10   continue
      do n=0, nmax
	 do m=0, n
	    y(n,m)=y(n,m)*sqrt(2*n+1.0d0)
	    d(n,m)=d(n,m)*sqrt(2*n+1.0d0)
         enddo
      enddo
      return
      end
c
c
c
c
c
      subroutine ylgndr2s(nmax, x, y, d)
      implicit real *8 (a-h,o-z)
c
c     Evaluate scaled normalized Legendre functions and their derivatives
c
c     Only for Ynm(x) with m>0
c          the functions are scaled by 1/sqrt(1-x**2)
c          the derivatives are scaled by sqrt(1-x**2)
c
c
c      Ynm(x) = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) Pnm(x)
c
c      d Ynm(x) / dx = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) d Pnm(x) / dx
c
c     for n = 0, 1, 2,..., nmax
c     and  m = 0, 1,..., n.
c
c     Parameters:
c     nmax                      must be non-negative
c     x                         -1 <= x <= 1
c     y(0:nmax,0:nmax)      resulting function values
c     d(0:nmax,0:nmax)      resulting derivative values
c
c     Upon return, y(n,m) will contain the function value Ynm(x) for 0
c     <= n <= nmax and 0 <= m <= n.  Other elements of y will contain
c     undefined values. The same convention for the derivatives.
c
      integer nmax, m
      real *8 x, y(0:nmax,0:nmax), d(0:nmax,0:nmax), u, v, w
      u=-sqrt(1-x*x)
      y(0,0)=1
      d(0,0)=0
c
c       ... first, evaluate standard Legendre polynomials
c
      m=0
      if (m.lt.nmax)  y(m+1,m)=x*y(m,m)*sqrt(2*m+1.0d0)
      if (m.lt.nmax)  d(m+1,m)=(x*d(m,m)+y(m,m))*sqrt(2*m+1.0d0)
      do 120 n=m+2, nmax
        y(n,m)=((2*n-1)*x*y(n-1,m) -
     1               sqrt((n+m-1.0d0)*(n-m-1.0d0))*y(n-2,m))
     2               /sqrt((n-m+0.0d0)*(n+m))
        d(n,m)=((2*n-1)*(x*d(n-1,m)+y(n-1,m)) -
     1               sqrt((n+m-1.0d0)*(n-m-1.0d0))*d(n-2,m))
     2               /sqrt((n-m+0.0d0)*(n+m))
120   continue
c
c       ... then, evaluate scaled associated Legendre functions
c
      do 210 m=1, nmax
c
	 if (m.eq.1)  y(m,m)=y(m-1,m-1)*(-1)*sqrt((2*m-1.0d0)/(2*m))
	 if (m.gt.1)  y(m,m)=y(m-1,m-1)*u*sqrt((2*m-1.0d0)/(2*m))
	 if (m.gt.0)  d(m,m)=y(m,m)*(-m*x)
c
	 if (m.lt.nmax)  y(m+1,m)=x*y(m,m)*sqrt(2*m+1.0d0)
	 if (m.lt.nmax)
     $      d(m+1,m)=(x*d(m,m)+(1-x**2)*y(m,m))*sqrt(2*m+1.0d0)
	 do 220 n=m+2, nmax
	    y(n,m)=((2*n-1)*x*y(n-1,m) -
     1               sqrt((n+m-1.0d0)*(n-m-1.0d0))*y(n-2,m))
     2               /sqrt((n-m+0.0d0)*(n+m))
	    d(n,m)=((2*n-1)*(x*d(n-1,m)+(1-x**2)*y(n-1,m)) -
     1               sqrt((n+m-1.0d0)*(n-m-1.0d0))*d(n-2,m))
     2               /sqrt((n-m+0.0d0)*(n+m))
220      continue
210   continue
      do n=0, nmax
	 do m=0, n
	    y(n,m)=y(n,m)*sqrt(2*n+1.0d0)
	    d(n,m)=d(n,m)*sqrt(2*n+1.0d0)
         enddo
      enddo
      return
      end
c
c
c
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c       fast version of real valued Legendre functions
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
      subroutine ylgndrini(nmax, rat1, rat2)
      implicit real *8 (a-h,o-z)
c
c     Precompute the recurrence coefficients for the fast
c     evaluation of normalized Legendre functions and their derivatives
c
c     Parameters:
c       nmax                      must be non-negative
c       rat1(0:nmax,0:nmax)       recurence coefficient
c       rat2(0:nmax,0:nmax)       recurence coefficient
c
      integer nmax, m
      real *8 x, rat1(0:nmax,0:nmax), rat2(0:nmax,0:nmax)
      rat1(0,0)=1
      rat2(0,0)=1
      do 10 m=0, nmax
	 if (m.gt.0)  rat1(m,m)=sqrt((2*m-1.0d0)/(2*m))
	 if (m.gt.0)  rat2(m,m)=1
	 if (m.lt.nmax)  rat1(m+1,m)=sqrt(2*m+1.0d0)
	 if (m.lt.nmax)  rat2(m+1,m)=1
	 do 20 n=m+2, nmax
	    rat1(n,m)=(2*n-1)
            rat2(n,m)=sqrt((n+m-1.0d0)*(n-m-1.0d0))
	    rat1(n,m)=rat1(n,m)/sqrt(dble(n-m)*(n+m))
	    rat2(n,m)=rat2(n,m)/sqrt(dble(n-m)*(n+m))
 20      continue
 10   continue
c
      return
      end
c
c
c
c
c
      subroutine ylgndrf(nmax, x, y, rat1, rat2)
      implicit real *8 (a-h,o-z)
c
c     Evaluate normalized Legendre functions
c
c      Ynm(x) = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) Pnm(x)
c
c     for n = 0, 1, 2,..., nmax
c     and  m = 0, 1,..., n.
c
c     Parameters:
c     nmax                      must be non-negative
c     x                         -1 <= x <= 1
c     y(0:nmax,0:nmax)      resulting function values
c
c     Upon return, y(n,m) will contain the function value Ynm(x) for 0
c     <= n <= nmax and 0 <= m <= n.  Other elements of y will contain
c     undefined values.
c
      integer nmax, m
      real *8 x, y(0:nmax,0:nmax), u, v, w
      real *8 rat1(0:nmax,0:nmax), rat2(0:nmax,0:nmax)
      u=-sqrt(1-x*x)
      y(0,0)=1
      do 10 m=0, nmax
	 if (m.gt.0)  y(m,m)=y(m-1,m-1)*u*rat1(m,m)
	 if (m.lt.nmax)  y(m+1,m)=x*y(m,m)*rat1(m+1,m)
	 do 20 n=m+2, nmax
	    y(n,m)=rat1(n,m)*x*y(n-1,m)-rat2(n,m)*y(n-2,m)
 20      continue
 10   continue
c
      do n=0, nmax
	 do m=0, n
	    y(n,m)=y(n,m)*sqrt(2*n+1.0d0)
         enddo
      enddo
c
      return
      end
c
c
c
c
c
      subroutine ylgndr2f(nmax, x, y, d, rat1, rat2)
      implicit real *8 (a-h,o-z)
c
c     Evaluate normalized Legendre functions and their derivatives
c
c      Ynm(x) = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) Pnm(x)
c
c      d Ynm(x) / dx = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) d Pnm(x) / dx
c
c     for n = 0, 1, 2,..., nmax
c     and  m = 0, 1,..., n.
c
c     Parameters:
c     nmax                      must be non-negative
c     x                         -1 <= x <= 1
c     y(0:nmax,0:nmax)      resulting function values
c     d(0:nmax,0:nmax)      resulting derivative values
c
c     Upon return, y(n,m) will contain the function value Ynm(x) for 0
c     <= n <= nmax and 0 <= m <= n.  Other elements of y will contain
c     undefined values. The same convention for the derivatives.
c
      integer nmax, m
      real *8 x, y(0:nmax,0:nmax), d(0:nmax,0:nmax), u, du, v, w
      real *8 rat1(0:nmax,0:nmax), rat2(0:nmax,0:nmax)
      u=-sqrt(1-x*x)
      du=x/sqrt(1-x*x)
      y(0,0)=1
      d(0,0)=0
      do 10 m=0, nmax
	 if (m.gt.0)  y(m,m)=y(m-1,m-1)*u*rat1(m,m)
	 if (m.gt.0)  d(m,m)=y(m,m)*(-m*x)/u**2
	 if (m.lt.nmax)  y(m+1,m)=x*y(m,m)*rat1(m+1,m)
	 if (m.lt.nmax)  d(m+1,m)=(x*d(m,m)+y(m,m))*rat1(m+1,m)
	 do 20 n=m+2, nmax
	    y(n,m)=rat1(n,m)*x*y(n-1,m)-rat2(n,m)*y(n-2,m)
	    d(n,m)=rat1(n,m)*(x*d(n-1,m)+y(n-1,m))-rat2(n,m)*d(n-2,m)
 20      continue
 10   continue
c
      do n=0, nmax
	 do m=0, n
	    y(n,m)=y(n,m)*sqrt(2*n+1.0d0)
	    d(n,m)=d(n,m)*sqrt(2*n+1.0d0)
         enddo
      enddo
c
      return
      end
c
c
c
c
c
      subroutine ylgndr2sf(nmax, x, y, d, rat1, rat2)
      implicit real *8 (a-h,o-z)
c
c     Evaluate scaled normalized Legendre functions and their derivatives
c
c     Only for Ynm(x) with m>0
c          the functions are scaled by 1/sqrt(1-x**2)
c          the derivatives are scaled by sqrt(1-x**2)
c
c
c      Ynm(x) = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) Pnm(x)
c
c      d Ynm(x) / dx = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) d Pnm(x) / dx
c
c     for n = 0, 1, 2,..., nmax
c     and  m = 0, 1,..., n.
c
c     Parameters:
c     nmax                      must be non-negative
c     x                         -1 <= x <= 1
c     y(0:nmax,0:nmax)      resulting function values
c     d(0:nmax,0:nmax)      resulting derivative values
c
c     Upon return, y(n,m) will contain the function value Ynm(x) for 0
c     <= n <= nmax and 0 <= m <= n.  Other elements of y will contain
c     undefined values. The same convention for the derivatives.
c
      integer nmax, m
      real *8 x, y(0:nmax,0:nmax), d(0:nmax,0:nmax), u, v, w
      real *8 rat1(0:nmax,0:nmax), rat2(0:nmax,0:nmax)
      u=-sqrt(1-x*x)
      u2 = 1-x*x
      y(0,0)=1
      d(0,0)=0
c
c       ... first, evaluate standard Legendre polynomials
c
      m=0
      if (m.lt.nmax)  y(m+1,m)=x*y(m,m)*rat1(m+1,m)
      if (m.lt.nmax)  d(m+1,m)=(x*d(m,m)+y(m,m))*rat1(m+1,m)
      do 120 n=m+2, nmax
        y(n,m)=rat1(n,m)*x*y(n-1,m)-rat2(n,m)*y(n-2,m)
        d(n,m)=rat1(n,m)*(x*d(n-1,m)+y(n-1,m))-rat2(n,m)*d(n-2,m)
120   continue
c
c       ... then, evaluate scaled associated Legendre functions
c
      do 210 m=1, nmax
c
	 if (m.eq.1)  y(m,m)=y(m-1,m-1)*(-1)*rat1(m,m)
	 if (m.gt.1)  y(m,m)=y(m-1,m-1)*u*rat1(m,m)
	 if (m.gt.0)  d(m,m)=y(m,m)*(-m*x)
c
	 if (m.lt.nmax)  y(m+1,m)=x*y(m,m)*rat1(m+1,m)
	 if (m.lt.nmax)
ccc     $      d(m+1,m)=(x*d(m,m)+(1-x**2)*y(m,m))*rat1(m+1,m)
     $      d(m+1,m)=(x*d(m,m)+u2*y(m,m))*rat1(m+1,m)
	 do 220 n=m+2, nmax
	    y(n,m)=rat1(n,m)*x*y(n-1,m)-rat2(n,m)*y(n-2,m)
ccc	    d(n,m)=rat1(n,m)*(x*d(n-1,m)+(1-x**2)*y(n-1,m))-
	    d(n,m)=rat1(n,m)*(x*d(n-1,m)+u2*y(n-1,m))-
     $         rat2(n,m)*d(n-2,m)
220      continue
210   continue
      do n=0, nmax
	 do m=0, n
	    y(n,m)=y(n,m)*sqrt(2*n+1.0d0)
	    d(n,m)=d(n,m)*sqrt(2*n+1.0d0)
         enddo
      enddo
      return
      end
c
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c       complex valued Legendre functions
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
      subroutine zylgndr(nmax, z, y)
      implicit none
c
c     Evaluate normalized Legendre function for complex argument
c
c      Ynm(x) = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) Pnm(x)
c
c     for n = 0, 1, 2,..., nmax
c     and  m = 0, 1,..., n.
c
c     Parameters:
c     nmax                      must be non-negative
c     z                         complex*16
c     y(0:nmax,0:nmax)      resulting function values
c
c     Upon return, y(n,m) will contain the function value Ynm(z)
c     for 0 <= n <= nmax  and  0 <= m <= n.  Other elements of y
c     will contain undefined values.
c
      integer nmax
      complex*16 z, y(0:nmax,0:nmax)
c
      integer m,n
      complex*16 u, v, w
c
      u=-sqrt(1-z*z)
      y(0,0)=1
      do 10 m=0, nmax
	 if (m.gt.0)  y(m,m)=y(m-1,m-1)*u*sqrt((2*m-1.0d0)/(2*m))
	 if (m.lt.nmax)  y(m+1,m)=z*y(m,m)*sqrt(2*m+1.0d0)
	 do 20 n=m+2, nmax
	    y(n,m)=((2*n-1)*z*y(n-1,m) -
     1               sqrt((n+m-1.0d0)*(n-m-1.0d0))*y(n-2,m))
     2               /sqrt((n-m+0.0d0)*(n+m))
 20      continue
 10   continue
      do n=0, nmax
	 do m=0, n
	    y(n,m)=y(n,m)*sqrt(2*n+1.0d0)
         enddo
      enddo
      return
      end
c
c
c
c
c
      subroutine zylgndr2(nmax, z, y, d)
      implicit real *8 (a-h,o-z)
c
c     Evaluate normalized Legendre functions and their derivatives
c       for complex argument
c
c      Ynm(x) = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) Pnm(x)
c
c      d Ynm(x) / dx = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) d Pnm(x) / dx
c
c     for n = 0, 1, 2,..., nmax
c     and  m = 0, 1,..., n.
c
c     Parameters:
c     nmax                      must be non-negative
c     x                         -1 <= x <= 1
c     y(0:nmax,0:nmax)      resulting function values, complex *16
c     d(0:nmax,0:nmax)      resulting derivative values, complex *16
c
c     Upon return, y(n,m) will contain the function value Ynm(x) for 0
c     <= n <= nmax and 0 <= m <= n.  Other elements of y will contain
c     undefined values. The same convention is valid for the derivative.
c
      integer nmax, m
      complex *16 z, y(0:nmax,0:nmax), d(0:nmax,0:nmax), u, du, v, w
      u=-sqrt(1-z*z)
      du=z/sqrt(1-z*z)
      y(0,0)=1
      d(0,0)=0
      do 10 m=0, nmax
	 if (m.gt.0)  y(m,m)=y(m-1,m-1)*u*sqrt((2*m-1.0d0)/(2*m))
	 if (m.gt.0)  d(m,m)=y(m,m)*(-m*z)/u**2
	 if (m.lt.nmax)  y(m+1,m)=z*y(m,m)*sqrt(2*m+1.0d0)
	 if (m.lt.nmax)  d(m+1,m)=(z*d(m,m)+y(m,m))*sqrt(2*m+1.0d0)
	 do 20 n=m+2, nmax
	    y(n,m)=((2*n-1)*z*y(n-1,m) -
     1               sqrt((n+m-1.0d0)*(n-m-1.0d0))*y(n-2,m))
     2               /sqrt((n-m+0.0d0)*(n+m))
	    d(n,m)=((2*n-1)*(z*d(n-1,m)+y(n-1,m)) -
     1               sqrt((n+m-1.0d0)*(n-m-1.0d0))*d(n-2,m))
     2               /sqrt((n-m+0.0d0)*(n+m))
 20      continue
 10   continue
      do n=0, nmax
	 do m=0, n
	    y(n,m)=y(n,m)*sqrt(2*n+1.0d0)
	    d(n,m)=d(n,m)*sqrt(2*n+1.0d0)
         enddo
      enddo
      return
      end
c
c
c
c
c
      subroutine zylgndrsc(nmax, z,scale, ysc)
      implicit none
c
c     Evaluate scaled versions of zylgndr.  zylgndr is the complex version
c     of the normalized Legendre function.  Scaling removes the possible
c     conditioning errors from zylgndr evaluated at large arguments.
c
c     y_nm = scale**(-n) * ysc_nm
c
c     for n = 0, 1, 2,..., nmax
c     and  m = 0, 1,..., n.
c
c     Parameters:
c     nmax                      must be non-negative
c     z (complex*16)            the argument
c     scale (real*8)
c          looks like scale wants to be O(1/z) and scale<1.
c     ysc(0:nmax,0:nmax)        resulting function values
c
      integer nmax
      complex*16 z, ysc(0:nmax,0:nmax)
      real*8 scale
c
      integer m,n
      complex*16 u, v, w
c
      u=-sqrt(1-z*z)
      ysc(0,0)=1
      do 10 m=0, nmax
	 if (m.gt.0)  then
            ysc(m,m)=ysc(m-1,m-1)*scale*u*sqrt((2*m-1.0d0)/(2*m))
c           call prinf('m=*',m,1)
c           call prin2('ysc(m,m)=*',ysc(m,m),2)
         endif
	 if (m.lt.nmax)  then
            ysc(m+1,m)=z*scale*ysc(m,m)*sqrt(2*m+1.0d0)
         endif
	 do 20 n=m+2, nmax
	    ysc(n,m)=((2*n-1)*scale*z*ysc(n-1,m) -
     1           sqrt((n+m-1.0d0)*(n-m-1.0d0))*scale**2*ysc(n-2,m))
     2           /sqrt((n-m+0.0d0)*(n+m))
 20      continue
 10   continue
      do n=0, nmax
	 do m=0, n
	    ysc(n,m)=ysc(n,m)*sqrt(2*n+1.0d0)
         enddo
      enddo
      return
      end
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c       truncated recurrences for Legendre functions:
c
c       Ynm(theta) for n = 0,nmax  but m = -m2,...,m2  with m2 < nmax.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
      subroutine ylgndr2s_trunc(nmax, m2, x, y, d)
      implicit real *8 (a-h,o-z)
c
c     Evaluate scaled normalized Legendre functions and their derivatives
c
c     Only for Ynm(x) with m>0
c          the functions are scaled by 1/sqrt(1-x**2)
c          the derivatives are scaled by sqrt(1-x**2)
c
c
c      Ynm(x) = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) Pnm(x)
c
c      d Ynm(x) / dx = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) d Pnm(x) / dx
c
c     for n = 0, 1, 2,..., nmax
c     and  m = 0, 1,..., n.
c
c     Parameters:
c     nmax                      must be non-negative
c     x                         -1 <= x <= 1
c     y(0:nmax,0:nmax)      resulting function values
c     d(0:nmax,0:nmax)      resulting derivative values
c
c     Upon return, y(n,m) will contain the function value Ynm(x) for 0
c     <= n <= nmax and 0 <= m <= n.  Other elements of y will contain
c     undefined values. The same convention for the derivatives.
c
      integer nmax, m, m2
      real *8 x, y(0:nmax,0:nmax), d(0:nmax,0:nmax), u, v, w
      u=-sqrt(1-x*x)
      y(0,0)=1
      d(0,0)=0
c
c       ... first, evaluate standard Legendre polynomials
c
      m=0
      if (m.lt.nmax)  y(m+1,m)=x*y(m,m)*sqrt(2*m+1.0d0)
      if (m.lt.nmax)  d(m+1,m)=(x*d(m,m)+y(m,m))*sqrt(2*m+1.0d0)
      do 120 n=m+2, nmax
        y(n,m)=((2*n-1)*x*y(n-1,m) -
     1               sqrt((n+m-1.0d0)*(n-m-1.0d0))*y(n-2,m))
     2               /sqrt((n-m+0.0d0)*(n+m))
        d(n,m)=((2*n-1)*(x*d(n-1,m)+y(n-1,m)) -
     1               sqrt((n+m-1.0d0)*(n-m-1.0d0))*d(n-2,m))
     2               /sqrt((n-m+0.0d0)*(n+m))
120   continue
c
c       ... then, evaluate scaled associated Legendre functions
c
      do 210 m=1, m2
c
	 if (m.eq.1)  y(m,m)=y(m-1,m-1)*(-1)*sqrt((2*m-1.0d0)/(2*m))
	 if (m.gt.1)  y(m,m)=y(m-1,m-1)*u*sqrt((2*m-1.0d0)/(2*m))
	 if (m.gt.0)  d(m,m)=y(m,m)*(-m*x)
c
	 if (m.lt.nmax)  y(m+1,m)=x*y(m,m)*sqrt(2*m+1.0d0)
	 if (m.lt.nmax)
     $      d(m+1,m)=(x*d(m,m)+(1-x**2)*y(m,m))*sqrt(2*m+1.0d0)
	 do 220 n=m+2, nmax
	    y(n,m)=((2*n-1)*x*y(n-1,m) -
     1               sqrt((n+m-1.0d0)*(n-m-1.0d0))*y(n-2,m))
     2               /sqrt((n-m+0.0d0)*(n+m))
	    d(n,m)=((2*n-1)*(x*d(n-1,m)+(1-x**2)*y(n-1,m)) -
     1               sqrt((n+m-1.0d0)*(n-m-1.0d0))*d(n-2,m))
     2               /sqrt((n-m+0.0d0)*(n+m))
220      continue
210   continue
      do n=0, nmax
	 do m=0, min(n,m2)
	    y(n,m)=y(n,m)*sqrt(2*n+1.0d0)
	    d(n,m)=d(n,m)*sqrt(2*n+1.0d0)
         enddo
      enddo
      return
      end
c
c
c
c
c
c
      subroutine ylgndrf_trunc(nmax, m2, x, y, rat1, rat2)
      implicit real *8 (a-h,o-z)
c
c     Evaluate normalized Legendre functions
c
c      Ynm(x) = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) Pnm(x)
c
c     for n = 0, 1, 2,..., nmax
c     and  m = 0, 1,..., min(m2,n).
c
c     Parameters:
c     nmax                      must be non-negative
c     x                         -1 <= x <= 1
c     y(0:nmax,0:nmax)      resulting function values
c
c     Upon return, y(n,m) will contain the function value Ynm(x) for 0
c     <= n <= nmax and 0 <= m <= n.  Other elements of y will contain
c     undefined values.
c
      integer nmax, m, m2
      real *8 x, y(0:nmax,0:nmax), u, v, w
      real *8 rat1(0:nmax,0:nmax), rat2(0:nmax,0:nmax)
      u=-sqrt(1-x*x)
      y(0,0)=1
      do 10 m=0, m2
	 if (m.gt.0)  y(m,m)=y(m-1,m-1)*u*rat1(m,m)
	 if (m.lt.nmax)  y(m+1,m)=x*y(m,m)*rat1(m+1,m)
	 do 20 n=m+2, nmax
	    y(n,m)=rat1(n,m)*x*y(n-1,m)-rat2(n,m)*y(n-2,m)
 20      continue
 10   continue
c
      do n=0, nmax
	 do m=0, min(n,m2)
	    y(n,m)=y(n,m)*sqrt(2*n+1.0d0)
         enddo
      enddo
c
      return
      end
c
c
c
c
c
      subroutine ylgndr2f_trunc(nmax, m2, x, y, d, rat1, rat2)
      implicit real *8 (a-h,o-z)
c
c     Evaluate normalized Legendre functions and their derivatives
c
c      Ynm(x) = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) Pnm(x)
c
c      d Ynm(x) / dx = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) d Pnm(x) / dx
c
c     for n = 0, 1, 2,..., nmax
c     and  m = 0, 1,..., min(m2,n).
c
c     Parameters:
c     nmax                      must be non-negative
c     x                         -1 <= x <= 1
c     y(0:nmax,0:nmax)      resulting function values
c     d(0:nmax,0:nmax)      resulting derivative values
c
c     Upon return, y(n,m) will contain the function value Ynm(x) for 0
c     <= n <= nmax and 0 <= m <= n.  Other elements of y will contain
c     undefined values. The same convention for the derivatives.
c
      integer nmax, m, m2
      real *8 x, y(0:nmax,0:nmax), d(0:nmax,0:nmax), u, du, v, w
      real *8 rat1(0:nmax,0:nmax), rat2(0:nmax,0:nmax)
      u=-sqrt(1-x*x)
      du=x/sqrt(1-x*x)
      y(0,0)=1
      d(0,0)=0
      do 10 m=0, m2
	 if (m.gt.0)  y(m,m)=y(m-1,m-1)*u*rat1(m,m)
	 if (m.gt.0)  d(m,m)=y(m,m)*(-m*x)/u**2
	 if (m.lt.nmax)  y(m+1,m)=x*y(m,m)*rat1(m+1,m)
	 if (m.lt.nmax)  d(m+1,m)=(x*d(m,m)+y(m,m))*rat1(m+1,m)
	 do 20 n=m+2, nmax
	    y(n,m)=rat1(n,m)*x*y(n-1,m)-rat2(n,m)*y(n-2,m)
	    d(n,m)=rat1(n,m)*(x*d(n-1,m)+y(n-1,m))-rat2(n,m)*d(n-2,m)
 20      continue
 10   continue
c
      do n=0, nmax
	 do m=0, min(n,m2)
	    y(n,m)=y(n,m)*sqrt(2*n+1.0d0)
	    d(n,m)=d(n,m)*sqrt(2*n+1.0d0)
         enddo
      enddo
c
      return
      end
c
c
c
c
c
      subroutine ylgndr2sf_trunc(nmax, m2, x, y, d, rat1, rat2)
      implicit real *8 (a-h,o-z)
c
c     Evaluate scaled normalized Legendre functions and their derivatives
c
c     Only for Ynm(x) with m>0
c          the functions are scaled by 1/sqrt(1-x**2)
c          the derivatives are scaled by sqrt(1-x**2)
c
c
c      Ynm(x) = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) Pnm(x)
c
c      d Ynm(x) / dx = sqrt(2n+1)  sqrt( (n-m)!/ (n+m)! ) d Pnm(x) / dx
c
c     for n = 0, 1, 2,..., nmax
c     and  m = 0, 1,..., min(n,m2).
c
c     Parameters:
c     nmax                      must be non-negative
c     x                         -1 <= x <= 1
c     y(0:nmax,0:nmax)      resulting function values
c     d(0:nmax,0:nmax)      resulting derivative values
c
c     Upon return, y(n,m) will contain the function value Ynm(x) for 0
c     <= n <= nmax and 0 <= m <= n.  Other elements of y will contain
c     undefined values. The same convention for the derivatives.
c
      integer nmax, m, m2
      real *8 x, y(0:nmax,0:nmax), d(0:nmax,0:nmax), u, v, w
      real *8 rat1(0:nmax,0:nmax), rat2(0:nmax,0:nmax)
      u=-sqrt(1-x*x)
      u2 = 1-x*x
      y(0,0)=1
      d(0,0)=0
c
c       ... first, evaluate standard Legendre polynomials
c
      m=0
      if (m.lt.nmax)  y(m+1,m)=x*y(m,m)*rat1(m+1,m)
      if (m.lt.nmax)  d(m+1,m)=(x*d(m,m)+y(m,m))*rat1(m+1,m)
      do 120 n=m+2, nmax
        y(n,m)=rat1(n,m)*x*y(n-1,m)-rat2(n,m)*y(n-2,m)
        d(n,m)=rat1(n,m)*(x*d(n-1,m)+y(n-1,m))-rat2(n,m)*d(n-2,m)
120   continue
c
c       ... then, evaluate scaled associated Legendre functions
c
      do 210 m=1, m2
c
	 if (m.eq.1)  y(m,m)=y(m-1,m-1)*(-1)*rat1(m,m)
	 if (m.gt.1)  y(m,m)=y(m-1,m-1)*u*rat1(m,m)
	 if (m.gt.0)  d(m,m)=y(m,m)*(-m*x)
c
	 if (m.lt.nmax)  y(m+1,m)=x*y(m,m)*rat1(m+1,m)
	 if (m.lt.nmax)
     $      d(m+1,m)=(x*d(m,m)+u2*y(m,m))*rat1(m+1,m)
	 do 220 n=m+2, nmax
	    y(n,m)=rat1(n,m)*x*y(n-1,m)-rat2(n,m)*y(n-2,m)
	    d(n,m)=rat1(n,m)*(x*d(n-1,m)+u2*y(n-1,m))-
     $         rat2(n,m)*d(n-2,m)
220      continue
210   continue
      do n=0, nmax
	 do m=0, min(n,m2)
	    y(n,m)=y(n,m)*sqrt(2*n+1.0d0)
	    d(n,m)=d(n,m)*sqrt(2*n+1.0d0)
         enddo
      enddo
      return
      end
c


      subroutine equivwl(iinf,isup,step,wlmoy)

      common /sixs_ffu/s(1501),wlinf,wlsup
      real step,wlmoy,s,wlinf,wlsup,seb,wlwave,sbor,wl,swl,coef
      integer iinf,isup,l

      seb=0.
      wlwave=0.

      do 50 l=iinf,isup
        sbor=s(l)
        if(l.eq.iinf.or.l.eq.isup) sbor=sbor*0.5
        wl=.25+(l-1)*step
        call solirr(wl,swl)
        coef=sbor*step*swl
        seb=seb+coef
        wlwave=wlwave+wl*coef
  50  continue
      wlmoy=wlwave/seb
      return
      end


*DECK RGG
      SUBROUTINE RGG (NM, N, A, B, ALFR, ALFI, BETA, MATZ, Z, IERR)
C***BEGIN PROLOGUE  RGG
C***PURPOSE  Compute the eigenvalues and eigenvectors for a real
C            generalized eigenproblem.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4B2
C***TYPE      SINGLE PRECISION (RGG-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of
C     subroutines from the eigensystem subroutine package (EISPACK)
C     to find the eigenvalues and eigenvectors (if desired)
C     for the REAL GENERAL GENERALIZED eigenproblem  Ax = (LAMBDA)Bx.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A, B, and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrices A and B.  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        A contains a real general matrix.  A is a two-dimensional
C          REAL array, dimensioned A(NM,N).
C
C        B contains a real general matrix.  B is a two-dimensional
C          REAL array, dimensioned B(NM,N).
C
C        MATZ is an INTEGER variable set equal to zero if only
C          eigenvalues are desired.  Otherwise, it is set to any
C          non-zero integer for both eigenvalues and eigenvectors.
C
C     On Output
C
C        A and B have been destroyed.
C
C        ALFR and ALFI contain the real and imaginary parts,
C          respectively, of the numerators of the eigenvalues.
C          ALFR and ALFI are one-dimensional REAL arrays,
C          dimensioned ALFR(N) and ALFI(N).
C
C        BETA contains the denominators of the eigenvalues,
C          which are thus given by the ratios  (ALFR+I*ALFI)/BETA.
C          Complex conjugate pairs of eigenvalues appear consecutively
C          with the eigenvalue having the positive imaginary part first.
C          BETA is a one-dimensional REAL array, dimensioned BETA(N).
C
C        Z contains the real and imaginary parts of the eigenvectors
C          if MATZ is not zero.  If the J-th eigenvalue is real, the
C          J-th column of  Z  contains its eigenvector.  If the J-th
C          eigenvalue is complex with positive imaginary part, the
C          J-th and (J+1)-th columns of  Z  contain the real and
C          imaginary parts of its eigenvector.  The conjugate of this
C          vector is the eigenvector for the conjugate eigenvalue.
C          Z is a two-dimensional REAL array, dimensioned Z(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          10*N       if N is greater than NM,
C          J          if the J-th eigenvalue has not been
C                     determined after a total of 30*N iterations.
C                     The eigenvalues should be correct for indices
C                     IERR+1, IERR+2, ..., N, but no eigenvectors are
C                     computed.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  QZHES, QZIT, QZVAL, QZVEC
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RGG
C
      INTEGER N,NM,IERR,MATZ
      REAL A(NM,*),B(NM,*),ALFR(*),ALFI(*),BETA(*),Z(NM,*)
      LOGICAL TF
C
C***FIRST EXECUTABLE STATEMENT  RGG
      IF (N .LE. NM) GO TO 10
      IERR = 10 * N
      GO TO 50
C
   10 IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      TF = .FALSE.
      CALL  QZHES(NM,N,A,B,TF,Z)
      CALL  QZIT(NM,N,A,B,0.0E0,TF,Z,IERR)
      CALL  QZVAL(NM,N,A,B,ALFR,ALFI,BETA,TF,Z)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 TF = .TRUE.
      CALL  QZHES(NM,N,A,B,TF,Z)
      CALL  QZIT(NM,N,A,B,0.0E0,TF,Z,IERR)
      CALL  QZVAL(NM,N,A,B,ALFR,ALFI,BETA,TF,Z)
      IF (IERR .NE. 0) GO TO 50
      CALL  QZVEC(NM,N,A,B,ALFR,ALFI,BETA,Z)
   50 RETURN
      END