! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
   PROGRAM GALAHAD_ROOTS_test_deck
   USE GALAHAD_ROOTS_double                       ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) ! set precision
   REAL ( KIND = wp ), PARAMETER :: one = 1.0_wp

   INTEGER :: order, type, nroots, status
   REAL ( KIND = wp ) :: tol, A( 0 : 4 ), ROOTS( 4 )
   REAL ( KIND = wp ) :: A1( 0 : 5 ), A2( 0: 2 ), ROOTS2( 1 )

   tol = EPSILON( one ) ** 0.75

   DO order = 2, 4
     DO type = 1, 2
       IF ( order == 2 ) THEN
         A( 0 ) = 2.01_wp
         A( 1 ) = - 3.01_wp
         A( 2 ) = 1.01_wp
         IF ( type == 2 ) A( 2 ) = 0.0_wp
       ELSE IF ( order == 3 ) THEN
         A( 0 ) = - 6.01_wp
         A( 1 ) = 11.01_wp
         A( 2 ) = -6.01_wp
         A( 3 ) = 1.01_wp
         IF ( type == 2 ) A( 3 ) = 0.0_wp
       ELSE
         IF ( type == 1 ) THEN
           A( 0 ) = 24.001_wp
           A( 1 ) = -50.001_wp
           A( 2 ) = 35.001_wp
           A( 3 ) = -10.001_wp
           A( 4 ) = 1.001_wp
         ELSE
           A( 0 ) = 1.00_wp
           A( 1 ) = -4.00_wp
           A( 2 ) = 6.00_wp
           A( 3 ) = -4.00_wp
           A( 4 ) = 1.00_wp
         END IF
       END IF

       IF ( type == 1 ) THEN
         IF ( order == 2 ) THEN
           WRITE( 6, "( /, ' Quadratic ' )" )
           CALL ROOTS_quadratic( A( 0 ), A( 1 ), A( 2 ), tol,                  &
             nroots, ROOTS( 1 ), ROOTS( 2 ) )
         ELSE IF ( order == 3 ) THEN
           WRITE( 6, "( /, ' Cubic ' )" )
           CALL ROOTS_cubic( A( 0 ), A( 1 ), A( 2 ), A( 3 ), tol,              &
             nroots, ROOTS( 1 ), ROOTS( 2 ), ROOTS( 3 ) )
         ELSE
           WRITE( 6, "( /, ' Quartic ' )" )
           CALL ROOTS_quartic( A( 0 ), A( 1 ), A( 2 ), A( 3 ), A( 4 ), tol,    &
             nroots, ROOTS( 1 ), ROOTS( 2 ), ROOTS( 3 ), ROOTS( 4 ) )
         END IF
       ELSE
         IF ( order == 2 ) THEN
           WRITE( 6, "( /, ' Quadratic ' )" )
           CALL ROOTS_solve( A( 0 : order ), tol, nroots,                     &
             ROOTS( : order ), status )
         ELSE IF ( order == 3 ) THEN
           WRITE( 6, "( /, ' Cubic ' )" )
           CALL ROOTS_solve( A( 0 : order ), tol, nroots,                     &
             ROOTS( : order ), status )
         ELSE
           WRITE( 6, "( /, ' Quartic ' )" )
           CALL ROOTS_solve( A( 0 : order ), tol, nroots,                     &
             ROOTS( : order ), status )
         END IF
       END IF
       IF ( nroots == 0 ) THEN
         WRITE( 6, "( ' no real roots ' )" )
       ELSE IF ( nroots == 1 ) THEN
         WRITE( 6, "( ' 1 real root ' )" )
       ELSE IF ( nroots == 2 ) THEN
         WRITE( 6, "( ' 2 real roots ' )" )
       ELSE IF ( nroots == 3 ) THEN
         WRITE( 6, "( ' 3 real roots ' )" )
       ELSE IF ( nroots == 4 ) THEN
         WRITE( 6, "( ' 4 real roots ' )" )
       END IF
       IF ( nroots /= 0 ) WRITE( 6, "( ' roots: ', 4ES12.4 )" ) ROOTS( : nroots )

     END DO
   END DO

!  Test for error exits

   WRITE(6,"( /, ' Tests for error exits ' )" )
   A1( 0 : 4 ) = A ; A1( 5 ) = 1.0_wp
   CALL ROOTS_solve( A1, tol, nroots, ROOTS, status )
   WRITE(6,"( ' Test 3: exit status ', I0 )" ) status
   A2 = A(  0 : 2 )
   CALL ROOTS_solve( A2, tol, nroots, ROOTS2, status )
   WRITE(6,"( ' Test 4: exit status ', I0 )" ) status

   STOP

   END PROGRAM GALAHAD_ROOTS_test_deck


real(kind=dp) function apfun(Peclet)

use kind_parameters
implicit none

! Calculating Ap using Power law scheme

real(kind=dp):: Peclet

Peclet = 1.0d0-0.1d0*dabs(Peclet)
!
apfun = max(0.0d0, (Peclet*Peclet*Peclet*Peclet*Peclet))
!apfun = max(0.0d0, 1.0d0 -0.50d0*dabs(Peclet))
end function


!  *********************************************************************
!  *                                                                   *
!  *                           function dcvab2                         *
!  *                                                                   *
!  *********************************************************************
!  Double Precision Version 1.6
!  Written by Gordon A. Fenton, TUNS, July 17, 1992
!  Latest Update: Apr 8, 2003
!
!  PURPOSE  returns the covariance between two 2-D local averages, one
!           having four times the area of the other. Used by LAS2G.
!
!  This function evaluates the covariance between two local averages in
!  2-dimensional space. One local average is assumed to be of size Dx x Dy
!  and the other of size 2*Dx x 2*Dy and they are separated in space by
!  a central distance having components Tx=C1*Dx and Ty=C2*Dy.
!
!  The covariance is obtained by a 16-pt Gaussian quadrature of a
!  4-D integral collapsed (by assuming the covariance function to be
!  quadrant symmetric) to a 2-D integral.
!  NOTE: if the covariance function is not quadrant symmetric, this
!        routine will return erroneous results. Quadrant symmetry means
!        that cov(X,Y) = cov(-X,Y) = cov(X,-Y) = cov(-X,-Y), where
!        cov(.,.) is the function returning the covariance between
!        points separated by lag (X,Y), as discussed next.
!
!  The covariance function is referenced herein using a call of the
!  form
!
!          V = cov( X, Y )
!
!  where X and Y are the lag distances between the points in the field.
!
!  Arguments to this function are as follows
!
!    cov       external covariance function provided by the user.
!
!    Dx        x-dimension of the smaller local average. (input)
!
!    Dy        y-dimension of the smaller local average. (input)
!
!    C1        x-direction distance between local average centers is C1*Dx.
!              (input)
!
!    C2        y-direction distance between local average centers is C2*Dy.
!              (input)
!
!  REVISION HISTORY:
!  1.1	eliminated unused local variable `zero' (Dec 5/96)
!  1.2	now including a Gaussian Quadrature integration option as an
!	alternative to the variance function approach to evaluate
!	covariances between local averages. Added `zero' back. (Jun 16/00)
!  1.3	now choose between Gauss Quadrature and var function approaches
!	to minimize numerical errors. Eliminated lvarfn. (Mar 27/01)
!  1.4	use Gauss quadrature unless intervals overlap (Apr 5/01)
!  1.5	use Gauss quadrature for everything (Apr 16/01)
!  1.51	removed unused abs statement function (Sep 21/01)
!  1.6	now use 16-pt Gauss quadrature for increased accuracy (Apr 8/02)
!---------------------------------------------------------------------------
      real*8 function dcvab2( cov, Dx, Dy, C1, C2 )
      parameter (NG = 16)
      implicit real*8 (a-h,o-z)
      dimension w(NG), z(NG)

      external cov

      data zero/0.d0/, sxt4th/0.015625d0/, quart/0.25d0/, half/0.5d0/
      data one/1.d0/, onept5/1.5d0/, two/2.d0/

!			these are for NG = 3
!     data w/0.555555555555556d0,.888888888888889d0,.555555555555556d0/
!     data z/-.774596669241483d0,.000000000000000d0,.774596669241483d0/

