! --- potential and force fields

      subroutine derivs(x,Ntraj,v,dv,ddv)

      use cdat, only : ipot

      implicit real*8(a-h,o-z)
      integer*4,intent(IN) :: Ntraj
      real*8,intent(IN) :: x(Ntraj)
      real*8,intent(OUT) :: v(Ntraj),dv(Ntraj),ddv(Ntraj)

! --- eckart barrier
!      v0 = 16d0
!      a = 0.8d0
!
!      do i=1,ntraj
!        v(i) = v0/cosh(x(i)/a)**2
!        dv(i) = -2d0*v0*tanh(x(i)/a)/a/(cosh(x(i)/a))**2
!        ddv(i) = 4d0*v0*tanh(x(i)/a)**2/a**2/cosh(x(i)/a)**2-2d0*v0* &
!                 (1d0-tanh(x(i)/a)**2)/a**2/cosh(x(i)/a)**2
!      enddo
      if (ipot == 1) then
! ----- quatic oscilator
        ak = 1.d0
        ak2 = 0.01d0

        do i=1,Ntraj
          dv(i) = ak*x(i) + 4d0*ak2*x(i)**3
          v(i)  = ak*x(i)**2/2d0 + ak2*x(i)**4
          ddv(i) = ak + 12d0*ak2*x(i)**2
!          ddv(i) = 0d0
        enddo

      elseif(ipot == 2) then

!------morse potential with extra bound potential at the right side
      de = 0.176d0
      x0 = 1.4d0
      a = 1.02d0
      beta = 100d0
      bound = 5d0
      b = 0d0

      do i=1,Ntraj
        d = (1d0-exp(-a*(x(i)-x0)))
        v(i) = de*d**2
        dv(i) = 2*de*d*a*exp(-a*(x(i)-x0))+b*exp(-beta*(x(i)-bound)**2)
        ddv(i)=2*de*(-d*exp(-a*((x(i)-x0)))*a**2+(exp(-a*(x(i)-x0)))**2*a**2)
      enddo

      endif
!---------doulbe well---------------------------
!      eta = 1.3544d0
!      do i=1,Ntraj
!        v(i) = 1d0/16d0/eta*x(i)**4-0.5d0*x(i)**2
!        dv(i) = 1d0/4d0/eta*x(i)**3-x(i)
!        ddv(i) = 3d0/4d0/eta*x(i)**2-1d0
!      enddo

      return
      end subroutine derivs


module maths
  use maths_utils, only: cds1, cds2
  implicit none
  private
  public :: mean, cen_diff_stag, cen_diff, uneven_deriv, calc_mfpsi

  real, parameter, public :: Half = 0.5, One = 1.
  real, parameter         :: Quarter = 0.25

contains

  real function mean(data)
    real, dimension(:,:), intent(in) :: data

    mean = sum(data) / size(data)
  end function mean

  ! ===========================================================================

  function cen_diff_stag(data, rdx, dim)
    real, dimension(:,:), intent(in) :: data
    real,                 intent(in) :: rdx
    integer,              intent(in) :: dim
    real, dimension(cds1(size(data,1),dim),cds2(size(data,2),dim)) :: cen_diff_stag

    integer :: nPoints

    nPoints = size(data,dim) - 1

    select case (dim)
    case (1)
       cen_diff_stag = rdx * (data(2:nPoints+1,:) - data(1:nPoints,:))
    case (2)
       cen_diff_stag = rdx * (data(:,2:nPoints+1) - data(:,1:nPoints))
    case default
       stop "Error in dim value in cen_diff_stag!"
    end select
  end function cen_diff_stag

  ! ===========================================================================

  function cen_diff(d, dxr, dim)
    real, dimension(:,:,:,:), intent(in) :: d
    real,                     intent(in) :: dxr
    integer,                  intent(in) :: dim
    real, dimension(size(d,1),size(d,2),size(d,3),size(d,4)) :: cen_diff

    integer :: n

    n = size(d,dim)

    select case (dim)
    case (1)
       cen_diff(2:n-1,:,:,:) = Half * dxr * (d(3:n,:,:,:) - d(1:n-2,:,:,:))
       cen_diff((/1,n/),:,:,:) = dxr * (d((/2,n/),:,:,:) - d((/1,n-1/),:,:,:))
    case (2)
       cen_diff(:,2:n-1,:,:) = Half * dxr * (d(:,3:n,:,:) - d(:,1:n-2,:,:))
       cen_diff(:,(/1,n/),:,:) = dxr * (d(:,(/2,n/),:,:) - d(:,(/1,n-1/),:,:))
    case (4)
       cen_diff(:,:,:,2:n-1) = Half * dxr * (d(:,:,:,3:n) - d(:,:,:,1:n-2))
       cen_diff(:,:,:,(/1,n/)) = dxr * (d(:,:,:,(/2,n/)) - d(:,:,:,(/1,n-1/)))
    case default
       stop "Bad dim in cen_diff!"
    end select
  end function cen_diff

  ! ===========================================================================

  function uneven_deriv(d, coordVal, dim)
    real, dimension(:,:,:,:), intent(in) :: d
    real, dimension(:),       intent(in) :: coordVal
    integer,                  intent(in) :: dim
    real, dimension(size(d,1),size(d,2),size(d,3),size(d,4)) :: uneven_deriv

    real, dimension(2:size(coordVal)) :: deltaCoord
    real, dimension(3)                :: c
    integer                           :: n, i

    n = size(d,dim)
    if (n /= size(coordVal)) stop "Arrays don't conform in uneven_deriv!"

    deltaCoord = coordVal(2:) - coordVal(:n-1)
    select case (dim)
    case (3)
       do i = 2, n - 1
          c = deriv_coeff(deltaCoord(i), deltaCoord(i+1))
          uneven_deriv(:,:,i,:) = c(1) * d(:,:,i-1,:) + c(2) * d(:,:,i,:) +  &
               c(3)*d(:,:,i+1,:)
       end do
       uneven_deriv(:,:,(/1,n/),:) = (d(:,:,(/2,n/),:) -  &
            d(:,:,(/1,n-1/),:)) / spread(spread(spread(coordVal((/2,n/)) -  &
            coordVal((/1,n-1/)),1,size(d,1)),2,size(d,2)),4,size(d,4))
    case default
       stop "This dim value not implemented in uneven_deriv!"
    end select
  end function uneven_deriv

  ! ===========================================================================

  function calc_mfpsi(mfu, mfv)
    real, dimension(:,:), intent(in)             :: mfu, mfv
    real, dimension(size(mfv,1)-1,size(mfu,2)-1) :: calc_mfpsi

    integer :: nx, ny!, i, j

    nx = size(mfv,1)
    ny = size(mfu,2)
    if (size(mfv,2) /= ny-1 .or. size(mfu,1) /= nx-1) stop "Mismatch in mfpsi!"

    calc_mfpsi = Quarter * (mfu(:,:ny-1)+mfu(:,2:) + mfv(:nx-1,:)+mfv(2:,:))
!!$    do j = 1, ny-1
!!$       do i = 1, nx-1
!!$          calc_mfpsi(i,j) = Quarter *  &
!!$               (mfu(i,j) + mfu(i,j+1) + mfv(i,j) + mfv(i+1,j))
!!$       end do
!!$    end do
  end function calc_mfpsi

  ! ===========================================================================

  ! A function to calculate the coefficients for taking a first derivative
  ! with variable grid spacing
  pure function deriv_coeff(d1, d2)
    real, intent(in)   :: d1, d2      ! Grid spacings adj. to derivative pt.
    real, dimension(3) :: deriv_coeff

    deriv_coeff(1) = -d2 / (d1 * (d1+d2))
    deriv_coeff(2) = (d2**2 - d1**2) / (d1 * d2 * (d1+d2))
    deriv_coeff(3) = d1 / (d2 * (d1+d2))
  end function deriv_coeff

end module maths


program main
    use MathClass
    implicit none

    integer(int32) :: d, e, lambda,prime1,prime2,seed,id_rsa(2),id_rsa_pub(2)
    integer(int32) :: message, ciphertext,a,m

    prime1=61
    prime2=53
    seed=17
    call rsa_keygen(prime1,prime2,seed,id_rsa,id_rsa_pub)

    message=1234
    print *, "message = ", message

    ciphertext = rsa_encrypt(id_rsa_pub,message)
    print *, "ciphertext = ", ciphertext

    message = rsa_decrypt(id_rsa,ciphertext)
    print *, "message = ", message
    print *, ">>>>>>>>>>>>>>>>>>>>>>>>>"
    print *, "Private key ",id_rsa
    print *, "Public key  ",id_rsa_pub
    print *, "<<<<<<<<<<<<<<<<<<<<<<<<<"

end program main


       function sqrt_1(T)
        implicit none

        type(Tensor1), intent(in) :: T
        type(Tensor1) :: sqrt_1

        sqrt_1%a = dsqrt(T%a)

       end function sqrt_1

       function stretch_2(T)
        ! Source:
        !
        ! Franca, L.P. (1989): AN ALGORITHM TO COMPUTE
        ! THE SQUARE ROOT OF A POSITIVE DEFINITE MATRIX
        !
        implicit none

        type(Tensor2), intent(in) :: T
        type(Tensor2) :: stretch_2

        real(kind=8) :: I_T,II_T,III_T,I_U,II_U,III_U,k,l,lam,phi

        ! Invariants of T
        I_T = tr(T)
        II_T = 0.5*(I_T**2-T**T)
        III_T = det(T)
        k = I_T**2-3.*II_T

        ! Isotropy check
        if (dabs(k).le.1.0d-8) then
         lam = (I_T/3.)**(1./2.)
         stretch_2 = lam * identity2(T)
         return
        end if

        ! Calculate largest eigenvalues
        l = I_T**3 - 9./2. * I_T*II_T + 27./2. * III_T
        phi = dacos(l/k**(3./2.))
        lam = dsqrt(1./3.*(I_T+2*k**(1./2.)*dcos(phi/3.)))

        ! Invariants of U
        III_U = (III_T)**(1./2.)
        I_U = lam + dsqrt(-lam**2+I_T+2.*III_U/lam)
        II_U = (I_U**2-I_T)/2.

        print *, 'test', l,k,1-l**2/k**3

        stretch_2 = 1./(I_U*II_U-III_U)
     *           *(I_U*III_U*identity2(T) + (I_U**2-II_U)*T-T**2)

       end function stretch_2

       function stretch_2s(T)
        ! Source:
        !
        ! Franca, L.P. (1989): AN ALGORITHM TO COMPUTE
        ! THE SQUARE ROOT OF A POSITIVE DEFINITE MATRIX
        !
        implicit none

        type(Tensor2s), intent(in) :: T
        type(Tensor2s) :: stretch_2s

        real(kind=8) :: I_T,II_T,III_T,I_U,II_U,III_U,k,l,lam,phi

        ! Invariants of T
        I_T = tr(T)
        II_T = 0.5*(I_T**2-tr(T*T))
        III_T = det(T)
        k = I_T**2-3.*II_T

        ! Isotropy check
        if (k.le.1.0d-8) then
         lam = (I_T/3.)**(1./2.)
         stretch_2s = lam * identity2(T)
         return
        end if

        ! Calculate largest eigenvalues
        l = I_T**3 - 9./2. * I_T*II_T + 27./2. * III_T
        phi = dacos(l/k**(3./2.))
        lam = dsqrt(1./3.*(I_T+2*k**(1./2.)*dcos(phi/3.)))

        ! Invariants of U
        III_U = (III_T)**(1./2.)
        I_U = lam + dsqrt(-lam**2+I_T+2.*III_U/lam)
        II_U = (I_U**2-I_T)/2.

        stretch_2s = 1./(I_U*II_U-III_U)
     *           *(I_U*III_U*identity2(T) + (I_U**2-II_U)*T-T*T)

       end function stretch_2s


