module two_point_flux_mod

use globals_mod

private

public :: xflux, yflux

contains

pure elemental function logmean(a,b) result(r)

    real(dp), intent(in)    :: a,b
    real(dp)                :: x,u,r

    real(dp), parameter :: eps = 1e-5
    real(dp), parameter :: c1 = 1.0/6.0
    real(dp), parameter :: c2 = 2.0/45.0
    real(dp), parameter :: c3 = 22.0/945.0

    x = a/b

    if (abs(a-b) < eps) then
        u  = (x*(x-2.0)+1.0)/(x*(x+2.0)+1.0)
        r = (a+b)*(0.5 - u*(c1 - u*(c2 - c3*u)))
    else
        r = (a-b)/log(x)
    endif

end function

pure function xflux(u,v) result(f)

    use equations_mod
    use config_mod, only: kappa

    real(dp), intent(in)    :: u(N_VARS)
    real(dp), intent(in)    :: v(N_VARS)
    real(dp)                :: f(N_VARS)

    real(dp)                :: dens,pres,velx,vely,enth
    real(dp)                :: bu,bv !! beta
    real(dp)                :: pu,pv !! pressure
    real(dp)                :: vu, wu, vv, wv !! velocity

    pu = pressure(u)
    pv = pressure(v)

    bu = 0.5*u(DENS_VAR)/pu
    bv = 0.5*v(DENS_VAR)/pv

    vu = u(MOMX_VAR)/u(DENS_VAR)
    wu = u(MOMY_VAR)/u(DENS_VAR)

    vv = v(MOMX_VAR)/v(DENS_VAR)
    wv = v(MOMY_VAR)/v(DENS_VAR)

    dens = logmean(u(DENS_VAR),v(DENS_VAR))
    velx = 0.5*(vu + vv)
    vely = 0.5*(wu + wv)
    pres = 0.5*(u(DENS_VAR)+v(DENS_VAR))/(bu+bv)

    enth = 0.5/(kappa-1)/logmean(bu,bv) &
         + pres/dens + velx*velx + vely*vely &
         - 0.25*(vu*vu + wu*wu + vv*vv + wv*wv)

    f(DENS_VAR) = dens * velx
    f(MOMX_VAR) = f(DENS_VAR) * velx + pres
    f(MOMY_VAR) = f(DENS_VAR) * vely
    f(ENER_VAR) = f(DENS_VAR) * enth

end function

pure function yflux(uL,uR) result(f)

    use equations_mod, only: N_VARS
    use equations_mod, only: DENS_VAR
    use equations_mod, only: MOMX_VAR
    use equations_mod, only: MOMY_VAR
    use equations_mod, only: ENER_VAR

    real(dp), intent(in) :: uL(N_VARS), uR(N_VARS)
    real(dp)             :: f(N_VARS)

    real(dp) :: ruL(N_VARS), ruR(N_VARS), rf(N_VARS) !! rotated

    ruL(DENS_VAR) = uL(DENS_VAR)
    ruL(MOMX_VAR) = uL(MOMY_VAR)
    ruL(MOMY_VAR) = uL(MOMX_VAR)
    ruL(ENER_VAR) = uL(ENER_VAR)

    ruR(DENS_VAR) = uR(DENS_VAR)
    ruR(MOMX_VAR) = uR(MOMY_VAR)
    ruR(MOMY_VAR) = uR(MOMX_VAR)
    ruR(ENER_VAR) = uR(ENER_VAR)

    rf = xflux(ruL,ruR)

    f(DENS_VAR) = rf(DENS_VAR)
    f(MOMX_VAR) = rf(MOMY_VAR)
    f(MOMY_VAR) = rf(MOMX_VAR)
    f(ENER_VAR) = rf(ENER_VAR)

end function

end module


      SUBROUTINE cyclic(a,b,c,alpha,beta,r,x,n)
      INTEGER n,NMAX
      REAL alpha,beta,a(n),b(n),c(n),r(n),x(n)
      PARAMETER (NMAX=500)
CU    USES tridag
      INTEGER i
      REAL fact,gamma,bb(NMAX),u(NMAX),z(NMAX)
      if(n.le.2)pause 'n too small in cyclic'
      if(n.gt.NMAX)pause 'NMAX too small in cyclic'
      gamma=-b(1)
      bb(1)=b(1)-gamma
      bb(n)=b(n)-alpha*beta/gamma
      do 11 i=2,n-1
        bb(i)=b(i)
11    continue
      call tridag(a,bb,c,r,x,n)
      u(1)=gamma
      u(n)=alpha
      do 12 i=2,n-1
        u(i)=0.
12    continue
      call tridag(a,bb,c,u,z,n)
      fact=(x(1)+beta*x(n)/gamma)/(1.+z(1)+beta*z(n)/gamma)
      do 13 i=1,n
        x(i)=x(i)-fact*z(i)
13    continue
      return
      END

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


PROGRAM main
  IMPLICIT NONE
  ! ...Local Scalars...
  INCLUDE 'mpif.h'
  INTEGER :: i,n,myid, ntasks, ierr, islave
  INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status
  INTEGER, PARAMETER :: master=0, msgtag1=11, msgtag2=12
  DOUBLE PRECISION, PARAMETER :: pi25dt = 3.141592653589793238462643d0
  DOUBLE PRECISION :: a,h,pi,sum,x,mypi
  !
  !...Executable Statements...
  !
  CALL MPI_INIT(ierr)
  CALL MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
  CALL MPI_COMM_SIZE(MPI_COMM_WORLD, ntasks, ierr)

  DO
    IF (myid == 0) THEN ! only master
      ! Input
      WRITE (6,10000)
      READ (5,10001) n
    END IF
    CALL MPI_Bcast(n, 1, MPI_INTEGER, master,MPI_COMM_WORLD,ierr)
    IF (n==0) EXIT
    !
    h = 1.0d0 / n ! stride
    !Calculation of the quadrature formula(summation)
    sum = 0.0d0

    DO i = 1+myid,n,ntasks
      x = h * (DBLE(i) - 0.5d0)
      sum = sum + 4.0 / (1.0 + x * x)
    END DO
    mypi = h * sum
    CALL MPI_Reduce(mypi, pi, 1, MPI_DOUBLE_PRECISION, MPI_SUM, 0,  MPI_COMM_WORLD, ierr)
    ! Output of the solution
    IF (myid == 0) THEN ! only master
      WRITE (*,*) pi, ABS(pi - pi25dt)
    END IF
  END DO

  CALL MPI_FINALIZE(ierr)

  !
  ! ...Format Declarations...
  !
  10000 format ( "Enter the number of intervals : (0 quits )" )
  10001 format ( i10 )

END PROGRAM main


c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the National Center for Atmospheric Research          *
c     *                                                               *
c     *                Boulder, Colorado  (80307)  U.S.A.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the National Science Foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c ... geo2math.f
c
c     file geo2math.f contains subroutines for converting scalar and
c     vector fields between geophysical and mathematical spherical
c     coordinates.  The latter is required when using most spherepack
c     software.  The four main subroutines in geo2math.f are described
c     as follows:
c
c     (1) subroutine geo2maths(ig,nlon,nlat,sg,sm,work)
c
c         converts the nlon by nlat scalar field sg given in
c         geophysical coordinates to the nlat by nlon scalar
c         field sm given in mathematical coordinates. sg and sm
c         can be identical in the program calling geo2maths.
c
c     (2) subroutine math2geos(ig,nlat,nlon,sm,sg,work)
c
c         converts the nlat by nlon scalar field sm given in
c         mathematical coordinates to the nlon by nlat scalar
c         field sg given in geophysical coordinates.  sm and
c         sg can be identical in the program calling math2geos.
c
c     (3) subroutine geo2mathv(ig,nlon,nlat,ug,vg,vm,wm,work)
c
c         converts the nlon by nlat vector field (ug,vg) given
c         in geophysical coordinates to the nlat by nlon vector
c         field (vm,wm) in mathematical coordinates.  ug and wm
c         can be identical in the program calling geo2mathv.  vg
c         and vm can be identical in the program calling geo2mathv.
c
c     (4) subroutine math2geov(ig,nlat,nlon,vm,wm,ug,vg,work)
c
c         converts the nlat by nlon vector field (vm,wm) given
c         in mathematical coordinates to the nlon by nlat vector
c         field (ug,vg) in spherical coordinates.  vm and vg can
c         be identical in the program calling math2geov.  wm and
c         ug can be identical in the program calling math2geov.
c
c *** (1),(2),(3),(4) argument description.
c
c ... ig
c
c     = 0 if the latitude values in the geophysical arrays sg,ug,vg are
c         ordered south to north with increasing latitude subscript
c         i=1,2,...,nlat.
c
c     = 1 if the latitude values in the geophysical arrays sg,ug,vg are
c         ordered north to south with increasing latitude subscript
c         i=1,2,...,nlat.
c
c ... nlon
c
c     the number of distinct londitude points.  nlon determines
c     the grid increment in longitude as 2*pi/nlon. nlon is the first
c     dimension of the geophysical arrays sg,ug,vg and the second
c     dimension of the mathematical arrays sm,vm,wm.  The longitude
c     grid is given by phi(j) = (j-1)*2*pi/nlon j=1,...,nlon.
c
c ... nlat
c
c     the number of distinct latitude and colatitude points and the
c     first dimension of sm,vm,wm and second dimension of sg,ug,vg.
c     If the (co)latitude grid is equally spaced then the grid increment
c     is dlat=pi/(nlat-1).  In this case the south to north latitude grid
c     underlying is
c
c        lat(i) = -0.5*pi + (i-1)*dlat (i=1,...,nlat)
c
c     and the north to south colatitude grid underlying sm,vm,wm is
c
c        colat(i) = (i-1)*dlat  (i=1,...,nlat)
c
c     If the grid is Gaussian let thetag(i) be the north to south colatitude
c     grid (as computed by the spherepack routine gaqd).  In this case
c
c        colat(i) = thetag(i) (i=1,...,nlat)
c
c     and
c
c        lat(i) = -0.5*pi + thetag(i) (i=1,...,nlat)
c
c     In either case lat(i) = colat(nlat-i+1) for all i.
c     If nlat is odd the equator is located at the (nlat+1)/2
c     latitude or colatitude point.  If nlat is even the equator is
c     half way between the nlat/2 and nlat/2+1 latitude or colatitude
c     points.  The equally spaced (co)latitude grid includes the poles.
c     The Gaussian grid excludes the poles.
c
c ... sg,sm
c
c     In (1),(2) sg is a nlon by nlat array containing the scalar field
c     in geophysical coordinates.  Latitude values in sg are ordered from
c     the southern to the northern hemisphere with increasing latitude
c     subscript if ig = 0 or ordered from the northern hemisphere to the
c     southern hemisphere if ig = 1.  sm is a nlat by nlon array containing
c     the scalar field in mathematical coordinates.  Colatitude values in sm
c     are ordered from the north to the south hemisphere  with increasing
c     colatitude subscript (i=1,...,nlat).  The (co)latitude grid for sg and
c     sm can be equally spaced or Gaussian.  sg and sm can be equivalenced or
c     be identical in the routine calling geo2maths or math2geos.  sg and
c     sm are related by
c
c          sm(nlat-i+1,j) = sg(j,i)    (if ig = 0)
c
c     or
c
c          sm(i,j) = sg(j,i)            (if ig = 1)
c
c     for i=1,...,nlat and j=1,...,nlon. This formula is not used because
c     the two arrays can be equivalenced or identical arguments in the
c     program calling geo2maths or math2geos.
c
c ... ug,vg,vm,wm
c
c     In (3),(4) ug is a nlon by nlat array containing the longitudinal
c     vector component.  vg is a nlon by nlat array containing the
c     latitudinal vector component.  Values in (ug,vg) are ordered
c     from the southern to the northern hemisphere with increasing
c     latitude subscript if ig = 0 or from the northern to southern
c     hemisphere if ig = 1.  vm is a nlat by nlon array containing the
c     the colatitudinal vector component.  wm is a nlat by nlon array
c     containing the east longitudinal vector component.  Values in
c     (vm,wm) are ordered from the northern to the southern hemisphere
c     with increasing colatitude subscript.  The (co)latitude grid for
c     both vector fields can be equally spaced or Gaussian.  ug,wm and
c     vg,vm can be equivalenced or be identical in the program calling
c     geo2mathv or math2geov.  They are related by
c
c          ug(j,nlat-i+1) =  wm(i,j)
c                                      (ig = 0)
c          vg(j,nlat-i+1) = -vm(i,j)
c
c     or
c
c          ug(j,i) =  wm(i,j)
c                                      (ig = 1)
c          vg(j,i) = -vm(i,j)
c
c
c     for i=1,...,nlat and j=1,...,nlon.  These formulas are not
c     used because ug,wm and vg,vm can be equivalenced or identical
c     arguments in the program calling math2geov or geo2mathv.
c
c     Let ib = nlat-i+1 for i=1,...,nlat.  Summarizing:
c     sg(j,i) or ug(j,i),vg(j,i) are values at (phi(j),lat(i)) if ig = 0
c     sg(j,i) or ug(j,i),vg(j,i) are values at (phi(j),lat(ib)) if ig = 1
c     sm(i,j) or vm(i,j),wm(i,j) are values at (colat(i),phi(j))
c
c ... work is an unsaved real work space of length at least nlon*nlat
c     in the routine calling (1),(2),(3), or (4).  It is used to simplify
c     a nonsquare array transposition in case it is required.
c
c *** example (1)
c
c     suppose you wish to compute the divergence of (ug,vg) on a Gaussian
c     grid in geophysical coordinates using the stored Legendre polynomial
c     routines of SPHEREPACK
c
c     (1) call geo2mathv to set vm,wm from ug,vg
c
c     (2) call vhags to compute the vector harmonic coefficients of vm,wm
c
c     (3) call divgs with the coefficients from (2) to compute the divergence
c         dv in mathematical spherical coordinates on the UNIT sphere.
c
c     (4) call math2geos to convert the scalar divergence dv back to
c         geophysical spherical coordinates.
c
c     (5) divide dv by R (the radius of the earth) to compute divergence
c         on the earth (scaling from unit sphere computation in (3)).
c
c *** example (2)
c
c     suppose you wish to compute a vector field (ug,vg) corresponding
c     to  a given divergence dvg and vorticity vtg (all in geophysical
c     coordinates) on an equally spaced (co)latitude grid using the
c     computed Legendre polynomial software.
c
c     (1) call geo2maths to set dvm from dvg
c
c     (2) call geo2maths to set vtm from vts
c
c     (3) call shaec to compute the scalar harmonic coefficients of dvm
c
c     (4) call shaec to compute the scalar harmonic coefficients of vtm
c
c     (5) call idvtec to compute (vm,wm) using the coefficients from (3),(4).
c
c     (6) call math2geov to set (ug,vg) from (vm,wm)
c
c     (7) multiply (ug,vg) by the earth's radius R for scaling
c         from the unit sphere computation in (5)
c
c *** END OF DOCUMENTATION ... CODE FOLLOWS:
c
c
      subroutine geo2maths(ig,nlon,nlat,sg,sm,work)
      implicit none
      integer ig,nlon,nlat,i,j,ij
      real sg(nlon,nlat),sm(nlat,nlon),work(*)