!			and these are for NG = 5
!     data w/ .236926885056189d0,.478628670499366d0,.568888888888889d0,
!    >        .478628670499366d0,.236926885056189d0/
!     data z/-.906179845938664d0,-.538469310105683d0,.000000000000000d0,
!    >        .538469310105683d0, .906179845938664d0/
!			these are for NG = 16
      data w/0.027152459411754094852d0, 0.062253523938647892863d0,    &
             0.095158511682492784810d0, 0.124628971255533872052d0,    &
             0.149595988816576732081d0, 0.169156519395002538189d0,    &
             0.182603415044923588867d0, 0.189450610455068496285d0,    &
             0.189450610455068496285d0, 0.182603415044923588867d0,    &
             0.169156519395002538189d0, 0.149595988816576732081d0,    &
             0.124628971255533872052d0, 0.095158511682492784810d0,    &
             0.062253523938647892863d0, 0.027152459411754094852d0/
      data z/-.989400934991649932596d0, -.944575023073232576078d0,    &
             -.865631202387831743880d0, -.755404408355003033895d0,    &
             -.617876244402643748447d0, -.458016777657227386342d0,    &
             -.281603550779258913230d0, -.095012509837637440185d0,    &
             0.095012509837637440185d0, 0.281603550779258913230d0,    &
             0.458016777657227386342d0, 0.617876244402643748447d0,    &
             0.755404408355003033895d0, 0.865631202387831743880d0,    &
             0.944575023073232576078d0, 0.989400934991649932596d0/

!					overlapping areas, GQ simplifies
!					to variance of larger area
      if( (C1 .lt. onept5) .and. (C2 .lt. onept5) ) then
         d1 = zero
         do 20 i = 1, NG
            xi = Dx*(one + z(i))
            d2 = zero
            do 10 j = 1, NG
               yi = Dy*(one + z(j))
               d2 = d2 + w(j)*(one-z(j))*cov(xi,yi)
  10        continue
            d1 = d1 + w(i)*(one-z(i))*d2
  20     continue
         dcvab2 = quart*d1
         return
      endif
!					otherwise, non-overlapping areas
      r1 = half*Dx
      r2 = half*Dy
      s2 = two*C1
      s1 = s2 - two
      s3 = s2 + two
      v2 = two*C2
      v1 = v2 - two
      v3 = v2 + two
      d1 = zero
      do 40 i = 1, NG
         xi1 = r1*(z(i) + s1)
         xi2 = r1*(z(i) + s2)
         xi3 = r1*(z(i) + s3)
         d21 = zero
         d22 = zero
         d23 = zero
         do 30 j = 1, NG
            yj1 = r2*(z(j) + v1)
            yj2 = r2*(z(j) + v2)
            yj3 = r2*(z(j) + v3)
            dz1 = one + z(j)
            dz2 = one - z(j)
            d21 = d21 + w(j)*(dz1*cov(xi1,yj1) + two*cov(xi1,yj2)    &
                             +dz2*cov(xi1,yj3))
            d22 = d22 + w(j)*(dz1*cov(xi2,yj1) + two*cov(xi2,yj2)    &
                             +dz2*cov(xi2,yj3))
            d23 = d23 + w(j)*(dz1*cov(xi3,yj1) + two*cov(xi3,yj2)    &
                             +dz2*cov(xi3,yj3))
  30     continue
         d1 = d1 + w(i)*((one+z(i))*d21 + two*d22 + (one-z(i))*d23)
  40  continue
      dcvab2 = sxt4th*d1

      return
      end


!----------------- BEGIN CL68_INTEGRAND -----------------------------
      function cl68_integrand(z)
! Dates: 06/09/95 - Written by D.M. Boore.  See 7/11/82 notes for
!                   stochastic model, with 6/9/95 addition that uses
!                   a variable transformation to remove the sqrt
!                   singularity at the origin.
!        01/03/95 - Name changed from cl_int to cl68_integrand
!        02/05/00 - Made changes suggested by C. Mueller to avoid
!                   possible numerical problem when "an" is large

      common /clint/ xi, an
!      real*8 y, dum

!      dum = 1.0d0-xi*dexp(-z**2)
!      y = an * dlog(dum)   ! Mueller modification
!      if (y .lt. -10.0d0**(-10)) then !based on machine epsilon for dble precsn
!        cl68_integrand = 0.0  ! or could let compiler deal with underflow
!      else
!        cl68_integrand = 2.0*(1.0d0-dexp(y))  ! Mueller modification
!      end if

      y = an * alog(1.0-xi*exp(-z**2))   ! Mueller modification
      cl68_integrand = 2.0*(1.0-exp(y))  ! Mueller modification

!      cl68_integrand = 2.0*(1.0-(1.0-xi*exp(-z**2))**an)  ! original

      return
      end
!----------------- END CL68_INTEGRAND -----------------------------


      subroutine sir(S, I, R, beta, gamma, dt)
        implicit none
        double precision S, I, R, beta, gamma, dt
        double precision infected, recovered

        infected = (-(beta*S*I) / (S + I + R)) * dt
        recovered = (gamma*I) * dt

        S = S - infected
        I = I + infected - recovered
        R = R + recovered
      end subroutine sir

C      program main
C      double precision, parameter :: S0 = 500, I0 = 10, R0 = 0
C      double precision, parameter :: beta = 0.5, gamma = 0.3, t = 1
C
C      call sir(S0, I0, R0, beta, gamma, t)
C      end program main


        subroutine Gaussmesh()
        use vaphfb_par
        implicit none

        integer k
        real*8 xxbet(AMP%NLEG_BET)
!+---------------------------------------------------------------------+
!   Gauss-Legendre integration points and weights                      |
!+---------------------------------------------------------------------+
!  2*pi*2*pi*2 = 8*pi**2
!  wwalp,wwbet,wwgam are defined in the above regions
!  .....................................................................

          if(.NOT. ALLOCATED(sdjmk)) &
     &    ALLOCATE(sdjmk(0:AMP%jjmax,0:AMP%jjmax*2,0:AMP%jjmax*2,0:AMP%NLEG_BET,0:1))

        if(AMP%NLEG_ALP.lt. 0 .or. AMP%NLEG_BET.lt. 0 .or. AMP%NLEG_GAM.lt. 0) &
     &  stop ' Mesh points in Euler angles are not set properly '

        if(.NOT. ALLOCATED(AMP%alpha))  ALLOCATE(AMP%alpha(1:AMP%NLEG_ALP))
        if(.NOT. ALLOCATED(AMP%beta))   ALLOCATE(AMP%beta(1:AMP%NLEG_BET))
        if(.NOT. ALLOCATED(AMP%gamma))  ALLOCATE(AMP%gamma(1:AMP%NLEG_GAM))
        if(.NOT. ALLOCATED(AMP%wwalp))  ALLOCATE(AMP%wwalp(1:AMP%NLEG_ALP))
        if(.NOT. ALLOCATED(AMP%wwbet))  ALLOCATE(AMP%wwbet(1:AMP%NLEG_BET))
        if(.NOT. ALLOCATED(AMP%wwgam))  ALLOCATE(AMP%wwgam(1:AMP%NLEG_GAM))
!      ...........Gauss-Legendre integration points and weights
        call gauleg(0.d0,2*pi, AMP%alpha,AMP%wwalp,AMP%NLEG_ALP)
        call gauleg(-1.d0,1.d0,xxbet,AMP%wwbet,AMP%NLEG_BET)
        call gauleg(0.d0,2*pi, AMP%gamma,AMP%wwgam,AMP%NLEG_GAM)

        do k=1,AMP%NLEG_BET
           AMP%beta(k) = dacos(xxbet(k))
        end do
!  ......................... a special case
        if(AMP%NLEG_ALP .eq. 1) then
           AMP%alpha(1)=0.d0
           AMP%wwalp(1) =1.d0
        endif
        if(AMP%NLEG_BET.eq. 1) then
           AMP%beta(1) =0.d0
           AMP%wwbet(1) =1.d0
        endif
        if(AMP%NLEG_GAM .eq. 1) then
           AMP%gamma(1)=0.d0
           AMP%wwgam(1) =1.d0
        endif

