      program main

c*********************************************************************72
c
cc MAIN is the main program for WAVE_MPI.
c
c  Discussion:
c
c    WAVE_MPI solves the wave equation in parallel using MPI.
c
c    Discretize the equation for u(x,t):
c      d^2 u/dt^2 - c^2 * d^2 u/dx^2 = 0  for 0 < x < 1, 0 < t
c    with boundary conditions:
c      u(0,t) = u0(t) = sin ( 2 * pi * ( 0 - c * t ) )
c      u(1,t) = u1(t) = sin ( 2 * pi * ( 1 - c * t ) )
c    and initial conditions:
c         u(x,0) = g(x,t=0) =                sin ( 2 * pi * ( x - c * t ) )
c      dudt(x,0) = h(x,t=0) = - 2 * pi * c * cos ( 2 * pi * ( x - c * t ) )
c
c    by:
c
c      alpha = c * dt / dx.
c
c      U(x,t+dt) = 2 U(x,t) - U(x,t-dt)
c        + alpha^2 ( U(x-dx,t) - 2 U(x,t) + U(x+dx,t) ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 November 2013
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Geoffrey Fox, Mark Johnson, Gregory Lyzenga, Steve Otto, John Salmon,
c    David Walker,
c    Solving problems on concurrent processors,
c    Volume 1: General Techniques and Regular Problems,
c    Prentice Hall, 1988,
c    ISBN: 0-13-8230226,
c    LC: QA76.5.F627.
c
c  Local parameters:
c
c    Local, double precision DT, the time step.
c
c    Local, integer ID, the MPI process ID.
c
c    Local, integer N_GLOBAL, the total number of points.
c
c    Local, integer N_LOCAL, the number of points visible to
c    this process.
c
c    Local, integer NSTEPS, the number of time steps.
c
c    Local, integer P, the number of MPI processes.
c
      implicit none

      include 'mpif.h'

      integer n_global
      parameter ( n_global = 401 )

      double precision dt
      parameter ( dt = 0.00125 )
      integer error
      integer i_global_hi
      integer i_global_lo
      integer id
      integer n_local
      integer nsteps
      parameter ( nsteps = 4000 )
      integer p
c
c  I really need an allocatable array here.
c  Just to get it done, I'll settle for using N_GLOBAL as the dimension.
c
      double precision u1_local(n_global)
      double precision wtime
c
c  Initialize MPI.
c
      call MPI_Init ( error )

      call MPI_Comm_rank ( MPI_COMM_WORLD, id, error )

      call MPI_Comm_size ( MPI_COMM_WORLD, p, error )

      if ( id .eq. 0 ) then
        call timestamp ( )
        write ( *, '(a)' ) ''
        write ( *, '(a)' ) 'MPI_WAVE:'
        write ( *, '(a)' ) '  FORTRAN77 version.'
        write ( *, '(a)' )
     &    '  Estimate a solution of the wave equation using MPI.'
        write ( *, '(a)' ) ''
        write ( *, '(a,i2,a)' ) '  Using ', p, ' processes.'
        write ( *, '(a,i6,a)' )
     &    '  Using a total of ', n_global, ' points.'
        write ( *, '(a,i6,a,g14.6)' )
     &    '  Using ', nsteps, ' time steps of size ', dt
        write ( *, '(a,g14.6)' )
     &    '  Computing final solution at time ', dt * nsteps
      end if

      wtime = MPI_Wtime ( )
c
c  Determine N_LOCAL
c
      i_global_lo = (   id       * ( n_global - 1 ) ) / p
      i_global_hi = ( ( id + 1 ) * ( n_global - 1 ) ) / p
      if ( 0 .lt. id ) then
        i_global_lo = i_global_lo - 1
      end if

      n_local = i_global_hi + 1 - i_global_lo
c
c  Update N_LOCAL values.
c
      call update ( id, p, n_global, n_local, nsteps, dt, u1_local )
c
c  Collect local values into global array.
c
      call collect ( id, p, n_global, n_local, nsteps, dt, u1_local )
c
c  Report elapsed wallclock time.
c
      wtime = MPI_Wtime ( ) - wtime

      if ( id .eq. 0 ) then
        write ( *, '(a)' ) ''
        write ( *, '(a,g14.6,a)' )
     &    '  Elapsed wallclock time was ', wtime, ' seconds.'
      end if
c
c  Terminate MPI.
c
      call MPI_Finalize ( error )
c
c  Terminate.
c
      if ( id .eq. 0 ) then
        write ( *, '(a)' ) ''
        write ( *, '(a)' ) 'WAVE_MPI:'
        write ( *, '(a)' ) '  Normal end of execution.'
        write ( *, '(a)' ) ''
        call timestamp ( )
      end if

      stop
      end
      subroutine update ( id, p, n_global, n_local, nsteps, dt,
     &  u1_local )

c*********************************************************************72
c
cc UPDATE advances the solution a given number of time steps.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 November 2013
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer ID, the identifier of this process.
c
c    Input, integer P, the number of processes.
c
c    Input, integer N_GLOBAL, the total number of points.
c
c    Input, integer N_LOCAL, the number of points visible to
c    this process.
c
c    Input, integer NSTEPS, the number of time steps.
c
c    Input, double precision DT, the size of the time step.
c
c    Output, double precision U1_LOCAL(N_LOCAL), the portion of the solution
c    at the last time, as evaluated by this process.
c
      implicit none

      include 'mpif.h'

      integer n_local

      double precision alpha
      double precision alpha2
      double precision c
      double precision dt
      double precision dudt
      double precision dx
      integer error
      double precision exact
      integer i
      integer i_global
      integer i_global_hi
      integer i_global_lo
      integer i_local
      integer i_local_hi
      integer i_local_lo
      integer id
      integer j
      integer ltor
      parameter ( ltor = 20 )
      integer n_global
      integer nsteps
      integer p
      integer rtol
      parameter ( rtol = 10 )
      integer status(MPI_STATUS_SIZE)
      double precision t
      double precision u0_local(n_local)
      double precision u1_local(n_local)
      double precision u2_local(n_local)
      double precision x
c
c  Determine the value of ALPHA.
c
      c = 1.0D+00
      dx = 1.0D+00 / dble ( n_global - 1 )
      alpha = c * dt / dx
      alpha2 = alpha * alpha

      if ( 1.0D+00 .le. abs ( alpha ) ) then

        if ( id .eq. 0 ) then
          write ( *, '(a)' ) ''
          write ( *, '(a)' ) 'UPDATE - Warning!'
          write ( *, '(a)' ) '  1 <= |ALPHA| = | C * dT / dX |.'
          write ( *, '(a,g14.6)' ) '  C = ', c
          write ( *, '(a,g14.6)' ) '  dT = ', dt
          write ( *, '(a,g14.6)' ) '  dX = ', dx
          write ( *, '(a,g14.6)' ) '  ALPHA = ', alpha
          write ( *, '(a)' ) '  Computation will not be stable!'
        end if

        call MPI_Finalize ( error )
        stop 1

      end if
c
c  The global array of N_GLOBAL points must be divided up among the processes.
c  Each process stores about 1/P of the total + 2 extra slots.
c
      i_global_lo = (   id       * ( n_global - 1 ) ) / p
      i_global_hi = ( ( id + 1 ) * ( n_global - 1 ) ) / p
      if ( 0 .lt. id ) then
        i_global_lo = i_global_lo - 1
      end if

      i_local_lo = 0
      i_local_hi = i_global_hi - i_global_lo

      t = 0.0D+00
      do i_global = i_global_lo, i_global_hi
        x = dble ( i_global ) / dble ( n_global - 1 )
        i_local = i_global - i_global_lo
        u1_local(i_local+1) = exact ( x, t )
      end do

      do i_local = i_local_lo, i_local_hi
        u0_local(i_local+1) = u1_local(i_local+1)
      end do
c
c  Take NSTEPS time steps.
c
      do i = 1, nsteps

        t = dt * dble ( i )
c
c  For the first time step, we need to use the initial derivative information.
c
        if ( i .eq. 1 ) then

          do i_local = i_local_lo + 1, i_local_hi - 1
            i_global = i_global_lo + i_local
            x = dble ( i_global ) / dble ( n_global - 1 )
            u2_local(i_local+1) =
     &        +         0.5D+00 * alpha2   * u1_local(i_local-1+1)
     &        + ( 1.0D+00 -       alpha2 ) * u1_local(i_local+0+1)
     &        +         0.5D+00 * alpha2   * u1_local(i_local+1+1)
     &        +                         dt * dudt ( x, t )
          end do
c
c  After the first time step, we can use the previous two solution estimates.
c
        else

          do i_local = i_local_lo + 1, i_local_hi - 1
            u2_local(i_local+1) =
     &        +               alpha2   * u1_local(i_local-1+1)
     &        + 2.0 * ( 1.0 - alpha2 ) * u1_local(i_local+0+1)
     &        +               alpha2   * u1_local(i_local+1+1)
     &        -                          u0_local(i_local+0+1)
          end do

        end if
c
c  Exchange data with "left-hand" neighbor.
c
        if ( 0 .lt. id ) then
          call MPI_Send ( u2_local(i_local_lo+2), 1,
     &      MPI_DOUBLE_PRECISION, id - 1, rtol, MPI_COMM_WORLD, error )
          call MPI_Recv ( u2_local(i_local_lo+1), 1,
     &      MPI_DOUBLE_PRECISION, id - 1, ltor, MPI_COMM_WORLD, status,
     &      error )
        else
          x = 0.0D+00
          u2_local(i_local_lo+1) = exact ( x, t )
        end if
c
c  Exchange data with "right-hand" neighbor.
c
        if ( id .lt. p - 1 ) then
          call MPI_Send ( u2_local(i_local_hi), 1, MPI_DOUBLE_PRECISION,
     &      id + 1, ltor, MPI_COMM_WORLD, error )
          call MPI_Recv ( u2_local(i_local_hi+1),   1,
     &      MPI_DOUBLE_PRECISION, id + 1, rtol, MPI_COMM_WORLD, status,
     &      error )
        else
          x = 1.0D+00
          u2_local(i_local_hi+1) = exact ( x, t )
        end if
c
c  Shift data for next time step.
c
        do i_local = i_local_lo, i_local_hi
          u0_local(i_local+1) = u1_local(i_local+1)
          u1_local(i_local+1) = u2_local(i_local+1)
        end do

      end do

      return
      end
      subroutine collect ( id, p, n_global, n_local, nsteps, dt,
     &  u_local )

c*********************************************************************72
c
cc COLLECT has workers send results to the master, which prints them.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 November 2013
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer ID, the identifier of this process.
c
c    Input, integer P, the number of processes.
c
c    Input, integer N_GLOBAL, the total number of points.
c
c    Input, integer N_LOCAL, the number of points visible
c    to this process.
c
c    Input, integer NSTEPS, the number of time steps.
c
c    Input, double precision DT, the size of the time step.
c
c    Input, double precision U_LOCAL(N_LOCAL), the final solution estimate
c    computed by this process.
c
      implicit none

      include 'mpif.h'

      integer n_global
      integer n_local

      integer buffer(2)
      integer collect1
      parameter ( collect1 = 10 )
      integer collect2
      parameter ( collect2 = 20 )
      double precision dt
      integer error
      double precision exact
      integer i
      integer i_global
      integer i_global_hi
      integer i_global_lo
      integer i_local
      integer i_local_hi
      integer i_local_lo
      integer id
      integer j
      integer n_local2
      integer nsteps
      integer p
      integer status(MPI_STATUS_SIZE)
      double precision t
      double precision u_global(n_global)
      double precision u_local(n_local)
      double precision x

      i_global_lo = (   id       * ( n_global - 1 ) ) / p
      i_global_hi = ( ( id + 1 ) * ( n_global - 1 ) ) / p
      if ( 0 < id ) then
        i_global_lo = i_global_lo - 1
      end if

      i_local_lo = 0
      i_local_hi = i_global_hi - i_global_lo
c
c  Master collects worker results into the U_GLOBAL array.
c
      if ( id .eq. 0 ) then
c
c  Copy the master's results into the global array.
c
        do i_local = i_local_lo, i_local_hi
          i_global = i_global_lo + i_local - i_local_lo
          u_global(i_global+1) = u_local(i_local+1)
        end do
c
c  Contact each worker.
c
        do i = 1, p - 1
c
c  Message "collect1" contains the global index and number of values.
c
          call MPI_Recv ( buffer, 2, MPI_INTEGER, i, collect1,
     &      MPI_COMM_WORLD, status, error )

          i_global_lo = buffer(1)
          n_local2 = buffer(2)

          if ( i_global_lo < 0 ) then
            write ( *, '(a,i6)' )
     &        '  Illegal I_GLOBAL_LO = ', i_global_lo
            call MPI_Finalize ( error )
            stop 1
          else if ( n_global <= i_global_lo + n_local2 - 1 ) then
            write ( *, '(a,i6)' )
     &        '  Illegal I_GLOBAL_LO + N_LOCAL = ',
     &        i_global_lo + n_local2
            call MPI_Finalize ( error )
            stop 1
          end if
c
c  Message "collect2" contains the values.
c
          call MPI_Recv ( u_global(i_global_lo+1), n_local2,
     &      MPI_DOUBLE_PRECISION, i, collect2, MPI_COMM_WORLD,
     &      status, error )

        end do
c
c  Print the results.
c
        t = dt * dble ( nsteps )
        write ( *, '(a)' ) ''
        write ( *, '(a)' ) '    I      X     F(X)   Exact'
        write ( *, '(a)' ) ''
        do i_global = 0, n_global - 1
          x = dble ( i_global ) / dble ( n_global - 1 )
          write ( *, '(2x,i3,2x,f6.3,2x,f6.3,2x,f6.3)' )
     &      i_global, x, u_global(i_global+1), exact ( x, t )
        end do
c
c  Workers send results to process 0.
c
      else
c
c  Message "collect1" contains the global index and number of values.
c
        buffer(1) = i_global_lo
        buffer(2) = n_local
        call MPI_Send ( buffer, 2, MPI_INTEGER, 0, collect1,
     &    MPI_COMM_WORLD, error )
c
c  Message "collect2" contains the values.
c
        call MPI_Send ( u_local, n_local, MPI_DOUBLE_PRECISION, 0,
     &    collect2, MPI_COMM_WORLD, error )

      end if

      return
      end
      function exact ( x, t )

c*********************************************************************72
c
cc EXACT evaluates the exact solution
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 November 2013
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the location.
c
c    Input, double precision T, the time.
c
c    Output, double precision EXACT, the value of the exact solution.
c
      implicit none

      double precision c
      parameter ( c = 1.0D+00 )
      double precision exact
      double precision pi
      parameter ( pi = 3.141592653589793D+00 )
      double precision t
      double precision x

      exact = sin ( 2.0D+00 * pi * ( x - c * t ) )

      return
      end
      function dudt ( x, t )

c*********************************************************************72
c
cc DUDT evaluates the partial derivative dudt.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 November 2013
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the location.
c
c    Input, double precision T, the time.
c
c    Output, double precision DUDT, the value of the time derivative of
c    the solution.
c
      implicit none

      double precision c
      parameter ( c = 1.0D+00 )
      double precision dudt
      double precision pi
      parameter ( pi = 3.141592653589793D+00 )
      double precision t
      double precision x

      dudt = - 2.0D+00 * pi * c * cos ( 2.0D+00 * pi * ( x - c * t ) )

      return
      end
      subroutine timestamp ( )

c*********************************************************************72
c
cc TIMESTAMP prints out the current YMDHMS date as a timestamp.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    None
c
      implicit none

      character * ( 8 ) ampm
      integer d
      character * ( 8 ) date
      integer h
      integer m
      integer mm
      character * ( 9 ) month(12)
      integer n
      integer s
      character * ( 10 ) time
      integer y

      save month

      data month /
     &  'January  ', 'February ', 'March    ', 'April    ',
     &  'May      ', 'June     ', 'July     ', 'August   ',
     &  'September', 'October  ', 'November ', 'December ' /

      call date_and_time ( date, time )

      read ( date, '(i4,i2,i2)' ) y, m, d
      read ( time, '(i2,i2,i2,1x,i3)' ) h, n, s, mm

      if ( h .lt. 12 ) then
        ampm = 'AM'
      else if ( h .eq. 12 ) then
        if ( n .eq. 0 .and. s .eq. 0 ) then
          ampm = 'Noon'
        else
          ampm = 'PM'
        end if
      else
        h = h - 12
        if ( h .lt. 12 ) then
          ampm = 'PM'
        else if ( h .eq. 12 ) then
          if ( n .eq. 0 .and. s .eq. 0 ) then
            ampm = 'Midnight'
          else
            ampm = 'AM'
          end if
        end if
      end if

      write ( *,
     &  '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' )
     &  d, month(m), y, h, ':', n, ':', s, '.', mm, ampm

      return
      end


c
c
c ... file rgrd1u.f
c
c     this file contains documentation followed by fortran code for
c     subroutine rgrd1u and additional subroutines.
c
c ... author
c
c     John C. Adams (NCAR 1999)
c
c ... subroutine rgrd1u(nx,p,mx,q,intpol,w,lw,iw,liw,ier)
c
c ... purpose
c
c     subroutine rgrd1u interpolates the nx vector p onto
c     the mx vector q. it is assumed that p and q are
c     values on uniform nx and mx grids which subdivide
c     the same interval (INCLUDING END POINTS).  if p and
c     q are values on nonuniform grids and/or if q is defined
c     on a grid which lies within the p grid then subroutine
c     rgrd1 (see file rgrd1.f) should be used.
c
c ... language
c
c     coded in portable FORTRAN77 and FORTRAN90
c
c ... test program
c
c     file trgrd1u.f on regridpack includes a test program for subroutine rgrd1u
c
c ... method
c
c     linear or cubic interpolation (see intpol) is used when the
c     mx uniform grid is not a subgrid of the nx uniform grid (i.e.,
c     whenever mx-1 does not divide nx-1).  q is set directly from
c     p in the subgrid case.
c
c ... required files
c
c     none
c
c ... efficiency
c
c     inner most loops in regridpack software vectorize.
c
c
c *** input arguments ***
c
c
c ... nx
c
c     the integer dimension of p.  nx > 1 if intpol = 1 or
c     nx > 3 if intpol = 3 is required (see ier = 2).
c
c ... p
c
c     a real nx dimensioned vector of given values
c
c ... mx
c
c     the integer dimension of q.  mx > 1 is required (see ier = 1)
c
c
c ... intpol
c
c     an integer which sets linear or cubic interpolation as follows:
c
c        intpol = 1 sets linear interpolation
c        intpol = 3 sets cubic interpolation
c
c     values other than 1 or 3 in intpol are not allowed (ier = 4).
c
c ... w
c
c     a real work space of length lw.
c
c ... lw
c
c     the integer length of the work space w in the routine calling rgrd1u.
c     if mx-1 divides nx-1 then the mx uniform grid is a subgrid of
c     the nx uniform grid.  in this case let lwmin = 1.  otherwise
c     let lwmin = mx if intpol = 1 or lwmin = mx if intpol = 3.
c     then lw must be greater than or equal to lwmin (see ier=4).
c
c ... iw
c
c     an integer work space of length liw
c
c ... liw
c
c     the integer length of the integer work space iw in the routine calling rgrd1u.
c     liw must be greater than or equal to mx.
c
c
c *** output arguments ***
c
c
c ... q
c
c     a real mx dimensioned vector of values which are interpolated from p.
c
c ... ier
c
c     an integer error flag set as follows:
c
c     ier = 0 if no errors in input arguments are detected
c
c     ier = 1 if  mx < 2
c
c     ier = 2 if nx < 2 when intpol=1 or nx < 4 when intpol=3.
c
c     ier = 3 if intpol is not equal to 1 or 3
c
c     ier = 4 if lw or liw is too small (insufficient work space)
c
c
c ************************************************************************
c
c     end of rgrd1u documentation, fortran code follows:
c
c ************************************************************************
c
c
      subroutine rgrd1u(nx,p,mx,q,intpol,w,lw,iw,liw,ier)
      implicit none
      integer intpol,liw,iw(liw),lw,nx,mx,ier,inmx,isubx
      integer i2,i3,i4,i5,lwmin
      real p(nx),q(mx),w(lw)
c
c     check input arguments
c
      ier = 1
c
c     check mx
c
      if (mx .lt. 2) return
c
c     check intpol
c
      ier = 3
      if (intpol.ne.1 .and. intpol.ne.3) return
c
c     check nx
c
      ier = 2
      if (intpol.eq.1 .and. nx.lt.2) return
      if (intpol.eq.3 .and. nx.lt.4) return
c
c     set subgrid integer indicator
c
      inmx = (nx-1)/(mx-1)
      isubx = nx - inmx*(mx-1)
c
c     set minimum and check work space
c
      ier = 4
      if (isubx.ne.1) then
	if (intpol.eq.1) lwmin = mx
	if (intpol.eq.3) lwmin = 4*mx
      else
	lwmin = 1
      end if
      if (lw .lt. lwmin) return
      if (liw .lt. mx) return
c
c     input arguments o.k.
c
      ier = 0
c
c     preset pointers
c
      i2 = 1
      i3 = 1
      i4 = 1
      i5 = 1
      if (intpol .eq. 1) then
c
c     linear interpolation in x
c
	if (isubx .ne. 1) then
	  call linmxu(nx,mx,iw,w)
	end if
	call lint1u(nx,p,mx,q,iw,w,inmx,isubx)
	return
      else
c
c     cubic interpolation in x
c
	if (isubx .ne. 1) then
	  i2 = 1
	  i3 = i2+mx
	  i4 = i3+mx
	  i5 = i4+mx
	  call cubnmxu(nx,mx,iw,w(i2),w(i3),w(i4),w(i5))
	end if
	call cubt1u(nx,p,mx,q,iw,w(i2),w(i3),w(i4),w(i5),inmx,isubx)
      return
      end if
      end

      subroutine lint1u(nx,p,mx,q,ix,dx,inmx,isubx)
      implicit none
      integer nx,mx,ix(mx),inmx,isubx,i,ii
      real p(nx),q(mx),dx(mx)
      if (isubx .eq. 1) then
c
c     mx grid is subset of nx grid so q can be set directly
c
	do ii=1,mx
	  i = inmx*(ii-1)+1
	  q(ii) = p(i)
	end do
	return
      else
c
c     linearly interpolate
c
	do ii=1,mx
	  i = ix(ii)
	  q(ii) = p(i)+dx(ii)*(p(i+1)-p(i))
	end do
	return
      end if
      end

      subroutine cubt1u(nx,p,mx,q,ix,dxm,dx,dxp,dxpp,inmx,isubx)
      implicit none
      integer nx,mx,ix(mx),inmx,isubx,i,ii
      real p(nx),q(mx)
      real dxm(mx),dx(mx),dxp(mx),dxpp(mx)

      if (isubx .eq. 1) then
c
c     mx grid is subset of nx grid so q can be set directly
c
	do ii=1,mx
	  i = inmx*(ii-1)+1
	  q(ii) = p(i)
	end do
	return

      else
c
c     cubically interpolate on uniform grid
c
	do ii=1,mx
	  i = ix(ii)
	  q(ii)=(dxm(ii)*p(i-1)+dx(ii)*p(i)+dxp(ii)*p(i+1)+
     +           dxpp(ii)*p(i+2))
	end do
	return
      end if
      end

      subroutine linmxu(nx,mx,ix,dx)
c
c     set linear interpolation terms
c
      implicit none
      integer nx,mx,ix(mx),i,ii
      real dx(mx),dnx,dmx,x,xx
c
c     set "virtual" uniform increments
c
      dnx = 1.0/(nx-1)
      dmx = 1.0/(mx-1)
c
c     set ix(ii) = i  s.t. i,i+1 can interpolate for ii
c
      do ii=1,mx
	xx = (ii-1)*dmx
	ix(ii) = min0(int(xx/dnx)+1,nx-1)
c
c     set scale term for linear
c
	i = ix(ii)
	x = (i-1)*dnx
	dx(ii) = (xx-x)/dnx
      end do
      return
      end

      subroutine cubnmxu(nx,mx,ix,dxm,dx,dxp,dxpp)
c
c     set cubic interpolation terms
c
      implicit none
      integer nx,mx,ix(mx),i,ii
      real dxm(mx),dx(mx),dxp(mx),dxpp(mx),dnx,dmx,odnx3
      real xx,xim,xi,xip,xipp
c
c     set "virtual" uniform increments
c
      dnx = 1.0/(nx-1)
      dmx = 1.0/(mx-1)
      odnx3 = 1.0/(6.*dnx*dnx*dnx)
c
c     set i=ix(ii) in [2,nx-2] such that
c     i-1,i,i+1,i+2 can be used to interpolate at ii
c
      do ii=1,mx
	xx = (ii-1)*dmx
	ix(ii) = min0(max0(int(xx/dnx)+1,2),nx-2)
	i = ix(ii)
c
c     set scale terms for cubic
c
	xi = (i-1)*dnx
	xim = xi-dnx
	xip = xi+dnx
	xipp = xip+dnx
	dxm(ii) = -(xx-xi)*(xx-xip)*(xx-xipp)*odnx3
	dx(ii) = 3.*(xx-xim)*(xx-xip)*(xx-xipp)*odnx3
	dxp(ii) = -3.*(xx-xim)*(xx-xi)*(xx-xipp)*odnx3
	dxpp(ii) = (xx-xim)*(xx-xi)*(xx-xip)*odnx3
      end do
      return
      end


      PROGRAM LA_SGESV_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_GESV
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, INFO, N, NRHS
!  .. "Local Arrays" ..
      INTEGER, ALLOCATABLE :: IPIV(:)
      REAL(WP), ALLOCATABLE :: A(:,:), AA(:,:), B(:,:), BB(:,:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'SGESV Example Program Results.'
      OPEN(UNIT=21,FILE='gesv.ma',STATUS='UNKNOWN')
      READ (21, * ) N
      READ (21, * ) NRHS
      ALLOCATE( A(N,N), AA(N,N), B(N,NRHS), BB(N,NRHS), IPIV(N) )
      DO J=1,N
      DO I=1,N
         READ(21,'(F2.0)') AA(I,J)
      ENDDO
      ENDDO
      CLOSE(21)

      DO J = 1, NRHS; BB(:,J) = SUM( AA, DIM=2)*J; ENDDO

      WRITE(*,*) 'The matrix A:'
      DO I=1,N; WRITE(*,"(4(I3,1X),I3,1X)") INT(AA(I,:)); ENDDO

      WRITE(*,*) 'The RHS matrix B:'
      DO I=1,N; WRITE(*,"(2(I3,1X),I3,1X)") INT(BB(I,:)); ENDDO

      WRITE(*,*) 'CALL LA_GESV( A, B )'
      A=AA; B=BB

      CALL LA_GESV(  A, B )

      WRITE(*,*) 'B - the solution vectors computed by LA_GESV'
      DO I=1,N; WRITE(*,"(2(E12.6,1X),E12.6,1X)") B(I,:); ENDDO

      WRITE(*,*) 'CALL LA_GESV( A, B(:,1), IPIV, INFO )'

      CALL LA_GESV(  AA, BB(:,1), IPIV, INFO )

      WRITE(*,*) ' A on exit:'
      DO I=1,N; WRITE(*,"(4(E12.6,1X),E12.6,1X)") AA(I,:); ENDDO

      WRITE(*,*) 'B on exit:'
      DO I=1,N; WRITE(*,"(4(E12.6,1X),E12.6,1X)") BB(I,1); ENDDO

      WRITE(*,*)'IPIV on exit:', IPIV

      WRITE(*,*)'INFO on exit:', INFO

      END PROGRAM LA_SGESV_EXAMPLE


program test

use, intrinsic :: iso_fortran_env, only : dp=>real64
use, intrinsic :: ieee_arithmetic, only : ieee_next_after

implicit none (type, external)
external :: dpmeps

real(dp) :: en, ep

en = epsilon(1._dp)
call dpmeps(ep)

print *, en, ep
print *, ieee_next_after(1._dp, 2._dp)

end program


subroutine splint(xa,ya,y2a,n,x,y)
!
implicit none
!
! Dummy arguments
!
integer :: n
real :: x,y
real,dimension(n) :: xa,y2a,ya
!
! Local variables
!
real :: a,b,h
integer :: k,khi,klo
!
klo = 1
khi = n
do
!.... begin debug lines
!        do i=1,13
!           write (56,*)'n=',n,' xa(i)=', xa(i),' ya(i)=',ya(i),
!     &     ' y2a(i)=',y2a(i)
!        end do
! ......end debug lines
  if (khi-klo>1) then
     k = (khi+klo)/2
     if (xa(k)>x) then
        khi = k
     else
        klo = k
     end if
     go to 10
  end if
  h = xa(khi) - xa(klo)
  if (h==0.) write (*,*) 'crop/splint.for: bad xa input.'
  a = (xa(khi)-x)/h
  b = (x-xa(klo))/h
  y = a*ya(klo) + b*ya(khi) + ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.
  go to 99999
 10   end do
!.... debug line
!       write(56,*)x,y
!
99999 end subroutine splint


!
!     (c) 2019 Guide Star Engineering, LLC
!     This Software was developed for the US Nuclear Regulatory Commission (US NRC)
!     under contract "Multi-Dimensional Physics Implementation into Fuel Analysis under
!     Steady-state and Transients (FAST)", contract # NRC-HQ-60-17-C-0007
!
!
!    NEMO - Numerical Engine (for) Multiphysics Operators
! Copyright (c) 2007, Stefano Toninel
!                     Gian Marco Bianchi  University of Bologna
!              David P. Schmidt    University of Massachusetts - Amherst
!              Salvatore Filippone University of Rome Tor Vergata
! 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 NEMO project 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 COPYRIGHT HOLDERS AND CONTRIBUTORS "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 COPYRIGHT OWNER OR CONTRIBUTORS 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.
!
!---------------------------------------------------------------------------------
!
! $Id: tools_math.f90 2469 2007-10-08 10:34:43Z sfilippo $
!
! Description:
!    To be added...
!
MODULE tools_math
    USE class_psblas, ONLY : psb_dpk_
    USE class_vector, ONLY : vector
    IMPLICIT NONE

    PRIVATE
    PUBLIC :: cart_to_polar
    PUBLIC :: factorize
    PUBLIC :: solve_sys
    PUBLIC :: build_prec
    PUBLIC :: lin_interp
    PUBLIC :: pwl_nearest
    PUBLIC :: pwl_deriv
    PUBLIC :: pwl_interp
    PUBLIC :: sort
    PUBLIC :: pi, it_time_, it_convergence_, it_counter_

    INTERFACE factorize
        MODULE PROCEDURE :: lu_fact
        MODULE PROCEDURE :: cholesky_fact_m
        MODULE PROCEDURE :: choloesky_fact_v
    END INTERFACE factorize

    INTERFACE solve_sys
        MODULE PROCEDURE :: lu_solve
        MODULE PROCEDURE :: cholesky_solve_m
        MODULE PROCEDURE :: cholesky_solve_v
        MODULE PROCEDURE :: psb_solve_sys
    END INTERFACE solve_sys

    INTERFACE build_prec
        PROCEDURE :: psb_build_prec
    END INTERFACE build_prec

    INTERFACE lin_interp
        MODULE PROCEDURE :: lin_interp_s
        MODULE PROCEDURE :: lin_interp_v
    END INTERFACE lin_interp

    INTERFACE pwl_deriv
        MODULE PROCEDURE :: pwl_deriv_x_s
        MODULE PROCEDURE :: pwl_deriv_x_v
        MODULE PROCEDURE :: pwl_deriv_x_vec
    END INTERFACE pwl_deriv

    INTERFACE pwl_interp
        MODULE PROCEDURE :: pwl_interp_dx_s
        MODULE PROCEDURE :: pwl_interp_dx_v
        MODULE PROCEDURE :: pwl_interp_x_s
        MODULE PROCEDURE :: pwl_interp_x_v
        MODULE PROCEDURE :: pwl_interp_x_vec
    END INTERFACE pwl_interp

    INTERFACE sort
        MODULE PROCEDURE :: isort
    END INTERFACE sort

    INTERFACE

        MODULE SUBROUTINE cart_to_polar(x,y,rho,theta,square)
            IMPLICIT NONE
            REAL(psb_dpk_), INTENT(IN) :: x, y
            REAL(psb_dpk_), INTENT(OUT) :: rho, theta
            LOGICAL, INTENT(IN), OPTIONAL :: square
        END SUBROUTINE cart_to_polar

        MODULE SUBROUTINE lu_fact(n,A,ipiv,info)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: n
            REAL(psb_dpk_), INTENT(INOUT) :: A(n,n)
            INTEGER, INTENT(OUT) :: ipiv(n)
            INTEGER, INTENT(OUT) :: info
        END SUBROUTINE lu_fact

        MODULE SUBROUTINE cholesky_fact_m(A)
            IMPLICIT NONE
            REAL(psb_dpk_), INTENT(INOUT) :: A(:,:)
        END SUBROUTINE cholesky_fact_m

        MODULE SUBROUTINE choloesky_fact_v(A)
            IMPLICIT NONE
            REAL(psb_dpk_), INTENT(INOUT) :: A(:)
        END SUBROUTINE choloesky_fact_v

        MODULE SUBROUTINE lu_solve(n,A,ipiv,b,info)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: n
            REAL(psb_dpk_), INTENT(IN) :: A(n,n)
            INTEGER, INTENT(IN) :: ipiv(n)
            REAL(psb_dpk_), INTENT(INOUT) :: b(n)
            INTEGER, INTENT(OUT) :: info
        END SUBROUTINE lu_solve

        MODULE SUBROUTINE cholesky_solve_m(A,b)
            IMPLICIT NONE
            REAL(psb_dpk_), INTENT(IN) :: A(:,:)
            REAL(psb_dpk_), INTENT(INOUT) :: b(:)
        END SUBROUTINE cholesky_solve_m

        MODULE SUBROUTINE cholesky_solve_v(A,b)
            IMPLICIT NONE
            REAL(psb_dpk_), INTENT(IN) :: A(:)
            REAL(psb_dpk_), INTENT(INOUT) :: b(:)
        END SUBROUTINE cholesky_solve_v

        MODULE SUBROUTINE psb_solve_sys(A,prec,b,x,desc,cmethod,eps,itmax,iter,err)
            USE psb_base_mod, ONLY : psb_dspmat_type, psb_desc_type
            USE psb_prec_mod, ONLY : psb_dprec_type
            IMPLICIT NONE
            TYPE(psb_dspmat_type), INTENT(IN)    :: A
            TYPE(psb_dprec_type),  INTENT(INOUT) :: prec
            REAL(psb_dpk_),      INTENT(IN)    :: b(:)
            REAL(psb_dpk_),      INTENT(INOUT) :: x(:)
            TYPE(psb_desc_type),   INTENT(IN)    :: desc
            CHARACTER(len=*),      INTENT(IN)    :: cmethod
            REAL(psb_dpk_),      INTENT(IN)    :: eps
            INTEGER,               INTENT(IN)    :: itmax
            INTEGER,               INTENT(OUT)   :: iter
            REAL(psb_dpk_),      INTENT(OUT)   :: err
        END SUBROUTINE psb_solve_sys

        SUBROUTINE psb_build_prec(cprec,nlev,cmethod,A,desc_a,prec)
        !! Note: This can't be a MODULE SUBROUTINE b/c of a compiler bug with
        !!       gfortran-8.3. IP 6/6/2019
            USE psb_base_mod, ONLY : psb_dspmat_type, psb_desc_type
            USE psb_prec_mod, ONLY : psb_dprec_type
            IMPLICIT NONE
            CHARACTER(len=*),      INTENT(IN) :: cprec
            INTEGER,               INTENT(IN) :: nlev
            CHARACTER(len=*),      INTENT(IN) :: cmethod
            TYPE(psb_dspmat_type), INTENT(IN) :: A
            TYPE(psb_desc_type),   INTENT(INOUT) :: desc_a
            TYPE(psb_dprec_type),  INTENT(INOUT) :: prec
        END SUBROUTINE psb_build_prec

        MODULE FUNCTION lin_interp_s(f1,f2,fac)
            IMPLICIT NONE
            REAL(psb_dpk_) :: lin_interp_s
            REAL(psb_dpk_), INTENT(IN) :: f1, f2
            REAL(psb_dpk_), INTENT(IN) :: fac
        END FUNCTION lin_interp_s

        MODULE FUNCTION lin_interp_v(f1,f2,fac)
            IMPLICIT NONE
            TYPE(vector) :: lin_interp_v
            TYPE(vector),   INTENT(IN) :: f1, f2
            REAL(psb_dpk_), INTENT(IN) :: fac
        END FUNCTION lin_interp_v

        MODULE SUBROUTINE pwl_nearest(x,x_data,i1,i2)
            IMPLICIT NONE
            REAL(psb_dpk_), INTENT(IN) :: x
            REAL(psb_dpk_), INTENT(IN) :: x_data(:)
            INTEGER, INTENT(OUT) :: i1, i2
        END SUBROUTINE pwl_nearest

        MODULE SUBROUTINE pwl_deriv_x_s(dydx,x,y_data,x_data)
            IMPLICIT NONE
            REAL(psb_dpk_), INTENT(OUT) :: dydx
            REAL(psb_dpk_), INTENT(IN) :: x
            REAL(psb_dpk_), INTENT(IN) :: y_data(:)
            REAL(psb_dpk_), INTENT(IN) :: x_data(:)
        END SUBROUTINE pwl_deriv_x_s

        MODULE SUBROUTINE pwl_deriv_x_v(dydx,x,y_data,x_data)
            IMPLICIT NONE
            REAL(psb_dpk_), INTENT(OUT) :: dydx(:)
            REAL(psb_dpk_), INTENT(IN) :: x
            REAL(psb_dpk_), INTENT(IN) :: y_data(:,:)
            REAL(psb_dpk_), INTENT(IN) :: x_data(:)
        END SUBROUTINE pwl_deriv_x_v

        MODULE SUBROUTINE pwl_deriv_x_vec(dydx,x,y_data,x_data)
            IMPLICIT NONE
            TYPE(vector), INTENT(OUT) :: dydx
            REAL(psb_dpk_), INTENT(IN) :: x
            TYPE(vector), INTENT(IN) :: y_data(:)
            REAL(psb_dpk_), INTENT(IN) :: x_data(:)
        END SUBROUTINE pwl_deriv_x_vec

        MODULE SUBROUTINE pwl_interp_dx_s(y,x,y_data,xmin,dx)
            IMPLICIT NONE
            REAL(psb_dpk_), INTENT(OUT) :: y
            REAL(psb_dpk_), INTENT(IN) :: x
            REAL(psb_dpk_), INTENT(IN) :: y_data(:)
            REAL(psb_dpk_), INTENT(IN) :: xmin, dx
        END SUBROUTINE pwl_interp_dx_s

        MODULE SUBROUTINE pwl_interp_dx_v(y,x,y_data,xmin,dx)
            IMPLICIT NONE
            REAL(psb_dpk_), INTENT(OUT) :: y(:)
            REAL(psb_dpk_), INTENT(IN) :: x(:)
            REAL(psb_dpk_), INTENT(IN) :: y_data(:)
            REAL(psb_dpk_), INTENT(IN) :: xmin, dx
        END SUBROUTINE pwl_interp_dx_v

        MODULE SUBROUTINE pwl_interp_x_s(y,x,y_data,x_data)
            IMPLICIT NONE
            REAL(psb_dpk_), INTENT(OUT) :: y
            REAL(psb_dpk_), INTENT(IN) :: x
            REAL(psb_dpk_), INTENT(IN) :: y_data(:)
            REAL(psb_dpk_), INTENT(IN) :: x_data(:)
        END SUBROUTINE pwl_interp_x_s

        MODULE SUBROUTINE pwl_interp_x_v(y,x,y_data,x_data)
            IMPLICIT NONE
            REAL(psb_dpk_), INTENT(OUT) :: y(:)
            REAL(psb_dpk_), INTENT(IN) :: x
            REAL(psb_dpk_), INTENT(IN) :: y_data(:,:)
            REAL(psb_dpk_), INTENT(IN) :: x_data(:)
        END SUBROUTINE pwl_interp_x_v

        MODULE SUBROUTINE pwl_interp_x_vec(y,x,y_data,x_data)
            IMPLICIT NONE
            TYPE(vector), INTENT(OUT) :: y
            REAL(psb_dpk_), INTENT(IN) :: x
            TYPE(vector), INTENT(IN) :: y_data(:)
            REAL(psb_dpk_), INTENT(IN) :: x_data(:)
        END SUBROUTINE pwl_interp_x_vec

    ! WARNING! One cannot use an ELEMENTAL function instead of a
    ! subroutine, because the DATA argument is not scalar.
    ! If rank(X) = 1 -> a subroutine is mandatory
    ! If rank(X) = 0 -> a function could be used
    ! We use in both cases a subroutine + generic interface

        MODULE SUBROUTINE isort(ivet)
            IMPLICIT NONE
            INTEGER, INTENT(INOUT) :: ivet(:)
        END SUBROUTINE isort

    END INTERFACE

    ! ----- SLATEC routines -----

    ! INTERFACE
    !     MODULE SUBROUTINE dnls1e(fcn,iopt,m,n,x,fvec,tol,nprint, &
    !         &            info,iw,wa,lwa)
    !         USE class_psblas, ONLY : psb_dpk_
    !         INTEGER :: iopt, m, n, nprint, info, lwa, iw(n)
    !         REAL(psb_dpk_) :: tol, x(n), fvec(m), wa(lwa)
    !         EXTERNAL fcn
    !     END SUBROUTINE dnls1e

    !     MODULE SUBROUTINE xsetf(kontrol)
    !         INTEGER :: kontrol
    !     END SUBROUTINE xsetf
    ! END INTERFACE

    ! ----- Named Constants -----

    ! Greek PI
    REAL(psb_dpk_), PARAMETER :: pi = 3.14159265358979323846264338327950288d0

    ! ITERATING class
    INTEGER, PARAMETER :: it_time_        = 1
    INTEGER, PARAMETER :: it_convergence_ = 2
    INTEGER, PARAMETER :: it_counter_     = 3

END MODULE tools_math


      SUBROUTINE COSQI (N,WSAVE)
      IMPLICIT NONE
      INTEGER :: N, K
      REAL :: WSAVE(*), DT, FK, PIH
      DATA PIH /1.57079632679491/
      DT = PIH/FLOAT(N)
      FK = 0.
      DO 101 K=1,N
         FK = FK+1.
         WSAVE(K) = COS(FK*DT)
  101 CONTINUE
      CALL RFFTI (N,WSAVE(N+1))
      RETURN
      END


*
*
*     ------------------------------------------------------------------
*	I N V M A T
*     ------------------------------------------------------------------
*
      SUBROUTINE INVMAT(A,B,MATDIM,NDIM)
C FIND INVERSE OF MATRIX A
C INPUT :
C        A : MATRIX TO BE INVERTED
C        B : SCRATCH ARRAY
C        MATDIM : PHYSICAL DIMENSION OF MATRICES
C        NDIM :   DIMENSION OF SUBMATRIX TO BE INVERTED
C
C OUTPUT : A : INVERSE MATRIX ( ORIGINAL MATRIX THUS DESTROYED )
C WARNINGS ARE ISSUED IN CASE OF CONVERGENCE PROBLEMS )
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(MATDIM,MATDIM),B(MATDIM,MATDIM)
C
      ITEST=0
      IF(NDIM.EQ.1)THEN
        IF(A(1,1) .NE. 0.0D0 ) THEN
           A(1,1) = 1.0D0/A(1,1)
        ELSE
           ITEST = 1
        END IF
      ELSE
        DETERM=0.0D0
        EPSIL=0.0D0
        CALL BNDINV(A,B,NDIM,DETERM,EPSIL,ITEST,MATDIM)
      END IF
C
      IF( ITEST .NE. 0 ) THEN
        WRITE (6,'(A,I3)') ' INVERSION PROBLEM NUMBER..',ITEST
      END IF
      NTEST = 1
      IF ( NTEST .NE. 0 ) THEN
        WRITE(6,*) ' INVERTED MATRIX '
        CALL WRTMAT(A,NDIM,NDIM,MATDIM,MATDIM)
      END IF
C
      RETURN
      END


module physconst
   use shr_kind_mod, only: r8 => shr_kind_r8
   use shr_const_mod, only: shr_const_g, shr_const_stebol, shr_const_tkfrz, &
                            shr_const_mwdair, shr_const_rdair, shr_const_mwwv, &
                            shr_const_latice, shr_const_latvap, shr_const_cpdair, &
                            shr_const_rhofw, shr_const_cpwv, shr_const_rgas, &
                            shr_const_karman, shr_const_pstd, shr_const_rhodair,&
                            shr_const_avogad, shr_const_boltz, shr_const_cpfw, &
                            shr_const_rwv, shr_const_zvir, shr_const_pi, &
                            shr_const_rearth, shr_const_sday, shr_const_cday, &
                            shr_const_spval
   implicit none
   private
   public :: physconst_readnl
   save
   real(r8), public, parameter :: avogad = shr_const_avogad
   real(r8), public, parameter :: boltz = shr_const_boltz
   real(r8), public, parameter :: cday = shr_const_cday
   real(r8), public, parameter :: cpair = shr_const_cpdair
   real(r8), public, parameter :: cpliq = shr_const_cpfw
   real(r8), public, parameter :: karman = shr_const_karman
   real(r8), public, parameter :: latice = shr_const_latice
   real(r8), public, parameter :: latvap = shr_const_latvap
   real(r8), public, parameter :: pi = shr_const_pi
   real(r8), public, parameter :: pstd = shr_const_pstd
   real(r8), public, parameter :: r_universal = shr_const_rgas
   real(r8), public, parameter :: rhoh2o = shr_const_rhofw
   real(r8), public, parameter :: spval = shr_const_spval
   real(r8), public, parameter :: stebol = shr_const_stebol
   real(r8), public, parameter :: c0 = 2.99792458e8_r8
   real(r8), public, parameter :: planck = 6.6260755e-34_r8
   real(r8), public, parameter :: mwco2 = 44._r8
   real(r8), public, parameter :: mwn2o = 44._r8
   real(r8), public, parameter :: mwch4 = 16._r8
   real(r8), public, parameter :: mwf11 = 136._r8
   real(r8), public, parameter :: mwf12 = 120._r8
   real(r8), public, parameter :: mwo3 = 48._r8
   real(r8), public, parameter :: mwso2 = 64._r8
   real(r8), public, parameter :: mwso4 = 96._r8
   real(r8), public, parameter :: mwh2o2 = 34._r8
   real(r8), public, parameter :: mwdms = 62._r8
   real(r8), public :: gravit = shr_const_g
   real(r8), public :: sday = shr_const_sday
   real(r8), public :: mwh2o = shr_const_mwwv
   real(r8), public :: cpwv = shr_const_cpwv
   real(r8), public :: mwdry = shr_const_mwdair
   real(r8), public :: rearth = shr_const_rearth
   real(r8), public :: tmelt = shr_const_tkfrz
   real(r8), public :: rga = 1._r8/shr_const_g
   real(r8), public :: ra = 1._r8/shr_const_rearth
   real(r8), public :: omega = 2.0_R8*shr_const_pi/shr_const_sday
   real(r8), public :: rh2o = shr_const_rgas/shr_const_mwwv
   real(r8), public :: rair = shr_const_rdair
   real(r8), public :: epsilo = shr_const_mwwv/shr_const_mwdair
   real(r8), public :: zvir = (shr_const_rwv/shr_const_rdair)-1.0_R8
   real(r8), public :: cpvir = (shr_const_cpwv/shr_const_cpdair)-1.0_R8
   real(r8), public :: rhodair = shr_const_pstd/(shr_const_rdair*shr_const_tkfrz)
   real(r8), public :: cappa = (shr_const_rgas/shr_const_mwdair)/shr_const_cpdair
   real(r8), public :: ez
   real(r8), public :: Cpd_on_Cpv = shr_const_cpdair/shr_const_cpwv
contains
   subroutine physconst_readnl(nlfile)
      character(len=*), intent(in) :: nlfile
    end subroutine physconst_readnl
  end module physconst


PROGRAM CIRA86

    ! COPYRIGHT 2021 MELWYN FRANCIS CARLO

    ! COMPILE AND EXECUTE BY USING THE FOLLOWING TERMINAL COMMANDS:
    ! gfortran cira86.f90 -o cira86
    ! ./cira86

    IMPLICIT NONE

    ! VARIABLE DECLARATIONS

    INTEGER                     ::  INPUT_TYPE,                                 &
                                    OUTPUT_TYPE,                                &
                                    INPUT_MONTH,                                &
                                    I_ERROR

    REAL                        ::  INPUT_PRESSURE,                             &
                                    INPUT_HEIGHT,                               &
                                    INPUT_LATITUDE

    CHARACTER(LEN = 50)         ::  OUTPUT_TYPE_OPTION_3,                       &
                                    TEMP_STRING

    CHARACTER(LEN =  8)         ::  FILENAME

    REAL, DIMENSION(25)         ::  IEX, INVERSE_HEIGHT
    REAL, DIMENSION(70)         ::  SCALE_HEIGHT
    REAL, DIMENSION(71)         ::  PRESSURE, H
    REAL, DIMENSION(21, 17)     ::  PP
    REAL, DIMENSION(2, 25, 17)  ::  TW
    REAL, DIMENSION(3, 71, 33)  ::  Z

    INTEGER                     ::  I,                                          &
                                    X,                                          &
                                    JJ,                                         &
                                    PKI,                                        &
                                    I_MAX,                                      &
                                    L_BEG,                                      &
                                    L_INC,                                      &
                                    L_STEP,                                     &
                                    ADJUSTED_LATITUDE

    ! CONSTANT VARIABLE DECLARATIONS AND DEFINITIONS

    CHARACTER(LEN = 10), PARAMETER :: OUTPUT_FORMAT =                           &
    '(A, F10.5)'

    CHARACTER(LEN = 2), DIMENSION(2), PARAMETER  :: FILENAME_PREFIX =           &
    [                                                                           &
        'cp', 'ch'                                                              &
    ]

    CHARACTER(LEN = 9), DIMENSION(12), PARAMETER :: MONTHS_LIST =               &
    [                                                                           &
        'JANUARY  ', 'FEBRUARY ', 'MARCH    ', 'APRIL    ', 'MAY      ',        &
        'JUNE     ', 'JULY     ', 'AUGUST   ', 'SEPTEMBER', 'OCTOBER  ',        &
        'NOVEMBER ', 'DECEMBER '                                                &
    ]

    CHARACTER(LEN = 8), DIMENSION(2),  PARAMETER :: INPUT_TYPES =               &
    [                                                                           &
        'PRESSURE', 'HEIGHT  '                                                  &
    ]

    CHARACTER(LEN = 21), DIMENSION(3) :: OUTPUT_TYPES =                         &
    [                                                                           &
        'TEMPERATURE          ', 'ZONAL WIND           ',                       &
        '                     '                                                 &
    ]

    ! INTRODUCTION

    PRINT  *,  NEW_LINE('1'),                                                   &
               NEW_LINE('1'),                                                   &
               NEW_LINE('1'),                                                   &
             ' #############################################################',  &
               NEW_LINE('1'),                                                   &
             ' ##                                                         ##',  &
               NEW_LINE('1'),                                                   &
             ' ##     COSPAR INTERNATIONAL REFERENCE ATMOSPHERE - 1986    ##',  &
               NEW_LINE('1'),                                                   &
             ' ##   ----------------------------------------------------  ##',  &
               NEW_LINE('1'),                                                   &
             ' ##                     0 TO 120 KILO-METERS                ##',  &
               NEW_LINE('1'),                                                   &
             ' ##                                                         ##',  &
               NEW_LINE('1'),                                                   &
             ' #############################################################',  &
               NEW_LINE('1')

    ! USER-INPUT FOR INPUT TYPE

    PRINT  *,                         NEW_LINE('1'),                            &
                                    ' ENTER 1 FOR PRESSURE-BASED INPUT.',       &
                                      NEW_LINE('1'),                            &
                                    ' ENTER 2 FOR HEIGHT-BASED INPUT.',         &
                                      NEW_LINE('1')

    WRITE (*, '(A)', ADVANCE='NO')  ' ENTER INPUT TYPE:  '

    READ  (*, '(I1)', IOSTAT=I_ERROR) INPUT_TYPE

    ! USER-INPUT VALIDATION FOR INPUT TYPE

    IF (I_ERROR /= 0) THEN
        PRINT *,                      NEW_LINE('1'),                            &
                                    ' ERROR: INVALID INPUT. ENDING PROGRAM.',   &
                                      NEW_LINE('1')
        RETURN
    END IF

    IF (INPUT_TYPE == 1) THEN
        L_INC                     =   5
        I_MAX                     =   71
        OUTPUT_TYPES(3)           = ' GEO-POTENTIAL HEIGHT'
        OUTPUT_TYPE_OPTION_3      = ' ENTER 3 FOR GEO-POTENTIAL HEIGHT'// &
                                    ' (IN KILO-METRES).'
    ELSE IF (INPUT_TYPE == 2) THEN
        L_INC                     =   10
        I_MAX                     =   25
        OUTPUT_TYPES(3)           = ' PRESSURE            '
        OUTPUT_TYPE_OPTION_3      = ' ENTER 3 FOR PRESSURE (IN MILLI-BARS).'
    ELSE
        PRINT *,                      NEW_LINE('1'),                            &
                                    ' ERROR: INVALID INPUT. ENDING PROGRAM.',   &
                                      NEW_LINE('1')
        RETURN
    END IF

    ! USER-INPUT FOR OUTPUT TYPE

    PRINT *,                          NEW_LINE('1'),                            &
                                      NEW_LINE('1'),                            &
                                    ' ENTER 1 FOR TEMPERATURE (IN KELVIN).',    &
                                      NEW_LINE('1'),                            &
                                    ' ENTER 2 FOR ZONAL WIND',                  &
                                    ' (IN METERS PER SECOND).',                 &
                                      NEW_LINE('1'),                            &
                                      OUTPUT_TYPE_OPTION_3,                     &
                                      NEW_LINE('1')

    WRITE (*, '(A)', ADVANCE='NO')  ' ENTER OUTPUT TYPE:  '

    READ  (*, '(I1)', IOSTAT=I_ERROR) OUTPUT_TYPE

    ! USER-INPUT VALIDATION FOR OUTPUT TYPE

    IF (I_ERROR /= 0) THEN
        PRINT *,                      NEW_LINE('1'),                            &
                                    ' ERROR: INVALID INPUT. ENDING PROGRAM.',   &
                                      NEW_LINE('1')
        RETURN
    END IF

    IF (OUTPUT_TYPE /= 1 .AND. OUTPUT_TYPE /= 2 .AND. OUTPUT_TYPE /= 3) THEN
        PRINT *,                      NEW_LINE('1'),                            &
                                    ' ERROR: INVALID INPUT. ENDING PROGRAM.',   &
                                      NEW_LINE('1')
        RETURN
    END IF

    IF (INPUT_TYPE == 2 .AND. OUTPUT_TYPE == 3) THEN
        I_MAX = 21
    END IF

    ! USER-INPUT FOR INPUT MONTH

    PRINT *,                          NEW_LINE('1'),                            &
                                      NEW_LINE('1'),                            &
                                    ' ENTER 1 FOR JANUARY,',                    &
                                    ' 2 FOR FEBRUARY, ...,',                    &
                                    ' 12 FOR DECEMBER.',                        &
                                      NEW_LINE('1')

    WRITE (*, '(A)', ADVANCE='NO')  ' ENTER MONTH:  '

    READ  (*, '(I2)', IOSTAT=I_ERROR) INPUT_MONTH

    ! USER-INPUT VALIDATION FOR INPUT MONTH

    IF (I_ERROR /= 0) THEN
        PRINT *,                      NEW_LINE('1'),                            &
                                    ' ERROR: INVALID INPUT. ENDING PROGRAM.',   &
                                      NEW_LINE('1')
        RETURN
    END IF

    IF (INPUT_MONTH < 1 .OR. INPUT_MONTH > 12) THEN
        PRINT *,                      NEW_LINE('1'),                            &
                                    ' ERROR: INVALID INPUT. ENDING PROGRAM.',   &
                                      NEW_LINE('1')
        RETURN
    END IF

    PRINT *
    PRINT *

    ! USER-INPUT FOR INPUT PRESSURE OR INPUT HEIGHT

    IF (INPUT_TYPE == 1) THEN

        TEMP_STRING =  'ENTER PRESSURE VALUE (IN MILLI-BARS):'
        WRITE (*, '(A)', ADVANCE='NO')   ' '//TRIM(TEMP_STRING)//'  '
        READ  (*,   *,   IOSTAT=I_ERROR)      INPUT_PRESSURE

    ELSE IF (INPUT_TYPE == 2) THEN

        TEMP_STRING = 'ENTER GEO-POTENTIAL HEIGHT VALUE (IN KILO-METERS):'
        WRITE (*, '(A)', ADVANCE='NO')   ' '//TRIM(TEMP_STRING)//'  '
        READ  (*,   *,   IOSTAT=I_ERROR)      INPUT_HEIGHT

    END IF

    ! USER-INPUT VALIDATION FOR INPUT PRESSURE OR INPUT HEIGHT

    IF (I_ERROR /= 0) THEN
        PRINT *,                      NEW_LINE('1'),                            &
                                    ' ERROR: INVALID INPUT. ENDING PROGRAM.',   &
                                      NEW_LINE('1')
        RETURN
    END IF

    ! USER-INPUT FOR INPUT LATITUDE

    PRINT *,                          NEW_LINE('1'),                            &
                                      NEW_LINE('1'),                            &
                                    ' MUST BE IN THE INTERVAL [-80.0, 80.0]'

    WRITE (*, '(A)', ADVANCE='NO')  ' ENTER LATITUDE VALUE (IN DEGREES):  '

    READ  (*, *, IOSTAT=I_ERROR)      INPUT_LATITUDE

    ! USER-INPUT VALIDATION FOR INPUT LATITUDE

    IF (I_ERROR /= 0) THEN
        PRINT *,                      NEW_LINE('1'),                            &
                                    ' ERROR: INVALID INPUT. ENDING PROGRAM.',   &
                                      NEW_LINE('1')
        RETURN
    END IF

    IF (ABS(INPUT_LATITUDE) > 80.0) THEN
        PRINT *,                      NEW_LINE('1'),                            &
                                    ' ERROR: INVALID INPUT. ENDING PROGRAM.',   &
                                      NEW_LINE('1')
        RETURN
    END IF

    L_BEG                          =  INT((INPUT_LATITUDE + 80) / L_INC) + 1
    ADJUSTED_LATITUDE              = (INT(L_BEG) - CEILING(161.0 /              &
                                     (L_INC * 2))) * L_INC

    ! OPEN ONE OF THE VAX/VMS-STYLE BINARY DATA (*.DAT) FILES

    WRITE (FILENAME, '(A2, I2, A4)')  FILENAME_PREFIX(INPUT_TYPE),              &
                                      INPUT_MONTH + 10,                         &
                                      '.dat'

    OPEN (UNIT=1,                                                               &
          STATUS='OLD',                                                         &
          IOSTAT=I_ERROR,                                                       &
          FORM='UNFORMATTED',                                                   &
          FILE=TRIM(FILENAME))

    ! FILE OPEN VALIDATION

    IF (I_ERROR /= 0) THEN
        PRINT *,                  NEW_LINE('1'),                                &
                                ' ERROR: THE FILENAME LABELLED ',               &
                                  ACHAR(39),                                    &
                                  TRIM(FILENAME),                               &
                                  ACHAR(39),                                    &
                                  NEW_LINE('1'),                                &
                                ' EITHER DOES NOT EXIST OR HAS BEEN',           &
                                ' DOCTORED.',                                   &
                                  NEW_LINE('1'),                                &
                                ' PLEASE DOWNLOAD AGAIN A FRESH COPY OF',       &
                                ' THE MENTIONED FILE.',                         &
                                  NEW_LINE('1')
        RETURN
    END IF

    ! READ FILE CONTENTS INTO VARIABLES

    IF (INPUT_TYPE == 1) THEN
        READ (1)                  SCALE_HEIGHT,                                 &
                                  PRESSURE,                                     &
                                  H,                                            &
                                  Z
    ELSE IF (INPUT_TYPE == 2) THEN
        READ (1)                  INVERSE_HEIGHT,                               &
                                  TW,                                           &
                                  PP,                                           &
                                  IEX
    END IF

    ! CLOSE FILE

    CLOSE (1)

    ! PERFORMING THE REQUIRED CALCULATIONS

    I = 1

    IF (INPUT_TYPE == 1) THEN

        DO WHILE (I <= I_MAX .AND. PRESSURE(I) <= INPUT_PRESSURE)
            I   = I + 1
        END DO

    ELSE IF (INPUT_TYPE == 2) THEN

        DO WHILE (I <= I_MAX .AND. PKI >= INPUT_HEIGHT)
            I   = I + 1
            PKI = INVERSE_HEIGHT(I)
        END DO

    END IF

    JJ          = L_BEG
    L_STEP      = 1

    IF (INPUT_TYPE == 1) THEN
        X = Z(OUTPUT_TYPE,  I, JJ)
    ELSE IF (OUTPUT_TYPE == 3) THEN
        X = PP(I, JJ)
    ELSE
        X = TW(OUTPUT_TYPE, I, JJ)
    END IF

    ! DISPLAYING THE USER INPUTS

    PRINT  *,                               NEW_LINE('1'),                      &
                                            NEW_LINE('1')

    WRITE (*, '(A, 50("-"), A, A)')  ' ',   NEW_LINE('1'),                      &
                                          ' USER INPUTS:'
    WRITE (*, '(A, 50("-"))')  ' '

    WRITE (*, '(A, A)')                   ' INPUT TYPE            =  ',         &
                                            TRIM(INPUT_TYPES(INPUT_TYPE))
    WRITE (*, '(A, A)')                   ' OUTPUT TYPE           =  ',         &
                                            TRIM(ADJUSTL(OUTPUT_TYPES(OUTPUT_TYPE)))
    WRITE (*, '(A, A)')                   ' INPUT MONTH           =  ',         &
                                            TRIM(MONTHS_LIST(INPUT_MONTH))
    WRITE (*, OUTPUT_FORMAT)              ' INPUT LATITUDE        =  ',         &
                                            INPUT_LATITUDE

    IF (INPUT_TYPE == 1) THEN
        WRITE (*, OUTPUT_FORMAT)          ' INPUT PRESSURE VALUE  =  ',         &
                                            INPUT_PRESSURE
    ELSE IF (INPUT_TYPE == 2) THEN
        WRITE (*, OUTPUT_FORMAT)          ' INPUT HEIGHT VALUE    =  ',         &
                                            INPUT_HEIGHT
    END IF

    ! DISPLAYING THE OUTPUT RESULTS

    WRITE (*, '(A, A, 50("-"), A, A)')      NEW_LINE('1'),                      &
                                          ' ',                                  &
                                            NEW_LINE('1'),                      &
                                          ' OUTPUT RESULTS:'
    WRITE (*, '(A, 50("-"))')             ' '

    IF (INPUT_TYPE == 1) THEN

        WRITE (*, OUTPUT_FORMAT)          ' SCALE HEIGHT          =  ',         &
                                            SCALE_HEIGHT(I)
        WRITE (*, OUTPUT_FORMAT)          ' PRESSURE (MB)         =  ',         &
                                            PRESSURE(I)
        WRITE (*, OUTPUT_FORMAT)          ' GEOMETRIC HEIGHT      =  ',         &
                                            H(I)
        WRITE (*, OUTPUT_FORMAT)          ' ADJUSTED LATITUDE     =  ',         &
                                            REAL(ADJUSTED_LATITUDE)
        WRITE (*, OUTPUT_FORMAT)          ' OUTPUT VALUE          =  ',         &
                                            REAL(X, 16)

    ELSE IF (INPUT_TYPE == 2) THEN

        IF (OUTPUT_TYPE /= 3) THEN
            WRITE (*, OUTPUT_FORMAT)      ' HEIGHT (KM)           =  ',         &
                                            INVERSE_HEIGHT(I)
        ELSE
            WRITE (*, OUTPUT_FORMAT)      ' HEIGHT (KM)           =  ',         &
                                            INVERSE_HEIGHT(I),                  &
                                            IEX(I)
        END IF
        WRITE     (*, OUTPUT_FORMAT)      ' ADJUSTED LATITUDE     =  ',         &
                                            REAL(ADJUSTED_LATITUDE)
        WRITE     (*, OUTPUT_FORMAT)      ' OUTPUT VALUE          =  ',         &
                                            REAL(X)

    END IF

    PRINT *
    PRINT *
    PRINT *

END PROGRAM CIRA86


function FourierTransform(f, start, end) result(y)
    procedure(Real) :: f
    Integer :: start, end
    Real :: y

    y = Integral_func(f2, start, end, 10000)

    contains

    function f2(x) result(y)
        Real :: y
        y = f(x)*exp(complex(0, -1)*PI*x)
    end function
end function

function ReverseFourierTransform(f, start, end) result(y)
    procedure(Real) :: f
    Integer :: start, end
    Real :: y

    y = Real(1) / (2 * PI) * Integral_func(f2, start, end, 10000)

    contains

    function f2(x) result(y)
        Real :: y
        y = f(x)*exp(complex(0, 1)*PI*x)
    end function
end function


    MODULE cdf_binomial_mod
! ______________________________________________________________________
!
!                             cdf_binomial_mod
!                             *=*=*=*=*=*=*=*=
!
!  -  SUBROUTINE CDF_BINOMIAL(WHICH, CUM, CCUM, S, N, PR, CPR, STATUS,
!                             CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CUM_BINOMIAL(S, N, PR, CPR, STATUS, CHECK_INPUT)
!  -  REAL (dpkind)FUNCTION CCUM_BINOMIAL(S, N, PR, CPR, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION INV_BINOMIAL(CUM, CCUM, N, PR, CPR, STATUS,
!                                         CHECK_INPUT)
!
!                             The Distribution
!                             ================
!
!   The density of the binomial distribution provides the probability of S
!   successes in N independent trials, each with probability of success
!   PR.  The density is proportional to:
!
!                                S       N-S
!                              PR  (1-PR)
!
!     The binomial is extended to non-integer values via the connection
!     between the cumulative binomial and the incomplete beta.
!
!                                Arguments
!                                =========
!
!  - INTEGER, INTENT(IN) :: WHICH. Integer indicating which of the next
!    four arguments is to be calculated.
!  Input Range: [ 1:4 ]
!     - 1 CUM and CCUM
!     - 2 S
!     - 3 N
!     - 4 PR and CPR
!  - REAL (dpkind), OPTIONAL :: CUM. The CDF of the binomial distribution,
!    i.e., the probability of 0 to S successes in N trials.
!  Range: [ 0:1-10^-10 ]
!  - REAL (dpkind), OPTIONAL :: CCUM. One minus the CDF of the binomial
!    distribution.
!  Range: [ 10^-10:1 ]
!  - REAL (dpkind) :: S. The upper limit of summation of the binomial
!    density. Note that S must be less than or equal to N.
!  Range: [ 0:10^10 ]
!  - REAL (dpkind) :: N. The number of independent trials generating the
!    binomial density. N must be greater than or equal to S.
!  Range: [ 0:10^10 ]
!  - REAL (dpkind), OPTIONAL :: PR. The probability of success in each
!    independent trial.
!  Range: [ 0:1 ]
!  - REAL (dpkind), OPTIONAL :: CPR. One minus the probability of success
!    in each independent trial; the probability of failure in each trial.
!  Range: [ 0:1 ]
!  - INTEGER, OPTIONAL, INTENT(OUT) :: STATUS. Return code.
!        0 problem solved successfully
!       -1 WHICH outside input range
!       -2 CUM outside range
!       -3 CCUM outside range
!       -4 S outside range
!       -5 N outside range
!       -6 PR outside range
!       -7 CPR outside range
!        3 CUM + CCUM is not nearly one
!        4 PR + CPR is not nearly one
!        5 S not between 0 and N.
!       10 cdf_beta (in local_cum_binomial) has no answer.
!      -50 Answer (if any) is BELOW the LOWER search bound
!       50 Answer (if any) is ABOVE the UPPER search bound
!  - LOGICAL, INTENT(IN), OPTIONAL :: CHECK_INPUT. If PRESENT and
!       .TRUE. input argument values are not checked for validity.
!
!  NOTE: CUM and CCUM and also PR and CPR must add to (nearly) one.
! ______________________________________________________________________
! .. Use Statements ..
      USE biomath_constants_mod
! ..
! .. Implicit None Statement ..
      IMPLICIT NONE
! ..
! .. Default Accessibility ..
      PRIVATE
! ..
! .. Public Statements ..
      PUBLIC :: ccum_binomial, cdf_binomial, cum_binomial, inv_binomial
! ..
    CONTAINS

!*********************************************************************

      FUNCTION ccum_binomial(s,n,pr,cpr,status,check_input)
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: cpr, pr
        REAL (dpkind) :: n, s
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
! .. Function Return Value ..
        REAL (dpkind) :: ccum_binomial
! ..
! .. Executable Statements ..

        CALL cdf_binomial(which=1,ccum=ccum_binomial,s=s,n=n,pr=pr, &
          cpr=cpr,status=status,check_input=check_input)

        RETURN

      END FUNCTION ccum_binomial

!*********************************************************************

      SUBROUTINE cdf_binomial(which,cum,ccum,s,n,pr,cpr,status, &
          check_input)
! .. Use Statements ..
        USE cdf_aux_mod
        USE zero_finder
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: ccum, cpr, cum, pr
        REAL (dpkind) :: n, s
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        INTEGER, INTENT (IN) :: which
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
! .. Local Structures ..
        TYPE (zf_locals) :: local
! ..
! .. Local Arrays ..
        REAL (dpkind) :: params(6)
! ..
! .. Local Scalars ..
        REAL (dpkind) :: fx, local_ccum, local_cpr, local_cum, local_pr, &
          try_ccum, try_cpr, try_cum, try_pr
        INTEGER :: zf_status
        LOGICAL :: has_status, local_check_input, match_cum, vary_pr
! ..
! .. Intrinsic Functions ..
        INTRINSIC MAX, PRESENT
! ..
! .. Executable Statements ..

        has_status = PRESENT(status)

        ! status = 0 means NO error

        IF (has_status) THEN
           status = 0
        END IF

        ! Check that at least one of cum, ccum is present in the calling list

        CALL check_complements(cum,ccum,the_binomial%name,'cum', 'ccum', &
             local_cum,local_ccum,set_values=(which/=1), bad_status=3, &
             status=status)

        IF (has_status) THEN
           IF (status /= 0) THEN
              RETURN
           END IF
        END IF

        ! Check that at least one of pr, cpr is present in the calling list

        CALL check_complements(pr,cpr,the_binomial%name,'pr','cpr', &
             local_pr,local_cpr,set_values=(which/=4), bad_status=4, &
             status=status)

        IF (has_status) THEN
           IF (status /= 0) THEN
              RETURN
           END IF
        END IF

        !==========
        ! Check that probabilities add to one
        !==========

        IF (which /= 4) THEN
           IF ( .NOT. add_to_one(local_pr,local_cpr,the_binomial%name, &
                'pr','cpr',4,status)) RETURN
        END IF

        params(1) = local_cum
        params(2) = local_ccum
        params(3) = s
        params(4) = n
        params(5) = local_pr
        params(6) = local_cpr

        IF (PRESENT(check_input)) THEN
          local_check_input = check_input
        ELSE
          local_check_input = .TRUE.
        END IF

        IF (local_check_input) THEN

          CALL validate_parameters(the_binomial,which,params,status)

          IF (has_status) THEN
             IF (status /= 0) THEN
                RETURN
             END IF
          END IF

          IF (which/=2 .AND. which/=3) THEN

            ! Assure that s is between 0 and n

            IF ( .NOT. in_range(value=s, lo=zero, hi=n, routine_name= &
              the_binomial%name, arg_name='s', bad_status=5,status=status)) &

              RETURN
          END IF

        END IF

        !==========
        ! Calculate answers
        !==========

        IF (which>1) match_cum = (local_cum <= half)

        SELECT CASE (which)

        CASE (1)
           ! Solve for the cumulative binomial (cdf)

           CALL local_cum_binomial(s,n,local_pr,local_cpr,local_cum, &
                local_ccum, status)

           IF (has_status) THEN
              IF (status /= 0) THEN
                 ! Problem can NOT be solved because cdf_beta has NO solution.
                 RETURN
              END IF
           END IF

           IF (PRESENT(cum)) cum = local_cum
           IF (PRESENT(ccum)) ccum = local_ccum

           RETURN

        CASE (2)
           ! Solve for s (number of successes)

          s = half * n
          zf_status = 0

! DMS
! Clearly s <= n, so the UPPER bound for s should be n
! We can not call cdf_set_zero() as in the other cases, because
! the_binomial structures contains PARAMETERS which can NOT be modified.
! The values are set like in  cdf_set_zero()

          CALL set_zero_finder( &
               low_limit=the_binomial%parameters(3)%low_bound, &
               hi_limit=n, abs_step=half, rel_step=half, &
               step_multiplier=five, abs_tol=1.0E-50_dpkind, &
               rel_tol=1.0E-8_dpkind, local=local)

          DO
!            CALL rc_interval_zf(zf_status, s, fx, local)
             CALL rc_step_zf(zf_status, s, fx, local)

            IF (zf_status /= 1) EXIT

            CALL local_cum_binomial(s, n, local_pr, local_cpr, try_cum, &
                                    try_ccum, status)

            IF (has_status) THEN
               IF (status /= 0) THEN
                  RETURN
               END IF
            END IF

            IF (match_cum) THEN
              fx = try_cum - local_cum
            ELSE
              fx = local_ccum - try_ccum
            END IF

          END DO

        CASE (3)
          ! Solve for n (sample size)

          n = two * MAX(s,one)
          zf_status = 0

          CALL cdf_set_zero_finder(the_binomial,4,local)

          DO
            CALL rc_step_zf(zf_status,n,fx,local)

            IF (zf_status/=1) EXIT

            CALL local_cum_binomial(s,n,local_pr,local_cpr,try_cum, &
                                    try_ccum, status)

            IF (has_status) THEN
               IF (status /= 0) THEN
                  RETURN
               END IF
            END IF

            IF (match_cum) THEN
              fx = try_cum - local_cum
            ELSE
              fx = try_ccum - local_ccum
            END IF
          END DO

        CASE (4)
           ! Solve for the binomial probability (pr) or
           ! its complement (cpr)

          zf_status = 0

!!! A difficult  case -- we  will try to  match the lesser of  cum and
!!! ccum If the answer <= 1/2 we will vary pr else we will vary cpr

! Decide whether to vary pr or cpr

          CALL local_cum_binomial(s,n,half,half,try_cum,try_ccum, status)

          IF (has_status) THEN
             IF (status /= 0) THEN
                RETURN
             END IF
          END IF

          vary_pr = (try_cum<=local_cum)

          IF (match_cum .AND. vary_pr) THEN

             ! We are trying to match cum varying pr

            CALL cdf_set_zero_finder(the_dummy_binomial,1,local)

            DO
              CALL rc_interval_zf(zf_status,try_pr,fx,local)

              try_cpr = one - try_pr

              IF (zf_status/=1) EXIT

              CALL local_cum_binomial(s,n,try_pr,try_cpr,try_cum, &
                                      try_ccum, status)

              IF (has_status) THEN
                 IF (status /= 0) THEN
                    RETURN
                 END IF
              END IF

              fx = local_cum - try_cum
            END DO

          ELSE IF (match_cum .AND. .NOT. vary_pr) THEN
            ! Try to match cum varying cpr

            CALL cdf_set_zero_finder(the_dummy_binomial,2,local)

            DO

              CALL rc_interval_zf(zf_status,try_cpr,fx,local)

              try_pr = one - try_cpr

              IF (zf_status/=1) EXIT

              CALL local_cum_binomial(s,n,try_pr,try_cpr,try_cum, &
                                      try_ccum, status)

              IF (has_status) THEN
                 IF (status /= 0) THEN
                    RETURN
                 END IF
              END IF

              fx = local_cum - try_cum
            END DO

          ELSE IF ( .NOT. match_cum .AND. vary_pr) THEN
! Try to match ccum varying pr

            CALL cdf_set_zero_finder(the_dummy_binomial,1,local)

            DO

              CALL rc_interval_zf(zf_status,try_pr,fx,local)

              try_cpr = one - try_pr

              IF (zf_status/=1) EXIT

              CALL local_cum_binomial(s,n,try_pr,try_cpr,try_cum, &
                                      try_ccum, status)

              IF (has_status) THEN
                 IF (status /= 0) THEN
                    RETURN
                 END IF
              END IF

              fx = local_ccum - try_ccum
            END DO

          ELSE

            ! Try to match ccum varying cpr

            CALL cdf_set_zero_finder(the_dummy_binomial,2,local)

            DO

              CALL rc_interval_zf(zf_status,try_cpr,fx,local)

              try_pr = one - try_cpr

              IF (zf_status/=1) EXIT

              CALL local_cum_binomial(s,n,try_pr,try_cpr,try_cum, &
                                      try_ccum, status)

              IF (has_status) THEN
                 IF (status /= 0) THEN
                    RETURN
                 END IF
              END IF

              fx = local_ccum - try_ccum
            END DO

          END IF

          IF (PRESENT(pr)) pr = try_pr

          IF (PRESENT(cpr)) cpr = try_cpr

        END SELECT

        IF (has_status) THEN
           ! Set the status of the zero finder
           CALL cdf_finalize_status( local, status )
        END IF

        RETURN

      END SUBROUTINE cdf_binomial

!*********************************************************************

      FUNCTION cum_binomial(s,n,pr,cpr,status,check_input)
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: cpr, pr
        REAL (dpkind) :: n, s
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
! .. Function Return Value ..
        REAL (dpkind) :: cum_binomial
! ..
! .. Executable Statements ..

        CALL cdf_binomial(which=1,cum=cum_binomial,s=s,n=n,pr=pr,cpr=cpr, &
                          status=status,check_input=check_input)

        RETURN

      END FUNCTION cum_binomial

!*********************************************************************

      FUNCTION inv_binomial(cum,ccum,n,pr,cpr,status,check_input)
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: ccum, cpr, cum, pr
        REAL (dpkind) :: n
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
! .. Function Return Value ..
        REAL (dpkind) :: inv_binomial
! ..
! .. Executable Statements ..

        CALL cdf_binomial(2,cum,ccum,inv_binomial,n,pr,cpr,status, &
                          check_input)

        RETURN

      END FUNCTION inv_binomial

!*********************************************************************

      SUBROUTINE local_cum_binomial(s,xn,pr,ompr,cum,ccum, status)
!----------------------------------------------------------------------
!                    CUMulative BINomial distribution
!
!                              Function
!
!     Returns the probability   of 0  to  S  successes in  XN   binomial
!     trials, each of which has a probability of success, PBIN.
!                              Arguments
!     S --> The upper limit of cumulation of the binomial distribution.
!
!     XN --> The number of binomial trials.
!
!     PR --> The probability of success in each binomial trial.
!
!     OMPR --> 1 - PBIN
!
!     CUM <-- Cumulative binomial distribution.
!
!     CCUM <-- Complement of Cumulative binomial distribution.
!
!     STATUS <-- status of the computation.
!                Set to 10 if cdf_beta has no answer.
!
!                              Method
!
!     Formula  26.5.24    of   Abramowitz  and    Stegun,  Handbook   of
!     Mathematical   Functions (1966) is   used  to reduce the  binomial
!     distribution  to  the  cumulative    beta distribution.
!----------------------------------------------------------------------
! .. Use Statements ..
        USE cdf_beta_mod
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (OUT) :: ccum, cum
        REAL (dpkind), INTENT (IN) :: ompr, pr, s, xn
        INTEGER, OPTIONAL, INTENT(OUT) :: status
! ..
! .. Local Scalars
        INTEGER :: beta_status
! ..
! .. Intrinsic Functions ..
        INTRINSIC PRESENT
! ..
! .. Executable Statements ..

        IF (s < xn) THEN
          CALL cdf_beta(1,ccum,cum,pr,ompr,s+one,xn-s, status=beta_status)

          IF (beta_status /= 0) THEN
             ! cdf_beta has NO answer.

             IF (PRESENT(status)) THEN
                status = 10
             ELSE
                WRITE (*,*) 'Error in local_cum_binomial call to cdf_beta'
                WRITE (*,*) 'Status: ', beta_status

                STOP 'Error in local_cum_binomial call to cdf_beta'
             END IF
          END IF
        ELSE
          cum = one
          ccum = zero
        END IF

        RETURN

      END SUBROUTINE local_cum_binomial

!*********************************************************************

    END MODULE cdf_binomial_mod


    Program zggqrf_example

!     ZGGQRF Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: dznrm2, zgemv
      Use lapack_interfaces, Only: zggqrf, ztrtrs, zunmqr, zunmrq
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Complex (Kind=dp), Parameter :: one = (1.0E0_dp, 0.0E0_dp)
      Complex (Kind=dp), Parameter :: zero = (0.0E0_dp, 0.0E0_dp)
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: rnorm
      Integer :: i, info, lda, ldb, lwork, m, n, p
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), b(:, :), d(:), taua(:), &
        taub(:), work(:), y(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: max, min
!     .. Executable Statements ..
      Write (nout, *) 'ZGGQRF Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, m, p
      lda = n
      ldb = n
      lwork = nb*(m+p)
      Allocate (a(lda,m), b(ldb,p), d(n), taua(m), taub(m+p), work(lwork), &
        y(p))

!     Read A, B and D from data file
      Read (nin, *)(a(i,1:m), i=1, n)
      Read (nin, *)(b(i,1:p), i=1, n)
      Read (nin, *) d(1:n)

!     Compute the generalized QR factorization of (A,B) as
!     A = Q*(R),   B = Q*(T11 T12)*Z
!            (0)          ( 0  T22)
      Call zggqrf(n, m, p, a, lda, taua, b, ldb, taub, work, lwork, info)

!     Compute c = (c1) = (Q**H)*d, storing the result in D
!                  (c2)
      Call zunmqr('Left', 'Conjugate transpose', n, 1, m, a, lda, taua, d, n, &
        work, lwork, info)

!     Putting Z*y = w = (w1), set w1 = 0, storing the result in Y1
!                        (w2)
      y(1:m+p-n) = zero

      If (n>m) Then

!       Copy c2 into Y2

        y(m+p-n+1:p) = d(m+1:n)

!       Solve T22*w2 = c2 for w2, storing result in Y2

        Call ztrtrs('Upper', 'No transpose', 'Non-unit', n-m, 1, &
          b(m+1,m+p-n+1), ldb, y(m+p-n+1), n-m, info)

        If (info>0) Then
          Write (nout, *) &
            'The upper triangular factor, T22, of B is singular, '
          Write (nout, *) 'the least squares solution could not be computed'
          Go To 100
        End If

!       Compute estimate of the square root of the residual sum of
!       squares norm(y) = norm(w2)
        rnorm = dznrm2(n-m, y(m+p-n+1), 1)

!       Form c1 - T12*w2 in D
        Call zgemv('No transpose', m, n-m, -one, b(1,m+p-n+1), ldb, &
          y(m+p-n+1), 1, one, d, 1)
      End If

!     Solve R*x = c1 - T12*w2 for x
      Call ztrtrs('Upper', 'No transpose', 'Non-unit', m, 1, a, lda, d, m, &
        info)

      If (info>0) Then
        Write (nout, *) 'The upper triangular factor, R, of A is singular, '
        Write (nout, *) 'the least squares solution could not be computed'
      Else

!       Compute y = (Z**H)*w
        Call zunmrq('Left', 'Conjugate transpose', p, 1, min(n,p), b(max(1, &
          n-p+1),1), ldb, taub, y, p, work, lwork, info)

!       Print least squares solution x
        Write (nout, *) 'Generalized least squares solution'
        Write (nout, 110) d(1:m)

!       Print residual vector y
        Write (nout, *)
        Write (nout, *) 'Residual vector'
        Write (nout, 120) y(1:p)

!       Print estimate of the square root of the residual sum of
!       squares
        Write (nout, *)
        Write (nout, *) 'Square root of the residual sum of squares'
        Write (nout, 130) rnorm
      End If
100   Continue

110   Format (3(' (',F9.4,',',F9.4,')',:))
120   Format (3(' (',1P,E9.2,',',1P,E9.2,')',:))
130   Format (1X, 1P, E10.2)
    End Program


      double precision function vnorm (n, v, w)
clll. optimize
c-----------------------------------------------------------------------
c this function routine computes the weighted root-mean-square norm
c of the vector of length n contained in the array v, with weights
c contained in the array w of length n..
c   vnorm = sqrt( (1/n) * sum( v(i)*w(i) )**2 )
c-----------------------------------------------------------------------
      integer n,   i
      double precision v, w,   sum
      dimension v(n), w(n)
      sum = 0.0d0
      do 10 i = 1,n
 10     sum = sum + (v(i)*w(i))**2
      vnorm = dsqrt(sum/dfloat(n))
      return
c----------------------- end of function vnorm -------------------------
      end


      SUBROUTINE fourn(data,nn,ndim,isign)
      INTEGER isign,ndim,nn(ndim)
      REAL data(*)
      INTEGER i1,i2,i2rev,i3,i3rev,ibit,idim,ifp1,ifp2,ip1,ip2,ip3,k1,
     *k2,n,nprev,nrem,ntot
      REAL tempi,tempr
      DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp
      ntot=1
      do 11 idim=1,ndim
        ntot=ntot*nn(idim)
11    continue
      nprev=1
      do 18 idim=1,ndim
        n=nn(idim)
        nrem=ntot/(n*nprev)
        ip1=2*nprev
        ip2=ip1*n
        ip3=ip2*nrem
        i2rev=1
        do 14 i2=1,ip2,ip1
          if(i2.lt.i2rev)then
            do 13 i1=i2,i2+ip1-2,2
              do 12 i3=i1,ip3,ip2
                i3rev=i2rev+i3-i2
                tempr=data(i3)
                tempi=data(i3+1)
                data(i3)=data(i3rev)
                data(i3+1)=data(i3rev+1)
                data(i3rev)=tempr
                data(i3rev+1)=tempi
12            continue
13          continue
          endif
          ibit=ip2/2
1         if ((ibit.ge.ip1).and.(i2rev.gt.ibit)) then
            i2rev=i2rev-ibit
            ibit=ibit/2
          goto 1
          endif
          i2rev=i2rev+ibit
14      continue
        ifp1=ip1
2       if(ifp1.lt.ip2)then
          ifp2=2*ifp1
          theta=isign*6.28318530717959d0/(ifp2/ip1)
          wpr=-2.d0*sin(0.5d0*theta)**2
          wpi=sin(theta)
          wr=1.d0
          wi=0.d0
          do 17 i3=1,ifp1,ip1
            do 16 i1=i3,i3+ip1-2,2
              do 15 i2=i1,ip3,ifp2
                k1=i2
                k2=k1+ifp1
                tempr=sngl(wr)*data(k2)-sngl(wi)*data(k2+1)
                tempi=sngl(wr)*data(k2+1)+sngl(wi)*data(k2)
                data(k2)=data(k1)-tempr
                data(k2+1)=data(k1+1)-tempi
                data(k1)=data(k1)+tempr
                data(k1+1)=data(k1+1)+tempi
15            continue
16          continue
            wtemp=wr
            wr=wr*wpr-wi*wpi+wr
            wi=wi*wpr+wtemp*wpi+wi
17        continue
          ifp1=ifp2
        goto 2
        endif
        nprev=n*nprev
18    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/fourn.for


      subroutine eos_cs(rho,cs,temp,kappa,mu,gamma,cp)
!-----------------------------------------------------------------------
! Reads and interpolates the equation of state tables to give
! temperatures, opacities ***USING sound speed***
! Updated to fortran 90 PJC 22/05/2008
! Extended to opacities DHF 01/09/2009
!-----------------------------------------------------------------------

	use unitdata

      implicit none

      integer :: i,j
	real, intent(inout) :: rho, cs,kappa,mu,gamma, temp,cp
      real :: mtemp,mtemp1,mtemp2,ctemp,ctemp1,ctemp2,temp1,temp2
      real :: mmu,mmu1,mmu2,cmu,cmu1,cmu2,mu1,mu2
      real :: mkap,mkap1,mkap2,ckap,ckap1,ckap2,kap1,kap2
      real :: mgamma,mgamma1,mgamma2,cgamma,cgamma1,cgamma2,gamma1,gamma2

! Find the relevant records in the table...
! ... for rho
         if (rho < eostable(1,1,1)) rho = 1.01*eostable(1,1,1)
         i = 1
         do
            if ((eostable(i,1,1) >= rho).or.(i == nrhopoints)) exit
            i = i + 1
         enddo

! ... and for sound speed

         if (cs < eostable(1,1,3)) cs = 1.01*eostable(1,1,3)
         j = 1
         do
            if ((eostable(i-1,j,3) >= cs).or.(j==nUpoints)) exit
            j = j + 1
         enddo

!         if(j==1) j=2
! Interpolate over the j value at i-1
         mtemp1 = (eostable(i-1,j-1,2) - eostable(i-1,j,2))/ &
              (eostable(i-1,j-1,3) - eostable(i-1,j,3))
         ctemp1 = eostable(i-1,j,2) - mtemp1*eostable(i-1,j,3)
         temp1 = mtemp1*cs + ctemp1

        ! print*, cs, j, mtemp1,ctemp1,temp1

         mmu1 = (eostable(i-1,j-1,4) - eostable(i-1,j,4))/ &
              (eostable(i-1,j-1,3) - eostable(i-1,j,3))
         cmu1 = eostable(i-1,j,4) - mmu1*eostable(i-1,j,3)
         mu1 = mmu1*cs + cmu1

	 mkap1 = (eostable(i-1,j-1,6) - eostable(i-1,j,6))/ &
              (eostable(i-1,j-1,3) - eostable(i-1,j,3))
	 ckap1 = eostable(i-1,j,6) - mkap1*eostable(i-1,j,3)
	 kap1 = mkap1*cs + ckap1

	 mgamma1 = (eostable(i-1,j-1,5) - eostable(i-1,j,5))/ &
              (eostable(i-1,j-1,3) - eostable(i-1,j,3))
	cgamma1 = eostable(i-1,j,5) - mgamma1*eostable(i-1,j,3)
	gamma1 = mgamma1*cs + cgamma1

! then interpolate over the j value at i
! Update j value as necessary
         j = 1
         do
            if ((eostable(i,j,3) >= cs).or.(j==nUpoints)) exit
            j = j + 1
         enddo

 !        if(j==1) j=2
         mtemp2 = (eostable(i,j-1,2) - eostable(i,j,2))/ &
              (eostable(i,j-1,3) - eostable(i,j,3))
         ctemp2 = eostable(i,j,2) - mtemp2*eostable(i,j,3)
         temp2 = mtemp2*cs + ctemp2

         mmu2 = (eostable(i,j-1,4) - eostable(i,j,4))/ &
              (eostable(i,j-1,3) - eostable(i,j,3))
         cmu2 = eostable(i,j,4) - mmu2*eostable(i,j,3)
         mu2 = mmu2*cs + cmu2

         mkap2 = (eostable(i,j-1,6) - eostable(i,j,6))/ &
              (eostable(i,j-1,3) - eostable(i,j,3))
         ckap2 = eostable(i,j,6) - mkap2*eostable(i,j,3)
         kap2 = mkap2*cs + ckap2

	 mgamma2 = (eostable(i,j-1,5) - eostable(i,j,5))/ &
              (eostable(i,j-1,3) - eostable(i,j,3))
         cgamma2 = eostable(i,j,5) - mgamma2*eostable(i,j,3)
         gamma2 = mgamma2*cs + cgamma2

! Finally interpolate over i at the fractional j value
         mtemp = (temp2 - temp1) / (eostable(i,1,1)-eostable(i-1,1,1))
         ctemp = temp2 - mtemp*eostable(i,1,1)
         temp = mtemp*rho + ctemp

         mmu = (mu2 - mu1) / (eostable(i,1,1)-eostable(i-1,1,1))
         cmu = mu2 - mmu*eostable(i,1,1)
         mu = mmu*rho + cmu

	mkap = (kap2 - kap1) / (eostable(i,1,1)-eostable(i-1,1,1))
         ckap = kap2 - mkap*eostable(i,1,1)
         kappa = abs(mkap*rho + ckap)

	mgamma = (gamma2 - gamma1) / (eostable(i,1,1)-eostable(i-1,1,1))
         cgamma = gamma2 - mgamma*eostable(i,1,1)
         gamma = mgamma*rho + cgamma

         cp = cs*cs/(temp*gamma*(gamma-1))

      end subroutine eos_cs


      subroutine fan1(x0,y0,r1,r2,a1,a2)
C     for  h-10/mt          es-1022
C... to draw a fan shade by providing the center coordinate,two radii
C    side-angles of the fan shaded circular arc.
C    x0,y0    center coordinate of a fan shaded circular arc.
C   r1       radius of the outside circular arcof the fan shade.
C   r2      radius of the inside circular arc of the fan shade.
C    a1      angle of the right side of the fan shade.
C    a2      angle of the left side of the fan shade.
       b1=a1*3.14159265/180.
      b2=a2*3.14159265/180.
      x1=x0+r1*cos(b1)
      y1=y0+r1*sin(b1)
      x2=x0+r1*cos(b2)
      y2=y0+r1*sin(b2)
      x3=x0+r2*cos(b2)
      y3=y0+r2*sin(b2)
      x4=x0+r2*cos(b1)
      y4=y0+r2*sin(b1)
C... to draw the outside circular arc.
      call arc1(x1,y1,x2,y2,x0,y0,2)
      call move(x2,y2,0)
      call move(x3,y3,1)
C... to draw the inside circular arc.
      call arc1(x3,y3,x4,y4,x0,y0,1)
      call move(x4,y4,0)
      call move(x1,y1,1)
      return
      end


      Complex*16 FUNCTION FPIBEL(W,flpar)
C****************************************************************************
C                       PION FORM FACTOR FROM BELLE
C
C            Rho(770)+rho(1450)+rho(1700) model is used as in:
C             M.Fujikawa et al., Phys.Rev.D 78 (2008) 072006
C                          -------------------
C       * flpar: = 0 - (all free) fit result for par(1...11)
C                = 1 - (par(1)=F_pi(0)=1-fixed) fit result for par(2...11)
C
C       * parameter : par(1)=overall norm. factor (=F_pi(0))
C                   : par(2)=rho(770) mass
C                   : par(3)=rho(770) width
C                   : par(4)=rho(1450) mass
C                   : par(5)=rho(1450) width
C                   : par(6)=rho(1450) admixture abs. value (|beta|)
C                   : par(7)=rho(1450) admixture phase (phi=arg(beta))
C                   : par(8)=rho(1700) mass
C                   : par(9)=rho(1700) width
C                   : par(10)=rho(1700) admixture abs. value (|gamma|)
C                   : par(11)=rho(1700) admixture phase (phi3=arg(gamma))
C
C       * x:=s=(M_pipi0)^2=W^2
C
C       * Notice: the following code was extracted (and checked) directly
C                 from the Belle fit function with minor cosmetic changes
C                 (this is internal comment of Belle)
C
C       * Notice: the following code was extracted (and checked) directly
C                 from  tauola_with_belle_fpi.F sent by D. Epifanov and
C                 it is an identical copy of
C                 Complex*16 FUNCTION FPIBEL(W,flpar)
C                 used in tauola_with_belle_fpi.F
C
C       * Called: CURR_PIPI0  if (FF2PIRHO = 2  or FF2PIRHO =3)
C                 in ../RChL-currents/value_parameter.f
C                 FF2PIRHO = 2 is for flpar = 0
C                 FF2PIRHO = 3 is for flpar = 1
C
C****************************************************************************
      implicit none
      integer flpar
      real W
      real*8 x,par(11),pi,pimas,pi0mas,taumas
      real*8 beta,berho1,berho2,berho3
      real*8 ps,prho1,prho2,prho3
      real*8 gamma1,gamma2,gamma3
      real*8 hs,h1,h2,h3,dhds1,dhds2,dhds3
      real*8 d1,d2,d3,fs1,fs2,fs3
      real*8 a1,b1,c1,bw_re1,bw_im1
      real*8 a2,b2,c2,bw_re2,bw_im2
      real*8 a3,b3,c3,bw_re3,bw_im3
      real*8 sinphi,cosphi,sinphi3,cosphi3
      complex*16 mbw1,mbw2,mbw3,mff,mephi,mephi3
      parameter(pi=3.141592653589)

      x=dble(W**2)
C------------- PARAMETERS --------------------
C     Particle mass (unit: GeV)

      pimas  = 0.1395702
      pi0mas = 0.13498
      taumas = 1.77699

C---------------------------------------------
C Opt. par. from Table VII of PRD78 (2008) 072006

      if(flpar.eq.0) then
         par(1) = 1.02
         par(2) = 0.7749
         par(3) = 0.1486
         par(4) = 1.428
         par(5) = 0.413
         par(6) = 0.13
         par(7) = 197
         par(8) = 1.694
         par(9) = 0.135
         par(10)= 0.028
         par(11)= -3
      else
         par(1) = 1.0
         par(2) = 0.7746
         par(3) = 0.1481
         par(4) = 1.446
         par(5) = 0.434
         par(6) = 0.15
         par(7) = 202
         par(8) = 1.728
         par(9) = 0.164
         par(10)= 0.037
         par(11)= 24
      endif

C========= Beta (s, rho(770), rho(1450), rho(1700)) ==================

       beta  =sqrt( (1.0 - (pimas - pi0mas)**2/x)
     +             *(1.0 - (pimas + pi0mas)**2/x) )

c      ----- rho(770) -----
       berho1=sqrt( ( 1.0 - (pimas - pi0mas)**2/(par(2)*par(2)) )
     +             *( 1.0 - (pimas + pi0mas)**2/(par(2)*par(2)) ) )

c      ----- rho(1450) -----
       berho2=sqrt( ( 1.0 - (pimas - pi0mas)**2/(par(4)*par(4)) )
     +             *( 1.0 - (pimas + pi0mas)**2/(par(4)*par(4)) ) )

c      ----- rho(1700) -----
       berho3=sqrt( ( 1.0 - (pimas - pi0mas)**2/(par(8)*par(8)) )
     +             *( 1.0 - (pimas + pi0mas)**2/(par(8)*par(8)) ) )

C========= Momentum (s, rho(770), rho(1450), rho(1700)) ==============
C
C       ps    : momentum of pi at s
C       prho1 : momentum of pi at s=rho(770)**2
C       prho2 : momentum of pi at s=rho(1450)**2
C       prho3 : momentum of pi at s=rho(1700)**2

       ps  = 0.5 * sqrt(x) * beta
c      ----- rho(770) -----
       prho1 = 0.5* par(2) * berho1
c      ----- rho(1450) -----
       prho2 = 0.5* par(4) * berho2
c      ----- rho(1700) -----
       prho3 = 0.5* par(8) * berho3

C========= Width (rho(770), rho(1450), rho(1700)) ====================

C      ----- rho(770) -----
       gamma1 = par(3) * ( par(2)*par(2)/x ) * (ps/prho1)**3
C      ----- rho(1450) -----
       gamma2 = par(5) * ( par(4)*par(4)/x ) * (ps/prho2)**3
C      ----- rho(1700) -----
       gamma3 = par(9) * ( par(8)*par(8)/x ) * (ps/prho3)**3

C============== h(rho(770), rho(1450), rho(1700)) ====================
C
C       hs : h(s)...s(s=x)
C       h1 : h(s) for s=rho(770)**2
C       h2 : h(s) for s=rho(1450)**2
C       h3 : h(s) for s=rho(1700)**2

        hs = (2.0/pi)*(ps/sqrt(x))*
     +       log( (sqrt(x) + 2.0*ps)/(2.0*pimas) )
C      ----- rho(770) -----
        h1 = (2.0/pi)*(prho1/par(2))*
     +       log( (par(2) + 2.0*prho1)/(2.0*pimas) )
C      ----- rho(1450) -----
        h2 = (2.0/pi)*(prho2/par(4))*
     +       log( (par(4) + 2.0*prho2)/(2.0*pimas) )
C      ----- rho(1700) -----
        h3 = (2.0/pi)*(prho3/par(8))*
     +       log( (par(8) + 2.0*prho3)/(2.0*pimas) )

C============ dhds(rho(770), rho(1450), rho(1700)) ===================
C
C       dhds = dh/ds = h(M_rho)[1/(8*p(M_rho)^2) - 1/(2M_rho^2)
C                                              + 1/(2pi*M_rho^2)
C       dhds1 : dh/ds for M_rho=rho(770)
C       dhds2 : dh/ds for M_rho=rho(1450)
C       dhds3 : dh/ds for M_rho=rho(1700)

C      ----- rho(770) -----
        dhds1 = h1*( 1.0/(8.0*prho1**2) - 1.0/(2.0*par(2)**2) )
     +                       +  1.0/(2.0*pi*par(2)**2)
C      ----- rho(1450) -----
        dhds2 = h2*( 1.0/(8.0*prho2**2) - 1.0/(2.0*par(4)**2) )
     +                       +  1.0/(2.0*pi*par(4)**2)
C      ----- rho(1700) -----
        dhds3 = h3*( 1.0/(8.0*prho3**2) - 1.0/(2.0*par(8)**2) )
     +                       +  1.0/(2.0*pi*par(8)**2)

C============ d(rho(770), rho(1450), rho(1700)) ======================
C
C       d = 3/pi * (m_pi^2/p(M_rho)^2) *
C            ln {(M_rho+2*p(M_rho))/2M_pi} + M_rho/(2pi*p(M_rho))
C                               - (m_pi^2 * M_rho)/(pi*p(M_rho)^3)
C       d1 : d for M_rho=rho(770)
C       d2 : d for M_rho=rho(1450)
C       d2 : d for M_rho=rho(1700)

C      ----- rho(770) -----
        d1 = (3.0/pi)*(pimas**2/prho1**2)
     +         * log((par(2) + 2.0*prho1)/(2.0*pimas))
     +         + par(2)/(2.0*pi*prho1)
     +         - ((pimas**2)*par(2))/(pi*prho1**3)
C      ----- rho(1450) -----
        d2 = (3.0/pi)*(pimas**2/prho2**2)
     +         * log((par(4) + 2.0*prho2)/(2.0*pimas))
     +         + par(4)/(2.0*pi*prho2)
     +         - ((pimas**2)*par(4))/(pi*prho2**3)
C      ----- rho(1700) -----
        d3 = (3.0/pi)*(pimas**2/prho3**2)
     +         * log((par(8) + 2.0*prho3)/(2.0*pimas))
     +         + par(8)/(2.0*pi*prho3)
     +         - ((pimas**2)*par(8))/(pi*prho3**3)

C================ f(s) (rho(770), rho(1450), rho(1700) ) ==========
C
C       f(s) = gamma-rho * M_rhp**2/p(M_rho)[ p(s)^2(h(s)-h(M_rho)
C                                 + (M_rho^2 -s)p(M_rho)^2 * dh/ds]
C       fs1 : f(s) for M_rho=rho(770)
C       fs2 : f(s) for M_rho=rho(1450)
C       fs3 : f(s) for M_rho=rho(1700)
C
C      ----- rho(770) -----
        fs1 = par(3) * (par(2)**2/prho1**3) *
     +        ( ps**2 *(hs - h1) + (par(2)**2 -x)*prho1**2 * dhds1 )
C      ----- rho(1450) -----
        fs2 = par(5) * (par(4)**2/prho2**3) *
     +        ( ps**2 *(hs - h2) + (par(4)**2 -x)*prho2**2 * dhds2 )
C      ----- rho(1700) -----
        fs3 = par(9) * (par(8)**2/prho3**3) *
     +        ( ps**2 *(hs - h3) + (par(8)**2 -x)*prho3**2 * dhds3 )

C====== BW form G&S model (rho(770) + rho(1450) + rho(1700)) ======
C    bw_re - real part ; bw_im - imaginary part

C      ----- rho(770) -----
       a1=par(2)*par(2) - x + fs1
       b1=sqrt(x)*gamma1
       c1=par(2)*par(2) + d1*par(2)*par(3)

       bw_re1= (a1*c1)/(a1**2 + b1**2)
       bw_im1= (b1*c1)/(a1**2 + b1**2)
       mbw1=dcmplx(bw_re1,bw_im1)

c      ----- rho(1450) -----
       a2=par(4)*par(4) - x + fs2
       b2=sqrt(x)*gamma2
       c2=par(4)*par(4)+ d2*par(4)*par(5)

       bw_re2= (a2*c2)/(a2**2 + b2**2)
       bw_im2= (b2*c2)/(a2**2 + b2**2)
       mbw2=dcmplx(bw_re2,bw_im2)

c      ----- rho(1700) -----
       a3=par(8)*par(8) - x + fs3
       b3=sqrt(x)*gamma3
       c3=par(8)*par(8)+ d3*par(8)*par(9)

       bw_re3= (a3*c3)/(a3**2 + b3**2)
       bw_im3= (b3*c3)/(a3**2 + b3**2)
       mbw3=dcmplx(bw_re3,bw_im3)

C====== admixtures of rho(1450) and rho(1700) ======

C --------- exp(i*arg(beta)) ----------
       sinphi=sin(par(7)*(pi/180.0))  ! use degree
       cosphi=cos(par(7)*(pi/180.0))  ! use degree
       mephi=dcmplx(cosphi,sinphi)

C --------- exp(i*arg(gamma)) ---------
       sinphi3=sin(par(11)*(pi/180.0))  ! use degree
       cosphi3=cos(par(11)*(pi/180.0))  ! use degree
       mephi3=dcmplx(cosphi3,sinphi3)

C================= Form factor =====================

       mff = 1.0/(1.0+par(6)*mephi+par(10)*mephi3)
       FPIBEL=par(1)*mff*(mbw1+par(6)*mephi*mbw2+par(10)*mephi3*mbw3)
      RETURN
      END