c
c     transpose sg into sm and reverse colatitude subscript order
c     if necessary
c
      do i=1,nlat
	do j=1,nlon
	  ij = (j-1)*nlat+i
	  work(ij) = sg(j,i)
	end do
      end do
      if (ig.eq.0) then
      do i=1,nlat
	do j=1,nlon
	  ij = (j-1)*nlat+i
	  sm(nlat-i+1,j) = work(ij)
	end do
      end do
      else
      do i=1,nlat
	do j=1,nlon
	  ij = (j-1)*nlat+i
	  sm(i,j) = work(ij)
	end do
      end do
      end if
      return
      end

      subroutine math2geos(ig,nlat,nlon,sm,sg,work)
      implicit none
      integer ig,nlon,nlat,i,j,ij
      real sm(nlat,nlon),sg(nlon,nlat),work(*)
c
c     transpose sm into sg and reverse colatitude subscript order
c     if necessary
c
      do i=1,nlat
	do j=1,nlon
	  ij = (j-1)*nlat+i
	  work(ij) = sm(i,j)
	end do
      end do
      if (ig.eq.0) then
      do i=1,nlat
	do j=1,nlon
	  ij = (j-1)*nlat+i
	  sg(j,nlat-i+1) = work(ij)
	end do
      end do
      else
      do i=1,nlat
	do j=1,nlon
	  ij = (j-1)*nlat+i
	  sg(j,i) = work(ij)
	end do
      end do
      end if
      return
      end

      subroutine geo2mathv(ig,nlon,nlat,ug,vg,vm,wm,work)
      implicit none
      integer ig,nlon,nlat,i,j,ij
      real ug(nlon,nlat),vg(nlon,nlat),work(*)
      real vm(nlat,nlon),wm(nlat,nlon)
c
c     convert vg to vm, ug to wm
c
      if (ig.eq.0) then
	do i=1,nlat
	  do j=1,nlon
	    ij = (j-1)*nlat+i
	    work(ij) = vg(j,i)
	  end do
	end do
	do i=1,nlat
	  do j=1,nlon
	    ij = (j-1)*nlat+i
	    vm(nlat-i+1,j) = -work(ij)
	  end do
	end do
	do i=1,nlat
	  do j=1,nlon
	    ij = (j-1)*nlat+i
	    work(ij) = ug(j,i)
	  end do
	end do
	do i=1,nlat
	  do j=1,nlon
	    ij = (j-1)*nlat+i
	    wm(nlat-i+1,j) = work(ij)
	  end do
	end do
      else
	do i=1,nlat
	  do j=1,nlon
	    ij = (j-1)*nlat+i
	    work(ij) = vg(j,i)
	  end do
	end do
	do i=1,nlat
	  do j=1,nlon
	    ij = (j-1)*nlat+i
	    vm(i,j) = -work(ij)
	  end do
	end do
	do i=1,nlat
	  do j=1,nlon
	    ij = (j-1)*nlat+i
	    work(ij) = ug(j,i)
	  end do
	end do
	do i=1,nlat
	  do j=1,nlon
	    ij = (j-1)*nlat+i
	    wm(i,j) = work(ij)
	  end do
	end do
      end if
      return
      end

      subroutine math2geov(ig,nlat,nlon,vm,wm,ug,vg,work)
      implicit none
      integer ig,nlon,nlat,i,j,ij
      real vm(nlat,nlon),wm(nlat,nlon),work(*)
      real ug(nlon,nlat),vg(nlon,nlat)
c
c     convert vm to vg, wm to ug
c
      if (ig.eq.0) then
	do i=1,nlat
	  do j=1,nlon
	    ij = (j-1)*nlat+i
	    work(ij) = vm(i,j)
	  end do
	end do
	do i=1,nlat
	  do j=1,nlon
	    ij = (j-1)*nlat+i
	    vg(j,nlat-i+1) = -work(ij)
	  end do
	end do
	do i=1,nlat
	  do j=1,nlon
	    ij = (j-1)*nlat+i
	    work(ij) = wm(i,j)
	  end do
	end do
	do i=1,nlat
	  do j=1,nlon
	    ij = (j-1)*nlat+i
	    ug(j,nlat-i+1) = work(ij)
	  end do
	end do
      else
	do i=1,nlat
	  do j=1,nlon
	    ij = (j-1)*nlat+i
	    work(ij) = vm(i,j)
	  end do
	end do
	do i=1,nlat
	  do j=1,nlon
	    ij = (j-1)*nlat+i
	    vg(j,i) = -work(ij)
	  end do
	end do
	do i=1,nlat
	  do j=1,nlon
	    ij = (j-1)*nlat+i
	    work(ij) = wm(i,j)
	  end do
	end do
	do i=1,nlat
	  do j=1,nlon
	    ij = (j-1)*nlat+i
	    ug(j,i) = work(ij)
	  end do
	end do
      end if
      return
      end


c     program DRSINT1R
c>> 1994-10-19 DRSINT1R Krogh  Changes to use M77CON
c>> 1994-08-08 DRSINT1R Snyder  Took '0' out of formats for C conversion
c>> 1991-11-20 CLL Edited for Fortran 90.
c>> 1987-12-09 DRSINT1R Snyder  Initial Code.
c--S replaces "?": DR?INT1R, ?INT1, ?INTA
c
c     DEMO DRIVER for 1 dimensional quadrature subprogram SINT1.
c
c     Compute the integral for X = 0.0 to X = PI of SIN(X), then
c     subtract 2.0 from the ANSWER.  The result should be zero.
c
c     The integrand is evaluated using reverse communication.
c
      real             A, B, ANSWER, WORK(1)
      integer IOPT(10)
c
10    format (/' DRSINT1R:'/
     1' Compute the integral for X = 0.0 to X = PI of SIN(X), then'/
     2' subtract 2.0 from the ANSWER.  The result should be zero.')
20    format (/' ANSWER          =',G15.8/
     1         ' ERROR ESTIMATE  =',G15.8/
     2         ' STATUS FLAG     =',I6/
     3         ' FUNCTION VALUES =',I6)
c
      print 10
      A = 0.0E0
      B = 4.0E0 * ATAN(1.0E0)
      IOPT(2) = 10
      IOPT(3) = 0
      IOPT(4) = 6
      IOPT(5) = 0
      call SINT1 (A, B, ANSWER, WORK, IOPT)
 30   continue
      call SINTA (ANSWER, WORK, IOPT)
      if (IOPT(1) .eq. 0) then
         ANSWER = SIN(WORK(1))
         go to 30
      end if
      print 20, ANSWER, WORK(1), IOPT(1), IOPT(3)
      stop
      end


module prescribe_grav_module

  use amrex_fort_module, only : rt => amrex_real
  implicit none

contains

  subroutine ca_prescribe_grav (lo,hi,grav,g_lo,g_hi,dx) &
       bind(C, name="ca_prescribe_grav")

    use amrex_constants_module, only: ZERO
    use prob_params_module, only: dim

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer, intent(in) :: lo(3), hi(3)
    integer, intent(in) :: g_lo(3), g_hi(3)
    real(rt), intent(out):: grav(g_lo(1):g_hi(1),g_lo(2):g_hi(2),g_lo(3):g_hi(3),dim)
    real(rt), intent(in) :: dx(3)

    ! Local variables
    !     integer          :: i, j, k
    !     real(rt)         :: x, y, z
    !     real(rt)         :: r, maggrav
    !     real(rt)         :: r_c, rho_c

    !     This is an example of how to specify a radial profile.
    !     Note that in this example r_c and rho_c could be saved
    !     in another module instead, like a probdata_module.
    !     Note also that you'll have to be careful if you're working
    !     in fewer than three dimensions; you may want to set
    !     z = 0 for 2D and y = 0 for 1D.
    !
    !     r_c = 1.0e9_rt
    !     rho_c = 1.0e8_rt
    !
    !     do k = lo(3), hi(3)
    !        if (dim .eq. 3) then
    !           z = problo(3) + (dble(k)+HALF) * dx(3) - center(3)
    !        else
    !           z = ZERO
    !        endif
    !
    !        do j = lo(2), hi(2)
    !           if (dim .ge. 2) then
    !              y = problo(2) + (dble(j)+HALF) * dx(2) - center(2)
    !           else
    !              y = ZERO
    !           endif
    !
    !           do i = lo(1), hi(1)
    !              x = problo(1) + (dble(i)+HALF) * dx(1) - center(1)
    !
    !              r = sqrt(x**2+y**2+z**2)
    !
    !              maggrav =-rho_c*Gconst*2*M_PI*(1/sqrt(1+(r/r_c)**2)-atanh(1/sqrt(1+(r/r_c)**2)))
    !
    !              Put in angular dependence
    !
    !              grav(i,j,k,1) = maggrav* ...
    !              grav(i,j,k,2) = maggrav* ...
    !              grav(i,j,k,3) = maggrav* ...
    !
    !           enddo
    !        enddo
    !     enddo

    grav(lo(1):hi(1),lo(2):hi(2),lo(3):hi(3),:) = ZERO

  end subroutine ca_prescribe_grav

end module prescribe_grav_module


program problem21
  use euler
  implicit none
  integer, parameter :: n = 10000
  integer*8          :: i, temp, sum

  sum = 0
  do i=1,n-1
     temp=sum_of_divisors(i)
     if ((i /= temp) .and. (sum_of_divisors(temp) == i)) then
        sum=sum+i
     end if
  end do

  print *, sum

end program problem21