!          if(.NOT. ALLOCATED(ieuler_ang)) &
!     &    ALLOCATE(ieuler_ang(1:AMP%NLEG_ALP,1:AMP%NLEG_BET,1:AMP%NLEG_GAM))
!        NNLEG_ALP=NLEG_ALP
!        NNLEG_BET=NLEG_BET
!        NNLEG_GAM=NLEG_GAM
!
!  ..........................
!       do J=0,JJmax
!          weightJ(J) = (2.d0*J+1.d0)/2.d0 !(8.d0*pi)
!       enddo
!      .........................
        return
        end


program lib92_quad
    use, intrinsic :: iso_fortran_env, only: real64, dp => real64
    implicit none

    call setup
    call runtest

contains

    subroutine runtest
        use parameter_def
        use grid_C
        use tatb_C
        use quad_I

        real*8 :: real64_kind_
        integer, parameter :: real64 = kind(real64_kind_)
        integer, parameter :: dp = real64

        integer :: i
        real(real64) :: result

        ! Integrate exp(-2x) from 0 to infinity. Expected result is 1/2.
        do i = 1, NNN1
            TA(i) = exp(-2*R(i)) * RP(i)
        end do
        call quad(result)

        print *, "RESULT from QUAD", result
        print *, "expected        ", 0.5_dp
        print *, "difference      ", abs(result - 0.5_dp)

        if(abs(result - 0.5_dp) > 1e-12_dp) then
            stop 1
        end if
    end subroutine runtest

    subroutine setup
        use parameter_def
        use grid_C
        use tatb_C
        use setqic_I
        use radgrd_I

        H = 5.0D-2
        RNT = 2.0D-6
        HP = 0.0D0
        N = NNNP
        MTP = NNNP

        call setqic
        call radgrd
    end subroutine setup

end program lib92_quad


!=========================================================================================
!Copyright (c) 2009, The Regents of the University of Massachusetts, Amherst.
!Developed by E. Polizzi
!All rights reserved.
!
!Redistribution and use in source and binary forms, with or without modification,
!are permitted provided that the following conditions are met:
!
!1. Redistributions of source code must retain the above copyright notice, this list of conditions
!   and the following disclaimer.
!2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions
!   and the following disclaimer in the documentation and/or other materials provided with the distribution.
!3. Neither the name of the University nor the names of its contributors may be used to endorse or promote
!    products derived from this software without specific prior written permission.
!
!THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING,
!BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
!ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
!EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
!SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
!LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
!IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!==========================================================================================

subroutine sset_point_gauss_legendre(nbe,e,xe,we)
  !  Purpose
  !  =======
  !  GAUSS-LEGENDRE Quadrature ROUTINE- Return weight and coordinate of the e^th node from nbe total # nodes
  !
  !  SINGLE PRECISION version
  !
  !  Arguments
  !  =========
  !
  !  nbe        (input)        INTEGER: total # nodes for Gauss quadrature
  !  e          (input)        INTEGER: e^th node
  !  xe         (output)       REAL SINGLE PRECISION:  Gauss coordinate for node e
  !  we         (output)       REAL SINGLE PRECISION:  Gauss weight for node e
  !=====================================================================
  ! Eric Polizzi 2009
  ! ====================================================================
  implicit none
  integer :: nbe,e
  real :: xe,we
!!!!!!!!!!
  double precision ::dxe,dwe

  dxe=dble(xe)
  dwe=dble(we)

  call  dset_point_gauss_legendre(nbe,e,dxe,dwe)

  xe=real(dxe)
  we=real(dwe)

end subroutine sset_point_gauss_legendre

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine dset_point_gauss_legendre(nbe,e,xe,we)
  !  Purpose
  !  =======
  !  GAUSS-LEGENDRE Quadrature ROUTINE- Return weight and coordinate of the e^th node from nbe total # nodes
  !
  !  DOUBLE PRECISION version
  !
  !  Arguments
  !  =========
  !
  !  nbe        (input)        INTEGER: total # nodes for Gauss quadrature
  !  e          (input)        INTEGER: e^th node
  !  xe         (output)       REAL DOUBLE PRECISION:  Gauss coordinate for node e
  !  we         (output)       REAL DOUBLE PRECISION:  Gauss weight for node e
  !=====================================================================
  ! Eric Polizzi 2009
  ! ====================================================================
  implicit none
  integer :: nbe,e
  double precision :: xe,we