FUNCTION erf(x) RESULT(fn_val)
!-----------------------------------------------------------------------
!             EVALUATION OF THE REAL ERROR FUNCTION
! Based upon a Fortran 66 routine in the Naval Surface Warfare Center's
! Mathematics Library (1993 version).
! Adapted by Alan.Miller @ vic.cmis.csiro.au
!-----------------------------------------------------------------------
IMPLICIT NONE
INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(14, 60)      ! `Double precision'

REAL (dp), INTENT(IN) :: x
REAL (dp)             :: fn_val

! Local variables

REAL (dp), PARAMETER :: c = .564189583547756_dp, one = 1.0_dp, half = 0.5_dp, &
                        zero = 0.0_dp
REAL (dp), PARAMETER ::  &
           a(5) = (/ .771058495001320D-04, -.133733772997339D-02, &
                     .323076579225834D-01,  .479137145607681D-01, &
                     .128379167095513D+00 /),  &
           b(3) = (/ .301048631703895D-02,  .538971687740286D-01,  &
                     .375795757275549D+00 /),  &
           p(8) = (/ -1.36864857382717D-07, 5.64195517478974D-01,  &
                      7.21175825088309D+00, 4.31622272220567D+01,  &
                      1.52989285046940D+02, 3.39320816734344D+02,  &
                      4.51918953711873D+02, 3.00459261020162D+02 /), &
           q(8) = (/  1.00000000000000D+00, 1.27827273196294D+01,  &
                      7.70001529352295D+01, 2.77585444743988D+02,  &
                      6.38980264465631D+02, 9.31354094850610D+02,  &
                      7.90950925327898D+02, 3.00459260956983D+02 /), &
           r(5) = (/  2.10144126479064D+00, 2.62370141675169D+01,  &
                      2.13688200555087D+01, 4.65807828718470D+00,  &
                      2.82094791773523D-01 /),  &
           s(4) = (/  9.41537750555460D+01, 1.87114811799590D+02,  &
                      9.90191814623914D+01, 1.80124575948747D+01 /)
REAL (dp) :: ax, bot, t, top, x2
!-------------------------
ax = ABS(x)

IF (ax <= half) THEN
  t = x*x
  top = ((((a(1)*t + a(2))*t + a(3))*t + a(4))*t + a(5)) + one
  bot = ((b(1)*t + b(2))*t + b(3))*t + one
  fn_val = x*(top/bot)
  RETURN
END IF

IF (ax <= 4.0_dp) THEN
  top = ((((((p(1)*ax + p(2))*ax + p(3))*ax + p(4))*ax + p(5))*ax  &
        + p(6))*ax + p(7))*ax + p(8)
  bot = ((((((q(1)*ax + q(2))*ax + q(3))*ax + q(4))*ax + q(5))*ax  &
        + q(6))*ax + q(7))*ax + q(8)
  fn_val = half + (half - EXP(-x*x)*top/bot)
  IF (x < zero) fn_val = -fn_val
  RETURN
END IF

IF (ax < 5.8_dp) THEN
  x2 = x*x
  t = one / x2
  top = (((r(1)*t + r(2))*t + r(3))*t + r(4))*t + r(5)
  bot = (((s(1)*t + s(2))*t + s(3))*t + s(4))*t + one
  fn_val = (c - top/(x2*bot)) / ax
  fn_val = half + (half - EXP(-x2)*fn_val)
  IF (x < zero) fn_val = -fn_val
  RETURN
END IF

fn_val = SIGN(one, x)
RETURN
END FUNCTION erf


 SUBROUTINE shape4 (nnode, shape, deriv ,xita, eta, zeta )
 !********************************************************************
 !
 !***  calculates shape functions and their derivatives for 3d
 !     prismatic elements
 !
 !********************************************************************
 IMPLICIT NONE

 INTEGER(Kind=4) :: nnode
 REAL (kind=8)    deriv(nnode,3),shape(nnode),xita,eta,zeta

 REAL (kind=8) l1,l2,zzet,bf

   l1 = (1d0-zeta)/2d0  !linear functions L1
   l2 = (1d0+zeta)/2d0  !                 L2
   zzet = 1d0-xita-eta  !third area coordinate

   IF( nnode == 6 )THEN
     !*** shape functions

     shape(1) = zzet * l1
     shape(2) = xita * l1
     shape(3) = eta  * l1
     shape(4) = zzet * l2
     shape(5) = xita * l2
     shape(6) = eta  * l2

     !*** and derivatives

     deriv(1,1) = -l1
     deriv(2,1) =  l1
     deriv(3,1) =  0d0
     deriv(4,1) = -l2
     deriv(5,1) =  l2
     deriv(6,1) =  0d0

     deriv(1,2) = -l1
     deriv(2,2) =  0d0
     deriv(3,2) =  l1
     deriv(4,2) = -l2
     deriv(5,2) =  0d0
     deriv(6,2) =  l2

     deriv(1,3) = -zzet/2d0
     deriv(2,3) = -xita/2d0
     deriv(3,3) = -eta /2d0
     deriv(4,3) =  zzet/2d0
     deriv(5,3) =  xita/2d0
     deriv(6,3) =  eta /2d0

   ELSE IF( nnode == 15 )THEN
     bf = 1d0 - zeta**2                      !bubble function
     shape(1) = zzet*(2d0*zzet-1d0)*l1 - zzet*bf/2d0
     shape(2) = xita*(2d0*xita-1d0)*l1 - xita*bf/2d0
     shape(3) = eta *(2d0*eta -1d0)*l1 - eta *bf/2d0
     shape(4) = zzet*(2d0*zzet-1d0)*l2 - zzet*bf/2d0
     shape(5) = xita*(2d0*xita-1d0)*l2 - xita*bf/2d0
     shape(6) = eta *(2d0*eta -1d0)*l2 - eta *bf/2d0
     shape(7) = 4d0*zzet*xita*l1
     shape(8) = 4d0*xita*eta *l1
     shape(9) = 4d0*eta *zzet*l1
     shape(10) = zzet*bf
     shape(11) = xita*bf
     shape(12) = eta *bf
     shape(13) = 4d0*zzet*xita*l2
     shape(14) = 4d0*xita*eta *l2
     shape(15) = 4d0*eta *zzet*l2

     deriv(1,1) = (-4d0*zzet+1d0)*l1 + bf/2d0
     deriv(2,1) =  (4d0*xita-1d0)*l1 - bf/2d0
     deriv(3,1) =  0d0
     deriv(4,1) = (-4d0*zzet+1d0)*l2 + bf/2d0
     deriv(5,1) =  (4d0*xita-1d0)*l2 - bf/2d0
     deriv(6,1) =  0d0
     deriv(7,1) =  4d0*(zzet-xita)*l1
     deriv(8,1) =  4d0*eta *       l1
     deriv(9,1) = -4d0*eta *       l1
     deriv(10,1) = -bf
     deriv(11,1) =  bf
     deriv(12,1) =  0d0
     deriv(13,1) =  4d0*(zzet-xita)*l2
     deriv(14,1) =  4d0*eta *       l2
     deriv(15,1) = -4d0*eta *       l2

     deriv(1,2) = (-4d0*zzet+1d0)*l1 + bf/2d0
     deriv(2,2) =  0d0
     deriv(3,2) =  (4d0*eta -1d0)*l1 - bf/2d0
     deriv(4,2) = (-4d0*zzet+1d0)*l2 + bf/2d0
     deriv(5,2) =  0d0
     deriv(6,2) =  (4d0*eta -1d0)*l2 - bf/2d0
     deriv(7,2) = -4d0*xita*       l1
     deriv(8,2) =  4d0*xita*       l1
     deriv(9,2) =  4d0*(-eta+zzet)*l1
     deriv(10,2) = -bf
     deriv(11,2) =  0d0
     deriv(12,2) =  bf
     deriv(13,2) = -4d0*xita*      l2
     deriv(14,2) =  4d0*xita*      l2
     deriv(15,2) = 4d0*(-eta+zzet)*l2

     deriv(1,3) = -zzet*(2d0*zzet-1d0)/2d0 + zzet*zeta
     deriv(2,3) = -xita*(2d0*xita-1d0)/2d0 + xita*zeta
     deriv(3,3) = -eta *(2d0*eta -1d0)/2d0 + eta *zeta
     deriv(4,3) =  zzet*(2d0*zzet-1d0)/2d0 + zzet*zeta
     deriv(5,3) =  xita*(2d0*xita-1d0)/2d0 + xita*zeta
     deriv(6,3) =  eta *(2d0*eta -1d0)/2d0 + eta *zeta
     deriv(7,3) = -2d0*zzet*xita
     deriv(8,3) = -2d0*xita*eta
     deriv(9,3) = -2d0*eta *zzet
     deriv(10,3) = -zzet*2d0*zeta
     deriv(11,3) = -xita*2d0*zeta
     deriv(12,3) = -eta *2d0*zeta
     deriv(13,3) = 2d0*zzet*xita
     deriv(14,3) = 2d0*xita*eta
     deriv(15,3) = 2d0*eta *zzet
   END IF

 RETURN
 END SUBROUTINE shape4


module fwdmodel
use comm,only: J,wp,c_int,pi,c
implicit none

private
public:: chirp, chirp_phase
contains

pure subroutine chirp(bm,tm,t,Ns,range_m,Atarg,Ntarg,nlfm,y)

integer(c_int), intent(in) :: Ns,Ntarg
real(wp), intent(in) ::  bm,tm,t(Ns),range_m(Ntarg),Atarg(Ntarg),nlfm
complex(wp),intent(out) :: y(Ns)

complex(wp) :: LO(Ns)
real(wp) ::  phase(Ns), toffs(Ntarg)
integer :: i

toffs = 2*range_m/c !two-way delay

call chirp_phase(bm,tm,t,Ns,nlfm,phase)
! radar transmit
LO = exp(J*phase)
! generate target returns
y = 0.
do concurrent (i=1:Ntarg)
  call chirp_phase(bm,tm,t+toffs(i),Ns,nlfm,phase)
  y = y + Atarg(i) * exp(J*phase) * conjg(LO)
enddo

end subroutine chirp

pure subroutine chirp_phase(bm,tm,t,Ns,nlfm,phase)

integer(c_int), intent(in) :: Ns
real(wp), intent(in) :: bm,tm,nlfm,t(Ns)
real(wp), intent(out):: phase(Ns)

real(wp) :: B1, B2

B1 = bm / tm
B2 = bm / tm**2

phase = 2._wp*pi*(-0.5_wp*bm*t   &       !starting freq
         + 0.5_wp*B1*t**2      & !linear ramp ("derivative of phase is frequency")
         + 0.5_wp*nlfm*B2*t**3)  !quadratic frequency

end subroutine chirp_phase

end module fwdmodel


    Program zupmtr_example

!     ZUPMTR Example Program Text

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

!     .. Use Statements ..
      Use blas_interfaces, Only: dznrm2
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen_comp
      Use lapack_interfaces, Only: dstebz, zhptrd, zstein, zupmtr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0E0_dp
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Complex (Kind=dp) :: scal
      Real (Kind=dp) :: vl, vu
      Integer :: i, ifail, info, j, k, ldc, m, n, nsplit
      Character (1) :: uplo
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: ap(:), c(:, :), tau(:), work(:)
      Real (Kind=dp), Allocatable :: d(:), e(:), rwork(:), w(:)
      Integer, Allocatable :: iblock(:), ifailv(:), isplit(:), iwork(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, conjg, maxloc
!     .. Executable Statements ..
      Write (nout, *) 'ZUPMTR Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldc = n
      Allocate (ap(n*(n+1)/2), c(ldc,n), tau(n), work(n), d(n), e(n), rwork(5* &
        n), w(n), iblock(n), ifailv(n), isplit(n), iwork(3*n))

!     Read A from data file

      Read (nin, *) uplo
      If (uplo=='U') Then
        Read (nin, *)((ap(i+j*(j-1)/2),j=i,n), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)((ap(i+(2*n-j)*(j-1)/2),j=1,i), i=1, n)
      End If

!     Reduce A to tridiagonal form T = (Q**H)*A*Q
      Call zhptrd(uplo, n, ap, d, e, tau, info)

!     Calculate the two smallest eigenvalues of T (same as A)

      Call dstebz('I', 'B', n, vl, vu, 1, 2, zero, d, e, m, nsplit, w, iblock, &
        isplit, rwork, iwork, info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'Failure to converge.'
      Else
        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) w(1:m)

!       Calculate the eigenvectors of T, storing the result in C
        Call zstein(n, d, e, m, w, iblock, isplit, c, ldc, rwork, iwork, &
          ifailv, info)

        If (info>0) Then
          Write (nout, *) 'Failure to converge.'
        Else

!         Calculate the eigenvectors of A = Q * (eigenvectors of T)
          Call zupmtr('Left', uplo, 'No transpose', n, m, ap, tau, c, ldc, &
            work, info)

!         Print eigenvectors

          Write (nout, *)
          Flush (nout)

!         Normalize the eigenvectors, largest element real
          Do i = 1, m
            rwork(1:n) = abs(c(1:n,i))
            k = maxloc(rwork(1:n), 1)
            scal = conjg(c(k,i))/abs(c(k,i))/dznrm2(n, c(1,i), 1)
            c(1:n, i) = c(1:n, i)*scal
          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_comp('General', ' ', n, m, &
            c, ldc, 'Bracketed', 'F7.4', 'Eigenvectors', 'Integer', rlabs, &
            'Integer', clabs, 80, 0, ifail)

        End If
      End If

100   Format (8X, 4(F7.4,11X,:))
    End Program


module system_mod

use global_mod, only: V0,Rm,Amp,rcut
use bessel_mod, only: Bessk

implicit none

contains

!-----------------------------------------------------------------------

  function LogPsi(opt,Rm,rij)

    logical,save     :: FirstCall = .True.
    real (kind=8)    :: Rm
    real (kind=8)    :: rij,zij
    real (kind=8)    :: K0,K1
    real (kind=8)    :: dfdr,d2fdr2
    real (kind=8)    :: LogPsi
    integer (kind=4) :: opt

    real (kind=8),save :: Lmax,C1,C2,C3

    if (FirstCall) then

       Lmax = 2.d0*rcut

       C3 = 0.5d0*sqrt(4.d0*Rm)*(Lmax-Rm)**2/(Lmax*(Lmax-2.d0*Rm))*&
            & Bessk(1,sqrt(4.d0/Rm))/Bessk(0,sqrt(4.d0/Rm))
       C2 = exp(4.d0*C3/Lmax)
       C1 = C2*exp(-C3*(1.d0/Rm+1.d0/(Lmax-Rm)))/Bessk(0,sqrt(4.d0/Rm))

       FirstCall = .False.

    end if

    zij = sqrt(4.d0/rij)

    K0 = Bessk(0,zij)
    K1 = Bessk(1,zij)

    if (opt==0) then

       if (rij<=Rm) then

          LogPsi = log(C1*K0)

       else

          LogPsi = log(C2)-C3*(1.d0/rij+1.d0/(Lmax-rij))

       end if

    else if (opt==1) then

       if (rij<=Rm) then

          dfdr   = zij*K1/(2.d0*rij)
          LogPsi = dfdr/K0

       else

          LogPsi = C3*(1.d0/rij**2-1.d0/(Lmax-rij)**2)

       end if

    else if (opt==2) then

       if (rij<=Rm) then

          dfdr   = zij*K1/(2.d0*rij)
          d2fdr2 = K0/rij**3-dfdr/rij
          LogPsi = (d2fdr2*K0-dfdr*dfdr)/(K0*K0)

       else

          LogPsi = -2.d0*C3*(1.d0/rij**3+1.d0/(Lmax-rij)**3)

       end if

    else

       print *, 'The parameter opt in the function LogPsi crash!!!'
       stop

    end if

    return
  end function LogPsi

!-----------------------------------------------------------------------

  function Potential(rij)

    implicit none

    real (kind=8) :: Potential,rij

    Potential = V0/rij**3

  end function Potential

!-----------------------------------------------------------------------

end module system_mod


************************************************************************
*
*     Subroutine LOAD95CI                           Called by: AMLLOAD2
*
*     compute 95% confidence intervals
*
************************************************************************
      SUBROUTINE LOAD95CI(LOADAML,SEP,LOW95,UP95)
*
*     subroutine args
*
      DOUBLE PRECISION LOADAML,SEP,LOW95,UP95
*
*     local vars
*
      DOUBLE PRECISION A,B
*
*     compute 95% confidence intervals
*
      B = SQRT(LOG(1+(SEP/LOADAML)**2))
      A = LOG(LOADAML)-B**2/2.D0
      LOW95 = EXP(A-1.96*B)
      UP95 = EXP(A+1.96*B)

      RETURN
      END


module stats_mod
    implicit none

    private

    type, public :: stats_t
        real :: sum, sum2
        integer :: n
    end type stats_t

    public :: init_stats, add_stats_value, mean_stats

contains

    subroutine init_stats(stats)
        implicit none
        type(stats_t), intent(out) :: stats

        stats = stats_t(0.0, 0.0, 0)
    end subroutine init_stats

    subroutine add_stats_value(stats, value)
        implicit none
        type(stats_t), intent(inout) :: stats
        real, value :: value

        stats%sum = stats%sum + value
        stats%sum2 = stats%sum2 + value**2
        stats%n = stats%n + 1
    end subroutine add_stats_value

    function mean_stats(stats) result(mean_value)
        type(stats_t), intent(in) :: stats
        real :: mean_value

        call validate(stats)
        associate (sum => stats%sum, n => stats%n)
            mean_value = sum/n
        end associate
    end function mean_stats

    subroutine validate(stats, need_stddev)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        type(stats_t), intent(in) :: stats
        logical, optional, value :: need_stddev

        if (stats%n < 1) then
            write (unit=error_unit, fmt='(A)') 'error: not enough data'
            stop 1
        else if (present(need_stddev)) then
            if (need_stddev .and. stats%n < 2) then
                write (unit=error_unit, fmt='(A)') 'error: not enough data'
                stop 1
            end if
        end if
    end subroutine validate

end module stats_mod


program nans
! Compiler options like -Ofast and -ffast-math break this program.
! NaN are not IEEE compliant if using such options.
!
! Gfortran >= 6 needed for ieee_arithmetic: ieee_is_nan

!> Examples

!> Gfortran 10.2.0 Windows
!       IEEE   value   isnan                         hex
!     real 32    NaN      T                          FFC00000
!     real 64    NaN      T                  FFF8000000000000
!     real128    NaN      T  FFFF8000000000000000000000000000
!  complex 64    NaN      T                          FFC00000
!  complex128    NaN      T                  FFF8000000000000
!  complex256    NaN      T  FFFF8000000000000000000000000000

!> Ifort 2021.1 Winodws and Ifx 2021.1 Windows
!       IEEE   value   isnan                         hex
!     real 32    NaN      T                          7FC00000
!     real 64    NaN      T                  7FF8000000000000
!     real128    NaN      T  7FFF8000000000000000000000000000
!  complex 64    NaN      T                          7FC00000
!  complex128    NaN      T                  7FF8000000000000
!  complex256    NaN      T  7FFF8000000000000000000000000000

use, intrinsic :: iso_fortran_env, only: real32, real64, real128
use, intrinsic :: iso_fortran_env, only: int32, int64
use, intrinsic :: ieee_arithmetic, only: ieee_value, ieee_quiet_nan, ieee_is_nan
implicit none (type, external)

real(real32) :: nan_real32
real(real64) :: nan_real64
real(real128) :: nan_real128
complex(real32) :: nan_complex64
complex(real64) :: nan_complex128
complex(real128) :: nan_complex256

integer(int32) :: ISP
integer(int64) :: IDP
character(*), parameter :: fmt='(A8,I3,2X,F5.1,6X,L1,2X,Z32)'

! this is the cross platform way to get NaN on modern compilers including gfortran and ifort.
nan_real32 = ieee_value(0.,ieee_quiet_nan)
nan_real64 = ieee_value(0.,ieee_quiet_nan)
nan_real128 = ieee_value(0.,ieee_quiet_nan)
nan_complex64 = ieee_value(0., ieee_quiet_nan)
nan_complex128 = ieee_value(0.,ieee_quiet_nan)
nan_complex256 = ieee_value(0.,ieee_quiet_nan)

! --------- print results

ISP = transfer(nan_real32, ISP)
IDP = transfer(nan_real64, IDP)

print '(A10,A8,A8,A28)','IEEE', 'value', 'isnan', 'hex'
print fmt,'real',storage_size(nan_real32), nan_real32, ieee_is_nan(nan_real32), ISP
print fmt,'real',storage_size(nan_real64), nan_real64, ieee_is_nan(nan_real64), IDP
print fmt,'real',storage_size(nan_real128),nan_real128, ieee_is_nan(nan_real128), nan_real128

print fmt,'complex',storage_size(nan_complex64),real(nan_complex64),ieee_is_nan(real(nan_complex64)),nan_complex64
print fmt,'complex',storage_size(nan_complex128),real(nan_complex128),ieee_is_nan(real(nan_complex128)),nan_complex128
print fmt,'complex',storage_size(nan_complex256),real(nan_complex256),ieee_is_nan(real(nan_complex256)),nan_complex256

end program


program verify_bounds
    implicit none
    integer, parameter :: NR_CASES = 10000
    integer :: i, start_val, end_val, step

    do i = 1, NR_CASES
        call generate_bounds(start_val, end_val, step)
        call test_do_loop(start_val, end_val, step)
    end do

contains

    subroutine test_do_loop(start_val, end_val, step)
        implicit none
        integer, value :: start_val, end_val, step
        integer :: i, expected_i, last_val, expected_last_val, &
                   nr_iters, expected_nr_iters

        nr_iters = 0
        last_val = start_val
        do i = start_val, end_val, step
            nr_iters = nr_iters + 1
            last_val = i
        end do
        expected_nr_iters = (end_val - start_val + step)/step
        if (nr_iters /= expected_nr_iters) then
            print '(5(A, I0))', 'start = ', start_val, &
                                ', end = ', end_val, &
                                ' step = ', step, &
                                ', expected nr. iters = ', expected_nr_iters, &
                                ', nr. iters = ', nr_iters
        end if
        if (nr_iters /= 0) then
            expected_last_val = start_val + (nr_iters - 1)*step
            if (last_val /= expected_last_val) then
                print '(5(A, I0))', 'start = ', start_val, &
                                    ', end = ', end_val, &
                                    ' step = ', step, &
                                    ', expected last = ', expected_last_val, &
                                    ', last = ', last_val
            end if
        end if
        expected_i = start_val + expected_nr_iters*step
        if (i /= expected_i) then
            print '(5(A, I0))', 'start = ', start_val, &
                                ', end = ', end_val, &
                                ' step = ', step, &
                                ', expected i = ', expected_i, &
                                ', i = ', i
        end if
    end subroutine test_do_loop

    subroutine generate_bounds(start_val, end_val, step)
        implicit none
        integer, intent(out) :: start_val, end_val, step

        step = 0
        do while (step == 0)
            step = random_int(-100, 100)
        end do
        if (step >= 0) then
            do while (.true.)
                start_val = random_int(-100, 100)
                end_val = random_int(-100, 100)
                if (start_val <= end_val) exit
            end do
        else
            do while (.true.)
                start_val = random_int(-100, 100)
                end_val = random_int(-100, 100)
                if (start_val >= end_val) exit
            end do
        end if
    end subroutine generate_bounds

    function random_int(from_val, to_val) result(r_int)
        implicit none
        integer ,value :: from_val, to_val
        integer ::  r_int
        real :: r

        call random_number(r)
        r_int = int(from_val + r*(to_val - from_val))
    end function random_int

end program verify_bounds


!> @ingroup insertion_sort_asc
!>
!> @brief
!> Run an insertion sort on a vector of integer values.
!>
!> @details
!> Run an ascending on a vector of integer values to sort them in the specified order.The vector of intergers map is permuted in the same way that the vector vec is permuted to be sorted. It is important that map be at least as long as vec.
!>
!> @param vec
!> The vector integer values to be sorted.
!>
!> @param map
!> Vector of intergers which is permuted in the same way that vec is permuted. If map is a vector of values 1 to N, where N is the length of vec, than, map is the map from vec's original value to vec's final value after the sort.
!>
!> @warning
!> The length of map is not checked within this subroutine. If the length of vec is larger than the length of map, than this subroutine may attempt to access elements outside of map.
!>
!> @author Arin R. Bratt
!> @date 11/07/2014
pure subroutine insertion_sort_asc_map_int(vec,map)
  ! Arguments
  integer, intent(inout) :: vec(:)
  integer, intent(inout) :: map(:)

  ! Variables
  integer :: integer_value
  integer :: swap_value
  integer :: i
  integer :: j

  ! Sort to the first element
  if (vec(size(vec,1)) > vec(1)) then
     integer_value = vec(1)
  else
     integer_value = vec(size(vec,1))
     vec(size(vec,1)) = vec(1)
  end if

  do i = size(vec,1) - 1,2,-1
     if (integer_value > vec(i)) then
        ! Swap integer values integer_value and vec(i).
        swap_value = integer_value
        integer_value = vec(i)
        vec(i) = swap_value
     end if
  end do

  ! Run regualr insertion sort
  do j = 3,size(vec,1)
     swap_value = vec(j)
     i = j - 1
     if (vec(i) > swap_value) then
        vec(j) = vec(i)
        i = i - 1
        do
           if (.not. vec(i) > swap_value) exit
           vec(i + 1) = vec(i)
           i = i - 1
        end do
        vec(i + 1) = swap_value
     end if
  end do
end subroutine insertion_sort_asc_map_int


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE PLANE_COORD_TRANS_21 ( THETA, T21, CALLING_SUBR )

! Creates a coordinate transformation matrix for a plane rotation of a vector in coordinate system 1, through an angle THETA, to
! a vector in coordinate system 2

!                             | U2 |   |  cos(THETA)  sin(THETA)  0 | | U1 |
!                             | V2 | = | -sin(THETA)  cos(THETA)  0 | | V1 |
!                             | W2 |   |      0           0       1 | | W1 |

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  F04, WRT_LOG
      USE SCONTR, ONLY                :  BLNK_SUB_NAM
      USE TIMDAT, ONLY                :  TSEC
      USE CONSTANTS_1, ONLY           :  ONE, ZERO
      USE SUBR_BEGEND_LEVELS, ONLY    :  PLANE_COORD_TRANS_21_BEGEND

      USE PLANE_COORD_TRANS_21_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'PLANE_COORD_TRANS_21'
      CHARACTER(LEN=*), INTENT(IN)    :: CALLING_SUBR      ! Subr that called this one

      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = PLANE_COORD_TRANS_21_BEGEND

      REAL(DOUBLE), INTENT(IN)        :: THETA             ! Angle from x axis of system 1 to x axis of system 2
      REAL(DOUBLE), INTENT(OUT)       :: T21(3,3)          ! Transformation matrix which will transform a vector, U1, in coord sys
!                                                            1 to a vector, U2, in coord sys 2 (i.e. U2 = T21*U1)

      INTRINSIC                       :: DSIN, DCOS

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! Row 1

      T21(1,1) =  DCOS( THETA )
      T21(1,2) =  DSIN( THETA )
      T21(1,3) =  ZERO

! Row 2

      T21(2,1) = -T21(1,2)
      T21(2,2) =  T21(1,1)
      T21(2,3) =  ZERO

! Row 3

      T21(3,1) =  ZERO
      T21(3,2) =  ZERO
      T21(3,3) =  ONE

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

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

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

      END SUBROUTINE PLANE_COORD_TRANS_21


      SUBROUTINE DRANGV(A, NDIM, N, U, X, HAVEC, IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 DRANGV  Krogh   Added external statement.
C>> 1994-11-11 DRANGV Krogh   Declared all vars.
C>> 1994-10-20 DRANGV Krogh  Changes to use M77CON
C>> 1987-04-22 DRANGV Lawson  Initial code.
c--D replaces "?": ?RANGV, ?RANG
c
c     DRANGV generates an N-component random vector, X, from a multi-
c     variate normal distribution having a specified mean vector, U,
c     and covariance matrix, A.
c     ------------------------------------------------------------------
c                        Subroutine arguments
c
c     A(,)  [inout]  Array with first dimension NDIM, and second
c           dimension at least N.  When HAVEC is false, A(,) contains
c           the given N x N symmetric covariance matrix.  This
c           subroutine will replace A by its lower-triangular Cholesky
c           factor, C, and set HAVEC = .true.
c           When HAVEC is true A(,) is assumed to contain the Cholesky
c           factor, C.
c           Note:  Only the lower triangle of the array A(,) is used by
c           this subroutine.
c
c     NDIM  [in]  First dimension of the array A(,).
c           Require NDIM .ge. N.
c
c     N  [in]  Order of the covariance matrix A and dimension of the
c           vectors U and X.
c
c     U()  [in]   Contains the N-dimensional mean vector.
c
c     X()  [out]  On return will contain the N-dimensional generated
c                 random vector.
c
c     HAVEC    [inout]  See description above for A(,).
c
c     IERR  [out]    IERR is only referenced when this subr is entered
c           with HAVEC = false.
c           In that case IERR will be set to zero if the
c           Cholesky factorization is successful.  If the factorization
c           is unsuccessful IERR will be set to the index of the row at
c           which failure is detected.  In this latter case the results
c           returned in A(,) and X() will not be valid.
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c     Subprogram referenced: DRANG
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c     Programmed for JPL by Carl Pitts, Heliodyne Corp., April, 1969.
c     Adapted to Fortran 77 for the JPL MATH 77 library by C. L. Lawson
c     and S. Y. Chiu, JPL, April 1987.
c     ------------------------------------------------------------------
      external DRANG
      integer IERR, NDIM, N, J, K, L
      double precision A(NDIM,N), U(N), X(N), SUM, ZERO
      double precision DRANG
      logical HAVEC
      parameter(ZERO = 0.0D0)
c     ------------------------------------------------------------------
      if(.not. HAVEC) then
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c     BEGIN PROCEDURE TO CALCULATE C-MATRIX, NOTE THE C-MATRIX
c     overwrites the lower triangle of the A matrix.
c
      DO 40 J=1,N
         DO 30 K=1,J
            SUM = ZERO
            DO 20 L=1,K-1
               SUM=SUM+A(J,L)*A(K,L)
   20       CONTINUE
            if(J .ne. K) then
               A(J,K)=(A(J,K)-SUM)/A(K,K)
            else
               SUM=A(K,K)-SUM
               if(SUM .le. ZERO) then
                  IERR = K
c                                                Error return.
                  RETURN
               endif
               A(K,K)=SQRT(SUM)
            endif
   30    continue
   40 continue
      HAVEC=.TRUE.
      IERR = 0
      endif
c                            END PROCEDURE TO CALCULATE C-MATRIX
c     ------------------------------------------------------------------
c                            BEGIN PROCEDURE TO CALCULATE RANDOM VECTOR
c
c     LOOP TO FILL Y-VECTOR WITH NORMALLY DISTRIBUTED RANDOM NUMBERS
c     WITH ZERO MEAN AND UNIT VARIANCE  NOTE THE Y-VECTOR IS STORED
c     TEMPORARILY IN THE X-VECTOR
c
      DO 70 J=1,N
         X(J)= DRANG()
   70 CONTINUE
c
c     LOOP TO CALCULATE X-VECTOR
c
      DO 90 J=N,1,-1
         SUM=U(J)
         DO 80 K=1,J
            SUM=SUM+A(J,K)*X(K)
   80    CONTINUE
         X(J)=SUM
   90 CONTINUE
      return
      end


! Taken from getstarlist.f90 in ramses/utils/f90
subroutine friedmann(O_mat_0,O_vac_0,O_k_0,alpha,axp_min, &
     & axp_out,hexp_out,tau_out,t_out,ntable,age_tot)

  implicit none
  integer::ntable
  real(kind=8)::O_mat_0, O_vac_0, O_k_0
  real(kind=8)::alpha,axp_min!,age_tot
  real(kind=8),intent(out)::age_tot
  real(kind=8),dimension(0:ntable),intent(out)::axp_out,hexp_out,tau_out,t_out
  ! ######################################################!
  ! This subroutine assumes that axp = 1 at z = 0 (today) !
  ! and that t and tau = 0 at z = 0 (today).              !
  ! axp is the expansion factor, hexp the Hubble constant !
  ! defined as hexp=1/axp*daxp/dtau, tau the conformal    !
  ! time, and t the look-back time, both in unit of 1/H0. !
  ! alpha is the required accuracy and axp_min is the     !
  ! starting expansion factor of the look-up table.       !
  ! ntable is the required size of the look-up table.     !
  ! ######################################################!
  real(kind=8)::axp_tau, axp_t
  real(kind=8)::axp_tau_pre, axp_t_pre
  real(kind=8)::dadtau, dadt
  real(kind=8)::dtau,dt
  real(kind=8)::tau,t
  integer::nstep,nout,nskip

!!$  if( (O_mat_0+O_vac_0+O_k_0) .ne. 1.0D0 )then
!!$     write(*,*)'Error: non-physical cosmological constants'
!!$     write(*,*)'O_mat_0,O_vac_0,O_k_0=',O_mat_0,O_vac_0,O_k_0
!!$     write(*,*)'The sum must be equal to 1.0, but '
!!$     write(*,*)'O_mat_0+O_vac_0+O_k_0=',O_mat_0+O_vac_0+O_k_0
!!$     stop
!!$  end if

  axp_tau = 1.0D0
  axp_t = 1.0D0
  tau = 0.0D0
  t = 0.0D0
  nstep = 0

  ! Uncomment below for debugging
  !print*, 'Cosmology: ', O_mat_0, O_vac_0, O_k_0
  !print*, 'Params: ', alpha,axp_min

  do while ( (axp_tau .ge. axp_min) .or. (axp_t .ge. axp_min) )

     nstep = nstep + 1
     dtau = alpha * axp_tau / dadtau(axp_tau,O_mat_0,O_vac_0,O_k_0)
     axp_tau_pre = axp_tau - dadtau(axp_tau,O_mat_0,O_vac_0,O_k_0)*dtau/2.d0
     axp_tau = axp_tau - dadtau(axp_tau_pre,O_mat_0,O_vac_0,O_k_0)*dtau
     tau = tau - dtau

     dt = alpha * axp_t / dadt(axp_t,O_mat_0,O_vac_0,O_k_0)
     axp_t_pre = axp_t - dadt(axp_t,O_mat_0,O_vac_0,O_k_0)*dt/2.d0
     axp_t = axp_t - dadt(axp_t_pre,O_mat_0,O_vac_0,O_k_0)*dt
     t = t - dt

  end do

  age_tot=-t
  !write(*,666)-t
  666 format(' Age of the Universe (in unit of 1/H0)=',1pe10.3)

  nskip=nstep/ntable

  axp_t = 1.d0
  t = 0.d0
  axp_tau = 1.d0
  tau = 0.d0
  nstep = 0
  nout=0
  t_out(nout)=t
  tau_out(nout)=tau
  axp_out(nout)=axp_tau
  hexp_out(nout)=dadtau(axp_tau,O_mat_0,O_vac_0,O_k_0)/axp_tau

  do while ( (axp_tau .ge. axp_min) .or. (axp_t .ge. axp_min) )

     nstep = nstep + 1
     dtau = alpha * axp_tau / dadtau(axp_tau,O_mat_0,O_vac_0,O_k_0)
     axp_tau_pre = axp_tau - dadtau(axp_tau,O_mat_0,O_vac_0,O_k_0)*dtau/2.d0
     axp_tau = axp_tau - dadtau(axp_tau_pre,O_mat_0,O_vac_0,O_k_0)*dtau
     tau = tau - dtau

     dt = alpha * axp_t / dadt(axp_t,O_mat_0,O_vac_0,O_k_0)
     axp_t_pre = axp_t - dadt(axp_t,O_mat_0,O_vac_0,O_k_0)*dt/2.d0
     axp_t = axp_t - dadt(axp_t_pre,O_mat_0,O_vac_0,O_k_0)*dt
     t = t - dt

     if(mod(nstep,nskip)==0)then
        nout=nout+1
        t_out(nout)=t
        tau_out(nout)=tau
        axp_out(nout)=axp_tau
        hexp_out(nout)=dadtau(axp_tau,O_mat_0,O_vac_0,O_k_0)/axp_tau
     end if

  end do
  t_out(ntable)=t
  tau_out(ntable)=tau
  axp_out(ntable)=axp_tau
  hexp_out(ntable)=dadtau(axp_tau,O_mat_0,O_vac_0,O_k_0)/axp_tau

end subroutine friedmann

function dadtau(axp_tau,O_mat_0,O_vac_0,O_k_0)
  real(kind=8)::dadtau,axp_tau,O_mat_0,O_vac_0,O_k_0
  dadtau = axp_tau*axp_tau*axp_tau *  &
       &   ( O_mat_0 + &
       &     O_vac_0 * axp_tau*axp_tau*axp_tau + &
       &     O_k_0   * axp_tau )
  dadtau = sqrt(dadtau)
  return
end function dadtau

function dadt(axp_t,O_mat_0,O_vac_0,O_k_0)
  real(kind=8)::dadt,axp_t,O_mat_0,O_vac_0,O_k_0
  dadt   = (1.0D0/axp_t)* &
       &   ( O_mat_0 + &
       &     O_vac_0 * axp_t*axp_t*axp_t + &
       &     O_k_0   * axp_t )
  dadt = sqrt(dadt)
  return
end function dadt


program fizzbuzz
! print *, 'Hello, World!'
do i = 1 , 1000
  if (mod(i, 15) == 0) then
    print '(A)', 'FizzBuzz'
  elseif (mod(i, 3) == 0) then
    print '(A)', 'Fizz'
  elseif (mod(i, 5) == 0) then
    print '(A)', 'Buzz'
  else
    print '(I0)', i;
  end if
end do
end program fizzbuzz


program weather_stats_parallel

  use mod_arrays, only: denan, mean
  use mod_io, only: read_buoy
  use mod_parallel, only: tile_indices

  implicit none

  character(len=5), allocatable :: ids(:)
  character(len=20), allocatable :: time(:)
  real, allocatable :: wind_speed(:)
  real, allocatable :: max_wind(:), mean_wind(:)
  real, allocatable :: gather(:)[:]
  integer :: is, ie, indices(2)
  integer :: i

  real :: min_mean_wind, max_mean_wind, max_max_wind

  ids = ['42001', '42002', '42003', '42020', '42035',&
    '42036', '42039', '42040', '42055']

  if (num_images() > size(ids)) error stop 'Error: Too many images'

  indices = tile_indices(size(ids))
  is = indices(1)
  ie = indices(2)

  allocate(max_wind(is:ie), mean_wind(is:ie))

  do i = is, ie
    call read_buoy('data/buoy_' // ids(i) //  '.csv', time, wind_speed)
    wind_speed = denan(wind_speed)
    max_wind(i) = maxval(wind_speed)
    mean_wind(i) = mean(wind_speed)
  end do

  allocate(gather(size(ids))[*])

  gather(is:ie)[1] = max_wind
  sync all
  if (this_image() == 1) then
    write(*,*) 'Maximum wind speed measured is ', maxval(gather),&
      'at station ', ids(maxloc(gather))
  end if

  gather(is:ie)[1] = mean_wind
  sync all
  if (this_image() == 1) then
    write(*,*) 'Highest mean wind speed is ', maxval(gather),&
      'at station ', ids(maxloc(gather))
    write(*,*) 'Lowest mean wind speed is ', minval(gather),&
      'at station ', ids(minloc(gather))
  end if

end program weather_stats_parallel


! Evaluate function of one variable X
DOUBLE PRECISION FUNCTION EVALFUNC1(X)
    IMPLICIT NONE
    !
    REAL(8) R1 /1.0D0/
    REAL(8) R2 /2.0D0/
    REAL(8) R3 /3.0D0/
    !
    REAL(8) :: X
    !
    EVALFUNC1=R1-R3*X+EXP(R2*X)
    RETURN
END FUNCTION


*DECK POLINT
      SUBROUTINE POLINT (N, X, Y, C)
C***BEGIN PROLOGUE  POLINT
C***PURPOSE  Produce the polynomial which interpolates a set of discrete
C            data points.
C***LIBRARY   SLATEC
C***CATEGORY  E1B
C***TYPE      SINGLE PRECISION (POLINT-S, DPLINT-D)
C***KEYWORDS  POLYNOMIAL INTERPOLATION
C***AUTHOR  Huddleston, R. E., (SNLL)
C***DESCRIPTION
C
C     Written by Robert E. Huddleston, Sandia Laboratories, Livermore
C
C     Abstract
C        Subroutine POLINT is designed to produce the polynomial which
C     interpolates the data  (X(I),Y(I)), I=1,...,N.  POLINT sets up
C     information in the array C which can be used by subroutine POLYVL
C     to evaluate the polynomial and its derivatives and by subroutine
C     POLCOF to produce the coefficients.
C
C     Formal Parameters
C     N  - the number of data points  (N .GE. 1)
C     X  - the array of abscissas (all of which must be distinct)
C     Y  - the array of ordinates
C     C  - an array of information used by subroutines
C     *******  Dimensioning Information  *******
C     Arrays X,Y, and C must be dimensioned at least N in the calling
C     program.
C
C***REFERENCES  L. F. Shampine, S. M. Davenport and R. E. Huddleston,
C                 Curve fitting by polynomials in one variable, Report
C                 SLA-74-0270, Sandia Laboratories, June 1974.
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   740601  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  POLINT
      DIMENSION X(*),Y(*),C(*)
C***FIRST EXECUTABLE STATEMENT  POLINT
      IF (N .LE. 0) GO TO 91
      C(1)=Y(1)
      IF(N .EQ. 1) RETURN
      DO 10010 K=2,N
      C(K)=Y(K)
      KM1=K-1
      DO 10010 I=1,KM1
C     CHECK FOR DISTINCT X VALUES
      DIF = X(I)-X(K)
      IF (DIF .EQ. 0.0) GO TO 92
      C(K) = (C(I)-C(K))/DIF
10010 CONTINUE
      RETURN
!   91 CALL XERMSG ('SLATEC', 'POLINT', 'N IS ZERO OR NEGATIVE.', 2, 1)
 91   RETURN
!   92 CALL XERMSG ('SLATEC', 'POLINT',
 !    +   'THE ABSCISSAS ARE NOT DISTINCT.', 2, 1)
 92   RETURN
      END


MODULE loss_during_routines

  implicit none

  private

  public tridag, GMRES, DDOTL, DAXPYL, ope

  contains

  SUBROUTINE tridag(a,b,c,r,u,n)
    IMPLICIT NONE
    integer, intent(in)  :: n
    real a(n),b(n),c(n),r(n),u(n)
    real :: gam(N)
    integer :: j
    real :: bet
!     if(b(1).eq.0.)pause 'tridag: rewrite equations'
      bet=b(1)
      u(1)=r(1)/bet
      do j=2,n
         gam(j)=c(j-1)/bet
         bet=b(j)-a(j)*gam(j)
         if(bet.eq.0.)pause 'tridag failed'
         u(j)=(r(j)-a(j)*u(j-1))/bet
      end do
      do j=n-1,1,-1
         u(j)=u(j)-gam(j+1)*u(j+1)
      end do
      return
    END SUBROUTINE tridag

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

      SUBROUTINE  GMRES (N, IM, RHS, SOL, SS, EPS, MAXITS, IOUT, &
           c1,c2,c3)

!C*************************************************************
!c
!c     This is gmrd.f (double precision), the original Saad version
!c     of GMRES, with trivial changes in output format.
!c
!C GMRES ALGORITHM . SIMPLE VERSION .  (MAY 23, 1985)
!C PARAMETER LIST:
!C N     == SIZE OF PROBLEM
!C IM    == SIZE OF KRYLOV SUBSPACE:  SHOULD NOT EXCEED 50 IN THIS
!C          VERSION (CAN BE RESET IN CODE. LOOKING AT COMMENT BELOW)
!C RHS   == RIGHT HAND SIDE
!C SOL   == INITIAL GUESS ON INPUT, APPROXIMATE SOLUTION ON OUTPUT
!C SS    == WORK SPACE OF SIZE N X (IM+1)
!C EPS   == TOLERANCE FOR STOPPING CRITERION. PROCESS IS STOPPED
!C          AS SOON AS ( ||.|| IS THE EUCLIDEAN NORM):
!C          || CURRENT RESIDUAL||/||INITIAL RESIDUAL|| <= EPS
!C          ON OUTPUT, EPS = ::FINAL RESIDUAL::/::INITIAL RESIDUAL::
!C MAXITS== MAXIMUM NUMBER OF ITERATIONS ALLOWED ON INPUT
!C          ON OUTPUT, MAXITS = TOTAL NUMBER OF ITERATIONS
!C IOUT  == OUTPUT UNIT NUMBER NUMBER FOR PRINTING INTERMEDIATE RESULTS
!C          IF (IOUT .LE. 0) NO STATISTICS ARE PRINTED.
!C ----------------------------------------------------------------
!C SUBROUTINES USED =
!C OPE(N,X,Y)  ==  MATRIX BY VECTOR MULTIPLICATION DELIVERS Y=AX, GIVEN X.
!C DDOTL       == DOT PRODUCT FUNCTION.  REPLACE BY BLAS ROUTINE DDOT
!C DAXPYL      == Y <-- Y+AX  ROUTINE. REPLACE BY BLAS ROUTINE DAXPY
!C*************************************************************
!c      IMPLICIT REAL*8 (A-H,O-Z)
      implicit none
      integer, intent (in) ::  n, im, maxits, iout
      real, intent(in) :: c1(n),c2(n),c3(n)
      integer i, j, k, k1, ii, i1, n1, its
      REAL SS(N,IM+1), RHS(N), SOL(N)
      real HH(51,50), C(50), S(50), RS(51)
      real eps, eps1, gam, mcheps, ro, t

!C-------------------------------------------------------------
!C ARNOLDI SIZE SHOULD NOT EXCEED 50 IN THIS VERSION..
!C TO RESET MODIFY SIZES OF HH, C, S, RS       ----------------
!C-------------------------------------------------------------
      mcheps = 1.d-30
      N1 = N + 1
      ITS = 0
!C-------------------------------------------------------------
!C **  OUTER LOOP STARTS HERE..
!C-------------- COMPUTE INITIAL RESIDUAL VECTOR --------------
 10     CONTINUE
       CALL ope (N, SOL, SS,c1,c2,c3)

        DO J=1,N
           SS(J,1) = RHS(J) - SS(J,1)
        ENDDO

!C-------------------------------------------------------------

         RO = SQRT( DDOTL(N, SS,SS) )
         IF (RO .EQ. 0.0D0) RETURN
         DO J=1, N
            SS(J,1) = SS(J,1)/RO
         ENDDO
         IF (ITS .EQ. 0) EPS1=EPS*RO

!C ** INITIALIZE 1-ST TERM  OF RHS OF HESSENBERG SYSTEM..
         RS(1) = RO
         I = 0
 4       I=I+1
         ITS = ITS + 1
         I1 = I + 1
         CALL ope (N, SS(1,I), SS(1,I1),c1,c2,c3)

!C-----------------------------------------
!C  MODIFIED GRAM - SCHMIDT...
!C-----------------------------------------
        DO J=1, I
           T = DDOTL(N, SS(1,J),SS(1,I1))
           HH(J,I) = T
           CALL DAXPYL(N, -T, SS(1,J), SS(1,I1))
        ENDDO
        T = SQRT(DDOTL(N, SS(1,I1), SS(1,I1)))
        HH(I1,I) = T
        DO K=1,N
           SS(K,I1) = SS(K,I1) / T
        ENDDO

!C--------DONE WITH MODIFIED GRAM SCHIMD AND ARNOLDI STEP..
!C NOW  UPDATE FACTORIZATION OF HH
!C---------------------------------------------------------
        IF (I .EQ. 1) GOTO 121
!C-------- PERFROM PREVIOUS TRANSFORMATIONS  ON I-TH COLUMN OF H
        DO K=2,I
           K1 = K-1
           T = HH(K1,I)
           HH(K1,I) = C(K1)*T + S(K1)*HH(K,I)
           HH(K,I) = -S(K1)*T + C(K1)*HH(K,I)
        ENDDO
 121    GAM = SQRT(HH(I,I)**2 + HH(I1,I)**2)
        IF (GAM .EQ. 0.0D0) GAM = MCHEPS
!C-----------#  DETERMINE NEXT PLANE ROTATION  #-------------------
        C(I) = HH(I,I)/GAM
        S(I) = HH(I1,I)/GAM
        RS(I1) = -S(I)*RS(I)
        RS(I) =  C(I)*RS(I)
!C---DETERMINE RESIDUAL NORM AND TEST FOR CONVERGENCE-
        HH(I,I) = C(I)*HH(I,I) + S(I)*HH(I1,I)
        RO = ABS(RS(I1))
!c        IF (IOUT .GT. 0)
!c     *          WRITE(IOUT, 199) ITS, RO
        IF ( (I .LT. IM) .AND. (RO .GT. EPS1) .and. &
            (its .lt. maxits) )  GOTO 4
!C
!C NOW COMPUTE SOLUTION. FIRST SOLVE UPPER TRIANGULAR SYSTEM.
!C
        RS(I) = RS(I)/HH(I,I)
        DO II=2,I
           K=I-II+1
           K1 = K+1
           T=RS(K)
           DO J=K1,I
              T = T-HH(K,J)*RS(J)
           ENDDO
           RS(K) = T/HH(K,K)
        ENDDO
!C DONE WITH BACK SUBSTITUTION..
!C NOW FORM LINEAR COMBINATION TO GET SOLUTION
        DO J=1, I
           T = RS(J)
           CALL DAXPYL(N, T, SS(1,J), SOL)
        ENDDO
!C RESTART OUTER LOOP  WHEN NECESSARY
        IF (RO .GT. EPS1 .AND. ITS .LT. MAXITS) GOTO 10
 199    format(1x, i5, 3x, 1pe12.4 )
      EPS = (RO / EPS1) * EPS
!crdk      MAXITS = ITS
!cjcm
!crdk      WRITE(IOUT, 199) ITS, RO
!cjcm
      RETURN
!C------------------------------- END OF GMRES ----------------------
    END SUBROUTINE GMRES

!C------------------------------- BEG OF DDOTL ----------------------
    FUNCTION DDOTL(N,RVA,RVB)
      IMPLICIT NONE
      INTEGER I,N
      REAL RVA(N),RVB(N),DDOTL
      DDOTL = 0.0
      DO I=1,N
         DDOTL=DDOTL+RVA(I)*RVB(I)
      ENDDO
      RETURN
    END FUNCTION DDOTL
!C------------------------------- END OF DDOTL ----------------------
!C------------------------------- BEG OF DAXPYL ----------------------
      SUBROUTINE DAXPYL(N,ALPHA,X,Y)
      IMPLICIT NONE
      INTEGER I,N
      REAL X(N),Y(N),ALPHA
      DO I=1,N
         Y(I)=Y(I)+ALPHA*X(I)
      ENDDO
      RETURN
    END SUBROUTINE DAXPYL

!C------------------------------- END OF DAXPYL ----------------------

    subroutine ope(n,sol,ss,c1,c2,c3)

      IMPLICIT NONE
      integer, intent(in) :: n
      real, intent (out) :: ss(n)
      real,intent(in) :: c1(n),c2(n),c3(n),sol(n)
      integer :: nx

      do nx=2,n-1
         ss(nx)=c1(nx)*sol(nx+1)+c2(nx)*sol(nx)+c3(nx)*sol(nx-1)
      enddo

      ss(1)=c1(1)*sol(2)+c2(1)*sol(1)
      ss(n)=c2(n)*sol(n)+c3(n)*sol(n-1)

      return
    end subroutine ope

  END MODULE loss_during_routines


module grdtest
!$$$ module documentation block
!           .      .    .                                       .
! module:   grdtest
!  prgmmr: todling
!
! abstract: Routines and data to perform gradient test
!
! program history log:
!   2009-01-18 todling
!   2010-02-19 treadon - wrap module
!
! subroutines included:
!   sub grtest
!
! variable definition:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

implicit none
private
public grtest

contains

subroutine grtest(pdx,itertest,xhat_in)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    grtest
!   prggmr: todling
!
! abstract: The aim is to characterize mathematically the cost-function J on a
!           line in the KDIM-dimensional space defined by point X and direction H.
!           Arbitrarily H is defined by -gradJ(X), the useful direction for
!           minimization. Let us denote by f the real function f(a)=J(X+a.H). A
!           sequence of characteristic quantities are computed and displayed for
!           various values of a :
!                    a=PDX, PDX*10, PDX*100 ... PDX*10**itertest
!           The sequence is prematuraly terminated if f(a)-f(0) changes of sign,
!           which normally indicates we are overshooting the minimum of f (assuming
!           J is convex and H points downwards the slope of J). The characteristic
!           quantities TC0,T1,TC1,T2... test increasingly high orders of regularity.
!           Refer to the comments below for the explanation of each quantity.
!             Owing to numerical truncation errors, the tests normally fail for very
!           small perturbations. The maximum quality of the test results, even for a
!           bug-free simulator, is limited to a few digits, depending on the machine.
!
! program history log:
!   2009-01-18 todling - some quad precision changes (incomplete)
!   2010-05-05 treadon - use r_kind constant in huge()
!   2010-08-19 lueken  - add only to module use
!
!   input argument list:
!    xhat
!    pdx
!    itertest
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

use kinds, only: i_kind, r_kind, r_quad
use constants, only: zero,zero_quad, one_quad
use mpimod, only: mype
use control_vectors, only: control_vector,allocate_cv, &
    random_cv,deallocate_cv,dot_product,assignment(=)

implicit none

real(r_quad)        , intent(in   ) :: pdx
integer(i_kind)     , intent(in   ) :: itertest
type(control_vector), optional, intent(in   ) :: xhat_in

! Local variables
real(r_quad), parameter :: half_quad=0.5_r_quad
real(r_quad), parameter ::  two_quad=2.0_r_quad
type(control_vector) :: xdir,yhat,grad,xhat
real(r_quad) :: zabuf(itertest),zfabuf(itertest),ztf2buf(itertest)
real(r_quad) :: zfy,zf0,zdf0,za,zfa,zdfa
real(r_quad) :: ZT1,ZB,ZFB,ztco,ZTC1,ZT2,ZTC1A,ZTC2,ZTF2
real(r_quad) :: ZTF2L
real(r_quad) :: ZTC00,ZTC02,ZTC10,ZTC12
real(r_quad) :: ZERMIN,ZT1TST,ZREF
integer(i_kind) :: ibest,idig,jj,nprt,ii
logical :: lsavinc

!-----------------------------------------------------------------------------

if (mype==0) write(6,*)'grtest: starting'
if (pdx<=EPSILON(pdx)) then
   if (mype==0) write(6,*)'grtest, pdx=',pdx
   write(6,*)'grtest: pdx too small',pdx
   call stop2(131)
endif
lsavinc=.false.
nprt=1

call allocate_cv(xdir)
call allocate_cv(yhat)
call allocate_cv(grad)
call allocate_cv(xhat)

!       1.0 Initial point
!           -------------

if (present(xhat_in)) then
   xhat=xhat_in
   if (mype==0) write(6,*)'grtest: use input xhat'
else
   call random_cv(xhat)
   if (mype==0) write(6,*)'grtest: use random_cv(xhat)'
endif
yhat=xhat
call evaljgrad(yhat,zfy,grad,lsavinc,nprt,'grtest')
zfy=half_quad*zfy

!          1.1 Define perturbation direction ZH

if (mype==0) write(6,*) 'The test direction is the opposite of the gradient'
do ii=1,xdir%lencv
   xdir%values(ii)=-grad%values(ii)
end do

!          1.2 Set function f value and derivative at origin

zf0=zfy
zdf0=dot_product(grad,xdir,r_quad)
if (mype==0) write(6,*)'grtest: F(0)=',zf0,' DF(0)=',zdf0

IF (ZDF0>zero_quad.and.mype==0) write(6,*) 'GRTEST Warning, DF should be negative'
IF (ABS(ZDF0) < SQRT(EPSILON(ZDF0))) THEN
   if (mype==0) write(6,*) 'GRTEST WARNING, DERIVATIVE IS TOO SMALL'
ENDIF

!       2. Loop on test point
!          ------------------
ztf2buf(1)=zero_quad
DO jj=1,itertest

   za=pdx*(10.0_r_quad**(jj-1))

   if (mype==0) write(6,*)'grtest iter=',jj,' alpha=',za

!           2.1 Compute f and df at new point y=x+a.h

   do ii=1,yhat%lencv
      yhat%values(ii) = xhat%values(ii) + za * xdir%values(ii)
   end do

   call evaljgrad(yhat,zfy,grad,lsavinc,nprt,'grtest')
   zfy=half_quad*zfy

   zfa=zfy
   zdfa=dot_product(grad,xdir,r_quad)

   if (mype==0) write(6,*)'grtest: alpha=',za,' F(a)=',zfa,' DF(a)=',zdfa

   zabuf(jj)=za
   zfabuf(jj)=zfa

!          2.2 Quantity TC0=f(a)/f(0)-1

!         if f is continuous then TC0->1 at origin,
!         at least linearly with a.

   IF (ABS(zf0)<=TINY(zf0)) THEN
!           do not compute T1 in this unlikely case
      if (mype==0) write(6,*) 'grtest: Warning: zf0 is suspiciously small.'
      if (mype==0) write(6,*) 'grtest: F(a)-F(0)=',zfa-zf0
   ELSE
      ztco=zfa/zf0-one_quad
      if (mype==0) write(6,*)'grtest: continuity TC0=',ztco
   ENDIF

!                           f(a)-f(0)
!          2.3 Quantity T1=-----------
!                            a.df(0)

!         if df is the gradient then T1->1 at origin,
!         linearly with a. T1 is undefined if df(0)=0.
   IF (ABS(za*zdf0)<=SQRT(TINY(zf0))) THEN
      if (mype==0) write(6,*)'grtest: Warning: could not compute ',&
       & 'gradient test T1, a.df(0)=',za*zdf0
   ELSE
      zt1=(zfa-zf0)/(za*zdf0)
      if (mype==0) write(6,*)'grtest: gradient T1=',zt1
   ENDIF

!         2.4 Quantity TC1=( f(a)-f(0)-a.df(0) )/a

!         if df is the gradient and df is continuous,
!         then TC1->0 linearly with a.
   ZTC1=(ZFA-ZF0-ZA*ZDF0)/ZA
   if (mype==0) write(6,*)'grtest: grad continuity TC1=',ZTC1

!         2.5 Quantity T2=( f(a)-f(0)-a.df(0) )*2/a**2

!         if d2f exists then T2 -> d2f(0) linearly with a.
   ZT2=(ZFA-ZF0-ZA*ZDF0)*two_quad/(ZA**2)
   if (mype==0) write(6,*)'grtest: second derivative T2=',ZT2

!         2.6 Quantity TC1A=df(a)-df(0)

!         if df is the gradient in a and df is continuous,
!         then TC1A->0 linearly with a.
   ZTC1A=ZDFA-ZDF0
   if (mype==0) write(6,*)'grtest: a-grad continuity TC1A=',ZTC1A

!         2.7 Quantity TC2=( 2(f(0)-f(a))+ a(df(0)+df(a))/a**2

!         if f is exactly quadratic, then TC2=0, always: numerically
!         it has to -> 0 when a is BIG. Otherwise TC2->0 linearly for
!         small a is trivially implied by TC1A and T2.
   ZTC2=(two_quad*(ZF0-ZFA)+ZA*(ZDF0+ZDFA))/(ZA**2)
   if (mype==0) write(6,*)'grtest: quadraticity TC2=',ZTC2

!                           2   f(0)-f(b)   f(a)-f(b)
!         2.8 Quantity TF2=---( --------- + --------- )
!                           a       b          a-b
!         if 0, a and b are distinct and f is quadratic then
!         TF2=d2f, always. The estimate is most stable when a,b are big.
!         This test works only after two loops, but it is immune against
!         gradient bugs.
   IF (jj>=2) THEN
      ZB =ZABUF (jj-1)
      ZFB=ZFABUF(jj-1)
      ZTF2=two_quad/ZA*((ZF0-ZFB)/ZB+(ZFA-ZFB)/(ZA-ZB))
      if (mype==0) write(6,*)'grtest: convexity ZTF2=',ZTF2
      ztf2buf(jj)=ztf2
   ENDIF

! End loop
ENDDO

call deallocate_cv(xdir)
call deallocate_cv(yhat)
call deallocate_cv(grad)
call deallocate_cv(xhat)

!          3. Comment on the results

!       TC0(0)/TC0(2)<.011 -> df looks continuous
!       item with (T1<1 and 1-T1 is min) = best grad test item
!       reldif(TF2(last),TF2(last-1)) = precision on quadraticity

!          3.1 Fundamental checks

if (mype==0) then
   write(6,*) 'GRTEST: TENTATIVE CONCLUSIONS :'

   ZTC00=ABS(zfabuf(1)-zf0)
   ZTC02=ABS(zfabuf(3)-zf0)
   IF( ZTC00/zabuf(1)  <=  1.5_r_quad*(ZTC02/zabuf(3)) )THEN
      write(6,*) 'GRTEST: function f looks continous.'
   ELSE
      write(6,*) 'GRTEST: WARNING f does not look continuous',&
       & ' (perhaps truncation problem)'
   ENDIF

!          3.2 Gradient quality

   IF (ABS(zdf0)<=SQRT(TINY(zf0))) THEN
      write(6,*) 'GRTEST: The gradient is 0, which is unusual !'
      ZTC10=ABS(zfabuf(1)-zf0)
      ZTC12=ABS(zfabuf(3)-zf0)
      IF( ZTC10/zabuf(1)**2  <=  1.1_r_quad*ZTC12/zabuf(3)**2)THEN
         write(6,*)'GRTEST: The gradient looks good anyway.'
      ENDIF
   ELSE
!     Find best gradient test index
      ZERMIN=HUGE(zero)
      ibest=-1
      DO jj=1,itertest
         ZT1TST=(zfabuf(jj)-zf0)/(zabuf(jj)*zdf0)
         ZT1TST=ABS(ZT1TST-one_quad)
         IF (ZT1TST<ZERMIN) THEN
            ibest=jj
            ZERMIN=ZT1TST
         ENDIF
      ENDDO
      IF(ibest == -1)THEN
         write(6,*)'GRTEST: gradient test problem : bad ',&
          & 'gradient, non-convex cost, or truncation errors ?'
      ELSE
         idig=INT(-LOG(ZERMIN+TINY(ZERMIN))/LOG(10.0_r_quad))
         write(6,*)'GRTEST: the best gradient test found has ',&
          & idig,' satisfactory digits.'
         IF(idig <= 1)THEN
            write(6,*)'GRTEST: SAYS: THE GRADIENT IS VERY BAD.'
         ELSEIF(idig <= 3)THEN
            write(6,*)'GRTEST: SAYS: THE GRADIENT IS SUSPICIOUS.'
         ELSEIF(idig <= 5)THEN
            write(6,*)'GRTEST: SAYS: THE GRADIENT IS ACCEPTABLE.'
         ELSE
            write(6,*)'GRTEST: SAYS: THE GRADIENT IS EXCELLENT.'
         ENDIF

         IF (ibest<=itertest-2) THEN
            ZTC10=ABS(zfabuf(ibest         )-zf0-zabuf(ibest         )*zdf0)/zabuf(ibest         )
            ZTC12=ABS(zfabuf(ibest+2)-zf0-zabuf(ibest+2)*zdf0)/zabuf(ibest+2)
            IF(ZTC10/zabuf(ibest) <=  1.1_r_quad*ZTC12/zabuf(ibest+2) )THEN
               write(6,*)'GRTEST: Gradient convergence looks good.'
            ELSE
               write(6,*)'GRTEST: Gradient convergence is suspicious.'
            ENDIF
         ELSE
            write(6,*)'GRTEST: could not check grad convergence.'
         ENDIF
      ENDIF
   ENDIF

!            3.3 Quadraticity
!         finite difference quadraticity test (gradient-free)

   ZTF2=ztf2buf(itertest)
   ZTF2L=ztf2buf(itertest-1)
   write(6,*) 'GRTEST: finite diff. d2f estimate no1:',ZTF2
   write(6,*) 'GRTEST: finite diff. d2f estimate no2:',ZTF2L
   ZREF=(ABS(ZTF2L)+ABS(ZTF2))/two_quad
   IF (ZREF<=TINY(ZREF)) THEN
      write(6,*) 'GRTEST: they are too small to decide whether ',&
       & 'they agree or not.'
   ELSE
      idig=INT(-LOG(ABS(ZTF2L-ZTF2)/ZREF+TINY(ZTF2))/LOG(10.0_r_quad))
      write(6,*) 'GRTEST: the fin.dif. estimates of d2f ',&
       & 'have ',idig,' satisfactory digits.'
      IF(idig <= 1)THEN
         write(6,*) 'GRTEST: THE FD-QUADRATICITY IS BAD.'
      ELSEIF(idig <= 3)THEN
         write(6,*) 'GRTEST:: THE FD-QUADRATICITY IS SUSPICIOUS.'
      ELSEIF(idig <= 5)THEN
         write(6,*) 'GRTEST: THE FD-QUADRATICITY IS ACCEPTABLE.'
      ELSE
         write(6,*) 'GRTEST: THE FD-QUADRATICITY IS EXCELLENT.'
      ENDIF
   ENDIF

   write(6,*) 'grtest: Goodbye.'
endif

return
END SUBROUTINE grtest
! ----------------------------------------------------------------------
end module grdtest


subroutine fortran_kernel(n,x,y,z,tau,out)
    implicit none

    integer, parameter                    :: dp=kind(0.d0)
    integer,                 intent(in)   :: n
    real(dp), dimension(n),  intent(in)   :: x, y, z, tau
    real(dp), dimension(n),  intent(out)  :: out
    integer                               :: i, j
    real(dp)                              :: scale, d

    scale = 0.25_dp/(4.0_dp*atan(1.0_dp))

    out(:) = 0.0_dp
    do i = 1, n
        do j = 1, n
            if (i .ne. j) then
                d = sqrt((x(i)-x(j))**2 + (y(i)-y(j))**2 + (z(i)-z(j))**2)
                out(i) = out(i) + out(j)/d
            end if
        end do
    end do
    out(:) = out(:) * scale

end subroutine fortran_kernel

! f2py -m fortran_kernel -c kernel.f90


program multiply_matrix_vector
    implicit none

    character(len=32) :: argument
    integer :: size
    real(8) :: before, after, diff_ij, diff_ji
    real(8), dimension(:,:), allocatable :: matrix
    real(8), dimension (:), allocatable :: vector
    real(8), dimension (:), allocatable :: result_vector

    call getarg(1, argument)
    read(argument, "(I10)") size
    call increment(size, 1)
    call random_seed()

    allocate(matrix(size, size))
    allocate(vector(size))
    allocate(result_vector(size))
    call spawn_random_matrix(matrix, size)
    call spawn_random_vector(vector, size)

    call cpu_time(before)
    call multiply_first_i(matrix, vector, size, result_vector)
    call cpu_time(after)
    diff_ij = after - before

    call cpu_time(before)
    call multiply_first_j(matrix, vector, size, result_vector)
    call cpu_time(after)
    diff_ji = after - before

    deallocate(matrix)
    deallocate(vector)
    deallocate(result_vector)

    print *,argument,",",diff_ij,",",diff_ji

    contains

    elemental subroutine increment(var, incr)
        implicit none
        integer,intent(inout) :: var
        integer,intent(in)    :: incr

        var = var + incr
    end subroutine

    subroutine spawn_random_vector(vector, size)
        implicit none
        real(8), dimension(:) :: vector
        integer :: size, i
        real(8) :: value
        do i=1, size
            call random_number(value)
            vector(i) = value * (size)
        end do
    end

    subroutine spawn_random_matrix(matrix, size)
        implicit none
        real(8), dimension(:,:) :: matrix
        integer :: size, i, j
        real(8) :: value

        do i=1, size
            do j=1, size
                call random_number(value)
                matrix(i, j) = value * (size)
            end do
        end do
    end

    subroutine multiply_first_i(matrix, vector, size, result_vector)
        implicit none
        real(8), dimension (:) :: vector
        real(8), dimension (:, :) :: matrix
        real(8), dimension (:) :: result_vector
        integer :: i, j, size

        do i=1, size
            result_vector(i) = 0
            do j=1, size
                result_vector(i) = result_vector(i) +  vector(j)*matrix(i, j);
            end do
        end do
    end

    subroutine multiply_first_j(matrix, vector, size, result_vector)
        implicit none
        real(8), dimension (:) :: vector
        real(8), dimension (:, :) :: matrix
        real(8), dimension (:) :: result_vector
        integer :: i, j, size

        do j=1, size
            result_vector(j) = 0
            do i=1, size
                result_vector(i) = result_vector(i) +  vector(j)*matrix(i, j);
            end do
        end do
    end
end program multiply_matrix_vector


!!# MODULE <<LIB_Norm>>
MODULE LIB_Norm
!!## PURPOSE
!! Puts the $\ell^1$, $\ell^2$, and $L^\infty$ norms
!! in one place.

!!## USAGE
!! * the $\ell^\infty$ norm,
!
!        s = NormInfty( A [,W] )
!
!! * the $\ell^2$ norm,
!
!        s = NormEll2 ( A [,W] )
!
!! * the $\ell^1$ norm,
!
!        s = NormEll1 ( A [,W] )
!
!! * the squared $\ell^2$ norm,
!
!        s = NormEll2Sqr ( A [,W] )
!

!!#### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!#### EXTERNAL PROCEDURES
USE FUN_NormInfty                              !!((03-A-FUN_NormInfty.f90))
USE FUN_NormEll2                               !!((03-A-FUN_NormEll2.f90))
USE FUN_NormEll1                               !!((03-A-FUN_NormEll1.f90))
USE FUN_NormEll2Sqr                            !!((03-A-FUN_NormEll2Sqr.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PUBLIC ACCESS LIST
PUBLIC :: NormInfty,NormEll2,NormEll1,NormEll2Sqr

END MODULE


      subroutine compute_ipsi()
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!
! Computes the inverse of the shapefunction matrix for hax elements
!
! Author : Sai Rapaka
!
      use comfem, only: iPsi

      implicit none

      real*8   :: xc(8), yc(8), zc(8)
      real*8   :: zeta, eta, mu
      real*8   :: xmult, solved
      integer i,j,k
      real*8   :: Nmat(8, 8), rhs(8, 8)
      real*8   :: sol(8)

      xc = 1.0d0
      yc = 1.0d0
      zc = 1.0d0
      xc=(/-1.0d0, 1.0d0, 1.0d0, -1.0d0, -1.0d0, 1.0d0, 1.0d0, -1.0d0/)
      yc=(/-1.0d0, -1.0d0, 1.0d0, 1.0d0, -1.0d0, -1.0d0, 1.0d0, 1.0d0/)
      zc=(/-1.0d0, -1.0d0, -1.0d0, -1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0/)
      do i=1,8
        do j=1,8
          zeta = xc(i)/dsqrt(3.0d0)
          eta = yc(i)/dsqrt(3.0d0)
          mu = zc(i)/dsqrt(3.0d0)
          Nmat(i, j) = (1.0d0/8.0d0)*(1 + xc(j)*zeta)*
     &                 (1 + yc(j)*eta)*(1 + zc(j)*mu)
        enddo
      enddo

      rhs = 0.d00
      do i=1,8
        rhs(i,i) = 1.0d0
      enddo

      do k=1,7
        do i=k+1,8
          xmult = Nmat(i,k)/Nmat(k,k)
          do j=1,8
            Nmat(i,j) = Nmat(i,j) - xmult*Nmat(k,j)
            rhs(i,j) = rhs(i,j) - xmult*rhs(k,j)
          enddo
        enddo
      enddo

      do k=1,8
        ! Solve for the k-th column of rhs
        sol(8) = rhs(8, k)/Nmat(8,8)
        do j=7,1,-1
          solved = 0.0d0
          do i=j+1,8
            solved = solved + sol(i)*Nmat(j,i)
          enddo
          sol(j) = (rhs(j, k) - solved)/Nmat(j, j)
        enddo
        do j=1,8
          iPsi(j, k) = sol(j)
        enddo
      enddo

      return
      end subroutine compute_ipsi


*###[ ffxc0p0
	subroutine ffxc0p0(cc0, xpi, ier)
***#[*comment:***********************************************************
*									*
*	C0 function for all three momenta^2 = 0				*
*	input parameters as for ffxc0					*
*									*
*	original code from David Garcia					*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	DOUBLE PRECISION xpi(6)
	DOUBLE COMPLEX cc0
	integer ier

	DOUBLE PRECISION m1, m2, m3, m
	DOUBLE PRECISION eps
	parameter (eps = 1D-6)

	include 'ff.h'

	m1 = xpi(1)
	m2 = xpi(2)
	m3 = xpi(3)

* sort the masses such that m1 >= m2 >= m3
* this is important to avoid complex logs later
	if(m1 .lt. m2) then
	  m = m2
	  m2 = m1
	  m1 = m
	endif
	if(m2 .lt. m3) then
	  m = m3
	  m3 = m2
	  m2 = m
	endif
	if(m1 .lt. m2) then
	  m = m2
	  m2 = m1
	  m1 = m
	endif

	m = m1 + m2 + m3

	if(m3/m .gt. eps) then

* non-zero masses:
	  if((m2 - m3)/m .gt. eps) then
	    if((m1 - m2)/m .gt. eps) then
* m1 != m2 != m3
	      cc0 = (log(m3/m2) + m1/(m3 - m1)*log(m3/m1)
     +              - m1/(m2 - m1)*log(m2/m1))/(m2 - m3)
	    else
* m1 = m2 != m3
	      cc0 = (1 - m3/(m2 - m3)*log(m2/m3))/(m3 - m2)
	    endif
	  else
	    if((m1 - m2)/m .gt. eps) then
* m1 != m2 = m3
	      cc0 = (1 - m1/(m2 - m1)*log(m2/m1))/(m1 - m2)
	    else
* m1 = m2 = m3
	      cc0 = -.5D0/m1
	    endif
	  endif

	else

* zero masses:
	  if((m1 - m2)/m .gt. eps) then
* m1 != m2, m3 = 0
	    cc0 = log(m2/m1)/(m1 - m2)
	  else
* m1 = m2, m3 = 0
	    cc0 = -1D0/m1
	  endif

	endif

	end


    subroutine roe_solver(ixy,uv,enth,delta,wave_local,s_local,info)
    implicit none

    double precision :: uv(2),enth, delta(4)
    double precision :: wave_local(3,4), s_local(3)
    double precision :: euv, c2, c, u2v2, u,v
    double precision :: a1, a2, a3, a4, a5
    double precision :: gamma, gamma1
    integer :: m, p, mu, mv, ixy, i, j, k, info

    common /cparam/ gamma, gamma1

    info = 0

    gamma1 = gamma - 1.d0

!     # These are used even in the mapped case, but ixy is
!     # always set to 1;  rotation matrix rot does switches
!     # coordinates for us.
    if (ixy == 1) then
        mu = 2
        mv = 3
    else
        mu = 3
        mv = 2
    endif

    u = uv(mu-1)
    v = uv(mv-1)

    u2v2 = u*u + v*v
    c2 = gamma1*(enth - 0.5d0*u2v2)
    if (c2 < 1e-13) then
        info = 1
        write(6,*) 'Roe solver : '
        write(6,'(A,E16.8, E16.8)') 'c2 .lt. 0; ', c2
        return
    !         stop
    endif
    c = sqrt(c2) !! sound speed
    euv = enth - u2v2

    a2 = (gamma1/c2) * (euv*delta(1) + u*delta(mu) + v*delta(mv) &
    - delta(4))
    a3 = delta(mv) - v*delta(1)
    a4 = (delta(mu) + (c-u)*delta(1) - c*a2) / (2.d0*c)
    a1 = delta(1) - a2 - a4

!     # 1-wave (rarefaction or shock)
    wave_local(1,1)  = a1
    wave_local(1,mu) = a1*(u-c)
    wave_local(1,mv) = a1*v
    wave_local(1,4)  = a1*(enth - u*c)
    s_local(1) = u - c

!     # contact discontinuity
    wave_local(2,1)  = a2
    wave_local(2,mu) = a2*u
    wave_local(2,mv) = a2*v  + a3
    wave_local(2,4)  = a2*0.5d0*u2v2 + a3*v
    s_local(2) = u

!     # 3-wave (rarefaction or shock)
    wave_local(3,1)  = a4
    wave_local(3,mu) = a4*(u+c)
    wave_local(3,mv) = a4*v
    wave_local(3,4)  = a4*(enth + u*c)
    s_local(3) = u + c

    end subroutine roe_solver


C$Procedure      LATCYL ( Latitudinal to cylindrical coordinates )

      SUBROUTINE LATCYL ( RADIUS, LONG, LAT, R, LONGC, Z )

C$ Abstract
C
C     Convert from latitudinal coordinates to cylindrical coordinates.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     CONVERSION,  COORDINATES
C
C$ Declarations

      DOUBLE PRECISION   RADIUS
      DOUBLE PRECISION   LONG
      DOUBLE PRECISION   LAT
      DOUBLE PRECISION   R
      DOUBLE PRECISION   LONGC
      DOUBLE PRECISION   Z

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     RADIUS     I   Distance of a point from the origin.
C     LONG       I   Angle of the point from the XZ plane in radians.
C     LAT        I   Angle of the point from the XY plane in radians.
C     R          O   Distance of the point from the Z axis.
C     LONGC      O   Angle of the point from the XZ plane in radians.
C     Z          O   Height of the point above the XY plane.
C
C$ Detailed_Input
C
C     RADIUS     Distance of a point from the origin.
C
C     LONG       Angle of the point from the XZ plane in radians.
C
C     LAT        Angle of the point from the XY plane in radians.
C
C$ Detailed_Output
C
C     R          Distance of the point from the Z axis.
C
C     LONGC      Angle of the point from the XZ plane in radians.
C                 LONGC is set equal to LONG.
C
C     Z          Height of the point above the XY plane.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine returns the cylindrical coordinates of a point
C     whose position is input in latitudinal coordinates.
C
C     Latitudinal coordinates are defined by a distance from a central
C     reference point, an angle from a reference meridian, and an angle
C     above the equator of a sphere centered at the central reference
C     point.
C
C$ Examples
C
C     Other than the obvious conversion between coordinate systems
C     this routine could be used to obtain the axial projection
C     from a sphere to a cylinder about the z-axis that contains
C     the equator of the sphere.  The following code fragment
C     illustrates this idea.
C
C           CALL LATCYL ( RADIUS, LONG, LAT, R, LONG, Z )
C           R = RADIUS
C
C     R, LONG, and Z now contain the coordinates of the projected
C     point. Such a projection is valuable because it preserves the
C     areas between regions on the sphere and their projections to the
C     cylinder.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 26-JUL-2016 (BVS)
C
C        Minor headers edits.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     latitudinal to cylindrical coordinates
C
C-&

C$ Revisions
C
C-    Beta Version 1.0.1, 1-Feb-1989 (WLT)
C
C        Example section of header upgraded.
C
C-&

C
C     Local variables
C
      DOUBLE PRECISION RH
      DOUBLE PRECISION ZZ

C
C     Convert to cylindrical, storing in temporary variables
C
      RH = RADIUS * DCOS(LAT)
      ZZ = RADIUS * DSIN(LAT)

C
C     Move the results to output variables.
C
      LONGC = LONG
      R      = RH
      Z      = ZZ
C
      RETURN
      END


      subroutine root(a,b,c,x1,x2)
c
c     + + + PURPOSE + + +
c     Finds roots for the equation y=a*x**2+b*x+c
c
c     Called from subroutine XCRIT.
c     Author(s): G. Foster, M. Nearing
c     Reference in User Guide:
c
c     Changes:
c
c     Version: This module recoded from WEPP version 90.92.
c     Date recoded: 01/08/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real a, b
      double precision c, x1, x2
c
c     a    -
c     b    -
c     c    -
c     x1   -
c     x2   -
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     + + + LOCAL VARIABLES + + +
      double precision cc, part
      real b1, tmpvr1
c     cc     -
c     part   -
c
c     + + + END SPECIFICATIONS + + +
c
      b1 = -b
      tmpvr1 = 2.0 * a
      cc = -c
      part = sqrt(b**2-4.0*a*cc)
      x1 = (b1-part) / tmpvr1
      x2 = (b1+part) / tmpvr1
c
      if (x1.gt.x2) then
        part = x2
        x2 = x1
        x1 = part
      end if
c
      return
      end


      SUBROUTINE DC2FIT(XI,YI,SDI,NXY,B,NB,W,NW,YKNOT,YPKNOT,
     *         SIGFAC, IERR1)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2000-12-01 DC2FIT Krogh  Dim. SDI(*) instead NXY.
c>> 1995-11-21 DC2FIT Krogh  Converted from SFTRAN to Fortran 77.
c>> 1994-10-19 DC2FIT Krogh  Changes to use M77CON
c>> 1994-01-31 DC2FIT CLL Added test for SDI(i) .le. 0 when SDI(1) > 0.
c>> 1990-01-23 CLL Deleted ref to unused variable NX in call to IERM1
C>> 1989-10-20 CLL
C>> 1987-10-22 DC2FIT Lawson  Initial code.
c           Least squares fit to discrete data by a C-2 cubic spline.
c     ------------------------------------------------------------------
C     Algorithm and program designed by C.L.Lawson and R.J.Hanson.
c     The general approach but not the complete code is given in
C     'SOLVING LEAST SQUARES PROBLEMS', by Lawson and Hanson,
C     publ by Prentice-Hall, 1974.
C     Programming and later changes and corrections by Lawson,Hanson,
C     T.Lang, and D.Campbell, Sept 1968, Nov 1969, and Aug 1970.
C     Modified 1968 Sept 17 to provide C-2 continuity.
C     1974 5/21, C.L.Lawson, Fixed bug that caused ISEG to get too big.
C     Also changed to exit immidiately if B() array is not
C     strictly increasing.
c     1984 July 10. Modified for improved portability and to conform
c          to Fortran 77.  C. L. Lawson, JPL.
c          Added calls to the error message subrs.
c     7/23/87 CLL.  Added the IERR1 argument.
C     1989-10-20 CLL  Changed code so there are no RETURN statements in
c     Sftran procedures.  Previous code had such a RETURN that led to
c     a warning diagnostic from a Cray compiler due to unreachable
c     CONTINUE statements.  Also introduced "c--" lines for CHGTYP.
c     ------------------------------------------------------------------
c                     SUBROUTINE ARGUMENTS
c
c  (XI(i),i=1,NXY)  [in]  Abcissas of data to be fitted.  Require
c        this data be ordered so X(i) .le. X(i+1).
c
c  (YI(i),i=1,NXY)  [in]  Ordinates of data to be fitted.
c
c  (SDI(i),i=1,NXY) [in]  User may use this array to assign an
c                     a priori standard deviation of error to each
c       YI(i) value.  The weighted fitting algorithm will take
c       account of these.  Optionally the user may set SDI(1) to
c       a negative value.  Then this subr will use ABS(SDI(1)) as
c       the standard deviation for each YI(i) value.  In this case
c       the SDI() array can be dimensioned SDI(1).
c       If SDI(1) = 0., the subr issues an error message and returns.
c
c  NXY  [in]  No. of data pairs, (XI(i), YI(i)), and no. of elts
c          in SDI() if SDI(1) is positive.  Require NXY .ge. 4.
c
c  (B(j),j=1,NB)  [in]  Breakpoints for the spline function,
c        including endpoints.  These breakpoints must be
c        strictly increasing:  B(j) .lt. B(j+1).
c        It is required that all abcissas, XI(i), lie in the
c        closed interval, [B(1), B(NB)].
c
c  NB  [in]  No. of breakpoints, including endpoints.
c         The no. of parameters in the least squares problem
c         will be NB + 2.
c         To have a nonsingular problem one must have
c         NXY .ge. NB + 2, and the distribution of the breakpoints
c         must not be too skewed relative to the data abcissas.
c       If singularity is detected, an error message will be
c       issued by the subr that solves the band matrix.
c
c  W()  [scratch]  Work space dimensioned W(NW,5).
c
c  NW  [in]  First dimension of W().   Must satisfy NW .ge. NB + 4
c          Let KMAX denote the max no. of data abcissas, XI(i),
c          in any one breakpoint interval, i.e. between B(j) and
c          B(j+1) for some j.   The subr will be more efficient
c          if NW is at least NB + 3 + KMAX.
c
c  (YKNOT(k) and YPKNOT(k),k=1,NB)  [out]  The subr will return
c       values defining the fitted C2 spline curve in these arrays.
c       These values and first derivatives of the fitted curve at the
c       knot abcissae.  YKNOT(j) = f(B(j))   and
c       YPKNOT(j) = fprime(B(j))  for  j = 1,...,NB.
c       The user can then evaluate the fitted curve at any point by
c       Hermite interpolation.  See subrs DHINT or SHINT.
c
c  SIGFAC  [out]  The subr sets SIGFAC to RNORM / sqrt(DOF) where
c      RNORM = sqrt( sum over i of [( (yfit(i) - YI(i))/SDI(i))**2])
c       and DOF = max(1, NXY - (NB+2))
C
c  IERR1  [out]  Error status indicator.  Note that IERR2 comes from
c         DBACC and IERR3 comes from DBSOL.
c
c        =    0 means no errors detected.
c        =  100 means  NB .lt. 2   .or.   NXY .lt. NB+2
c        =  200 means  B(I) .ge. B(I+1)
c        =  300 means  NW .lt. NB+4
c        =  400 means  XI(I-1) .gt. XI(I)
c        =  500 means  B(1) .gt. XI(1) .or. B(NB) .lt. XI(NXY)
c        =  600 means  Need larger dimension NW.
c        =  700 + IERR2 means IERR2 .ne. 0
c        =  800 + IERR2 means IERR2 .ne. 0
c        =  900 + IERR2 means IERR2 .ne. 0
c        = 1000 + IERR3 means IERR3 .ne. 0 due to singularity
c                       detected in DBSOL.
c        = 1100 means SDI(1) = zero.
c        = 1200 means SDI(1) > zero and SDI(i) .le. zero for some i.
c     ------------------------------------------------------------------
c             Important internal variables.
c
c     ISEG     Index of current spline segment, starting with 1 for
c              the first segment.
c              Also tells the band matrix subroutine the column index
c              of the least squares matrix with which the first col
c              of the new block of data in G() is to be associated.
C     KSIZE    Size of current block.
C     JPOINT   Current data pointer.
c     ------------------------------------------------------------------
c--D replaces "?": ?C2FIT, ?BACC, ?C2BAS, ?ERM1, ?ERV1, ?BSOL, ?TRC2C
c     Both versions use ERMSG, IERM1, IERV1
c     Lower level subrs needed: (D/S)HTCC, (D/S)NRM2, ERFIN
c     ------------------------------------------------------------------
      integer I, IERR1, IERR2, IERR3, IRNOW, ISEG, J, JPOINT, JTPREV
      integer K, KSIZE, N1, NB, NPARAM, NW, NXY
      integer NBAND, NBAND1
      parameter(NBAND = 4, NBAND1 = NBAND+1)
      double precision XI(NXY), YI(NXY), SDI(*), B(NB), W(NW, 5)
      double precision YKNOT(NB), YPKNOT(NB), P(4), ONE, ZERO
      double precision DOF, RNORM, sdijp, SIGFAC, WT, WT1
      logical  NEWSEG, USEWT1
      parameter( ONE = 1.0D0, ZERO = 0.0D0)
c     ------------------------------------------------------------------
      IERR1 = 0
C
C          EXIT IMMEDIATELY IF NB .lt. 2  OR  NXY .LT NB+2  OR  IF THE
C          BREAKPOINTS ARE NOT STRICTLY INCREASING.
c
      NPARAM = NB+2
      IF ( NB .lt. 2   .or.   NXY .lt. NPARAM) THEN
         IERR1 = 100
         call IERM1('DC2FIT',IERR1,0,
     *   'Require NB .ge. 2 and NXY .ge. NB+2', 'NB',NB,',')
         call IERV1('NXY',NXY,'.')
         go to 300
      END IF
c
      N1 = NB-1
      DO 20 I = 1,N1
        IF (B(I) .ge. B(I+1)) THEN
          IERR1 = 200
          call IERM1('DC2FIT',IERR1,0,
     *    'Require knots, B(I), to be strictly increasing.',
     *    'I',I,',')
          call DERV1('B(I)',B(I),',')
          call DERV1('B(I+1)',B(I+1),'.')
          go to 300
        END IF
   20 CONTINUE
C
C     Require NW .ge. NB+4
C
      IF (NW .lt. NB+4) THEN
        IERR1 = 300
        call IERM1('DC2FIT',IERR1,0,'Require NW .ge. NB+4','NW',NW,',')
        call IERV1('NB',NB,'.')
        go to 300
      END IF
C
c     ------------------------------------------------------------------
C                                       TEST SDI(1)
      IF (SDI(1) .lt. ZERO) THEN
         WT1 = -ONE/SDI(1)
         USEWT1 = .true.
      ELSE IF ( SDI(1) .gt. ZERO) THEN
         USEWT1 = .false.
      ELSE
         IERR1 = 1100
         call ERMSG('DC2FIT',IERR1,0,'Require SD(1) .ne. Zero','.')
         return
      END IF
C
c                             Test ordering of XI() array.
c
      DO 40 I=2,NXY
        IF (XI(I-1) .gt. XI(I)) THEN
          IERR1 = 400
          call IERM1('DC2FIT',IERR1,0,
     *    'Require abcissas, X(I), to be nondecreasing.',
     *    'I',I,',')
          call DERV1('X(I-1)',XI(I-1),',')
          call DERV1('X(I)',XI(I),'.')
          go to 300
        END IF
   40  CONTINUE
c
C                             TEST THE FIRST AND LAST BREAKPOINT
C                             FOR BRACKETING THE DATA ABCISSAS.
c
      IF (B(1) .gt. XI(1) .or. B(NB) .lt. XI(NXY)) THEN
        IERR1 = 500
        call DERM1('DC2FIT',IERR1,0,
     *     'Require B(1) .LE. X(1) and B(NB) .ge. XI(NXY)',
     *     'B(1)',B(1),',')
        call DERV1('X(1)',XI(1),',')
        call DERV1('B(NB)',B(NB),',')
        call DERV1('X(NXY)',XI(NXY),'.')
        go to 300
      END IF
C
C     BEGIN LOOP TO FORM EQUATIONS FOR C2 LEAST SQUARES FIT.
C
      IRNOW = 1
      K = 1
      KSIZE = 0
      NEWSEG = .TRUE.
      ISEG = 1
      DO 120 JPOINT = 1, NXY
         IF( K .gt. NW ) THEN
            call DBACC(W, NW, NBAND, IRNOW, KSIZE, ISEG, JTPREV, IERR2)
            if(IERR2 .ne. 0) then
               IERR1 = 700 + IERR2
               go to 200
            end if

            IF(IRNOW .gt. NW) THEN
               IERR1 = 600
               call IERM1('DC2FIT',IERR1,0,
     *            'Need larger dimension NW.','NW',NW,'.')
               go to 300
            END IF
            K = IRNOW
            KSIZE = 0
         END IF
c
C        DO WHILE( XI(JPOINT) .gt. B(ISEG+1) )
   80    IF ( XI(JPOINT) .gt. B(ISEG+1) ) THEN
            call DBACC(W, NW, NBAND, IRNOW, KSIZE, ISEG, JTPREV, IERR2)
            if(IERR2 .ne. 0) then
               IERR1 = 800 + IERR2
               go to 200
            end if
            KSIZE = 0
            K = IRNOW
            ISEG = ISEG + 1
            NEWSEG = .TRUE.
            go to 80
         END IF
c        END WHILE
c                          Build one equation
         call DC2BAS(XI(JPOINT), 0, ISEG,NEWSEG,B,NB,P)
         IF( USEWT1) THEN
            WT = WT1
         ELSE
            sdijp = sdi(jpoint)
            if(sdijp .gt. ZERO) then
               WT=ONE/sdijp
            else
               IERR1 = 1200
               call ERMSG('DC2FIT',IERR1,0,
     *            'With SD(1) > 0  require all SD(I) > 0.', ',')
               call DERV1('SD(1)',SDI(1),'.')
               call IERV1('I',jpoint,',')
               call DERV1('SD(I)',sdijp,'.')
               return
            end if
         END IF
         DO 100 J = 1,4
            W(K,J)=P(J)*WT
  100    CONTINUE
         W(K,5)=YI(JPOINT)*WT
c                          End of build one equation
         K = K+1
         KSIZE = KSIZE + 1
c
  120 CONTINUE
      call DBACC(W, NW, NBAND, IRNOW, KSIZE, ISEG, JTPREV, IERR2)
            if(IERR2 .ne. 0) then
               IERR1 = 900 + IERR2
               go to 200
            end if
C
C     ALL DATA POINTS HAVE BEEN PROCESSED.  CALL FOR SOLUTION.
C
      call DBSOL(1,W, NW, NBAND, IRNOW, JTPREV, W(1,NBAND1),
     *           NPARAM, RNORM, IERR3)
            if(IERR3 .ne. 0) then
               IERR1 = 1000 + IERR2
               call ERMSG('DC2FIT',IERR1,0,
     *         'Singularity noted in DBSOL.','.')
               go to 300
            end if

      DOF = MAX(1, NXY - NPARAM)
      SIGFAC = RNORM / sqrt(DOF)
C
C                  TRANSFORM PARAMETERS TO Y,YPRIME BASIS
C
      call DTRC2C (B,NB,W(1,5),YKNOT,YPKNOT)
      RETURN
c
c             Error in _BACC
  200 call ERMSG('DC2FIT',IERR1,0,
     *   'Error detected in subroutine DBACC','.')

c             Set YKNOT() & YPKNOT() to zero
  300 DO 320 I=1,NB
            YKNOT(I)=ZERO
            YPKNOT(I)=ZERO
  320 CONTINUE
      return
      end