program HC_SCE
    implicit none
    INTEGER,parameter :: dp=8
    REAL(dp),allocatable    ::  H(:,:),S(:,:),C(:,:),E(:),B(:),A(:,:),X(:),Y(:),work(:),iwork(:),wr(:),wi(:),vs(:,:)
    INTEGER,allocatable :: ipiv(:)
    INTEGER :: m,n,k,i,j,INFO,NRHS,incx,lwork,liwork,sdim,ldvs
    LOGICAL,allocatable :: select(:,:),bwork(:)

    m=5
    n=5
    k=5
    allocate(H(m,k),S(k,n),B(n),C(m,n))
    H = reshape((/  -0.42400401342556060 , -0.40143227390650277 , -6.9120337961858791E-006 , &
&                   8.6134463450626697E-010 , -6.9147694707777760E-006 , -0.40143227390650238 , &
&                   -0.29964623883643193 , -8.9726936647882560E-006 , 4.9061116280668671E-010 , &
&                   -8.9740202969982782E-006 , -6.9120337962066958E-006 , -8.9726936648298894E-006 , &
&                   0.80413378049744566 , -1.8838840210033680E-010 , -3.8197224985613721E-007 , &
&                   8.5924509174439834E-010 , 4.8774366490089704E-010 , -1.8838840210033680E-010 , &
&                   0.80417210170273057 , 1.5203947981790279E-011 , -6.9147694707755170E-006 , &
&                   -8.9740202969951222E-006 , -3.8197224985613721E-007 , 1.5203950672231617E-011 ,&
&                   0.80413378335169927/),(/m,k/))
    S = reshape( (/1.0000000107623999 , 0.95479507666315644 , 0.0000000000000000 , 5.3953328491069285E-013 , 0.0000000000000000 , 0.95479507666315644 , 0.99999999999886702 , 0.0000000000000000 , 6.3781864686742656E-013 , 0.0000000000000000 , 0.0000000000000000 , 0.0000000000000000 , 1.0000000364970107 , 0.0000000000000000 , 0.0000000000000000 , -5.3953328491104808E-013 , -6.3781864686711637E-013 , 0.0000000000000000 , 1.0000000364970068 , 0.0000000000000000 , 0.0000000000000000 , 0.0000000000000000 , 0.0000000000000000 , 0.0000000000000000 , &
    &               1.0000000364970110/),(/k,n/))

    B = reshape( (/1.0,2.0,3.0,4.0,5.0/),(/5/))
    write(*,*) "H is ------------------"
    do i =1,5
        write(*,*) "            ",H(i,:)
    enddo
    write(*,*) "S is ------------------"
    do i =1,5
        write(*,*) "            ",S(i,:)
    enddo
    write(*,*) "B is ------------------"
    write(*,*) B
!-----------------------------------------------------------------------------------------------------------------------------------
! BLACS基础功能
!-----------------------------------------------------------------------------------------------------------------------------------

!********************************
!GEMV 矩阵向量乘
!********************************
!call dgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
    allocate(X(2*n),Y(n))
    X(1:n)=B
    X(n+1:2*n)=B
    Y=0
    incx=1
    call dgemv('N',m,n,1.0_dp,H,m,X,incx,1.0_dp,Y,1)
    !X(incx,incx+n-1)
    !Y(incy,incy+m-1)
    !incx 向量的初始元素
    write(*,*) "H*B is --------------------"
    write(*,*) Y
    deallocate(X,Y)
!********************************
!SYMV 对称矩阵*向量
!********************************
!针对A是特殊的对称矩阵时
!参数和GESV不同
!call dsymv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
!y := alpha*A*x + beta*y,
!uplo
!   If uplo = 'U' or 'u', then the upper triangular part of the array a is used.
!   If uplo = 'L' or 'l', then the low triangular part of the array a is used.
!https://scc.ustc.edu.cn/zlsc/tc4600/intel/2017.0.098/mkl/common/mklman_f/index.htm#GUID-2EB693ED-69F3-48C7-B100-31F030797DDD.htm

    allocate(X(2*n),Y(n))
    X(1:n)=B
    X(n+1:2*n)=B
    incx=2
    !X(1,1+incx,1+2*incx,....,1+n*incx)`,向量的取样间隔
    call dsymv('U',m,1.0_dp,H,m,X,incx,0.0_dp,Y,1)
    write(*,*) "H*[B,B](1:2:2n) symv is --------------"
    write(*,*) Y
    deallocate(X,Y)

!********************************
!GEMM 矩阵乘
!********************************
!DGEMM
!D:double precision
!GE:general matrix
!MM:matrix-matrix
    call DGEMM('N','N',m,n,k,1.0_dp,H,m,S,k,0.0_dp,C,m)
    !C=alpha*OP(H)*OP(S)+beta*C
    write(*,*) "*********DGEMM***********"
    write(*,*) "H*S is ------------------"
    do i =1,5
        write(*,*) "            ",C(i,:)
    enddo

!!```
!
!******************************
! ![](/uploads/2019/08/gemm.jpg)
!******************************
!-----------------------------------------------------------------------------------------------------------------------------------
! Driver Routines
!-----------------------------------------------------------------------------------------------------------------------------------

! ### Driver Routines
!     Driver Routines 使用来解绝特定问题(如HC=SCE)的程序
!     Computational Routines 完成特定的计算任务比如LU分解
!     可以理解Driver Routines调用Computational Routines完成特定问题
! #### 线性方程组 | AX=B

!!```
    write(*,*) "================================================================="
    write(*,*) "======================Driver Routines============================"
    write(*,*) "================================================================="

    write(*,*) "***************************************"
    write(*,*) "*************  AX=B  ******************"
    write(*,*) "***************************************"
!********************************
![A]{X}={B} 线性问题,B可为矩阵或向量
!-SV simple,LU分解求解,B是标量
!-SVX expert,LU分解，比-SV提供更多的功能，比如误差分析等
!-SVM B是矢量
!-TRSM B(m,n) Solves a triangular matrix equation.
    !call dtrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
    !X and B are m-by-n matrices,
!-TRSVB(m) Solves a system of linear equations whose coefficients are in a triangular matrix.
    !call dtrsv(uplo, trans, diag, n, a, lda, x, incx)
    !b and x are n-element vectors,
!********************************
    allocate(A(m,m),X(m),ipiv(m))
    A=H
    X=B
    NRHS=1
    call DGESV(m,NRHS,A,m,ipiv,X,m,INFO)
    !Hx=X,结果保存到X中，
    !A LU分解后保存到A中
    !     A的上三角是U
    !     A的下三角(不包括对角线)是L
    !     MATLAB  [l,u,p]=lu(H)
    !m: A(m,m)
    !NRHS=1: X是一维的,若为AX=C(m,:)时，NRHS=m
    write(*,*) "H LU is ------------------"
    do i =1,5
        write(*,*)"            ", A(i,:)
    enddo
    write(*,*) "root of HX=B(-GESV) is ----------"
    write(*,*) X

    A=H
    X=B
    NRHS=1
    lwork=1!INTEGER. The size of the work array; lwork ≥ 1.
    allocate(work(lwork))!work is a workspace array, dimension at least max(1,lwork).
    !call dsysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info )
    call DSYSV('U',m,NRHS,A,m,ipiv,X,m,work,lwork,INFO)
    deallocate(work)
    write(*,*) "root of HX=B(-SYSV) is ----------"
    write(*,*) X

    A=H
    C=S
    NRHS=m
    call DGESV(m,NRHS,A,m,ipiv,C,m,INFO)
    write(*,*) "root of HX=C is ----------"
    do i =1,5
        write(*,*) "            ",C(i,:)
    enddo
    deallocate(A,X,ipiv)

!!```
!********************************
!  ![](/uploads/2019/08/gesv.jpg)
!********************************

! #### 最小二乘问题 | LLS(Linear Leqat squares problems)
!      `||Ax-b||2`

!!```
    write(*,*) "***************************************"
    write(*,*) "*********  min(||AX-B||2)  ************"
    write(*,*) "***************************************"
!*******************************
!找到X使得 (b(m)-A(m,n))的2范数||AX-B||2最小
! -LS 使用LU或QR分解计算
! -LSX
! -LSS SVD奇异值分解
!*******************************
!QR 设 A(m,n). 则存在一个单位列正交矩阵 Q(M,n) (即 Q∗Q = I ) 和一个上三角矩阵 R ∈Cn×n, 使得A=Q*R
!call dgels(trans, m, n, nrhs, a, lda, b, ldb, work, lwork, info)
    allocate(A(m,n),X(n))
    A=H
    X=B
    NRHS=1
    lwork=min(m,n)+max(1,m,m,NRHS) !The size of the work array; must be at least min (m, n)+max(1, m, n, nrhs).
    allocate(work(max(1,lwork)))
    call DGELS('N',m,n,NRHS,A,m,X,n,work,lwork,INFO)
    !返回值A与MATLAB X=qr(H)返回值一样
    !A的右上角与[Q,R]=qr(H)中的R一样,暂时不知道QR分解的下矩阵是什么
    deallocate(work)
    write(*,*) "H QR is ------------------"
    do i =1,5
        write(*,*) "            ",A(i,:)
    enddo
    write(*,*) "min(||AH-B||2), when X is (-GELS)"
    write(*,*) X
    deallocate(A,X)

!! ```

! #### 标准本征值问题AX=EX
! ##### 对称本征值问题|SEP(Symmetric eigenproblems)
!        Ax=Ex ,A=A^T(real)  A=A^H(complex)
!!```
    write(*,*) "***************************************"
    write(*,*) "*************  AX=EX  *****************"
    write(*,*) "***************************************"
!********************************
!********************************
!AX=EX 本征值问题
!-SYEV simple,L U 分解
!-SYEVX expert,比-EV提供更多的功能，比如误差分析等
!-SYEVD 不同的算法而已;根据测试EVR最快,EVD次之,SIESTA采用的EVD
!-SYEVR 不同的算法而已;测试[LAPACK Benchmark](https://www.netlib.org/lapack/lug/node71.html)
!-SYEVX 不同的算法而已;如图![Figure 3.2: Timings of driver routines for computing all eigenvalues and eigenvectors of a dense symmetric matrix. The upper graph shows times in seconds on an IBM Power3. The lower graph shows times relative to the fastest routine DSYEVR, which appears as a horizontal line at 1.](/uploads/2019/08/img255.gif)
!********************************
!call dsyev(jobz, uplo, n, a, lda, w, work, lwork, info)
!jobz = 'N', then only eigenvalues are computed.
!jobz = 'V', then eigenvalues and eigenvectors are computed.
!uplo="U" or "L", 分解存储A的方式
!work is a workspace array, its dimension max(1, lwork).
!lwork ≥ max(1, 3n-1).
!w本征值Array, size at least max(1, n)
!若jobz='V',A存储本征矢量,一列是一个本征矢,A(i,:)的本征值为w(i)
!若jobz='N',A存储A的L/U(uplo='L'/'U')会被用于计算，并无意义，不是LU分解
!MATLAB中lu(H),[l,u]=lu(H),[l,u,p]=lu(H)的结果不一样
    allocate(A(n,n),E(n))
    A=H
    E=0
    lwork=max(1,3*n-1)
    allocate(work(lwork))
    call DSYEV('V','U',n,A,n,E,work,lwork,INFO)
    deallocate(work)
    write(*,*) "HX=wX; w is ------------------"
    write(*,*) E
    write(*,*) "HX=wX; vectors is ------------------"
    do i =1,5
        write(*,*) "            ",A(i,:)
    enddo
    !H=U*U^T;U*U^T*X=EX
    !C=U^T*U;Cy=Ey, y=U^T*X
    deallocate(A,E)
!! ```

! ##### 非对称本征值问题|NEP(Nonsymmetric eigenproblems)
!        Ax=Ex ,A=QTQ^T(real)  A=QTQ^H(complex)
!                 Q幺正矩阵,T上三角矩阵
!!```
!********************************
!AX=EX 本征值问题
!-GEES simple Schur因子
!-GEESX expert,比-GEES提供更多的功能，比如误差分析等
!-GEEV 本征值本征矢
!-GEEVX expert
!********************************
!程序遇到问题，先搁置

!Error:         !        !call dgees(jobvs, sort, select, n, a, lda, sdim, wr, wi, vs, ldvs, work, lwork, bwork, info)
!Error:         !        !wr(>=n),wi(>=n)本征值的实部虚部,是T的对角元素
!Error:         !        !Arrays, size at least max (1, n) each.
!Error:         !        !Contain the real and imaginary parts, respectively, of the computed eigenvalues,
!Error:         !        !in the same order that they appear on the diagonal of the output real-Schur form T. Complex conjugate pairs of eigenvalues appear consecutively with the eigenvalue having positive imaginary part first.
!Error:         !        !select:是一个函数参数，逻辑型
!Error:         !            allocate(A(n,n),E(n))
!Error:         !            A=H
!Error:         !            E=0
!Error:         !            allocate(wr(n),wi(n))
!Error:         !            lwork=max(1,3*n)
!Error:         !            allocate(work(lwork))
!Error:         !            ldvs=n
!Error:         !            allocate(vs(ldvs,n))
!Error:         !            allocate(bwork(n))
!Error:         !            allocate(select(n,n))
!Error:         !            select=.true.
!Error:         !            bwork=.true.
!Error:         !
!Error:         !            call DGEES('V','S',select,n,A,n,sdim,wr,wi,vs,ldvs,work,lwork,bwork,info)
!Error:         !
!Error:         !
!Error:         !            deallocate(bwork)
!Error:         !            deallocate(vs)
!Error:         !            deallocate(work)
!Error:         !            deallocate(wr,wi)
!Error:         !            deallocate(A,E)

!! ```