!!!!!!!!!!

  !! nbe=3
  select case(nbe)

  case(3)

     select case(e)
     case(1)
        we=8.0d0/9.0d0
        xe=0.0d0
     case(2)
        we=5.0d0/9.0d0
        xe=sqrt(3.0d0/5.0d0)
     case(3)
        we=5.0d0/9.0d0
        xe=-sqrt(3.0d0/5.0d0)
     end select

  case(4)

     select case(e)

     case(1,2)
        we=(18.0d0+sqrt(30.0d0))/36.0d0
        !6.52145154862546142644d-01
        xe=sqrt((3.0d0-2.0d0*sqrt(6.0d0/5.0d0))/7.0d0)
        !3.39981043584856264792d-01
     case(3,4)
        we=(18.0d0-sqrt(30.0d0))/36.0d0
        ! 3.47854845137453857383d-01
        xe=sqrt((3.0d0+2.0d0*sqrt(6.0d0/5.0d0))/7.0d0)
        !8.61136311594052575248d-01

     end select

     if (ibclr(e,0)==e) xe=-xe

  case(5)

     select case(e)
     case(1)
        we=128.0d0/225.0d0
        xe=0.0d0
     case(2,3)
        !      we=9.06179845938663992811d-01
        we=(322.0d0+13.0d0*sqrt(70.0d0))/900.0d0
        !     xe= 5.38469310105683091018d-01
        xe=(1.0d0/3.0d0)*sqrt(5.0d0-2.0d0*sqrt(10.0d0/7.0d0))
        if (e==3) xe=-xe
     case(4,5)
        !     we=2.36926885056189087515d-01
        we=(322.0d0-13.0d0*sqrt(70.0d0))/900.0d0
        !        xe=9.06179845938663992811d-01
        xe=(1.0d0/3.0d0)*sqrt(5.0d0+2.0d0*sqrt(10.0d0/7.0d0))
        if (e==5) xe=-xe
     end select

  case(6)

     select case(e)
     case(1,2)
        xe=6.61209386466264513688d-01
        we= 3.60761573048138607569d-01
     case(3,4)
        xe=2.38619186083196908630d-01
        we=4.67913934572691047389d-01
     case(5,6)
        xe=9.32469514203152027832d-01
        we=1.71324492379170345043d-01
     end select

     if (ibclr(e,0)==e) xe=-xe

  case(8)

     select case(e)
     case(1,2)
        xe=1.83434642495649804936d-01
        we=3.62683783378361982976d-01
     case(3,4)
        xe=5.25532409916328985830d-01
        we=3.13706645877887287338d-01
     case(5,6)
        xe=7.96666477413626739567d-01
        we=2.22381034453374470546d-01
     case(7,8)
        xe=9.60289856497536231661d-01
        we=1.01228536290376259154d-01
     end select

     if (ibclr(e,0)==e) xe=-xe

  case(10)

     select case(e)
     case(1,2)
        we=2.95524224714752870187d-01
        xe=1.48874338981631210881d-01
     case(3,4)
        we=2.69266719309996355105d-01
        xe=4.33395394129247190794d-01
     case(5,6)
        we=2.19086362515982044000d-01
        xe=6.79409568299024406207d-01
     case(7,8)
        we=1.49451349150580593150d-01
        xe=8.65063366688984510759d-01
     case(9,10)
        we=6.66713443086881375920d-02
        xe=9.73906528517171720066d-01
     end select

     if (ibclr(e,0)==e) xe=-xe

  case(12)

     select case(e)
     case(1,2)
        we=2.49147045813402785006d-01
        xe=1.25233408511468915478d-01
     case(3,4)
        we=2.33492536538354808758d-01
        xe=3.67831498998180193757d-01
     case(5,6)
        we=2.03167426723065921743d-01
        xe=5.87317954286617447312d-01
     case(7,8)
        we=1.60078328543346226338d-01
        xe=7.69902674194304687059d-01
     case(9,10)
        we=1.06939325995318430960d-01
        xe=9.04117256370474856682d-01
     case(11,12)
        we=4.71753363865118271952d-02
        xe=9.81560634246719250712d-01

     end select

     if (ibclr(e,0)==e) xe=-xe

  case(16)

     select case(e)
     case(1,2)
        we=1.89450610455068496287d-01
        xe=9.50125098376374401877d-02
     case(3,4)
        we=1.82603415044923588872d-01
        xe=2.81603550779258913231d-01
     case(5,6)
        we=1.69156519395002538183d-01
        xe=4.58016777657227386350d-01
     case(7,8)
        we=1.49595988816576732080d-01
        xe=6.17876244402643748452d-01
     case(9,10)
        we=1.24628971255533872056d-01
        xe=7.55404408355003033891d-01
     case(11,12)
        we=9.51585116824927848073d-02
        xe=8.65631202387831743866d-01
     case(13,14)
        we=6.22535239386478928628d-02
        xe=9.44575023073232576090d-01
     case(15,16)
        we=2.71524594117540948514d-02
        xe=9.89400934991649932601d-01
     end select

     if (ibclr(e,0)==e) xe=-xe

  case(20)

     select case(e)
     case(1,2)
        we=1.52753387130725850699d-01
        xe=7.65265211334973337513d-02
     case(3,4)
        we=1.49172986472603746785d-01
        xe=2.27785851141645078076d-01
     case(5,6)
        we=1.42096109318382051326d-01
        xe=3.73706088715419560662d-01
     case(7,8)
        we=1.31688638449176626902d-01
        xe=5.10867001950827097985d-01
     case(9,10)
        we=1.18194531961518417310d-01
        xe=6.36053680726515025467d-01
     case(11,12)
        we=1.01930119817240435039d-01
        xe=7.46331906460150792634d-01
     case(13,14)
        we=8.32767415767047487264d-02
        xe=8.39116971822218823420d-01
     case(15,16)
        we=6.26720483341090635663d-02
        xe=9.12234428251325905857d-01
     case(17,18)
        we=4.06014298003869413320d-02
        xe=9.63971927277913791287d-01
     case(19,20)
        we=1.76140071391521183115d-02
        xe=9.93128599185094924776d-01

     end select

     if (ibclr(e,0)==e) xe=-xe

  case(24)

     select case(e)
     case(1,2)
        we=1.27938195346752156976d-01
        xe=6.40568928626056260827d-02
     case(3,4)
        we=1.25837456346828296117d-01
        xe=1.91118867473616309153d-01
     case(5,6)
        we=1.21670472927803391202d-01
        xe=3.15042679696163374398d-01
     case(7,8)
        we=1.15505668053725601353d-01
        xe=4.33793507626045138478d-01
     case(9,10)
        we=1.07444270115965634785d-01
        xe=5.45421471388839535649d-01
     case(11,12)
        we=9.76186521041138882720d-02
        xe=6.48093651936975569268d-01
     case(13,14)
        we=8.61901615319532759152d-02
        xe=7.40124191578554364260d-01
     case(15,16)
        we=7.33464814110803057346d-02
        xe=8.20001985973902921981d-01
     case(17,18)
        we=5.92985849154367807461d-02
        xe=8.86415527004401034190d-01
     case(19,20)
        we=4.42774388174198061695d-02
        xe=9.38274552002732758539d-01
     case(21,22)
        we=2.85313886289336631809d-02
        xe=9.74728555971309498199d-01
     case(23,24)
        we=1.23412297999871995469d-02
        xe=9.95187219997021360195d-01
     end select

     if (ibclr(e,0)==e) xe=-xe

  case(32)

     select case(e)
     case(1,2)
        we=9.65400885147278005666d-02
        xe=4.83076656877383162364d-02
     case(3,4)
        we=9.56387200792748594185d-02
        xe=1.44471961582796493484d-01
     case(5,6)
        we=9.38443990808045656367d-02
        xe=2.39287362252137074544d-01
     case(7,8)
        we=9.11738786957638847129d-02
        xe=3.31868602282127649782d-01
     case(9,10)
        we=8.76520930044038111450d-02
        xe=4.21351276130635345353d-01
     case(11,12)
        we=8.33119242269467552223d-02
        xe=5.06899908932229390044d-01
     case(13,14)
        we=7.81938957870703064685d-02
        xe=5.87715757240762329066d-01
     case(15,16)
        we=7.23457941088485062287d-02
        xe=6.63044266930215200960d-01
     case(17,18)
        we=6.58222227763618468406d-02
        xe=7.32182118740289680412d-01
     case(19,20)
        we=5.86840934785355471448d-02
        xe=7.94483795967942406965d-01
     case(21,22)
        we=5.09980592623761761959d-02
        xe=8.49367613732569970160d-01
     case(23,24)
        we=4.28358980222266806557d-02
        xe=8.96321155766052123971d-01
     case(25,26)
        we=3.42738629130214331033d-02
        xe=9.34906075937739689159d-01
     case(27,28)
        we=2.53920653092620594561d-02
        xe=9.64762255587506430761d-01
     case(29,30)
        we=1.62743947309056706058d-02
        xe=9.85611511545268335400d-01
     case(31,32)
        we=7.01861000947009660028d-03
        xe=9.97263861849481563534d-01
     end select

     if (ibclr(e,0)==e) xe=-xe

  case(40)

     select case(e)
     case(1,2)
        we=7.75059479784248112668d-02
        xe=3.87724175060508219329d-02
     case(3,4)
        we=7.70398181642479655914d-02
        xe=1.16084070675255208481d-01
     case(5,6)
        we=7.61103619006262423723d-02
        xe=1.92697580701371099719d-01
     case(7,8)
        we=7.47231690579682641980d-02
        xe=2.68152185007253681152d-01
     case(9,10)
        we=7.28865823958040590609d-02
        xe=3.41994090825758473008d-01
     case(11,12)
        we=7.06116473912867796979d-02
        xe=4.13779204371605001525d-01
     case(13,14)
        we=6.79120458152339038265d-02
        xe=4.83075801686178712903d-01
     case(15,16)
        we=6.48040134566010380719d-02
        xe=5.49467125095128202056d-01
     case(17,18)
        we=6.13062424929289391679d-02
        xe=6.12553889667980237972d-01
     case(19,20)
        we=5.74397690993915513665d-02
        xe=6.71956684614179548364d-01
     case(21,22)
        we=5.32278469839368243566d-02
        xe=7.27318255189927103277d-01
     case(23,24)
        we=4.86958076350722320604d-02
        xe=7.78305651426519387712d-01
     case(25,26)
        we=4.38709081856732719923d-02
        xe=8.24612230833311663197d-01
     case(27,28)
        we=3.87821679744720176413d-02
        xe=8.65959503212259503824d-01
     case(29,30)
        we=3.34601952825478473933d-02
        xe=9.02098806968874296732d-01
     case(31,32)
        we=2.79370069800234010984d-02
        xe=9.32812808278676533383d-01
     case(33,34)
        we=2.22458491941669572615d-02
        xe=9.57916819213791655824d-01
     case(35,36)
        we=1.64210583819078887131d-02
        xe=9.77259949983774262679d-01
     case(37,38)
        xe=9.90726238699457006464d-01
        we=1.04982845311528136146d-02
     case(39,40)
        we=4.52127709853319125846d-03
        xe=9.98237709710559200369d-01
     end select

     if (ibclr(e,0)==e) xe=-xe

  case(48)

     select case(e)
     case(1,2)
        we=6.47376968126839225006d-02
        xe=3.23801709628693620343d-02
     case(3,4)
        we=6.44661644359500822082d-02
        xe=9.70046992094626989322d-02
     case(5,6)
        we=6.39242385846481866207d-02
        xe=1.61222356068891718055d-01
     case(7,8)
        we=6.31141922862540256548d-02
        xe=2.24763790394689061224d-01
     case(9,10)
        we=6.20394231598926639029d-02
        xe=2.87362487355455576728d-01
     case(11,12)
        we=6.07044391658938800517d-02
        xe=3.48755886292160738148d-01
     case(13,14)
        we=5.91148396983956357477d-02
        xe=4.08686481990716729925d-01
     case(15,16)
        we=5.72772921004032157044d-02
        xe=4.66902904750958404535d-01
     case(17,18)
        we=5.51995036999841628676d-02
        xe=5.23160974722233033658d-01
     case(19,20)
        we=5.28901894851936670964d-02
        xe=5.77224726083972703838d-01
     case(21,22)
        we=5.03590355538544749590d-02
        xe=6.28867396776513624013d-01
     case(23,24)
        we=4.76166584924904748267d-02
        xe=6.77872379632663905208d-01
     case(25,26)
        we=4.46745608566942804201d-02
        xe=7.24034130923814654658d-01
     case(27,28)
        we=4.15450829434647492133d-02
        xe=7.67159032515740339276d-01
     case(29,30)
        we=3.82413510658307063158d-02
        xe=8.07066204029442627087d-01
     case(31,32)
        we=3.47772225647704388909d-02
        xe=8.43588261624393530704d-01
     case(33,34)
        we=3.11672278327980889025d-02
        xe=8.76572020274247885885d-01
     case(35,36)
        we=2.74265097083569482001d-02
        xe=9.05879136715569672805d-01
     case(37,38)
        we=2.35707608393243791410d-02
        xe=9.31386690706554333107d-01
     case(39,40)
        we=1.96161604573555278142d-02
        xe=9.52987703160430860724d-01
     case(41,42)
        we=1.55793157229438487279d-02
        xe=9.70591592546247250472d-01
     case(43,44)
        we=1.14772345792345394895d-02
        xe=9.84124583722826857765d-01
     case(45,46)
        we=7.32755390127626210220d-03
        xe=9.93530172266350757526d-01
     case(47,48)
        we=3.15334605230583863260d-03
        xe=9.98771007252426118580d-01

     end select

     if (ibclr(e,0)==e) xe=-xe

  end select!!!!!!!!!!!!!!!!!!!!!!! nbe