! ##### 奇异值问题|SVD(Singular value decomposion)
!! ```
!********************************
!暂时还不懂
!-GESVD
!********************************
!! ```

! ### 广义的本征值问题 | Generalized eigenvalue problems
! #### 对称的本征值问题|**GSEP** Generalized symmetric-definite eigenproblems
! AX=EBX
! ABX=EX
! BAX=EX
! 其中A,B是对称的或哈密顿量 ， **B是正定的**
!! ```
!********************************
!-SYGV
!-HEGV
!-SPGV
!-HPGV
!********************************
!call dsygv(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, info)
!itype
! itype = 1, the problem type is A*x = lambda*B*x;
! itype = 2, the problem type is A*B*x = lambda*x;
! itype = 3, the problem type is B*A*x = lambda*x.
! jobz = 'N' or 'U'
! B输入矩阵和输出本征矢量

    allocate(A(n,n),E(n))
    A=H
    C=S
    E=0
    lwork=max(1,3*n-1)
    allocate(work(lwork))
    call DSYGV(1,'V','U',n,A,n,C,n,E,work,lwork,INFO)
    !算完后，A被覆盖了一堆中间数据
    write(*,*) "HC=SCE; E is ------------------"
    write(*,*) E
    write(*,*) "HC=SCE; C is ------------------"
    do i =1,5
        write(*,*) "            ",C(i,:)
    enddo
    deallocate(work)
    deallocate(A,E)

!! ```

! #### 广义非对称的本征值问题|**GNEP** Generalized nonsymmetric  eigenproblems
!! ```
!********************************
!-GEES
!-GEESX
!-GEEV
!-GEEVX
!********************************
!暂时懒得看了
!! ```

!-----------------------------------------------------------------------------------------------------------------------------------
!Computational Routines
!-----------------------------------------------------------------------------------------------------------------------------------
! ### Computational Routines
!自己组合Computational Routines来解决一个问题，如分解，变为三角阵
!通常的过程,先分解(factorize -TRF)再处理,如求逆(-TRI)、求GSEP(-SYGST)等
! 通过这些程序，我们也可以一步步实现分解(LU,chol,QR...),解决线性方程,LLS,SVD,(广义)本征值问题
! 下面为几个示例
! #### Facrotize分解(-TRF)
! 不同类型的矩阵分解结果不同，如[Routines for Matrix Factorization](https://scc.ustc.edu.cn/zlsc/tc4600/intel/2017.0.098/mkl/common/mklman_f/index.htm#GUID-2EB693ED-69F3-48C7-B100-31F030797DDD.htm)
!! ```
    write(*,*) "================================================================="
    write(*,*) "======================Computational Routine======================"
    write(*,*) "================================================================="
!*********************************
!- 通常的矩阵:：LU分解 `-GETRF` A=PLU
!- 正定对称矩阵：Cholesky 分解 `-POTRF` A=U^T*U or L*L^T
!- 对称非正定矩阵：系统非正定分解  `-SYTRF` A=P^TU^TDUP or PLDL^TP^T
!*********************************

!******
!LU分解
!******
    write(*,*) "***************************************"
    write(*,*) "*********  LU -> AX=B H^-1************"
    write(*,*) "***************************************"
!call dgetrf( m, n, a, lda, ipiv, info )
!返回值A,ipiv可用于后续计算
    allocate(A(m,n),E(n))
    A=H
    E=B
    allocate(ipiv(m))
    call DGETRF(m,n,A,m,ipiv,INFO)
    write(*,*) "lu(H) is ------------------"
    do i =1,5
        write(*,*) "            ",A(i,:)
    enddo
!LU分解求HX=B示例
!call dgetrs( trans, n, nrhs, a, lda, ipiv, b, ldb, info )
!Solves a system of linear equations with an LU-factored square coefficient matrix, with multiple right-hand sides.
!ldbINTEGER. The leading dimension of b; ldb ≥ max(1, n)
!**ipiv 是-GETRF的返回值**
!**A也是-GERTF的LU分解后的矩阵***
!ipiv Array, size at least max(1, n). The ipiv array, as returned by ?getrf.
    call DGETRS('N', n,1,A,m,ipiv,E,n,INFO)
    write(*,*) "use lu(H) to solve HX=B, X is "
    write(*,*) E
!计算之后，不会改变A和ipiv的值

!LU分解求逆A^-1示例
! invert using factorization
!call dgetri( n, a, lda, ipiv, work, lwork, info )
    lwork=n
    allocate(work(lwork))
    call DGETRI(n,A,m,ipiv,work,lwork,INFO)
    write(*,*) "use lu(H) to get H^-1:"
    do i =1,5
        write(*,*) "            ",A(i,:)
    enddo
    deallocate(work)
    deallocate(ipiv)
    deallocate(A,E)

!**********************
!Cholesky factorization
!**********************
    write(*,*) "***************************************"
    write(*,*) "*****  Cholesky -> S^-1 HC=ESC ********"
    write(*,*) "***************************************"
!call dpotrf( uplo, n, a, lda, info )
    allocate(A(m,n),E(n))
    A=H
    C=S
    E=B
    call DPOTRF('U',n,C,m,INFO)
    !上部分变为U,下三角部分不变
    write(*,*) "chol(S) is: -----------"
    do i =1,5
        write(*,*) "            ",C(i,:)
    enddo
!chol分解求HX=B示例
!call dpotrs( uplo, n, nrhs, a, lda, b, ldb, info )
    call DPOTRS('U',n,1,C,m,E,m,INFO)
    write(*,*) "use chol(S) to solve SX=B, X is "
    write(*,*) E
!chol分解求逆A^-1示例
!call dpotri( uplo, n, a, lda, info )
    call DPOTRI('U',n,C,m,INFO)
    !结果inv(C)也是对称的，所以，C的上三角矩阵是逆，下三角依旧没变
    write(*,*) "use chol(S) to get S^-1:"
    do i =1,5
        write(*,*) "            ",C(i,:)
    enddo
!chol分解求广义本征值HC=SCE示例

    A=H
    C=S
    E=0.0_dp
    write(*,*) "use chol(S) to solve HC=SCE"
    write(*,*) "    HC=SCE(-POTRF): 1. S=U^T*U,y=UC"
!***
    call DPOTRF('U',n,C,m,INFO)
    !C=U*U^T,仅改变C的上三角
!***
    write(*,*) "    HC=SCE(-SYGST): 2. tmpC=inv(U^-T)*H*inv(U)"
!call dsygst(itype, uplo, n, a, lda, b, ldb, info)
!The routine reduces real symmetric-definite generalized eigenproblems
!A*z = λ*B*z, A*B*z = λ*z, or B*A*z = λ*z
!itype=1,     2,              3
!to the standard form C*y = λ*y.
!Here A is a real symmetric matrix,
!and B is a real symmetric positive-definite matrix.
!Before calling this routine, call ?potrf to compute the Cholesky factorization: B = UT*U or B = L*LT.
    call DSYGST(1,'U',n,A,m,C,m,INFO)
    !A=inv(U^T)*A*inv(U)，仅改变A的上三角
!***
    write(*,*) "    HC=SCE(-SYEV?): 3. tmpCy=Ey(本征值问题)"
!call dsyevd(jobz, uplo, n, a, lda, w, work, lwork, iwork, liwork, info)
    lwork=2*n*n + 6*n + 1
    allocate(work(lwork))
    liwork= 5*n + 3
    allocate(iwork(liwork))
    call DSYEVD('V','U',n,A,m,E,work,lwork,iwork,liwork,INFO)
    !y保存到A中了
    write(*,*) "    HC=SCE(-SYEV?):    E is:"
    write(*,*) "            ", E
!***
    write(*,*) "    HC=SCE(-SYEV?): 4. y=UC,(线性方程问题)"
    !可选方案很多，
    !a. inv(U)*y
    !因为U已经上三角了
    !b. Dirver routines解方程  -TRSM(B(m,n), -TRSV(B(n))
    !c. Computational routines  -TRTRS
!call dtrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb) B=AX
!call dtrtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb, info )
!AX=B结果输出到B
![Fortran使用Scalapack求解HC=SCE](/2019/08/04/HC_SCE)此文采用的TRSM
!此处采用TRTRS
    call DTRTRS('U','N','N',n,n,C,m,A,m,INFO)
    write(*,*) "    HC=SCE(-TRTRS):    C is:"
    do i =1,5
        write(*,*) "            ",A(i,:)
    enddo
    deallocate(work,iwork)

!! ```
! 除了上述之外，还有很多的computational routines
! 先这样吧,补充相关知识后再回来补充

    deallocate(H,S,B,C)

end program HC_SCE


!------------------------------------------------------------------------------
!
! PROGRAM: RK_method
!
! DESCRIPTION:
!>  Solution of n-rank ordinary differential equation (ODE)
!   by superposition and Runge-Kutta method
!
! REVISION HISTORY:
! 13 11 2021 - Initial Version
! TODO_dd_mmm_yyyy - TODO_describe_appropriate_changes - TODO_name
!------------------------------------------------------------------------------
!------------------------------------------------------------------------------
!
include "RK-file/module.f90"
include "RK-file/subroutine.f90"

program RK_method
    use parameters
    use func_param
    implicit none

    integer i  ! loop dummy number
    ! integer count

    character(30) :: rank
    character(30) :: stepsize
    character(30) :: selection

    write (rank, *) n
    write (stepsize, "(f15.3)") h
    write (selection, *) select

!---Output for monitor
    write (*, *) ""
    write (*, *) "-----------------------------------------------------------"
    write (*, *) "             Solving the n-rank ODE PROGRAM                "
    write (*, *) "-----------------------------------------------------------"
    write (*, *) "      rank = "//adjustl(trim(rank))//" h = "//adjustl(trim(stepsize))
    write (*, *) "    select = "//adjustl(trim(selection))
    write (*, *) ""

!---Main calculation part
    !---Airy, Lecture
    if (select == 1 .or. select == 2) then
        write (*, *) "    -------- solution --------- "
        call initialize

        do i = 1, loop
            call RK(i)
        end do

    !---calculate report ploblem
    else if (select == 3) then
        open (10, file = "output.csv", status = "replace")

        do count = 1, n

            write (*, *) "    -------- intial solution --------- "
            call initialize
            write (*, *) ""

            if (count == 1) then
                write (*, *) "    --------    solution u   --------- "
                write (10, *) "u"

                do i = 1, loop
                    call RK(i)  ! Output u and z
                end do

            else if (count == 2) then
                write (*, *) "    --------    solution z   --------- "
                write (10, *) "z"

                do i = 1, loop
                    call RK(i)  ! Output u and z
                end do

            end if
        end do

        write (*, *) "    -------- Final solution ---------"
        call calculate_C

        close (10)

    end if

    stop
end program


*> \brief \b SSYRK
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
*
*       .. Scalar Arguments ..
*       REAL ALPHA,BETA
*       INTEGER K,LDA,LDC,N
*       CHARACTER TRANS,UPLO
*       ..
*       .. Array Arguments ..
*       REAL A(LDA,*),C(LDC,*)
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SSYRK  performs one of the symmetric rank k operations
*>
*>    C := alpha*A*A**T + beta*C,
*>
*> or
*>
*>    C := alpha*A**T*A + beta*C,
*>
*> where  alpha and beta  are scalars, C is an  n by n  symmetric matrix
*> and  A  is an  n by k  matrix in the first case and a  k by n  matrix
*> in the second case.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>           On  entry,   UPLO  specifies  whether  the  upper  or  lower
*>           triangular  part  of the  array  C  is to be  referenced  as
*>           follows:
*>
*>              UPLO = 'U' or 'u'   Only the  upper triangular part of  C
*>                                  is to be referenced.
*>
*>              UPLO = 'L' or 'l'   Only the  lower triangular part of  C
*>                                  is to be referenced.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*>          TRANS is CHARACTER*1
*>           On entry,  TRANS  specifies the operation to be performed as
*>           follows:
*>
*>              TRANS = 'N' or 'n'   C := alpha*A*A**T + beta*C.
*>
*>              TRANS = 'T' or 't'   C := alpha*A**T*A + beta*C.
*>
*>              TRANS = 'C' or 'c'   C := alpha*A**T*A + beta*C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>           On entry,  N specifies the order of the matrix C.  N must be
*>           at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*>          K is INTEGER
*>           On entry with  TRANS = 'N' or 'n',  K  specifies  the number
*>           of  columns   of  the   matrix   A,   and  on   entry   with
*>           TRANS = 'T' or 't' or 'C' or 'c',  K  specifies  the  number
*>           of rows of the matrix  A.  K must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*>          ALPHA is REAL
*>           On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is REAL array of DIMENSION ( LDA, ka ), where ka is
*>           k  when  TRANS = 'N' or 'n',  and is  n  otherwise.
*>           Before entry with  TRANS = 'N' or 'n',  the  leading  n by k
*>           part of the array  A  must contain the matrix  A,  otherwise
*>           the leading  k by n  part of the array  A  must contain  the
*>           matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>           On entry, LDA specifies the first dimension of A as declared
*>           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
*>           then  LDA must be at least  max( 1, n ), otherwise  LDA must
*>           be at least  max( 1, k ).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*>          BETA is REAL
*>           On entry, BETA specifies the scalar beta.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*>          C is REAL array of DIMENSION ( LDC, n ).
*>           Before entry  with  UPLO = 'U' or 'u',  the leading  n by n
*>           upper triangular part of the array C must contain the upper
*>           triangular part  of the  symmetric matrix  and the strictly
*>           lower triangular part of C is not referenced.  On exit, the
*>           upper triangular part of the array  C is overwritten by the
*>           upper triangular part of the updated matrix.
*>           Before entry  with  UPLO = 'L' or 'l',  the leading  n by n
*>           lower triangular part of the array C must contain the lower
*>           triangular part  of the  symmetric matrix  and the strictly
*>           upper triangular part of C is not referenced.  On exit, the
*>           lower triangular part of the array  C is overwritten by the
*>           lower triangular part of the updated matrix.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*>          LDC is INTEGER
*>           On entry, LDC specifies the first dimension of C as declared
*>           in  the  calling  (sub)  program.   LDC  must  be  at  least
*>           max( 1, n ).
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup single_blas_level3
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  Level 3 Blas routine.
*>
*>  -- Written on 8-February-1989.
*>     Jack Dongarra, Argonne National Laboratory.
*>     Iain Duff, AERE Harwell.
*>     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*>     Sven Hammarling, Numerical Algorithms Group Ltd.
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE SSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
*
*  -- Reference BLAS level3 routine (version 3.4.0) --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      REAL ALPHA,BETA
      INTEGER K,LDA,LDC,N
      CHARACTER TRANS,UPLO
*     ..
*     .. Array Arguments ..
      REAL A(LDA,*),C(LDC,*)
*     ..
*
*  =====================================================================
*
*     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC MAX
*     ..
*     .. Local Scalars ..
      REAL TEMP
      INTEGER I,INFO,J,L,NROWA
      LOGICAL UPPER
*     ..
*     .. Parameters ..
      REAL ONE,ZERO
      PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
*     ..
*
*     Test the input parameters.
*
      IF (LSAME(TRANS,'N')) THEN
          NROWA = N
      ELSE
          NROWA = K
      END IF
      UPPER = LSAME(UPLO,'U')
*
      INFO = 0
      IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
          INFO = 1
      ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
     +         (.NOT.LSAME(TRANS,'T')) .AND.
     +         (.NOT.LSAME(TRANS,'C'))) THEN
          INFO = 2
      ELSE IF (N.LT.0) THEN
          INFO = 3
      ELSE IF (K.LT.0) THEN
          INFO = 4
      ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
          INFO = 7
      ELSE IF (LDC.LT.MAX(1,N)) THEN
          INFO = 10
      END IF
      IF (INFO.NE.0) THEN
          CALL XERBLA('SSYRK ',INFO)
          RETURN
      END IF