end subroutine dset_point_gauss_legendre
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


      subroutine r8mkspline(x,nx,fspl,ibcxmin,bcxmin,ibcxmax,bcxmax,
     >   ilinx,ier)
C
C  make a 2-coefficient 1d spline
C
C  only 2 coefficients, the data and its 2nd derivative, are needed to
C  fully specify a spline.  See e.g. Numerical Recipies in Fortran-77
C  (2nd edition) chapter 3, section on cubic splines.
C
C  input:
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER i,inwk
!============
! idecl:  explicitize implicit REAL declarations:
      REAL*8 bcxmax
!============
      integer nx                        ! no. of data points
      REAL*8 x(nx)                        ! x axis data, strict ascending order
C
C  input/output:
      REAL*8 fspl(2,nx)                   ! f(1,*):  data in; f(2,*):  coeffs out
C
C     f(1,j) = f(x(j))  on input (unchanged on output)
C     f(2,j) = f''(x(j)) (of interpolating spline) (on output).
C
C  ...boundary conditions...
C
C  input:
C
      integer ibcxmin                   ! b.c. flag @ x=xmin=x(1)
      REAL*8 bcxmin                       ! b.c. data @xmin
C
      integer ibcxmax                   ! b.c. flag @ x=xmax=x(nx)
      REAL*8 bcxcmax                      ! b.c. data @xmax
C
C  ibcxmin=-1 -- periodic boundary condition
C                (bcxmin,ibcxmax,bcxmax are ignored)
C
C                the output spline s satisfies
C                s'(x(1))=s'(x(nx)) ..and.. s''(x(1))=s''(x(nx))
C
C  if non-periodic boundary conditions are used, then the xmin and xmax
C  boundary conditions can be specified independently:
C
C  ibcxmin (ibcxmax) = 0 -- this specifies a "not a knot" boundary
C                condition, see "cubsplb.for".  This is a common way
C                for inferring a "good" spline boundary condition
C                automatically from data in the vicinity of the
C                boundary.  ... bcxmin (bcxmax) are ignored.
C
C  ibcxmin (ibcxmax) = 1 -- boundary condition is to have s'(x(1))
C                ( s'(x(nx)) ) match the passed value bcxmin (bcxmax).
C
C  ibcxmin (ibcxmax) = 2 -- boundary condition is to have s''(x(1))
C                ( s''(x(nx)) ) match the passed value bcxmin (bcxmax).
C
C  ibcxmin (ibcxmax) = 3 -- boundary condition is to have s'(x(1))=0.0
C                ( s'(x(nx))=0.0 )
C
C  ibcxmin (ibcxmax) = 4 -- boundary condition is to have s''(x(1))=0.0
C                ( s''(x(nx))=0.0 )
C
C  ibcxmin (ibcxmax) = 5 -- boundary condition is to have s'(x(1))
C                ( s'(x(nx)) ) match the 1st divided difference
C                e.g. at x(1):  d(1)/h(1), where
C                           d(j)=f(1,j+1)-f(1,j)
C                           h(j)=x(j+1)-x(j)
C
C  ibcxmin (ibcxmax) = 6 -- BC is to have s''(x(1)) ( s''(x(nx)) )
C                match the 2nd divided difference
C                e.g. at x(1):
C                     e(1) = [d(2)/h(2) - d(1)/h(1)]/(0.5*(h(1)+h(2)))
C
C  ibcxmin (ibcxmax) = 7 -- BC is to have s'''(x(1)) ( s'''(x(nx)) )
C                match the 3rd divided difference
C                e.g. at x(1): [e(2)-e(1)]/(0.33333*(h(1)+h(2)+h(3)))
C
C  output:
C
      integer ilinx                     ! =1: hint, x axis is ~evenly spaced
C
C  let dx[avg] = (x(nx)-x(1))/(nx-1)
C  let dx[j] = x(j+1)-x(j), for all j satisfying 1.le.j.lt.nx
C
C  if for all such j, abs(dx[j]-dx[avg]).le.(1.0e-3*dx[avg]) then
C  ilinx=1 is returned, indicating the data is (at least nearly)
C  evenly spaced.  Even spacing is useful, for speed of zone lookup,
C  when evaluating a spline.
C
C  if the even spacing condition is not satisfied, ilinx=2 is returned.
C
      integer ier                       ! exit code, 0=OK
C
C  an error code is returned if the x axis is not strict ascending,
C  or if nx.lt.4, or if an invalid boundary condition specification was
C  input.
C
C------------------------------------
C
C  this routine calls traditional 4 coefficient spline software, and
C  translates the result to 2 coefficient form.
C
C  this could be done more efficiently but we decided out of conservatism
C  to use the traditional software.
C
C------------------------------------
C  workspaces -- f90 dynamically allocated
C
      REAL*8, dimension(:,:), allocatable :: fspl4 ! traditional 4-spline
      REAL*8, dimension(:), allocatable :: wk ! cspline workspace
C
C------------------------------------
C
      allocate(fspl4(4,nx),wk(nx))
C
C  make the traditional call
C
      do i=1,nx
         fspl4(1,i)=fspl(1,i)
         fspl(2,i)=0.0_r8  ! for now
      enddo
C
      inwk=nx
C
C  boundary conditions imposed by cspline...
C
      call r8cspline(x,nx,fspl4,ibcxmin,bcxmin,ibcxmax,bcxmax,
     >   wk,inwk,ilinx,ier)
C
      if(ier.eq.0) then
C
C  copy the output -- careful of end point.
C
         do i=1,nx-1
            fspl(2,i)=2.0_r8*fspl4(3,i)
         enddo
         fspl(2,nx)=2.0_r8*fspl4(3,nx-1) +
     >        (x(nx)-x(nx-1))*6.0_r8*fspl4(4,nx-1)
      endif
C
      deallocate(fspl4,wk)
C
      return
      end


C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C          PROGRAM TO ILLUSTRATE THE USE OF SUBROUTINE HWSCYL TO SOLVE
C     THE EQUATION
C
C     (1/R)(D/DR)(R*(DU/DR)) + (D/DZ)(DU/DZ)
C
C     = (2*R*Z)**2*(4*Z**2 + 3*R**2)
C
C     ON THE RECTANGLE 0 .LT. R .LT. 1, 0 .LT. Z .LT. 1 WITH THE
C     BOUNDARY CONDITIONS
C
C     U(0,Z) UNSPECIFIED
C                                            0 .LE. Z .LE. 1
C     (DU/DR)(1,Z) = 4*Z**4
C
C     AND
C
C     (DU/DZ)(R,0) = 0
C                                            0 .LE. R .LE. 1
C     (DU/DZ)(R,1) = 4*R**4 .
C
C          THE R-INTERVAL WILL BE DIVIDED INTO 50 PANELS AND THE
C     Z-INTERVAL WILL BE DIVIDED INTO 100 PANELS.
C
      DIMENSION       F(75,105)  ,BDA(101)   ,BDB(101)   ,BDC(51)    ,
     1                BDD(51)    ,W(1373)    ,R(51)      ,Z(101)
C
C     FROM DIMENSION STATEMENT WE GET VALUE OF IDIMF.  ALSO NOTE THAT W
C     IS DIMENSIONED 4*(N+1) + (13 + INT(LOG2(N+1)))*(M+1) .
C
      IDIMF = 75
      A = 0.
      B = 1.
      M = 50
      MBDCND = 6
      C = 0.
      D = 1.
      N = 100
      NBDCND = 3
      ELMBDA = 0.
C
C     AUXILIARY QUANTITIES.
C
      MP1 = M+1
      NP1 = N+1
C
C     GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING
C     BOUNDARY DATA AND THE RIGHT SIDE OF THE POISSON EQUATION.
C
      DO 101 I=1,MP1
         R(I) = FLOAT(I-1)/50.
  101 CONTINUE
      DO 102 J=1,NP1
         Z(J) = FLOAT(J-1)/100.
  102 CONTINUE
C
C     GENERATE BOUNDARY DATA.
C
      DO 103 J=1,NP1
         BDB(J) = 4.*Z(J)**4
  103 CONTINUE
      DO 104 I=1,MP1
         BDC(I) = 0.
         BDD(I) = 4.*R(I)**4
  104 CONTINUE
C
C     BDA IS A DUMMY VARIABLE.
C
C
C     GENERATE RIGHT SIDE OF EQUATION.
C
      DO 106 I=1,MP1
         DO 105 J=1,NP1
            F(I,J) = 4.*R(I)**2*Z(J)**2*(4.*Z(J)**2+3.*R(I)**2)
  105    CONTINUE
  106 CONTINUE
      CALL HWSCYL (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,ELMBDA,F,
     1             IDIMF,PERTRB,IERROR,W)
C
C     COMPUTE DISCRETIZATION ERROR BY MINIMIZING OVER ALL A THE FUNCTION
C     NORM(F(I,J) - A*1 - U(R(I),Z(J))).  THE EXACT SOLUTION IS
C                U(R,Z) = (R*Z)**4 + ARBITRARY CONSTANT.
C
      X = 0.
      DO 108 I=1,MP1
         DO 107 J=1,NP1
            X = X+F(I,J)-(R(I)*Z(J))**4
  107    CONTINUE
  108 CONTINUE
      X = X/FLOAT(NP1*MP1)
      DO 110 I=1,MP1
         DO 109 J=1,NP1
            F(I,J) = F(I,J)-X
  109    CONTINUE
  110 CONTINUE
      ERR = 0.
      DO 112 I=1,MP1
         DO 111 J=1,NP1
            X = ABS(F(I,J)-(R(I)*Z(J))**4)
            IF (X .GT. ERR) ERR = X
  111    CONTINUE
  112 CONTINUE
      PRINT 1001 , IERROR,PERTRB,ERR,W(1)
      STOP IERROR
C
 1001 FORMAT (1H1,20X,25HSUBROUTINE HWSCYL EXAMPLE///
     1        10X,46HTHE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS//
     2        32X,10HIERROR = 0/32X,20HPERTRB = 2.26734E-04/
     3        18X,34HDISCRETIZATION ERROR = 3.73672E-04/
     4        12X,33HREQUIRED LENGTH OF W ARRAY = 1118//
     5        10X,32HTHE OUTPUT FROM YOUR COMPUTER IS//
     6        32X,8HIERROR =,I2/32X,8HPERTRB =,E12.5/
     7        18X,22HDISCRETIZATION ERROR =,E12.5/
     8        12X,28HREQUIRED LENGTH OF W ARRAY =,F5.0)
C
      END


program ex23

    use utils

    implicit none

    real(rk) :: A(5,10)
    real(rk) :: B(5,10)
    integer :: i, j

    call initRand()
    call randMat(A, -1.0_rk, 1.0_rk)
    call printMatrix(A, 'A')

    B = cos(A)

    call printMatrix(B, 'B')

end program ex23


! THIS VERSION: GALAHAD 2.1 - 27/10/2007 AT 15:00 GMT.
   PROGRAM GALAHAD_GLRT_test_deck
   USE GALAHAD_GLRT_DOUBLE                            ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: working = KIND( 1.0D+0 ) ! set precision
   REAL ( KIND = working ), PARAMETER :: zero = 0.0_working
   REAL ( KIND = working ), PARAMETER :: one = 1.0_working, two = 2.0_working
   INTEGER, PARAMETER :: n = 100                  ! problem dimension
   INTEGER :: i, nn, pass
   REAL ( KIND = working ) :: sigma, eps, p
!  REAL ( KIND = working ) :: f
   REAL ( KIND = working ), DIMENSION( n ) :: X, R, VECTOR, H_vector, O
   REAL ( KIND = working ), DIMENSION( 0 ) :: X0, R0, VECTOR0
   TYPE ( GLRT_data_type ) :: data
   TYPE ( GLRT_control_type ) :: control
   TYPE ( GLRT_inform_type ) :: inform

!  ==============
!  Normal entries
!  ==============

   WRITE( 6, "( /, ' ==== normal exits ====== ', / )" )

! Initialize control parameters

   OPEN( UNIT = 23, STATUS = 'SCRATCH' )
!  OPEN( UNIT = 23 )
   DO pass = 1, 14
      IF ( pass /= 4 .AND. pass /= 7 .AND. pass /= 8 )                         &
           CALL GLRT_initialize( data, control )
      control%error = 23 ; control%out = 23 ; control%print_level = 10
      inform%status = 1
      p = 3.0_working
      sigma = one ; eps = zero
      IF ( pass == 2 ) control%unitm = .FALSE. ; sigma = 1000.0_working
      IF ( pass == 4 ) THEN
           sigma = sigma / two ; inform%status = 6
      END IF
      IF ( pass == 5 ) sigma = 0.0001_working
      IF ( pass == 7 ) THEN
         sigma = 0.1_working ; inform%status = 6
      END IF
      IF ( pass == 8 ) THEN
         sigma = 100.0_working ; inform%status = 6
      END IF
      IF ( pass == 9 ) sigma = 10.0_working
      IF ( pass == 10 ) sigma = 10.0_working
      IF ( pass == 11 ) sigma = 10000.0_working
      IF ( pass == 12 .OR. pass == 14 ) eps = one
      IF ( pass == 13 .OR. pass == 14 ) O = one

      IF ( pass == 10 .OR. pass == 11 ) THEN
         R( : n - 1 ) = 0.000000000001_working ; R( n ) = one
      ELSE
         R = one
      END IF
!      IF ( pass == 13 .OR. pass == 14 ) THEN
!       control%error = 6 ; control%out = 6 ; control%print_level = 1
!      END IF

!  Iteration to find the minimizer

      DO
         IF ( pass == 14 ) THEN
           CALL GLRT_solve( n, p, sigma, X, R, VECTOR, data, control,         &
                            inform, eps = eps, O = O )
         ELSE IF ( pass == 13 ) THEN
           CALL GLRT_solve( n, p, sigma, X, R, VECTOR, data, control,         &
                            inform, O = O )
         ELSE IF ( pass == 12 ) THEN
           CALL GLRT_solve( n, p, sigma, X, R, VECTOR, data, control,         &
                            inform, eps = eps )
         ELSE
           CALL GLRT_solve( n, p, sigma, X, R, VECTOR, data, control,         &
                            inform )
         END IF

! Branch as a result of inform%status

         SELECT CASE( inform%status )

!  Form the preconditioned gradient

         CASE( 2 )
            VECTOR = VECTOR / two

!  Form the matrix-vector product

         CASE ( 3 )
            IF ( pass == 2 .OR. pass == 6 .OR. pass == 7 .OR. pass == 8 ) THEN
               H_vector( 1 ) =  two * VECTOR( 1 ) + VECTOR( 2 )
               DO i = 2, n - 1
                 H_vector( i ) = VECTOR( i - 1 ) + two * VECTOR( i ) +         &
                                 VECTOR( i + 1 )
               END DO
               H_vector( n ) = VECTOR( n - 1 ) + two * VECTOR( n )
            ELSE IF ( pass == 9 ) THEN
               H_vector( 1 ) = VECTOR( 1 ) + VECTOR( 2 )
               DO i = 2, n - 1
                 H_vector( i ) = VECTOR( i - 1 ) - two * VECTOR( i ) +         &
                                 VECTOR( i + 1 )
               END DO
               H_vector( n ) = VECTOR( n - 1 ) + VECTOR( n )
            ELSE IF ( pass == 10 .OR. pass == 11 ) THEN
              H_vector( 1 ) = - two * VECTOR( 1 )
              H_vector( 2 : n - 1 ) = 0.0001_working * VECTOR( 2 : n - 1 )
              H_vector( n ) = - VECTOR( n )
            ELSE
               H_vector( 1 ) = - two * VECTOR( 1 ) + VECTOR( 2 )
               DO i = 2, n - 1
                 H_vector( i ) = VECTOR( i - 1 ) - two * VECTOR( i ) +         &
                                 VECTOR( i + 1 )
               END DO
               H_vector( n ) = VECTOR( n - 1 ) - two * VECTOR( n )
            END IF
            VECTOR = H_vector

!  Restart

         CASE ( 4 )
            IF ( pass == 10 .OR. pass == 11 ) THEN
               R( : n - 1 ) = 0.000000000001_working
               R( n ) = one
            ELSE
               R = one
            END IF

!  Form the product with the preconditioner

         CASE( 5 )
            VECTOR = two * VECTOR

!  Successful return

         CASE ( - 2 : 0 )
            EXIT

!  Error returns

         CASE DEFAULT
            EXIT
         END SELECT
      END DO

      WRITE( 6, "( ' pass ', I3, ' GLRT_solve exit status = ', I6 )" )         &
             pass, inform%status
!     WRITE( 6, "( ' its, solution and Lagrange multiplier = ', I6, 2ES12.4 )")&
!               inform%iter + inform%iter_pass2, f, inform%multiplier
      IF ( pass /= 3 .AND. pass /= 6 .AND. pass /= 7 )                         &
        CALL GLRT_terminate( data, control, inform ) !  delete internal workspace
   END DO

!  =============
!  Error entries
!  =============

   WRITE( 6, "( /, ' ==== error exits ====== ', / )" )

! Initialize control parameters

   DO pass = 2, 9
      sigma = one
      eps = zero
      p = 3.0_working
      CALL GLRT_initialize( data, control )
      control%error = 23 ; control%out = 23 ; control%print_level = 10
      inform%status = 1
      nn = n
      IF ( pass == 2 ) control%itmax = 0
      IF ( pass == 3 ) inform%status = 0
      IF ( pass == 4 ) nn = 0
      IF ( pass == 5 ) sigma = - one
      IF ( pass == 6 ) CYCLE
      IF ( pass == 7 ) eps = - one
      IF ( pass == 8 ) p = one
      IF ( pass == 9 ) p = two
      IF ( pass == 9 ) control%unitm = .FALSE.

      R = one

!  Iteration to find the minimizer

      DO
         IF ( pass == 4 ) THEN
           CALL GLRT_solve( nn, p, sigma, X0, R0,                          &
                            VECTOR0, data, control, inform )
         ELSE IF ( pass == 7 ) THEN
           CALL GLRT_solve( nn, p, sigma, X( : nn ), R( : nn ),            &
                            VECTOR( : nn ), data, control, inform, eps = eps )
         ELSE
           CALL GLRT_solve( nn, p, sigma, X( : nn ), R( : nn ),            &
                            VECTOR( : nn ), data, control, inform )
         END IF

! Branch as a result of inform%status

         SELECT CASE( inform%status )

!  Form the preconditioned gradient

         CASE( 2 )
            IF ( pass /= 3 ) THEN
               VECTOR = VECTOR / two
            ELSE
               VECTOR = - VECTOR / two
            END IF

!  Form the matrix-vector product

         CASE ( 3 )
            H_vector( 1 ) = - two * VECTOR( 1 ) + VECTOR( 2 )
            DO i = 2, n - 1
              H_vector( i ) = VECTOR( i - 1 ) - two * VECTOR( i ) +         &
                              VECTOR( i + 1 )
            END DO
            H_vector( n ) = VECTOR( n - 1 ) - two * VECTOR( n )
            VECTOR = H_vector

!  Restart

         CASE ( 4 )
            R = one

!  Form the product with the preconditioner

         CASE( 5 )
            IF ( pass /= 3 ) THEN
               VECTOR = two * VECTOR
            ELSE
               VECTOR = - two * VECTOR
            END IF

!  Successful return

         CASE ( - 2 : 0 )
            EXIT

!  Error returns

         CASE DEFAULT
            EXIT
         END SELECT
      END DO

      WRITE( 6, "( ' pass ', I3, ' GLRT_solve exit status = ', I6 )" )         &
             pass, inform%status
      CALL GLRT_terminate( data, control, inform ) !  delete internal workspace
   END DO
   CLOSE( unit = 23 )

!  STOP
   END PROGRAM GALAHAD_GLRT_test_deck


submodule(euler_interface_m) euler_prob_0009_m
    implicit none

contains

    module character(len=20) function euler0009()
        write (euler0009, "(i20)") ans(1000)
    end function euler0009

    integer function ans(n)
        integer, intent(in) :: n
        integer :: a, b, c

        ans = 0
        outer: do a = 1, n
            inner: do b = a + 1, n
                c = n - a - b
                if (a**2 + b**2 == c**2) then
                    ans = a*b*c
                    return
                end if
            end do inner
        end do outer
    end function ans

end submodule euler_prob_0009_m


program test_expBesselI

    use bessel_mod
    use constants
    use netcdf
    use check_mod

    implicit none

    integer :: nPts, lMax, lMaxTmp, iErr, i, j, lOut
    integer, allocatable :: l(:)
    complex(kind=dbl), allocatable :: z(:,:), besselI(:), &
        expBesselI(:), expBesselIPrime(:), expBesselIOverGam(:)
    real :: dz, zMax
    complex, allocatable :: res(:,:), expRes(:,:)
    character(len=100) :: fName
    complex(kind=dbl) :: zLarge, zExtraLarge, zExtraSmall

    integer :: nc_id, n_id, res_re_id, res_im_id, &
        z_re_id, z_im_id, expres_re_id, expres_im_id

    lMax = 20
    lOut = 20
    nPts = 201
    allocate ( z(nPts,nPts), res(nPts,nPts), expRes(nPts,nPts) )
    allocate ( l(-lMax:lMax) )

    zMax = 10.0
    dz  = zMax * 2.0 / (nPts - 1)
    do i=1,nPts
        do j=1,nPts

            z(i,j)   = complex ( (i-1)*dz - zMax, (j-1)*dz - zMax )

        enddo
    enddo

    ! I_l(z) and exp(-z) * I_l(z) for small z values
    ! ----------------------------------------------

    allocate ( besselI(lMax+1), &
                expBesselI(lMax+1), &
                expBesselIPrime(lMax+1), &
                expBesselIOverGam(lMax+1) )

    do i=1,nPts
        do j=1,nPts

            lMaxTmp = lMax
            call besic ( z(i,j), lMaxTmp, besselI, iErr)

            if(iErr/=0) then
                    write(*,*) 'ERROR: iErr'
                    stop
            endif

            res(i,j)    = besselI(lOut+1)
            expRes(i,j) = exp ( -z(i,j) ) * res(i,j)

        enddo
    enddo

    ! I_l(z) and exp(-z) * I_l(z) for large z values
    ! ----------------------------------------------

    zLarge  = complex ( 7.0, 7.0 )
    call besIExp ( zLarge, lMax, expBesselI, expBesselIPrime, expBesselIOverGam )

    write(*,*) zLarge, expBesselI(lOut+1), expBesselIPrime(lOut+1)

    ! exp(-z) * I_l(z) for Re(z) < 1e-8
    ! ------------------------------

    zExtraSmall  = complex ( 1d-9, 1d-9 )
    lMaxTmp = lMax
    call bes_expand ( zExtraSmall, lMaxTmp, expBesselI, expBesselIPrime, expBesselIOverGam )

    write(*,*) zExtraSmall, expBesselI(lOut+1), expBesselIPrime(lOut+1), expBesselIOverGam(lOut+1)

    ! exp(-z) * I_l(z) for |z| > 700
    ! ------------------------------

    zExtraLarge  = complex ( 900, 900 )
    call besIExp ( zExtraLarge, lMax, expBesselI, expBesselIPrime, expBesselIOverGam )

    write(*,*) zExtraLarge, expBesselI(lOut+1), expBesselIPrime(lOut+1)

    ! write value to file for plotting in IDL and comparing
    ! to mathematica solutions
    ! -----------------------------------------------------

    fName = 'test_expBesselI.nc'
    call check ( nf90_create ( fName, nf90_clobber, nc_id ) )
    call check ( nf90_def_dim ( nc_id, "nPts", nPts, n_id ) )

    call check ( nf90_def_var ( nc_id, "res_re", nf90_real, &
        (/n_id,n_id/), res_re_id ) )
    call check ( nf90_def_var ( nc_id, "res_im", nf90_real, &
        (/n_id,n_id/), res_im_id ) )
    call check ( nf90_def_var ( nc_id, "z_re", NF90_REAL, &
        (/n_id,n_id/), z_re_id ) )
    call check ( nf90_def_var ( nc_id, "z_im", NF90_REAL, &
        (/n_id,n_id/), z_im_id ) )

    call check ( nf90_def_var ( nc_id, "expRes_re", nf90_real, &
        (/n_id,n_id/), expRes_re_id ) )
    call check ( nf90_def_var ( nc_id, "expRes_im", nf90_real, &
        (/n_id,n_id/), expRes_im_id ) )

    call check ( nf90_enddef ( nc_id ) )

    call check ( nf90_put_var ( nc_id, res_re_id, real ( res ) ) )
    call check ( nf90_put_var ( nc_id, res_im_id, aimag ( res ) ) )
    call check ( nf90_put_var ( nc_id, z_re_id, real ( z ) ) )
    call check ( nf90_put_var ( nc_id, z_im_id, aimag ( z ) ) )
    call check ( nf90_put_var ( nc_id, expRes_re_id, real ( expRes ) ) )
    call check ( nf90_put_var ( nc_id, expRes_im_id, aimag ( expRes ) ) )

    call check ( nf90_close ( nc_id ) )

end program test_expBesselI


#:include "common.fpp"

program test_mfi_blas
    use iso_fortran_env
    use mfi_blas
    use f77_blas
    implicit none
    integer, parameter :: N = 2000
    real(REAL64) :: A(N,N), B(N,N), C(N,N), D(N,N)
    real(REAL64) :: X(N), Y(N), Z(N), U(N)
    real(REAL64) :: alpha, beta
    integer :: i, j, k

    ! BLAS 1
    call test_axpy
    call test_copy
    call test_rotmg
    call test_swap
    call test_iamax
    call test_iamin
    ! BLAS 2
    call test_gemv
    ! BLAS 3
    call test_gemm

contains
    subroutine test_defaults
        C = .0_REAL64
        D = .0_REAL64
        Y = .0_REAL64
        Z = .0_REAL64
        alpha = 1.0_REAL64
        beta  = 0.0_REAL64
        call random_number(A)
        call random_number(B)
        call random_number(X)
    end subroutine

    subroutine test_rotmg
        real(REAL64) :: x1, y1, d1, d2, params(5)
        real(REAL64) :: expected(5)
        expected = [-1.d0, 1.6110934624105326d-6, -2.44140625d-4, 2.44140625d-4, 1.62760416d-6]
        d1 = 5.9d-8; d2 = 5.960464d-8; x1 = 1.d0; y1 = 150.d0; params = .0_REAL64
        @:timeit("time f77_rotmg: ", { call f77_rotmg(d1, d2, x1, y1, params) })
        call assert(all(is_almost_equal(params, expected)))
        d1 = 5.9d-8; d2 = 5.960464d-8; x1 = 1.d0; y1 = 150.d0; params = .0_REAL64
        @:timeit("time mfi_rotmg: ", { call mfi_rotmg(d1, d2, x1, y1, params) })
        call assert(all(is_almost_equal(params, expected)))
        d1 = 5.9d-8; d2 = 5.960464d-8; x1 = 1.d0; y1 = 150.d0; params = .0_REAL64
        @:timeit("time drotmg:    ", { call drotmg(d1, d2, x1, y1, params) })
        call assert(all(is_almost_equal(params, expected)))
    end subroutine

    subroutine test_axpy
        call test_defaults
        @:timeit("time f77_axpy: ", { call f77_axpy(N,2*alpha,X,1,Y,1) })
        Y = .0_REAL64
        @:timeit("time mfi_axpy: ", { call mfi_axpy(X,Y,2*alpha)       })
        @:timeit("time fortran:  ", { Z=2*X                            })
        call assert(all(is_almost_equal(2*X,Y) .and. is_almost_equal(2*X,Z)))
    end subroutine

    subroutine test_copy
        call test_defaults
        @:timeit("time f77_copy: ", { call f77_copy(N,X,1,Y,1) })
        @:timeit("time mfi_copy: ", { call mfi_copy(X,Y)       })
        @:timeit("time fortran:  ", { Z=X                      })
        call assert(all(is_almost_equal(X,Y) .and. is_almost_equal(X,Z)))
    end subroutine

    subroutine test_swap
        call test_defaults
        @:timeit("time f77_swap: ", { call f77_swap(N,X,1,Y,1) })
        @:timeit("time mfi_swap: ", { call mfi_swap(X,Y)       })
    end subroutine

    subroutine test_iamax
        call test_defaults
        @:timeit("time f77_iamax: ", { i = f77_iamax(N,X,1) })
        @:timeit("time mfi_iamax: ", { j = mfi_iamax(X)     })
        @:timeit("time maxloc:    ", { k = maxloc(X,1)      })
        call assert(i == j .and. j == k)
    end subroutine

    subroutine test_iamin
        call test_defaults
        @:timeit("time f77_iamin: ", { i = f77_iamin(N,X,1) })
        @:timeit("time mfi_iamin: ", { j = mfi_iamin(X)     })
        @:timeit("time minloc:    ", { k = minloc(X,1)      })
        call assert(i == j .and. j == k)
    end subroutine

    subroutine test_gemm
        call test_defaults
        @:timeit("time f77_gemm: ", { call f77_gemm('N', 'N', N, N, N, alpha, A, N, B, N, beta, C, N) })
        @:timeit("time mfi_gemm: ", { call mfi_gemm(A,B,C) })
        @:timeit("time matmul:   ", { D = matmul(A,B)      })
        call assert(all(is_almost_equal(C,D)))

        @:timeit("time f77_gemm, transa=T:     ", { call f77_gemm('T', 'N', N, N, N, alpha, A, N, B, N, beta, C, N) })
        @:timeit("time mfi_gemm, transa=T:     ", { call mfi_gemm(A,B,C,transa='T') })
        @:timeit("time matmul,   transpose(A): ", { D = matmul(transpose(A),B)      })
        call assert(all(is_almost_equal(C,D)))
    end subroutine

    subroutine test_gemv
        call test_defaults
        @:timeit("time f77_gemv: ", { call f77_gemv('N', N, N, alpha, A, N, X, 1, beta, Y, 1) })
        @:timeit("time mfi_gemv: ", { call mfi_gemv(A,X,Y) })
        @:timeit("time matmul:   ", { Z = matmul(A,X)      })
        call assert(all(is_almost_equal(Y,Z)))

        @:timeit("time f77_gemv: trans=T:      ", { call f77_gemv('T', N, N, alpha, A, N, X, 1, beta, Y, 1) })
        @:timeit("time mfi_gemv, trans=T:      ", { call mfi_gemv(A,X,Y,trans='T') })
        @:timeit("time matmul,   transpose(A): ", { Z = matmul(transpose(A),X)     })
        call assert(all(is_almost_equal(Y,Z)))
    end subroutine

    pure subroutine assert(test)
        logical, intent(in) :: test
        if (.not. test) then
            error stop 'different results'
        end if
    end subroutine

    logical pure elemental function is_almost_equal(x, y)
        real(REAL64), intent(in) :: x, y
        is_almost_equal = abs(x-y) < 10**6*epsilon(x)
    end function

end program