*
*     Quick return if possible.
*
      IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
     +    (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
*
*     And when  alpha.eq.zero.
*
      IF (ALPHA.EQ.ZERO) THEN
          IF (UPPER) THEN
              IF (BETA.EQ.ZERO) THEN
                  DO 20 J = 1,N
                      DO 10 I = 1,J
                          C(I,J) = ZERO
   10                 CONTINUE
   20             CONTINUE
              ELSE
                  DO 40 J = 1,N
                      DO 30 I = 1,J
                          C(I,J) = BETA*C(I,J)
   30                 CONTINUE
   40             CONTINUE
              END IF
          ELSE
              IF (BETA.EQ.ZERO) THEN
                  DO 60 J = 1,N
                      DO 50 I = J,N
                          C(I,J) = ZERO
   50                 CONTINUE
   60             CONTINUE
              ELSE
                  DO 80 J = 1,N
                      DO 70 I = J,N
                          C(I,J) = BETA*C(I,J)
   70                 CONTINUE
   80             CONTINUE
              END IF
          END IF
          RETURN
      END IF
*
*     Start the operations.
*
      IF (LSAME(TRANS,'N')) THEN
*
*        Form  C := alpha*A*A**T + beta*C.
*
          IF (UPPER) THEN
              DO 130 J = 1,N
                  IF (BETA.EQ.ZERO) THEN
                      DO 90 I = 1,J
                          C(I,J) = ZERO
   90                 CONTINUE
                  ELSE IF (BETA.NE.ONE) THEN
                      DO 100 I = 1,J
                          C(I,J) = BETA*C(I,J)
  100                 CONTINUE
                  END IF
                  DO 120 L = 1,K
                      IF (A(J,L).NE.ZERO) THEN
                          TEMP = ALPHA*A(J,L)
                          DO 110 I = 1,J
                              C(I,J) = C(I,J) + TEMP*A(I,L)
  110                     CONTINUE
                      END IF
  120             CONTINUE
  130         CONTINUE
          ELSE
              DO 180 J = 1,N
                  IF (BETA.EQ.ZERO) THEN
                      DO 140 I = J,N
                          C(I,J) = ZERO
  140                 CONTINUE
                  ELSE IF (BETA.NE.ONE) THEN
                      DO 150 I = J,N
                          C(I,J) = BETA*C(I,J)
  150                 CONTINUE
                  END IF
                  DO 170 L = 1,K
                      IF (A(J,L).NE.ZERO) THEN
                          TEMP = ALPHA*A(J,L)
                          DO 160 I = J,N
                              C(I,J) = C(I,J) + TEMP*A(I,L)
  160                     CONTINUE
                      END IF
  170             CONTINUE
  180         CONTINUE
          END IF
      ELSE
*
*        Form  C := alpha*A**T*A + beta*C.
*
          IF (UPPER) THEN
              DO 210 J = 1,N
                  DO 200 I = 1,J
                      TEMP = ZERO
                      DO 190 L = 1,K
                          TEMP = TEMP + A(L,I)*A(L,J)
  190                 CONTINUE
                      IF (BETA.EQ.ZERO) THEN
                          C(I,J) = ALPHA*TEMP
                      ELSE
                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                      END IF
  200             CONTINUE
  210         CONTINUE
          ELSE
              DO 240 J = 1,N
                  DO 230 I = J,N
                      TEMP = ZERO
                      DO 220 L = 1,K
                          TEMP = TEMP + A(L,I)*A(L,J)
  220                 CONTINUE
                      IF (BETA.EQ.ZERO) THEN
                          C(I,J) = ALPHA*TEMP
                      ELSE
                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                      END IF
  230             CONTINUE
  240         CONTINUE
          END IF
      END IF
*
      RETURN
*
*     End of SSYRK .
*
      END


! Demonstrate overloading with an interface and module procedures
module m
implicit none
interface mean
   module procedure mean_1d, mean_2d
end interface mean
contains
pure function mean_1d(x) result(y)
real, intent(in) :: x(:)
real             :: y
y = sum(x)/max(1,size(x))
end function mean_1d
!
pure function mean_2d(x) result(y)
real, intent(in) :: x(:,:)
real             :: y
y = sum(x)/max(1,size(x))
end function mean_2d
end module m
!
program main
use m, only: mean
implicit none
real :: x1(3),x2(2,3)
x1 = real([1,4,10])
x2(1,:) = x1
x2(2,:) = x1*3
print*,mean(x1),mean(x2) ! 5.0 10.0
end program main


c$$$    AddNumbers.for
c$$$    Copyright (C) 2019  Sriram C.
c$$$
c$$$    Redistribution and use in source and binary forms, with or without
c$$$    modification, are permitted provided that the following conditions
c$$$    are met:
c$$$
c$$$    1. Redistributions of source code must retain the above copyright notice
c$$$    this list of conditions and the following disclaimer.
c$$$    2. Redistributions in binary form must reproduce the above copyright
c$$$    notice, this list of conditions and the following disclaimer in the
c$$$    documentation and/or other materials provided with the distribution.
c$$$
c$$$    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
c$$$    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
c$$$    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
c$$$    PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
c$$$    OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
c$$$    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
c$$$    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
c$$$    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
c$$$    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
c$$$    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY
c$$$    WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY
c$$$    OF SUCH DAMAGE.

c       Add 2 numbers A and B and store the result in C
        SUBROUTINE ADD(L,M,N)
        INTEGER L,M,N

        N = L + M

        RETURN
        END

c       Add 2 matrices A and B and store the result in C
C       In this example, we assume the matrices are 2x2 matrices
        SUBROUTINE MATRIXADD(A,B,C)
        REAL A(2,2), B(2,2), C(2,2)

        DO I = 1,2
           DO J = 1,2
              C(I,J)=A(I,J)+B(I,J)
           END DO
        END DO

        RETURN
        END


!#########################################################################
!# ***********************************************************************
!# <name> transform_basicRoutines </name>
!# ***********************************************************************
!#
!# <purpose>
!# This module contains basic transformation routines for lines and
!# line segments.
!#
!# </purpose>
!#########################################################################

module transform_basicRoutines

  use fsystem

  implicit none

  contains

!<function>
  !REAL(DP) FUNCTION DPO2SG(dpx,dpy,Pstart,Pend)
  real(DP) function pdist_point_StrghtLineSeg(dpx,dpy,Pstart,Pend)

  !<description>
  ! Determine minimum (Euclidean) distance from a point (dpx,dpy) to
  ! a straight line segment.
  !
  ! Return value = minimum distance
  !</description>

  !<input>

  ! dpx - x-coodinate of point
  real(DP), intent(IN) :: dpx

  ! dpy - y-coodinate of point
  real(DP), intent(IN) :: dpy

  ! Pstart - starting point of the line segment.
  !          Pstart(1) = x-coordinate
  !          Pstart(2) = y-coordinate
  real(DP), dimension(:), intent(IN) :: Pstart

  ! Pend - endpoint of the line segment.
  !        Pend(1) = x-coordinate
  !        Pend(2) = y-coordinate
  real(DP), dimension(:), intent(IN) :: Pend

  !</input>

!</function>

  ! local variables
  real(DP) :: dsx1,dsy1,dsx2,dsy2,dvx,dvy,dwx,dwy
  real(DP) :: dbx,dby,db
  real(DP) :: dvl,dpl

  dsx1 = Pstart(1)
  dsy1 = Pstart(2)
  dsx2 = Pend(1)
  dsy2 = Pend(2)

  ! Vector Pstart -> Pend and its length
  dvx = dsx2-dsx1
  dvy = dsy2-dsy1
  dvl = sqrt(dvx*dvx+dvy*dvy)

  ! Vector Pstart -> (dpx,dpy)
  dwx = dpx-dsx1
  dwy = dpy-dsy1

  ! Scalar product to calculate the length of the
  ! projected vector
  dpl = dwx*dvx+dwy*dvy

  ! Relative length of the projection:
  db  = dpl/(dvl*dvl)

  ! Relative Length <= 0
  ! => Connection between Pstart and (dpx,dpy) is shortest distance
  !
  ! Relative Length >= 1
  ! => Connection between Pend and (dpx,dpy) is shortest distance
  if (db.le.0D0) then
    pdist_point_StrghtLineSeg = sqrt((dpx-dsx1)**2+(dpy-dsy1)**2)
  else if (db.ge.1D0) then
    pdist_point_StrghtLineSeg = sqrt((dpx-dsx2)**2+(dpy-dsy2)**2)
  else
    ! Calculate the projection and the distance to that point.
    ! Remember to take the square root of the distances as they
    ! are squared...
    dbx = dsx1+dvx*db
    dby = dsy1+dvy*db
    pdist_point_StrghtLineSeg = sqrt((dpx-dbx)**2+(dpy-dby)**2)
  endif

  end function pdist_point_StrghtLineSeg

!<subroutine>
  !SUBROUTINE PPO2SG(dpx,dpy,Pstart,Pend,DPARM,DPROJ)
  subroutine pproj_point_StrghtLineSeg(dpx,dpy,Pstart,Pend,dparm,Dproj)

  !<description>
  ! Project a point (dpx,dpy) onto a line segment.
  !</description>

  !<input>

  ! dpx - x-coodinate of point
  real(DP), intent(IN) :: dpx

  ! dpy - y-coodinate of point
  real(DP), intent(IN) :: dpy

  ! Pstart - starting point of the line segment.
  !          Pstart(1) = x-coordinate
  !          Pstart(2) = y-coordinate
  real(DP), dimension(:), intent(IN) :: Pstart

  ! Pend - endpoint of the line segment.
  !        Pend(1) = x-coordinate
  !        Pend(2) = y-coordinate
  real(DP), dimension(:), intent(IN) :: Pend

  !</input>

  !<output>

  ! Dproj - Projection of (dpx,dpy) onto the line segment.
  !         Dproj(1) = x-coordinate
  !         Dproj(2) = y-coordinate
  real(DP), dimension(:), intent(OUT) :: Dproj

  ! dparm  - Parameter value of the projected point along the line
  !          segment. Values in [0,1].
  !          Dproj = Pstart + dparm*(Pend-Pstart)
  real(DP), intent(OUT) :: dparm

  !</output>

! </subroutine>

  ! local variables
  real(DP) :: dsx1,dsy1,dsx2,dsy2,dvx,dvy,dwx,dwy
  real(DP) :: dvl, dpl

  dsx1 = Pstart(1)
  dsy1 = Pstart(2)
  dsx2 = Pend(1)
  dsy2 = Pend(2)

  ! Vector Pstart -> Pend and its length
  dvx = dsx2-dsx1
  dvy = dsy2-dsy1
  dvl = sqrt(dvx*dvx+dvy*dvy)

  ! Vector Pstart -> (dpx,dpy)
  dwx = dpx-dsx1
  dwy = dpy-dsy1

  ! Scalar product to calculate the length of the
  ! projected vector
  dpl = dwx*dvx+dwy*dvy

  ! Relative length of our projected vector:
  dparm  = dpl/(dvl*dvl)

  ! Length <= 0
  ! => Point is projected onto the starting point Pstart
  !
  ! Length >= 1
  ! => Point is projected onto the endpoint Pend
  if (dparm.le.0D0) then
    dparm = 0D0
    Dproj(1)=dsx1
    Dproj(2)=dsy1
  else if (dparm.ge.1D0) then
    dparm = 1D0
    Dproj(1)=dsx2
    Dproj(2)=dsy2
  else
    ! Calculate the projection and the distance to that point.
    ! Remember to take the square root of the distances as they
    ! are squared...
    Dproj(1) = dsx1+dvx*dparm
    Dproj(2) = dsy1+dvy*dparm
  endif

  end subroutine pproj_point_StrghtLineSeg

!<function>
  !REAL(DP) FUNCTION DPO2SL(dpx,dpy,PPT1,PPT2)
  real(DP) function pdist_point_StrghtLine(dpx,dpy,Ppt1,Ppt2)

  !<description>
  ! Determine minimum (Euclidean) distance from a point (dpx,dpy) to
  ! a straight line, given by two points on the line.
  !
  ! In contrast to pdist_point_StrghtLineSeg the line has no starting/ending point!
  !
  ! Return value = minimum distance, >= 0.
  ! < 0 indicates an error: Ppt1=Ppt2
  !</description>

  !<input>

  ! dpx - x-coodinate of point
  real(DP), intent(IN) :: dpx

  ! dpy - y-coodinate of point
  real(DP), intent(IN) :: dpy

  ! Ppt1 - one point of the line segment.
  !          Ppt1(1) = x-coordinate
  !          Ppt1(2) = y-coordinate
  real(DP), dimension(:), intent(IN) :: Ppt1

  ! Ppt2   - another point of the line segment.
  !          Ppt2(1) = x-coordinate
  !          Ppt2(2) = y-coordinate
  real(DP), dimension(:), intent(IN) :: Ppt2

  !</input>

!</function>

  ! local variables
  real(DP) :: dsx1,dsy1,dsx2,dsy2,dvx,dvy,dwx,dwy
  real(DP) :: db,dbx,dby
  real(DP) :: dvl,dpl

  dsx1 = Ppt1(1)
  dsy1 = Ppt1(2)
  dsx2 = Ppt2(1)
  dsy2 = Ppt2(2)

  ! Vector Pstart -> Pend and its length DC2
  dvx = dsx2-dsx1
  dvy = dsy2-dsy1
  dvl = sqrt(dvx*dvx+dvy*dvy)

  ! Stop calculation if both points are the same.
  if (dvl.eq.0D0) then
    pdist_point_StrghtLine = -1
    return
  end if

  ! Vector Pstart -> (dpx,dpy)
   dwx = dpx-dsx1
   dwy = dpy-dsy1

   !Calculate length of projected vector
   dpl = dwx*dvx+dwy*dvy

   ! Calculate the projection
   db  = dpl/dvl
   dbx = dsx1+dvx*db
   dby = dsy1+dvy*db
   pdist_point_StrghtLine = sqrt((dpx-dby)**2+(dpy-dby)**2)

   end function pdist_point_StrghtLine

!<subroutine>
  !SUBROUTINE PPO2SL(dpx,dpy,Ppt1,Ppt2,dparm,Dproj)
  subroutine pproj_point_StrghtLine(dpx,dpy,Ppt1,Ppt2,dparm,Dproj)

  !<description>
  ! In contrast to pproj_point_StrghtLineSeg the line has no starting/ending point!
  !</description>

  !<input>

  ! dpx - x-coodinate of point
  real(DP), intent(IN) :: dpx

  ! dpy - y-coodinate of point
  real(DP), intent(IN) :: dpy

  ! Ppt1 - one point of the line segment.
  !          Ppt1(1) = x-coordinate
  !          Ppt1(2) = y-coordinate
  real(DP), dimension(:), intent(IN) :: Ppt1

  ! Ppt2   - another point of the line segment.
  !          Ppt2(1) = x-coordinate
  !          Ppt2(2) = y-coordinate
  real(DP), dimension(:), intent(IN) :: Ppt2

  !</input>

  !<output>

  ! Dproj - Projection of (dpx,dpy) onto the line segment.
  !         Dproj(1) = x-coordinate
  !         Dproj(2) = y-coordinate
  real(DP), dimension(:), intent(OUT) :: Dproj

  ! dparm  - Parameter value of the projected point along the line
  !          segment. Values in [0,1].
  !          Dproj = Pstart + dparm*(Pend-Pstart)
  real(DP), intent(OUT) :: dparm

  !</output>

! </subroutine>

  ! local variables
  real(DP) :: dsx1,dsy1,dsx2,dsy2,dvx,dvy,dwx,dwy
  real(DP) :: dvl,dpl

  dsx1 = Ppt1(1)
  dsy1 = Ppt1(2)
  dsx2 = Ppt2(1)
  dsy2 = Ppt2(2)

  ! Vector Pstart -> Pend and its length DC2
  dvx = dsx2-dsx1
  dvy = dsy2-dsy1
  dvl = sqrt(dvx*dvx+dvy*dvy)

  ! Stop calculation if both points are the same.
  if (dvl.eq.0D0) then
    dparm = 1D99
    return
  end if

  ! Vector Pstart -> (dpx,dpy)
  dwx = dpx-dsx1
  dwy = dpy-dsy1

  ! Calculate length of projected vector
  dpl = dwx*dvx+dwy*dvy

  ! Calculate the projection and the distance to that point
  dparm  = dpl/(dvl*dvl)
  Dproj(1) = dsx1+dvx*dparm
  Dproj(2) = dsy1+dvy*dparm

  end subroutine pproj_point_StrghtLine

!<function>
  !INTEGER FUNCTION PTROLN (dpx,dpy,Ppt1,Ppt2)
  integer function ptest_pointRightLeftOnLine(dpx,dpy,Ppt1,Ppt2)

  !<description>
  ! Test if a point is right-side of a line
  !
  ! This routine tests, if a given point (dpx,dpy) is right-side or
  ! left-side of a line, given by two points.
  !
  ! Return value >  0, if the point is right-side of the line Ppt1->Ppt2
  !              <  0, if the point if left-side of the line
  !              =  0, if the point is on the line or if an error
  !              occurred (Ppt1=Ppt2)
  !
  ! Remark: More specifically the return value is the squared scalar
  !         product of the normal vector of the line with the vector
  !         Ppt1->point...
  !</description>

  !<input>

  ! dpx - x-coodinate of point
  real(DP), intent(IN) :: dpx

  ! dpy - y-coodinate of point
  real(DP), intent(IN) :: dpy

  ! Ppt1 - one point of the line segment.
  !          Ppt1(1) = x-coordinate
  !          Ppt1(2) = y-coordinate
  real(DP), dimension(:), intent(IN) :: Ppt1

  ! Ppt2   - another point of the line segment.
  !          Ppt2(1) = x-coordinate
  !          Ppt2(2) = y-coordinate
  real(DP), dimension(:), intent(IN) :: Ppt2

  !</input>

  ! local variables
  real(DP) :: dnx,dny

  ! To distinguish where the point is, relative to the line, we check
  ! the vector Ppt1->point in relation to the normal vector of the line.
  !
  ! At first build the normal vector by rotating the tangential vector
  ! by -90 degrees; this points to the right side of the line.
  dnx = (Ppt2(2)-Ppt1(2))
  dny = -(Ppt2(1)-Ppt1(1))

  ! If this normal vector points into the "same" direction like the
  ! vector Ppt1->point, the point is on the right.
  ! So we build the scalar product. This is:
  !  > 0, if the point is on the right
  !  < 0, if the point is on the left
  !  = 0, if the point is on the line
  ! and thus a candidate to serve as a return value of this function!
  ptest_pointRightLeftOnLine = dnx*(dpx-Ppt1(1)) + dny*(dpy-Ppt1(2))

  end function ptest_pointRightLeftOnLine

end module transform_basicRoutines


program test_general_ub
  use mod_orrb
  implicit none

  character(len=40) :: test_name
  character(len=*), parameter :: fmt="(A40, 'Time: ',ES8.2,', ubw: ',I3,', error: ',ES8.2, ', ', A10)"

  real(kind=dp) :: t0, t1
  type(error_info) :: error
  integer(kind=int32) :: na, lbwa, ubwa, j
  real(kind=dp), parameter :: tol=1e-14, c=9
  !
  real(kind=dp), dimension(:,:), allocatable :: a_d, a0_d, a1_d
  complex(kind=dp), dimension(:,:), allocatable :: a_z, a0_z, a1_z
  type(d_ub), allocatable :: ub_d
  type(z_ub), allocatable :: ub_z

  call initialize_errors

  print *
  print *, "--------------------------------"
  print *
  print *, "Real UB Decomposition Tests"
  print *

  na=40
  lbwa=3; ubwa=5
  ub_d=d_random_ub(na,lbwa,ubwa,error=error)
  a_d=general(ub_d,error)
  a1_d=a_d
  call cpu_time(t0)
  ub_d=ub(a_d,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_d = general(ub_d,error)
  test_name="Random Real UB;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,ub_d%ubw,t0,t1,c*tol,error)

  na=40
  lbwa=3; ubwa=1
  ub_d=d_random_ub(na,lbwa,ubwa,error=error)
  a_d=general(ub_d,error)
  a1_d=a_d
  call cpu_time(t0)
  ub_d=ub(a_d,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_d = general(ub_d,error)
  test_name="Random Real UB, ubwa=1"
  call d_output_result(test_name,a0_d,a1_d,ubwa,ub_d%ubw,t0,t1,c*tol,error)

  na=40
  lbwa=3; ubwa=0
  ub_d=d_random_ub(na,lbwa,ubwa,error=error)
  a_d=general(ub_d,error)
  a1_d=a_d
  call cpu_time(t0)
  ub_d=ub(a_d,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_d = general(ub_d,error)
  test_name="Random Real UB, ubwa=0"
  call d_output_result(test_name,a0_d,a1_d,ubwa,ub_d%ubw,t0,t1,c*tol,error)

  na=1
  lbwa=0; ubwa=0
  ub_d=d_random_ub(na,lbwa,ubwa,error=error)
  a_d=general(ub_d,error)
  a1_d=a_d
  call cpu_time(t0)
  ub_d=ub(a_d,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_d = general(ub_d,error)
  test_name="Random Real UB, na=1"
  call d_output_result(test_name,a0_d,a1_d,ubwa,ub_d%ubw,t0,t1,c*tol,error)

  na=2
  lbwa=1; ubwa=1
  ub_d=d_random_ub(na,lbwa,ubwa,error=error)
  a_d=general(ub_d,error)
  a1_d=a_d
  call cpu_time(t0)
  ub_d=ub(a_d,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_d = general(ub_d,error)
  test_name="Random Real UB, na=2"
  call d_output_result(test_name,a0_d,a1_d,ubwa,ub_d%ubw,t0,t1,c*tol,error)

  na=3
  lbwa=1; ubwa=1
  ub_d=d_random_ub(na,lbwa,ubwa,error=error)
  a_d=general(ub_d,error)
  a1_d=a_d
  call cpu_time(t0)
  ub_d=ub(a_d,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_d = general(ub_d,error)
  test_name="Random Real UB, na=3"
  call d_output_result(test_name,a0_d,a1_d,ubwa,ub_d%ubw,t0,t1,c*tol,error)

  na=4
  lbwa=2; ubwa=2
  ub_d=d_random_ub(na,lbwa,ubwa,error=error)
  a_d=general(ub_d,error)
  a1_d=a_d
  call cpu_time(t0)
  ub_d=ub(a_d,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_d = general(ub_d,error)
  test_name="Random Real UB, na=4"
  call d_output_result(test_name,a0_d,a1_d,ubwa,ub_d%ubw,t0,t1,c*tol,error)

  na=50
  lbwa=3; ubwa=13
  ub_d=d_random_ub(na,[ (lbwa, j=1,na) ], &
       [ (ubwa-1, j=1,na-ubwa), (ubwa, j=na-ubwa+1,na) ], error=error )
  a_d=general(ub_d,error)
  a1_d=a_d
  ub_d=ub(a_d,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t0)
  a0_d = general(ub_d,error)
  call cpu_time(t1)
  test_name="Random Real Square Termination UB;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,ub_d%ubw,t0,t1,c*tol,error)
  deallocate(ub_d)

  !
  ! Complex UB test
  !
  print *
  print *, "--------------------------------"
  print *
  print *, "Complex UB Decomposition Tests"
  print *

  na=40
  lbwa=3; ubwa=5
  ub_z=z_random_ub(na,lbwa,ubwa,error=error)
  a_z=general(ub_z,error)
  a1_z=a_z
  call cpu_time(t0)
  ub_z=ub(a_z, lbwa, lbwa, ubwa+1, tol,error)
  call cpu_time(t1)
  a0_z=general(ub_z,error)
  test_name="Random Complex UB;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,ub_z%ubw,t0,t1,c*tol,error)

  na=40
  lbwa=3; ubwa=1
  ub_z=z_random_ub(na,lbwa,ubwa,error=error)
  a_z=general(ub_z,error)
  a1_z=a_z
  call cpu_time(t0)
  ub_z=ub(a_z, lbwa, lbwa, ubwa+1, tol,error)
  call cpu_time(t1)
  a0_z=general(ub_z,error)
  test_name="Random Complex UB, ubwa=1;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,ub_z%ubw,t0,t1,c*tol,error)

  na=40
  lbwa=3; ubwa=0
  ub_z=z_random_ub(na,lbwa,ubwa,error=error)
  a_z=general(ub_z,error)
  a1_z=a_z
  call cpu_time(t0)
  ub_z=ub(a_z, lbwa, lbwa, ubwa+1, tol,error)
  call cpu_time(t1)
  a0_z=general(ub_z,error)
  test_name="Random Complex UB, ubwa=0;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,ub_z%ubw,t0,t1,c*tol,error)

  na=1
  lbwa=0; ubwa=0
  ub_z=z_random_ub(na,lbwa,ubwa,error=error)
  a_z=general(ub_z,error)
  a1_z=a_z
  call cpu_time(t0)
  ub_z=ub(a_z, lbwa, lbwa, ubwa+1, tol,error)
  call cpu_time(t1)
  a0_z=general(ub_z,error)
  test_name="Random Complex UB, na=1;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,ub_z%ubw,t0,t1,c*tol,error)

  na=2
  lbwa=1; ubwa=1
  ub_z=z_random_ub(na,lbwa,ubwa,error=error)
  a_z=general(ub_z,error)
  a1_z=a_z
  call cpu_time(t0)
  ub_z=ub(a_z, lbwa, lbwa, ubwa+1, tol,error)
  call cpu_time(t1)
  a0_z=general(ub_z,error)
  test_name="Random Complex UB, na=2;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,ub_z%ubw,t0,t1,c*tol,error)

  na=3
  lbwa=1; ubwa=1
  ub_z=z_random_ub(na,lbwa,ubwa,error=error)
  a_z=general(ub_z,error)
  a1_z=a_z
  call cpu_time(t0)
  ub_z=ub(a_z, lbwa, lbwa, ubwa+1, tol,error)
  call cpu_time(t1)
  a0_z=general(ub_z,error)
  test_name="Random Complex UB, na=3;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,ub_z%ubw,t0,t1,c*tol,error)

  na=4
  lbwa=2; ubwa=2
  ub_z=z_random_ub(na,lbwa,ubwa,error=error)
  a_z=general(ub_z,error)
  a1_z=a_z
  call cpu_time(t0)
  ub_z=ub(a_z, lbwa, lbwa, ubwa+1, tol,error)
  call cpu_time(t1)
  a0_z=general(ub_z,error)
  test_name="Random Complex UB, na=4;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,ub_z%ubw,t0,t1,c*tol,error)

  na=50
  lbwa=3; ubwa=13
  ub_z=z_random_ub(na,[ (lbwa, j=1,na) ], &
       [ (ubwa-1, j=1,na-ubwa), (ubwa, j=na-ubwa+1,na) ], error = error)
  a_z=general(ub_z,error)
  a1_z=a_z
  call cpu_time(t0)
  ub_z=ub(a_z,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_z = general(ub_z,error)
  test_name="Random Complex Square Termination UB;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,ub_z%ubw,t0,t1,c*tol,error)
  print *

contains

  subroutine d_output_result(name,a0,a1,ubw0,ubw1,t0,t1,bnd,error)
    character(len=*) :: name
    real(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: ubw0, ubw1
    type(error_info) :: error

    real(kind=dp) :: berr
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       berr = maxabs(a1-a0)
       if (ubw0==ubw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, ubw1, berr, test_result
    end if
  end subroutine d_output_result

  subroutine z_output_result(name,a0,a1,ubw0,ubw1,t0,t1,bnd,error)
    character(len=*) :: name
    complex(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: ubw0, ubw1
    type(error_info) :: error

    real(kind=dp) :: berr
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       berr = maxabs(a1-a0)
       if (ubw0==ubw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, ubw1, berr, test_result
    end if
  end subroutine z_output_result

end program test_general_ub


*
*     -------------------------------------------------------------
*      N I N E 1 3
*     -------------------------------------------------------------
*
*                                                                  *
*     THIS PACKAGE DETERMINES THE VALUES OF 9j COEFFICIENT         *
*                                                                  *
*     |  J1/2      J2/2  J3/2+1 |                                  *
*     |  L1/2      L2/2  J3/2   |                                  *
*     |  K1/2 + 1  K1/2    1    |                                  *
*                                                                  *
*     Written by G. Gaigalas,                                      *
*     Vilnius, LITHUANIA                              January 1997 *
*
      SUBROUTINE NINE13(J1,J2,J3,L1,L2,K1,A)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
      A=ZERO
      K2=K1-2
      L3=J3-2
      IV=J3*(J1-L1)*(J1+L1+2)-K1*(J1-J2)*(J1+J2+2)+K1*J3*(K2-L3)
      IF(IV.EQ.0) THEN
        CALL NINE(J1,J2,J3,L1,L2,L3,K1,K2,2,0,IN,A)
      ELSE
        IS=L3-K2
        IF(IS.EQ.0) THEN
          S1=ZERO
        ELSE
          CALL SIXJ(J1,L1,K2,L2,J2,L3,1,S1)
          CALL ACONST(J1+1,L1,K2+1,J2,L3+1,A1)
          S1=S1*A1*DBLE(IS)/TWO
        ENDIF
        CALL ACONST(L1+1,J1,K2+1,L2,L3+1,A2)
        IF(DABS(A2).LT.EPS) THEN
          S2=ZERO
        ELSE
          CALL SIXJ(J1,J2,J3,L2,L1,K2,1,S2)
           S2=S2*A2*DBLE(J3)/TWO
        ENDIF
        CALL ACONST(J2+1,J1,L3+1,L2,K2+1,A3)
        IF(DABS(A3).LT.EPS) THEN
          S3=ZERO
        ELSE
          CALL SIXJ(J1,J2,L3,L2,L1,K1,1,S3)
          S3=S3*A3*DBLE(K1)/TWO
        ENDIF
        S=S1+S2-S3
        IF(DABS(S).LT.EPS) RETURN
        VAR2=DBLE(K2+3)*DBLE(K2+2)*DBLE(K2+1)*
     :       DBLE(L3+3)*DBLE(L3+2)*DBLE(L3+1)
        A=S*DBLE(8)/(DBLE(IV)*DSQRT(VAR2))
        IF(MOD(J2+L3+L1+K2,4).NE.0) A=-A
      ENDIF
      RETURN
      END


PROGRAM CriticalMass
    implicit none
    real :: massU, R, sigT, xBank(10000000, 2), yBank(10000000, 2), &
            zBank(10000000, 2), nU, ran1, L, theta, phi, x, y, z
    real, parameter :: rhoU = 19.E3, sigS = 4.2E-28, sigA = 0.1E-28, &
                       sigF = 1.3E-28, prob2 = 0.56, prob3 = 0.44
    integer :: n, i, j, numNeutrons, iBank, numBank, current, next

    ! Open the data file
    open(unit = 2, file = 'critical_mass.dat', status = 'replace')

    ! Establish constants

    ! Mass of Uranium-235 in kg
    massU = 1.8E1
    ! Number of starting neutrons
    numNeutrons = 1.0E9
    ! Radius of sphere
    R = (3. * massU / (4. * acos(-1.0) * rhoU)) ** (1. / 3.)
    ! Number density of Uranium-235
    nU = rhoU / (235. * 1.661E-27)
    ! Total cross section
    sigT = sigS + sigA + sigF

    print *, "MassU:", massU, "Radius:", R
    write(2, *) 0, numNeutrons

    ! For 200 generations of neutrons,
    do j = 1, 200
        ! Reset neutron bank index
        iBank = 0

        ! Alternate between the database column indicies
        if(mod(j, 2).eq.0) then
            current = 2
            next = 1
        else
            current = 1
            next = 2
        endif

        ! For every neutron,
        do n = 1, numNeutrons
            if(j.eq.1) then
                ! Emit neutrons on first generation
                call emitNeutron(x, y, z, theta, phi)
            else
                ! Load locations from bank otherwise
                x = xBank(n, current)
                y = yBank(n, current)
                z = zBank(n, current)

                ! Get new directions
                call scatter(theta, phi)
            endif

            ! While neutron is still inside of the sphere,
            do while(sqrt(x*x + y*y + z*z).le.R)
                ! Generate random
                call random_number(ran1)

                ! Find distance traveled
                L = -log(ran1) / (nU * sigT)
                ! And update the neutron positions
                x = x + L * sin(theta) * cos(phi)
                y = y + L * sin(theta) * sin(phi)
                z = z + L * cos(theta)

                ! If still inside of the sphere,
                if(sqrt(x*x + y*y + z*z).le.R) then
                    ! Generate random
                    call random_number(ran1)

                    ! and find interaction type from the probabilities
                    if(ran1.lt.(sigA / sigT)) then
                        ! Neutron absorbed, go to next neutron
                        goto 2
                    elseif(ran1.lt.((sigA + sigS) / sigT)) then
                        ! Neutron scattered
                        call scatter(theta, phi)
                    else
                        ! Fission event, find number of neutrons produced
                        call random_number(ran1)
                        if(ran1.lt.prob2) then
                            ! 2 produced
                            numBank = 2
                        else
                            ! 3 produced
                            numBank = 3
                        endif

                        ! Bank neutrons' positions
                        do i = 1, numBank
                            iBank = iBank + 1

                            ! Exit if the bank is full
                            if (iBank.gt.9999999) goto 3

                            xBank(iBank, next) = x
                            yBank(iBank, next) = y
                            zBank(iBank, next) = z
                        enddo
                    endif
                endif
            enddo

2           continue
        enddo

        print *, "Gen:", j, "Number:", iBank
        ! update the number of neutrons for next generation
        numNeutrons = iBank
        ! Save to file
        write(2, *) j, numNeutrons
    enddo
    ! Close the file
3   close(2)
    print *, "Done."
end PROGRAM CriticalMass

SUBROUTINE emitNeutron(x, y, z, theta, phi)
!   Creates a photon packet by initializing its coordinates and direction vector
!   x       R4 x-coordinate
!   y       R4 y-coordinate
!   z       R4 z-coordinate
!   theta   R4 angle
!   phi     R4 angle
    implicit none
    real, intent(out) :: x, y, z, theta, phi

    ! Start a center of sphere
    x = 0.0
    y = 0.0
    z = 0.0

    call scatter(theta, phi)
end SUBROUTINE emitNeutron

SUBROUTINE scatter(theta, phi)
!   Scatters the photon isotropically by giving it new direction vectors
!   theta   R4 angle
!   phi     R4 angle
    implicit none
    real, intent(out) :: theta, phi
    real :: ran

    call random_number(ran)
    theta = acos(2.0 * ran - 1.0)

    call random_number(ran)
    phi = 2.0 * ran * acos(-1.0)  ! arccos(-1) = pi
end SUBROUTINE scatter


program problem44
  implicit none
  integer :: answer,j,k,Pj,Pk,D

  answer=huge(answer)

  do k=2,huge(k)
     Pk=P(k)
     if (Pk - P(k-1) > answer .or. Pk < 0) exit ! already too large, short circuit
     do j=k-1,1,-1
        Pj=P(j)
        D = Pk-Pj
        if (D > answer .or. Pj < 0) exit ! already too large, short circuit
        if (is_P(Pj + Pk) .and. is_P(D)) then
           print *, j,k,Pj,Pk,D
           if (D<answer) then
              answer=D
           end if
        end if
     end do
  end do

  print *, answer

contains

  pure function P(n)
    implicit none
    integer, intent(in) :: n
    integer             :: P
    P=n*(3*n-1)/2
  end function P

  pure function is_P(x)
    implicit none
    integer, intent(in) :: x
    double precision    :: n
    logical             :: is_P
    n = (sqrt(dble(24*x + 1)) + 1)/6
    is_P = (whole(n))
  end function is_P

  pure function whole(x)
    implicit none
    double precision, intent(in) :: x
    logical                      :: whole
    whole = (mod(x,1.0) == 0.0)
  end function whole

end program problem44


    Program zheev_example

!     ZHEEV 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: zscal
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen
      Use lapack_interfaces, Only: ddisna, zheev
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: eerrbd, eps
      Integer :: i, ifail, info, k, lda, lwork, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), work(:)
      Complex (Kind=dp) :: dummy(1)
      Real (Kind=dp), Allocatable :: rcondz(:), rwork(:), w(:), zerrbd(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, cmplx, conjg, epsilon, max, maxloc, nint, real
!     .. Executable Statements ..
      Write (nout, *) 'ZHEEV Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      Allocate (a(lda,n), rcondz(n), rwork(3*n-2), w(n), zerrbd(n))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call zheev('Vectors', 'Upper', n, a, lda, w, dummy, lwork, rwork, info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max((nb+1)*n, nint(real(dummy(1))))
      Allocate (work(lwork))

!     Read the upper triangular part of the matrix A from data file

      Read (nin, *)(a(i,i:n), i=1, n)

!     Solve the Hermitian eigenvalue problem
      Call zheev('Vectors', 'Upper', n, a, lda, w, work, lwork, rwork, info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) w(1:n)

        Write (nout, *)
        Flush (nout)

!       Normalize the eigenvectors so that the element of largest absolute
!       value is real.
        Do i = 1, n
          rwork(1:n) = abs(a(1:n,i))
          k = maxloc(rwork(1:n), 1)
          Call zscal(n, conjg(a(k,i))/cmplx(abs(a(k,i)),kind=dp), a(1,i), 1)
        End Do

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_complex_gen('General', ' ', n, n, a, lda, &
          'Eigenvectors', ifail)

!       Get the machine precision, EPS and compute the approximate
!       error bound for the computed eigenvalues.  Note that for
!       the 2-norm, max( abs(W(i)) ) = norm(A), and since the
!       eigenvalues are returned in descending order
!       max( abs(W(i)) ) = max( abs(W(1)), abs(W(n)))

        eps = epsilon(1.0E0_dp)
        eerrbd = eps*max(abs(w(1)), abs(w(n)))

!       Call DDISNA to estimate reciprocal condition
!       numbers for the eigenvectors
        Call ddisna('Eigenvectors', n, n, w, rcondz, info)

!       Compute the error estimates for the eigenvectors

        Do i = 1, n
          zerrbd(i) = eerrbd/rcondz(i)
        End Do

!       Print the approximate error bounds for the eigenvalues
!       and vectors

        Write (nout, *)
        Write (nout, *) 'Error estimate for the eigenvalues'
        Write (nout, 110) eerrbd
        Write (nout, *)
        Write (nout, *) 'Error estimates for the eigenvectors'
        Write (nout, 110) zerrbd(1:n)
      Else
        Write (nout, 120) 'Failure in ZHEEV. INFO =', info
      End If

100   Format (3X, (8F8.4))
110   Format (4X, 1P, 6E11.1)
120   Format (1X, A, I4)
    End Program


subroutine fdot(mtx1,mtx2,ans,l,m,n)

    implicit none
    integer, intent(in) :: l,m,n
    real, intent(in) :: mtx1(l,m)
    real, intent(in) :: mtx2(m,n)
    real, intent(out) :: ans(l,n)

    ans =  MATMUL(mtx1,mtx2)

end subroutine fdot


	SUBROUTINE GR_CLVL  ( maxlvl, cmin, cmax, cint, dmin, dmax,
     +			      nlvl,   clvl, rint, iret )
C************************************************************************
C* GR_CLVL								*
C*									*
C* This subroutine selects contour levels given the range of data	*
C* values in the grid subset area input for the contour interval	*
C* and the minimum and maximum grid values.  If the minimum or maximum	*
C* input value is missing, the data value will be used.  If the contour	*
C* interval is non-positive, a contour interval producing five to ten 	*
C* contours will be selected.						*
C*									*
C* GR_CLVL  ( MAXLVL, CMIN, CMAX, CINT, DMIN, DMAX, NLVL, CLVL, 	*
C*		RINT, IRET )						*
C*									*
C* Input parameters:							*
C*	MAXLVL		INTEGER		Max number of contour levels	*
C*	CMIN		REAL		Minimum contour value		*
C*	CMAX		REAL		Maximum contour value		*
C*	CINT		REAL		Contour interval		*
C*	DMIN		REAL		Minimum data value		*
C*	DMAX		REAL		Maximum data value		*
C*									*
C* Output parameters:							*
C*	NLVL		INTEGER		Number of contour levels	*
C*	CLVL (NLVL)	REAL		Contour levels			*
C*	RINT		REAL		Computed contour interval	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					  1 = no valid contour level	*
C*					 -8 = invalid data range	*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 2/85						*
C* M. desJardins/GSFC	 9/88	Rewrote for GEMPAK4			*
C* G. Krueger/EAI	 8/93	Modified to return computed interval	*
C* T. Lee/GSC		 6/99	Returned when no valid contour level	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		clvl (*)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
	nlvl = 0
C
C*	Check that data range is valid.
C
	IF  ( ( ERMISS ( dmin ) ) .or. ( ERMISS ( dmax ) ) .or.
     +	      ( dmin .gt. dmax ) )  THEN
	    iret = -8
	    RETURN
	END IF
C
C*	Set rmin and rmax to the minimum and maximum values to use.
C
	IF  ( ERMISS ( cmin ) .or. ( cmin .lt. dmin ) )  THEN
	    rmin = dmin
	  ELSE
	    rmin = cmin
	END IF
	IF  ( ERMISS ( cmax ) .or. ( cmax .gt. dmax ) )  THEN
	    rmax = dmax
	  ELSE
	    rmax = cmax
	END IF
	IF  ( rmax .lt. rmin )  THEN
	    IRET = 1
	    RETURN
	END IF
C
C*	Get contour interval if none was specified.
C
	IF  ( ( cint .eq. 0. ) .or. ( ERMISS ( cint ) ) )  THEN
	    CALL GR_CVAL  ( rmin, rmax, rint, iret )
	    IF  ( iret .ne. 0 )  RETURN
	  ELSE
	    rint = cint
	END IF
C
C*	If identical minimum and maximum values input, use that as
C*	contour level.
C
	IF  ( rmin .eq. rmax )  THEN
	    nlvl = 1
	    clvl ( nlvl ) = rmin
C
C*	    Otherwise compute levels as even multiples of the contour
C*	    interval.  If no levels are generated, make the minimum
C*	    and maximum values the only levels.
C
	  ELSE
	    CALL GR_CMPV  ( rmin, rmax, rint, maxlvl, nlvl, clvl, iret )
	    IF  ( nlvl .eq. 0 )  THEN
		nlvl = 2
		clvl ( 1 ) = rmin
		clvl ( 2 ) = rmax
	    END IF
	END IF
C*
	RETURN
	END


      subroutine   furlea(
     i                    spavac,time1,time0,
     m                    ii)
c
c     + + + PURPOSE + + +
c     This subprogram allows for lower end advance during the depletion
c     and recession phases.
c
c     Called from FURREC
c     Author(s): E. R. Kottwitz
c     Reference in User Guide: Chapter 12
c
c     NOTE:  THIS MODULE HAS NOT BEEN RECODED
c
c     + + + PARAMETERS + + +
      include 'pmxpln.inc'
      include 'pmxsrg.inc'
      include 'pxstep.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
      integer   ii
      real      spavac,time1,time0
c
c     + + + ARGUMENT DEFINITIONS + + +
c     ii     - primary kinematic wave calculation counter
c     spavac - space averaging coefficient for flow area for current
c              time
c     time1  - time of current set of calculations (s)
c     time0  - time of previous set of calculations (s)
c
c     + + + COMMON BLOCKS + + +
      include 'ciraflo.inc'
c       read: aqcnst,aqexp
c
      include 'cirfurr.inc'
c       read: spavz
c     modify: aflow(0:xsteps,2),infltr(0:xsteps,2),inoptm(0:xsteps),
c             tadvan(0:xsteps),xpostn(0:xsteps)
c
      include 'cirinfl.inc'
c       read: kosta,kostf,kostk
c
c     + + + LOCAL VARIABLES + + +
      real      deltax,ratio,tiavq
c
c     + + + LOCAL DEFINITIONS + + +
c     deltax - advance distance during the current time step (m)
c     ratio  - ratio of deltax to (location of next node - location of
c              current node) (m/m)
c     tiavq  - time averaging coefficient for flow rate
c
c     + + + DATA INITIALIZATIONS + + +
      data      tiavq/0.35/
c
c     + + + END SPECIFICATIONS + + +
c
c     Determine advance distance (deltax) and ratio of this distance to
c     the interval between the next node and the current node
c
c      ---- (WEPP Equation 12.14, solved for DELTAX)
      deltax = (1.0-tiavq)*qflow(ii,2)*(time1-time0)/
     1         (spavac*aflow(ii,2)+spavz*(infltr(ii,2)-infltr(ii,1)))
   10 ratio = deltax/(xpostn(ii+1)-xpostn(ii))
c
c     If next statement is true then shift current calculation
c     boundary downslope.  Linearly interpolate for inoptm(i) and
c     adjust aflow, infltr, tadvan, and xpostn arrays.
c
      if(ratio.le.0.5 .or. (ratio.lt.1.0 .and. ii.eq.xsteps-1))then
        inoptm(ii) = inoptm(ii)+(inoptm(ii+1)-inoptm(ii))*ratio
        xpostn(ii) = xpostn(ii)+deltax
        tadvan(ii) = time1
        aflow(ii,2) = 0.0
        qflow(ii,2) = 0.0
c
c        ---- (WEPP Equation 12.4, where tau=inoptm)
        infltr(ii,1) = kostk*inoptm(ii)**kosta+kostf*inoptm(ii)
        infltr(ii,2) = infltr(ii,1)
c
c     If next statement is true then shift next calculation boundary
c     upslope.  Linearly interpolate for inoptm(i+1), adjust aflow,
c     infltr, tadvan, and xpostn arrays.
c
      elseif(ratio.gt.0.5 .and. ratio.lt.1.0 .and. ii.lt.(xsteps-1))then
        ii = ii+1
        inoptm(ii) = inoptm(ii-1)+(inoptm(ii)-inoptm(ii-1))*ratio
        xpostn(ii) = xpostn(ii-1)+deltax
        tadvan(ii) = time1
        aflow(ii,2) = 0.0
        qflow(ii,2) = 0.0
c
c        ---- (WEPP Equation 12.4, where tau=inoptm)
        infltr(ii,1) = kostk*inoptm(ii)**kosta+kostf*inoptm(ii)
        infltr(ii,2) = infltr(ii,1)
c
c     If none of the above statements is true then increment i.
c     Linearly interpolate for tadvan(i) and aflow(i,2) and adjust
c     infltr array
c
      else
        ii = ii+1
        tadvan(ii) = time0+(time1-time0)/ratio
        aflow(ii,2) = aflow(ii-1,2)*(ratio-1.0)/ratio
        qflow(ii,2) = aqcnst*aflow(ii,2)**aqexp
c
c        ---- (WEPP Equation 12.4, where tau=inoptm+time1-tadvan)
        infltr(ii,2) = kostk*(inoptm(ii)+time1-tadvan(ii))**kosta+
     1                 kostf*(inoptm(ii)+time1-tadvan(ii))
c
c        ---- (WEPP Equation 12.4 where tau=inoptm)
        infltr(ii,1) = kostk*inoptm(ii)**kosta+kostf*inoptm(ii)
c
c       If the next statement is true then adjust deltax and make next
c       round of calculation boundary adjustments.
c
        if(ii.lt.xsteps)then
          deltax = deltax-(xpostn(ii)-xpostn(ii-1))
          goto 10
        endif
      endif
c
      return
      end