c subroutine lfpt (n,m,theta,cp,pb)
c
c dimension of
c arguments
c                        cp((n/2)+1)
c
c purpose                routine lfpt uses coefficients computed by
c                        routine alfk to compute the single precision
c                        normalized associated legendre function pbar(n,
c                        m,theta) at colatitude theta.
c
c usage                  call lfpt(n,m,theta,cp,pb)
c
c arguments
c
c on input               n
c                          nonnegative integer specifying the degree of
c                          pbar(n,m,theta)
c                        m
c                          is the order of pbar(n,m,theta). m can be
c                          any integer however pbar(n,m,theta) = 0
c                          if abs(m) is greater than n and
c                          pbar(n,m,theta) = (-1)**m*pbar(n,-m,theta)
c                          for negative m.
c
c                        theta
c                          single precision colatitude in radians
c
c                        cp
c                          single precision array of length (n/2)+1
c                          containing coefficients computed by routine
c                          alfk
c
c on output              pb
c                          single precision variable containing
c                          pbar(n,m,theta)
c
c special conditions     calls to routine lfpt must be preceded by an
c                        appropriate call to routine alfk.
c
c precision              single
c
c algorithm              the trigonometric series formula used by
c                        routine lfpt to calculate pbar(n,m,th) at
c                        colatitude th depends on m and n as follows:
c
c                           1) for n even and m even, the formula is
c                              .5*cp(1) plus the sum from k=1 to k=n/2
c                              of cp(k)*cos(2*k*th)
c                           2) for n even and m odd. the formula is
c                              the sum from k=1 to k=n/2 of
c                              cp(k)*sin(2*k*th)
c                           3) for n odd and m even, the formula is
c                              the sum from k=1 to k=(n+1)/2 of
c                              cp(k)*cos((2*k-1)*th)
c                           4) for n odd and m odd, the formula is
c                              the sum from k=1 to k=(n+1)/2 of
c                              cp(k)*sin((2*k-1)*th)
c
c accuracy               comparison between routines lfpt and double
c                        precision dlfpt on the cray1 indicates greater
c                        accuracy for greater values on input parameter
c                        n.  agreement to 13 places was obtained for
c                        n=10 and to 12 places for n=100.
c
c timing                 time per call to routine lfpt is dependent on
c                        the input parameter n.
c
      subroutine lfpt (n,m,theta,cp,pb)
      dimension       cp(1)
c
      pb = 0.
      ma = iabs(m)
      if(ma .gt. n) return
      if (n)  10, 10, 30
   10 if (ma)  20, 20, 30
   20 pb= sqrt(.5)
      go to 140
   30 np1 = n+1
      nmod = mod(n,2)
      mmod = mod(ma,2)
      if (nmod)  40, 40, 90
   40 if (mmod)  50, 50, 70
   50 kdo = n/2+1
      cdt = cos(theta+theta)
      sdt = sin(theta+theta)
      ct = 1.
      st = 0.
      sum = .5*cp(1)
      do  60 kp1=2,kdo
         cth = cdt*ct-sdt*st
         st = sdt*ct+cdt*st
         ct = cth
         sum = sum+cp(kp1)*ct
   60 continue
      pb= sum
      go to 140
   70 kdo = n/2
      cdt = cos(theta+theta)
      sdt = sin(theta+theta)
      ct = 1.
      st = 0.
      sum = 0.
      do  80 k=1,kdo
         cth = cdt*ct-sdt*st
         st = sdt*ct+cdt*st
         ct = cth
         sum = sum+cp(k)*st
   80 continue
      pb= sum
      go to 140
   90 kdo = (n+1)/2
      if (mmod) 100,100,120
  100 cdt = cos(theta+theta)
      sdt = sin(theta+theta)
      ct = cos(theta)
      st = -sin(theta)
      sum = 0.
      do 110 k=1,kdo
         cth = cdt*ct-sdt*st
         st = sdt*ct+cdt*st
         ct = cth
         sum = sum+cp(k)*ct
  110 continue
      pb= sum
      go to 140
  120 cdt = cos(theta+theta)
      sdt = sin(theta+theta)
      ct = cos(theta)
      st = -sin(theta)
      sum = 0.
      do 130 k=1,kdo
         cth = cdt*ct-sdt*st
         st = sdt*ct+cdt*st
         ct = cth
         sum = sum+cp(k)*st
  130 continue
      pb= sum
  140 return
      end


subroutine polarize_prop(eta_I,eta_Q,eps_I,eps_Q,ds,I,Q,U)
!subroutine to do a propagation of polarized radiation over a cell.
!this method assumes constant conditions over the entire propagation.
!tested against a matlab routine that computes the propagation in a
!different manner by a finite difference method.
implicit none

double precision I,Q,U,I0,Q0,ds
double precision eta_I,eta_Q,eps_I,eps_Q
double precision shQ,chQ,e_tau,fac,o11,o12

!input:
!I,Q		-- incoming Stokes I and Q parameters
!eta_I		-- opacity
!eta_Q		-- polarized opacity
!eps_I		-- spontaneous emission rate
!eps_Q		-- polarized emission rate
!ds		-- depth length

!output:
!I,Q		-- outgoing Stokes parameters

!we use Eq. (8.14) from L&L04
!I(s) = \int_0^s ds' O(s,s') e(s') + O(s,0) I(0)
!where I and e are vectors, and O is a 2x2 matrix
!we use the fact that within a cell e(s') = e. Also
!we use the expression from Eq. (8.28) for O(s,s')
!				  | cosh(eta_Q*(s-s')	-sinh(eta_Q*(s-s')|
!O(s,s') = exp(-eta_I * (s-s')) * |  					  |
!				  |-sinh(eta_Q*(s-s')	 cosh(eta_Q*(s-s')|

!expressions for the integrated elements of O(s,s') are computed using Wolfram
!Alpha. See following links for results:
! https://www.wolframalpha.com/input/?i=%5Cint+exp(-a*(s-x))+*+cosh(b*(s-x))+dx+from+0+to+s
! https://www.wolframalpha.com/input/?i=%5Cint+exp(-a*(s-x))+*+sinh(b*(s-x))+dx+from+0+to+s

I0 = I
Q0 = Q

shQ = dsinh(eta_Q*ds)
chQ = dcosh(eta_Q*ds)

e_tau = dexp(-eta_I*ds)

fac = (eta_I**2.d0 - eta_Q**2.d0)**(-1.d0)

o11 = fac*eta_I*(1.d0 - (chQ + (eta_Q/eta_I)*shQ)*e_tau)
o12 =-fac*eta_Q*(1.d0 - (chQ + (eta_I/eta_Q)*shQ)*e_tau)

I = o11*eps_I + o12*eps_Q + e_tau*( chQ*I0 - shQ*Q0)
Q = o12*eps_I + o11*eps_Q + e_tau*(-shQ*I0 + chQ*Q0)
U = U * e_tau

end subroutine

subroutine trace_out_raytrace(x_co,y_co,tot_node,X_all,star_mod,R_star,XYZ_star,T_star,NN,&
&max_ne,neigh_list,dir,dx,n_depth_rt,depth_list,node_count,nlevels,nu0,I_in)
!subroutine that traces from a starting point on the sphere to the observer on the other side of the
!sphere, listing the nodes it passes in depth_list
implicit none
integer tot_node,node,new_node,max_ne,i,n_depth_rt,star_mod
integer in_sim,neigh_num,k_cur,node_count,node_save
integer nlevels

integer, dimension (tot_node,max_ne) :: NN
integer, dimension (tot_node) :: neigh_list
integer, dimension (2,n_depth_rt) :: depth_list

double precision dx,r,rsave
double precision R_star,T_star
double precision xcorr,ycorr,rcorr
double precision x_co,y_co,z_co

double precision, dimension (3) :: start,XYZ_star
double precision, dimension (3) :: X_phot,dir
double precision, dimension (3,tot_node) :: X_all
double precision, dimension (nlevels) :: nu0
double precision, dimension (nlevels) :: I_in

!input
!tot_node       -- total node number
!start          -- starting coordinates
!X_all          -- all coordinates of the nodes
!dx             -- ray-trace step precision
!max_ne         -- maximum number of neighbours
!neigh_list     -- list of number of neighbours for each node
!dir            -- photon direction/positive z-direction

!output
!depth_list     -- list with nodes to go through including distance between them
!node_count     -- how many nodes does the ray-trace pass

!we start by finding the stating point for this calculation.
!

z_co = -1.d0*dsqrt(1.d0 - x_co**2.d0 - y_co**2.d0)
do i = 1,nlevels
  call black_body(2.73d0,nu0(i),I_in(i))
end do

if (star_mod.eq.1) then
  xcorr = x_co - XYZ_star(1)
  ycorr = y_co - XYZ_star(2)

  rcorr = dsqrt(xcorr**2.d0 + ycorr**2.d0)
  if (rcorr.lt.R_star) then
    z_co = XYZ_star(3) + R_star
    do i = 1,nlevels
      call black_body(T_star,nu0(i),I_in(i))
    end do
  endif
endif

start(1) = x_co
start(2) = y_co
start(3) = z_co

in_sim     = 0
k_cur      = 0
node_count = 0

!find the nearest node for the starting position
!unfortunately, we will have to check every node
rsave = 10.d0

do i = 1,tot_node
  r = norm2(start(:)-X_all(:,i))
  if (r.lt.rsave) then
    rsave = r
    node = i
  endif
end do

node_save = node

!photon start is the node position
X_phot(:) = start

do while (in_sim.eq.0)
!evolve photon position
  X_phot(:) = X_phot(:) + dx * dir(:)
  k_cur = k_cur + 1

  if (norm2(X_phot).gt.1.d0) then
    node_count = node_count + 1
    in_sim=1
    depth_list(2,node_count) = k_cur
    depth_list(1,node_count) = node
  endif

  neigh_num = neigh_list(node)

  call check_neigh(X_phot,node,X_all(:,node),neigh_num,NN(node,1:neigh_num),X_all(:,NN(node,1:neigh_num)),new_node)

!  write(*,*)'iii'
  if (new_node.ne.node) then
    node_count = node_count + 1

!how long did the photon stay with the n'th (node_count) node for
!what is the new node -- save this information for the output
    depth_list(2,node_count) = k_cur
    depth_list(1,node_count) = new_node
    node = new_node
  endif
end do

if (node_count.gt.n_depth_rt) then
  write(*,*)'node_count=',node_count,'while n_depth_rt=',n_depth_rt
  write(*,*)'adjust n_depth_rt parameter! Make it bigger.'
  stop
endif

node = node_save

end subroutine

subroutine ray_in_raytrace(vel_obs,node_count,pol_rayt_list,b_list,bvec_list,&
&dust_dens,alpha,kd,bb_list,vel_list,length_list,dx,nu0,I_in,I_out,Q_out,U_out,tau,&
&I_dust,Q_dust,U_dust,tau_dust)
!using the ray-trace list of all the nodes with associated distances,
!using information about these nodes (temp,vel) and the earlier computed
!polariztion parameters to ray-trace through the simulation
implicit none
integer node,node_count,g1,g2,i

integer, dimension(node_count) :: length_list

double precision I_in,I_out,Q_in,Q_out,U_in,U_out,dx,nu0
double precision v_corr,vel_obs,delta_x,I_corr,kd
double precision eta_I,eta_Q,eps_I,eps_Q,tau,cnu
double precision I_dust,Q_dust_in,Q_dust_out,U_dust_in,U_dust_out
double precision sig_dust_0,sig_dust_2,mu,mu2,sI,sQ,I_bb,e_dust
double precision tau_dust,tau_dust_tot,alpha,Q_dust,U_dust
double precision phi,q_phi_rot,u_phi_rot

double precision, dimension(node_count) :: bb_list,vel_list,b_list,dust_dens
double precision, dimension(3,node_count) :: bvec_list
double precision, dimension(4,node_count) :: pol_rayt_list

!input
!vel_obs        --- velocity of observation
!node_count     --- number of nodes passed in inward tracing
!pol_rayt_list  --- list of polarization coefficients
!b_list         --- list with (mass weighed) temperatures inward tracing nodes
!bvec_list      --- list of magnetic field vectors
!vel_list       --- list with velocities of inward tracing nodes
!length_list    --- list with lengths (in steps) spent in each node
!dx             --- distance weighing of length_list (dx * steps = length)
!nu0            --- central line-frequency
!I_in           --- incoming Stokes I
!Q_in           --- incoming Stokes Q
!U_in           --- incoming Stokes U

!output:
!I_out           --- outgoing Stokes I
!Q_out           --- outgoing Stokes Q
!U_out           --- outgoing Stokes U

cnu = 2.99792E8 / nu0

I_out = I_in
Q_in = 0.d0
U_in = 0.d0
tau = 0.d0
tau_dust_tot = 0.d0

I_dust = I_in
sig_dust_0 = 0.d0
sig_dust_2 = 0.d0
Q_dust_in = 0.d0
U_dust_in = 0.d0

do i = 1,node_count-1
!correct for the velocity-shift --- Maxwell-Boltzmann distribution from the Temperature
!temperature is in fact a temperature that is weighed already over particle size
  v_corr = (1.d0/(b_list(i)*dsqrt(dacos(-1.d0))))*dexp((-(vel_obs - vel_list(i))**2.d0)/(b_list(i)**2.d0))

!rotate Q and U parameters from the global axis system
!to the node axis system
  call rot_stokes(Q_in,U_in,Q_out,U_out,bvec_list(:,i))
!  call rot_stokes(Q_dust_in,U_dust_in,Q_dust_out,U_dust_out,bvec_list(:,i))

  mu = bvec_list(3,i)
  mu2 = 1.d0 - mu * mu          !gamma = angle of B with plane of the sky

!we have already computed the propagation parameters
  eta_I = cnu * v_corr * pol_rayt_list(1,i)
  eta_Q = cnu * v_corr * pol_rayt_list(2,i)
  eps_I = cnu * v_corr * pol_rayt_list(3,i)
  eps_Q = cnu * v_corr * pol_rayt_list(4,i)

!add the dust part

!compute the optical depth for this cell-path
  delta_x = dx * (length_list(i+1) - length_list(i))
!now propagate
  if (delta_x*eta_I.gt.1D-30) then       !if not, don't even bother -- will result in NaN
  !source function

    call polarize_prop(eta_I,eta_Q,eps_I,eps_Q,delta_x,I_out,Q_out,U_out)
    tau = tau + eta_I * delta_x

  endif

  tau_dust = kd * dust_dens(i) * delta_x
  if (tau_dust.gt.1D-30) then
    call black_body(bb_list(i),nu0,I_bb)

    e_dust = dexp(-tau_dust)

    sI = 0.5d0 * alpha * (mu2 - 2.d0 / 3.d0 )
    sQ = alpha * mu2

    I_dust = I_dust*e_dust + I_bb*(1-e_dust)
    sig_dust_0 = sig_dust_0*e_dust + I_bb*(1-e_dust)
    sig_dust_2 = sig_dust_2*e_dust + sI*I_bb*(1-e_dust)

    phi = dacos(bvec_list(2,i)/dsqrt(bvec_list(1,i)**2.d0 + bvec_list(2,i)**2.d0))
    if (bvec_list(1,i).lt.0.d0) phi = -phi

    q_phi_rot = dcos(2.d0 * phi)
    u_phi_rot = dsin(2.d0 * phi)

    Q_dust_in = Q_dust_in*e_dust + sQ*I_bb*(1-e_dust) * q_phi_rot
    U_dust_in = U_dust_in*e_dust + sQ*I_bb*(1-e_dust) * u_phi_rot
    tau_dust_tot = tau_dust_tot + tau_dust
  endif

!  write(*,*)i,eta_I,eta_I*delta_x
!rotate the Q and U parameters from the node axis system
!to the global axis system
  call rot_stokes_back(Q_out,U_out,Q_in,U_in,bvec_list(:,i))
!  call rot_stokes_back(Q_dust_out,U_dust_out,Q_dust_in,U_dust_in,bvec_list(:,i))

end do

!correct for the black-body background radiation.
call black_body(2.73d0,nu0,I_corr)

I_out = I_out - I_corr
Q_out = Q_in
U_out = U_in

I_dust = I_dust - I_corr
if (I_dust.eq.0.d0) then
  Q_dust = 0.d0
  U_dust = 0.d0
  tau_dust = 0.d0
else
  Q_dust = I_dust * Q_dust_in/(sig_dust_0 - sig_dust_2)
  U_dust = I_dust * U_dust_in/(sig_dust_0 - sig_dust_2)
  tau_dust = tau_dust_tot
endif
!convert to temperature units?

!write(*,*)I_out,Q_out,U_out
!write(*,*)I_dust,Q_dust,U_dust

end subroutine


!
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!  .                                                             .
!  .                  copyright (c) 1998 by UCAR                 .
!  .                                                             .
!  .       University Corporation for Atmospheric Research       .
!  .                                                             .
!  .                      all rights reserved                    .
!  .                                                             .
!  .                                                             .
!  .                          SPHEREPACK                         .
!  .                                                             .
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!
!
!
! ... file advec.f
!
!     program advec solves the time-dependent linear advection
!     equation for geopotential phi using the SPHEREPACK software
!
!          d(phi)/dt = -(u, v) DOT gradient(phi)
!
!                    = -(u*gdphl + v*gdpht)
!
! ... required files
!
!     gradgc.f, shagc.f, shsgc.f, vhsgc.f, sphcom.f hrfft.f, gaqd.f
!
!
! definitions:
!
!
!     nlat          number of gaussian latitudes excluding poles
!     nlon          number of distinct longitudes
!     omega         rotation rate of earth in radians per second
!     alpha         angle between axis of rotation and the coordinate
!                   axis
!     beta          latitude of the cosine bell
!     aa            radius of earth in meters
!     ncycle        cycle number
!     time          model time in seconds
!     dt            time step
!     lambda        longitude
!     theta         latitude
!
!   the first dimension of the following two dimensional arrays
!   corresponds to the latitude index with values i=1, ..., nlat
!   where i=1 is the northern most gaussian point thetag(i)
!   and i=nlat is the southern most gaussian point thetag(nlat).
!   the second dimension is longitude with values j=1, ..., nlon
!   where j=1 corresponds to zero longitude and j=nlon corresponds
!   to 2pi minus 2pi/nlon.
!
!
!     thetag(i)    vector of gaussian points on the full sphere which
!                  have north to south orientation as i=1, ..., nlat
!
!     u(i, j)       east longitudinal velocity component
!     v(i, j)       latitudinal velocity component
!
!     phi(i, j)     the geopotential at t = time
!
!     phnew(i, j)   the geopotential at t=time+dt
!
!     phold(i, j)   the geopotential at t=time-dt
!
!     gdphl(i, j)   the longitudinal derivative component of
!                  the gradient of phi
!
!                       gdphl = 1/(cos(theta))*d(phi)/dlambda

!
!     gdpht(i, j)   the latitudinal derivative component of
!                  the gradient of phi
!
!                       gdpht = d(phi)/dtheta

!
!   the following two dimensional arrays are nonzero in the triangle
!   n=1, ..., nlat and m less than or equal to n.
!
!     ar(m, n), br(m, n)    spectral coefficients of phi
!
program advec
    use spherepack
    implicit none
    real(wp) :: alpha
    real(wp) :: alphad
    real(wp) :: beta
    real(wp) :: ca
    real(wp) :: cl
    real(wp) :: clh
    real(wp) :: ct
    real(wp) :: cth
    real(wp) :: cthclh
    real(wp) :: cthslh
    real(wp) :: ddt
    real(wp) :: dlon
    real(wp) :: dt
    real(wp) :: err2
    real(wp) :: errm
    real(wp) :: error
    real(wp) :: htime
    real(wp) :: hzero
    integer(ip) :: i
    integer(ip) :: ier
    integer(ip) :: ierror
    integer(ip) :: isym
    integer(ip) :: j
    integer(ip) :: k
    integer(ip) :: mprint
    integer(ip) :: ncycle
    integer(ip) :: nt
    integer(ip) :: ntime
    real(wp) :: omega
    real(wp) :: p0
    real(wp) :: p2

    real(wp) :: pmax
    real(wp) :: re
    real(wp) :: sa
    real(wp) :: sl
    real(wp) :: slh
    real(wp) :: st
    real(wp) :: sth
    real(wp) :: tdt
    real(wp) :: time
    real(wp) :: uhat
    real(wp) :: xlhat
    real(wp) :: xlm
    !
    !     set grid size with parameter statements
    !
    integer nnlat, nnlon, nn15, llwork, lldwork, llvhsgc, llshagc
    integer nlat, nlon, lwork, ldwork, lvhsgc, lshagc

    !     parameter (nnlat=12, nnlon=23, ddt=1200.)
    parameter (nnlat=23, nnlon=45, ddt=600.)
    !     parameter (nnlat=45, nnlon=90, ddt=300.)
    !
    !     set saved and unsaved workspace lengths in terms of nnlat, nnlon
    !     (see documentation for shagc, vhsgc, vhsgci, gradgc for estimates)
    !
    parameter (nn15=nnlon+15)
    parameter(llwork=4*nnlat*nnlon+2*nnlat*(nnlat+1))
    parameter (lldwork = 2*nnlat*(nnlat+1)+1)
    parameter (llvhsgc = 7*nnlat*nnlat+nnlon+15)
    parameter (llshagc = 5*nnlat*nnlat + nnlon+15)
    !
    !     dimension arrays
    !
    real u(nnlat, nnlon), v(nnlat, nnlon)
    real phold(nnlat, nnlon), phnew(nnlat, nnlon), phi(nnlat, nnlon)
    real pexact(nnlat, nnlon)
    real dpdt(nnlat, nnlon)
    real gdphl(nnlat, nnlon), gdpht(nnlat, nnlon), work(llwork)

    real wshagc(llshagc), wvhsgc(llvhsgc), wshsgc(llshagc)
    real ar(nnlat, nnlat), br(nnlat, nnlat)
    real thetag(nnlat), colat(nnlat)
    real dtheta(nnlat), dwts(nnlat)
    !
    !     set constants
    !
    omega = (pi+pi)/(12.*24.*3600.)
    p0 = 1000.
    re = 1.0/3.0
    hzero = 1000.
    alphad = 60.
    alpha = pi*alphad/180.
    beta = pi/6.
    !
    !     set one array and no equatorial symmetry
    !
    nt = 1
    isym = 0
    !
    !     set time step depending on resolution
    !
    dt = ddt
    tdt = dt+dt
    !
    !     set workspace length arguments
    !
    lwork = llwork
    ldwork = lldwork
    lshagc = llshagc
    lvhsgc = llvhsgc
    !
    !     set grid size arguments
    !
    nlat = nnlat
    nlon = nnlon
    !
    !     compute nlat latitudinal gaussian points in thetag  with
    !     north to south orientation using gaqd from SPHEREPACK
    !
    call compute_gaussian_latitudes_and_weights(nlat, dtheta, dwts, ier)
    do  i=1, nlat
        thetag(i) = 0.5*pi- dtheta(i)
        colat(i) = dtheta(i)
    end do
    !
    !     preset saved workspaces for gradgc and shagc and shsgc
    !
    call vhsgci(nlat, nlon, wvhsgc, ierror)
    if(ierror /= 0) write (*, 10) ierror
10  format(' error in vsgci = ', i5)
    call shagci(nlat, nlon, wshagc, ierror)
    if(ierror /= 0) write (*, 20) ierror
20  format(' error in shagci = ', i5)
    call shsgci(nlat, nlon, wshsgc, ierror)
    if(ierror /= 0) write (*, 21) ierror
21  format(' error in shsgci = ', i5)
    !
    !     set vector velocities and cosine bell in geopotential
    !
    ca = cos(alpha)
    sa = sin(alpha)
    dlon = (pi+pi)/nlon
    do j=1, nlon
        xlm = (j-1)*dlon
        sl = sin(xlm)
        cl = cos(xlm)
        do i=1, nlat
            st = cos(colat(i))
            ct = sin(colat(i))
            sth = ca*st+sa*ct*cl
            cthclh = ca*ct*cl-sa*st
            cthslh = ct*sl
            xlhat = atanxy(cthclh, cthslh)
            clh = cos(xlhat)
            slh = sin(xlhat)
            cth = clh*cthclh+slh*cthslh
            uhat = omega*cth
            u(i, j) = (ca*sl*slh+cl*clh)*uhat
            v(i, j) = (ca*st*cl*slh-st*sl*clh+sa*ct*slh)*uhat
        end do
    end do
    !
    !       compute geopotential at t=-dt in phold and at t=0.0 in phi
    !       to start up leapfrog scheme
    !
    call gpot(-dt, alpha, beta, omega, hzero, re, nlat, nlon, &
        nlat, colat, phold)
    call gpot(0., alpha, beta, omega, hzero, re, nlat, nlon, &
        nlat, colat, phi)
    !
    !     smooth geopotential at t=-dt and t=0. by synthesizing after analysis
    !
    call shagc(nlat, nlon, isym, nt, phold, nlat, nlon, ar, br, nlat, &
        nlat, wshagc, ierror)
    if ( ierror /=0) write (*, 26) ierror
    call shsgc(nlat, nlon, isym, nt, phold, nlat, nlon, ar, br, nlat, &
        nlat, wshsgc, ierror)
    if ( ierror /=0) write (*, 28) ierror
    call shagc(nlat, nlon, isym, nt, phi, nlat, nlon, ar, br, nlat, &
        nlat, wshagc, ierror)
    if ( ierror /=0) write (*, 26) ierror
    call shsgc(nlat, nlon, isym, nt, phi, nlat, nlon, ar, br, nlat, &
        nlat, wshsgc, ierror)
    if ( ierror /=0) write (*, 28) ierror
28  format(' ierror in shsgc = ', i5)
    !
    !     compute l2 and max norms of geopotential at t=0.
    !
    p2 = 0.0
    pmax = 0.0
    do j=1, nlon
        do i=1, nlat
            pmax = amax1(abs(phi(i, j)), pmax)
            p2 = p2 + phi(i, j)**2
        end do
    end do
    p2 = sqrt(p2)
    !
    !     set number of time steps for 12 days
    !     (time to circumvent the earth)
    !
    ntime = int((12.*24.*3600.)/dt+0.5)
    mprint = ntime/12
    time = 0.0
    ncycle = 0
    do k=1, ntime+1
        !
        !       compute harmonic coefficients for phi at current time
        !
        call shagc(nlat, nlon, isym, nt, phi, nlat, nlon, ar, br, nlat, &
            nlat, wshagc, ierror)
        if ( error /=0) write (*, 26) ierror
26      format(' ierror in shagc = ', i5)
        !
        !       compute gradient of phi at current time
        !
        call gradgc(nlat, nlon, isym, nt, gdpht, gdphl, nlat, nlon, ar, br, &
            nlat, nlat, wvhsgc, ierror)
        if ( error /=0) write (*, 27) ierror
27      format(' ierror in gradgc = ', i5)
                !
                !       compute the time derivative of phi, note that the sign
                !       of the last term is positive because the gradient is
                !       computed with respect to colatitude rather than latitude.
                !
        do j=1, nlon
            do i=1, nlat
                dpdt(i, j) = -u(i, j)*gdphl(i, j) + v(i, j)*gdpht(i, j)
            end do
        end do
        !
        if (mod(ncycle, mprint) == 0) then
            !
            !     write variables
            !
            err2 = 0.0
            errm = 0.0
            call gpot(time, alpha, beta, omega, hzero, re, nlat, nlon, nlat, &
                colat, pexact)
            do j=1, nlon
                do i=1, nlat
                    err2 = err2 + (pexact(i, j)-phi(i, j))**2
                    errm = amax1(abs(pexact(i, j)-phi(i, j)), errm)
                end do
            end do
            errm = errm/pmax
            err2 = sqrt(err2)/p2
            htime = time/3600.
            write (*, 390) ncycle, htime, dt, nlat, nlon, omega, hzero, &
                alphad, errm, err2
390         format(//' advecting cosine bell, test case 2', / &
                , ' cycle number              ', i10 &
                , ' model time in  hours      ', f10.2/ &
                , ' time step in seconds      ', f10.0 &
                , ' number of latitudes       ', i10/ &
                , ' number of longitudes      ', i10 &
                , ' rotation rate        ', 1pe15.6/ &
                , ' mean height          ', 1pe15.6 &
                , ' tilt angle                ', 0pf10.2/ &
                , ' max geopot. error    ', 1pe15.6 &
                , ' RMS geopot. error    ', 1pe15.6)

        end if
        time = time + dt
        ncycle = ncycle+1
            !
            !       update phold, phi for next time step
            !
        do j=1, nlon
            do i=1, nlat
                phnew(i, j) = phold(i, j) + tdt*dpdt(i, j)
                phold(i, j) = phi(i, j)
                phi(i, j) = phnew(i, j)
            end do
        end do
    !
    !     end of time loop
    !
    end do

contains

    subroutine gpot(t, alpha, beta, omega, hzero, re, nlat, nlon, idim, &
        colat, h)
        implicit none
        real(wp) :: alpha
        real(wp) :: beta
        real(wp) :: ca
        real(wp) :: cl
        real(wp) :: clh
        real(wp) :: colat
        real(wp) :: ct
        real(wp) :: cth
        real(wp) :: cthclh
        real(wp) :: cthslh
        real(wp) :: dist
        real(wp) :: dlon
        real(wp) :: h
        real(wp) :: hzero
        integer(ip) :: i
        integer(ip) :: idim
        integer(ip) :: j
        integer(ip) :: nlat
        integer(ip) :: nlon
        real(wp) :: omega
        real(wp) :: pi
        real(wp) :: r
        real(wp) :: re
        real(wp) :: sa
        real(wp) :: sl
        real(wp) :: slh
        real(wp) :: st
        real(wp) :: sth
        real(wp) :: t
        real(wp) :: that
        real(wp) :: theta
        real(wp) :: tpi
        real(wp) :: x1
        real(wp) :: xc
        real(wp) :: y1
        real(wp) :: yc
        real(wp) :: z1
        real(wp) :: zc
        !
        !     computes advecting cosine bell on a tilted grid a time t.
        !
        ! input parameters
        !
        !     t      time in seconds
        !
        !     alpha  tilt angle in radians
        !
        !     beta   colatitude of cosine bell in untilted coordinate
        !            system in radians
        !
        !     omega  angular velocity in radians per second
        !
        !     hzero  maximum value of cosine bell
        !
        !     re     radius of support for cosine bell in radians
        !
        !     nlat   number of latitudes including the poles
        !
        !     nlon   number of distinct longitude lines
        !
        !     idim   first dimension of output array h
        !
        !     colat  vector of Gauss colatitude grid points
        !
        ! output parameter
        !
        !     h      an nlat by nlon array containing the geopotential
        !
        !             on a tilted grid
        !
        dimension h(idim, nlon), colat(nlat)
        real lambda, lambdc, lhat
        lambdc = omega*t
        call stoc(1., beta, lambdc, xc, yc, zc)
        ca = cos(alpha)
        sa = sin(alpha)
        pi = 4.*atan(1.)
        tpi = pi+pi
        dlon = tpi/nlon
        do 10 j=1, nlon
            lambda = (j-1)*dlon
            cl = cos(lambda)
            sl = sin(lambda)
            do 10 i=1, nlat
                theta = colat(i)
                st = cos(theta)
                ct = sin(theta)
                sth = ca*st+sa*ct*cl
                cthclh = ca*ct*cl-sa*st
                cthslh = ct*sl
                lhat = atanxy(cthclh, cthslh)
                clh = cos(lhat)
                slh = sin(lhat)
                cth = clh*cthclh+slh*cthslh
                that = atanxy(sth, cth)
                call stoc(1., that, lhat, x1, y1, z1)
                dist = sqrt((x1-xc)**2+(y1-yc)**2 &
                    +(z1-zc)**2)
                h(i, j) = 0.
                if(dist >= re) go to 10
                r = 2.*asin(dist/2.)
                if(r >= re) go to 10
                h(i, j) = hzero*.5*(cos(r*pi/re)+1.)
10          continue

        end subroutine gpot

        real function atanxy(x, y)
            implicit none
            real(wp) :: x
            real(wp) :: y
            atanxy = 0.
            if(x==0. .and. y==0.) return
            atanxy = atan2(y, x)

        end function atanxy

        subroutine ctos(x, y, z, r, theta, phi)
            implicit none
            real(wp) :: phi
            real(wp) :: r
            real(wp) :: r1
            real(wp) :: theta
            real(wp) :: x
            real(wp) :: y
            real(wp) :: z
            r1 = x*x+y*y
            if(r1 /= 0.) go to 10
            phi = 0.
            theta = 0.
            if(z < 0.) theta = 4.*atan(1.)
            return
10          r = sqrt(r1+z*z)
            r1 = sqrt(r1)
            phi = atan2(y, x)
            theta = atan2(r1, z)

        end subroutine ctos

        subroutine stoc(r, theta, phi, x, y, z)
            implicit none
            real(wp) :: phi
            real(wp) :: r
            real(wp) :: st
            real(wp) :: theta
            real(wp) :: x
            real(wp) :: y
            real(wp) :: z
            st = sin(theta)
            x = r*st*cos(phi)
            y = r*st*sin(phi)
            z = r*cos(theta)

        end subroutine stoc

    end program advec


c     # ------------------------------------------------------------
c     # Streamfunction, velocity components and derivatives
c     #
c     # Stream function depends on these global variables
c     #         example (0=incompressible; 1=compressible)
c     #         mapping (0=torus; 1=twisted torus)
c     # ------------------------------------------------------------
      double precision function torus_psi(x,y)
      implicit none

      double precision x, y

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision alpha, beta
      common /torus_comm/ alpha, beta

      double precision revs_per_s
      common /stream_comm/ revs_per_s

      double precision psi

      if (beta .ne. 0) then
          write(6,'(A,A)') 'psi (psi.f) : Streamfunction only works ',
     &         'for beta == 0'
          stop 'error'
      endif

      psi = pi2*revs_per_s*alpha*(pi2*y + alpha*sin(pi2*y))

      torus_psi = psi

      end

c     =================================================
c     This is called by compute_velocity_psi or
c     compute_velocity_psi_nomap
c     =================================================
      subroutine get_psi_vel(xd1,xd2,ds,vn,t)
      implicit none

      double precision xd1(3),xd2(3), ds, vn, torus_psi,t

      vn = (torus_psi(xd1(1),xd1(2)) -
     &      torus_psi(xd2(1),xd2(2)))/ds

      end

      subroutine torus_psi_derivs(x,y,p,px,py)
      implicit none

      double precision x, y
      double precision p, px, py

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision alpha, beta
      common /torus_comm/ alpha,beta

      double precision revs_per_s
      common /stream_comm/ revs_per_s

      if (beta .ne. 0) then
          write(6,'(A,A)') 'psi (psi.f) : Streamfunction only works ',
     &         'for beta == 0'
          stop 'error'
      endif

c     # Stream function for rigid body rotation.
      p = (pi2*revs_per_s)*alpha*(pi2*y + alpha*sin(pi2*y))
      px = 0
      py = (pi2)**2*revs_per_s*alpha*(1 + alpha*cos(pi2*y))

      end

      subroutine torus_velocity_components(x,y,u)
      implicit none

      double precision x, y, u(2)

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision revs_per_s
      common /stream_comm/ revs_per_s

      integer example
      common /example_comm/ example

      if (example .eq. 0) then
          u(1) = revs_per_s
          u(2) = 0
      elseif (example .eq. 1) then
           u(1) = 0
           u(2) = 1
      endif

      end

      subroutine torus_basis_complete(x,y, t, tinv,tderivs, flag)
      implicit none

      double precision x,y
      integer flag
      double precision t(3,2), tinv(3,2), tderivs(3,2,2)

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision alpha, beta
      common /torus_comm/ alpha, beta

      double precision r1, r1x, r1xx, r1y, r1yy, r1xy
      double precision R,  Rx,  Rxx,  Ry,  Ryy,  Rxy
      double precision f(3), fx(3), fy(3), fxx(3), fyy(3), fxy(3)
      double precision g(3), gx(3), gy(3), gxx(3), gyy(3), gxy(3)
      double precision t1(3), t2(3), a11, a12, a22, a21
      double precision det, a11inv, a22inv, a12inv, a21inv
      double precision pi4
      double precision torus_dot

      integer k, i
      logical compute_covariant, compute_contravariant
      logical compute_derivatives, b(32)

      if (flag > 7) then
          write(6,*) 'psi.f : flag > 7'
          stop 'error'
      endif

c     # flag = 0      NA
c     # flag = 1      Covariant basis only
c     # flag = 2      NA
c     # flag = 3      Covariant + contravariant basis
c     # flag = 4      Derivatives only
c     # flag = 5      Derivatives + covariant basis
c     # flag = 6      NA
c     # flag = 7      Covariant + contravariant + derivatives

      do i = 1,bit_size(flag)
          b(i) = btest(flag,i-1)
      enddo

      compute_covariant     = b(1) .or. b(2)
      compute_contravariant = b(2)
      compute_derivatives   = b(3)

      pi4 = pi2*pi2

c     # Torus mapping
c     #
c     #    r1 = alpha*(1 + beta*sin(pi2*x))
c     #    R = 1 + r1*cos(pi2*y)
c     #
c     #    xp =  R*cos(pi2*x)
c     #    yp =  R*sin(pi2*x)
c     #    zp = r1*sin(pi2*y)
c     #
c     #  Express X,Y,Z as
c     #
c     #     X(x,y) = g(x,y)*f(x,y) == g(1)*f(1)
c     #     Y(x,y) = g(x,y)*f(x,y) == g(2)*f(2)
c     #     Z(x,y) = g(x,y)*f(x,y) == g(3)*f(3)
c     #
c     # Compute derivatives and use product rule to get higher order
c     # derivatives, i.e.
c     #
c     #     dX/dx = g(1)*fx(1) + gx(1)*f(1)
c     #     dY/dx = g(2)*fx(2) + gx(2)*f(2)
c     #     dZ/dx = g(3)*fx(3) + gx(3)*f(3)
c     #

      r1    = alpha*(1 + beta*sin(pi2*x))
      r1x   = pi2*alpha*beta*cos(pi2*x)
      r1xx  = -pi4*alpha*beta*sin(pi2*x)
      r1y = 0
      r1yy = 0
      r1xy = 0

      R     = 1 +   r1*cos(pi2*y)
      Rx    =      r1x*cos(pi2*y)
      Rxx   =     r1xx*cos(pi2*y)
      Ry    =  -pi2*r1*sin(pi2*y)
      Ryy   =  -pi4*r1*cos(pi2*y)
      Rxy   = -pi2*r1x*sin(pi2*y)

      f(1)  = cos(pi2*x);
      fx(1) = -pi2*sin(pi2*x)
      fy(1) = 0;

      f(2)  = sin(pi2*x);
      fx(2) = pi2*cos(pi2*x)
      fy(2) = 0;

      f(3)  = sin(pi2*y);
      fx(3) = 0;
      fy(3) = pi2*cos(pi2*y);

      g(1)  = R
      g(2)  = R
      g(3)  = r1

      gx(1) = Rx
      gx(2) = Rx
      gx(3) = r1x

      gy(1) = Ry
      gy(2) = Ry
      gy(3) = r1y

      if (compute_covariant) then
          do k = 1,3
              t(k,1) = gx(k)*f(k) + g(k)*fx(k);
              t(k,2) = gy(k)*f(k) + g(k)*fy(k);
          enddo
      endif

      if (compute_contravariant) then
          do k = 1,3
              t1(k) = t(k,1)
              t2(k) = t(k,2)
          enddo

c         # Compute grad psi(xi,eta)
          a11 = torus_dot(t1,t1)
          a22 = torus_dot(t2,t2)
          a12 = torus_dot(t1,t2)
          a21 = a12

c         # Determinant
          det = a11*a22 - a12*a21

c         # Contravariant vectors
          a11inv = a22/det
          a22inv = a11/det
          a12inv = -a12/det
          a21inv = -a21/det
          do k = 1,3
              tinv(k,1) = a11inv*t(k,1) + a12inv*t(k,2)
              tinv(k,2) = a21inv*t(k,1) + a22inv*t(k,2)
          end do
      endif

      if (compute_derivatives) then
          fxx(1) = -pi4*cos(pi2*x)
          fyy(1) = 0;
          fxy(1) = 0;

          fxx(2) = -pi4*sin(pi2*x)
          fyy(2) = 0;
          fxy(2) = 0;

          fxx(3) = 0;
          fxy(3) = 0;
          fyy(3) = -pi4*sin(pi2*y)

          gxx(1) = Rxx
          gxx(2) = Rxx
          gxx(3) = r1xx

          gyy(1) = Ryy
          gyy(2) = Ryy
          gyy(3) = r1yy

          gxy(1) = Rxy
          gxy(2) = Rxy
          gxy(3) = r1xy

          do k = 1,3
c             # d(t1)/dx = d(g*fx + gx*f)/dx
              tderivs(k,1,1) = g(k)*fxx(k) + 2*fx(k)*gx(k) + gxx(k)*f(k)

c             # d(t1)/dy = d(g*fx + gx*f)/dy
              tderivs(k,1,2) = g(k)*fxy(k) + gy(k)*fx(k) +
     &                    gx(k)*fy(k) + gxy(k)*f(k)

c             # d(t2)/dx = d(g*fy + gy*f)/dx
              tderivs(k,2,1) = g(k)*fxy(k) + gx(k)*fy(k) +
     &                    gy(k)*fx(k) + gxy(k)*f(k)

c             # d(t2)/dy = d(g*fy + gy*f)/dy
              tderivs(k,2,2) = g(k)*fyy(k) + 2*fy(k)*gy(k) + gyy(k)*f(k)
          enddo
      endif

      end


!> Simple program to test the timing API
PROGRAM timer_test
  use dl_timer

  integer, parameter :: r_def = KIND(1.0d0)

  integer :: time0
  integer :: istep
  integer, parameter :: nstep = 1000

  real(r_def) :: mysum
  !--------------------------------------------------------------
  ! Initialisation

  call timer_init()
  mysum = 0.0d0

  !--------------------------------------------------------------
  ! Time-stepping

  call timer_start(time0, label='Time-stepping')

  do istep = 1, nstep
     mysum = mysum + sqrt(5.0d0*istep*istep)
  end do

  call timer_stop(time0)

  !---------------------------------------------------------------
  ! Finalise

  ! Output the result to prevent the compiler optimising-out the loop
  write (*,*) 'Fake checksum = ', mysum

  call timer_report()

END PROGRAM timer_test


    MODULE cdf_nc_t_mod
! ----------------------------------------------------------------------

!                               cdf_nc_t_mod
!                               *=*=*=*=*=*=

!  -  SUBROUTINE CDF_NC_T(WHICH, CUM, CCUM, T, DF, PNONC, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CUM_NC_T(T,  DF, PNONC, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CCUM_NC_T(T, DF, PNONC, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION INV__NC_T(CUM, CCUM, DF, PNONC,STATUS,CHECK_INPUT)

!                             The Distribution
!                             ================

!   The noncentral T is the distribution of the ratio of two independent
!   random variables. The numerator random variable is distributed as a
!   normal distribution with mean PNONC and variance 1. The denominator
!   random variable is distributed as a the square root of a (central)
!   chi-squared with DF degrees of freedom divided by DF.

!                                Arguments
!                                =========

!  - INTEGER, INTENT(IN) :: WHICH. Integer indicating which of the next
!    arguments is to be calculated.
!  Input Range: [ 1:4 ]
!     1.  CUM and CCUM
!     2.  T
!     3.  DF
!     4.  PNONC
!  - REAL (dpkind), OPTIONAL :: CUM. The CDF of the noncentral t
!    distribution.
!  Range: [ 10^-10:1-10^-10 ]
!  - REAL (dpkind), OPTIONAL :: CCUM. One minus the CDF of the noncentral
!    t distribution.
!  Range: [ 10^-10:1-10^-10 ]
!  - REAL (dpkind) :: T. The upper limit of integration of the noncentral
!    t density. The lower limit is -oo.
!  Range: [ -10^100:10^100 ]
!  - REAL (dpkind) :: DF. The degrees of freedom.
!  Range: [ 10^-3:10^10 ]
!  - REAL (dpkind) :: PNONC. The noncentrality parameter.
!  Range: [ 0:10^4 ]
!  - INTEGER, OPTIONAL, INTENT(OUT) :: STATUS. Return code. Possible values:
!      0 Problem solved successfully
!     -1 WHICH outside input range
!     -2 CUM outside range
!     -3 CCUM outside range
!     -4 T outside range
!     -5 DF outside range
!     -6 PNONC outside range
!      3 CUM + CCUM is not nearly one
!     10 can not solve cdf_t or cdf_beta in local_cum_nc_t
!    -50 Answer (if any) is below the lower search bound
!     50 Answer (if any) is above the upper search bound
!  - LOGICAL, INTENT(IN), OPTIONAL :: CHECK_INPUT. If PRESENT and .TRUE.
!    input argument values are not checked for validity.
! ----------------------------------------------------------------------
! .. Use Statements ..
      USE biomath_constants_mod
! ..
! .. Default Accessibility ..
      PRIVATE
! ..
! .. Public Statements ..
      PUBLIC :: ccum_nc_t, cdf_nc_t, cum_nc_t, inv_nc_t
! ..
    CONTAINS

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

      FUNCTION ccum_nc_t(t,df,pnonc,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: ccum_nc_t
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: df, pnonc, t
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_nc_t(which=1,ccum=ccum_nc_t,t=t,df=df,pnonc=pnonc, &
          status=status,check_input=check_input)

        RETURN

      END FUNCTION ccum_nc_t

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

      SUBROUTINE cdf_nc_t(which,cum,ccum,t,df,pnonc,status,check_input)
! .. Use Statements ..
        USE cdf_aux_mod
        USE zero_finder
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: ccum, cum
        REAL (dpkind) :: df, pnonc, t
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        INTEGER, INTENT (IN) :: which
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
! .. Local Structures ..
! .. Local Arrays
        TYPE (zf_locals) :: local
! ..
! .. Local Scalars ..
        REAL (dpkind) :: fx, local_ccum, local_cum, try_ccum, try_cum
        INTEGER :: zf_status
        LOGICAL :: has_status, local_check_input, match_cum
! ..
! .. Intrinsic Functions ..
        INTRINSIC PRESENT
! ..
! .. Local Arrays ..
        REAL (dpkind) :: params(6)
! ..
        has_status = PRESENT(status)

! status = 0 means NO error

        IF (has_status) THEN
          status = 0
        END IF

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

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

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

        params(1) = local_cum
        params(2) = local_ccum
        params(3) = t
        params(4) = df
        params(5) = pnonc

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

        IF (local_check_input) THEN
          CALL validate_parameters(the_non_central_t,which,params,status)

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

! ++++++++++          ++++++++++          ++++++++++
! Compute the Answers
! ++++++++++          ++++++++++          ++++++++++

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

        SELECT CASE (which)
        CASE (1)
! Solve for cumulative (cdf) value

          CALL local_cum_nc_t(t,df,pnonc,local_cum,local_ccum,status)

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

        CASE (2)

! Solve for t

! Start value for t:
          t = five
          zf_status = 0

          CALL cdf_set_zero_finder(the_non_central_t,3,local)

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

            IF (zf_status/=1) EXIT

            CALL local_cum_nc_t(t,df,pnonc,try_cum,try_ccum,status)

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

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

          END DO

        CASE (3)
! Solve for F

! Start value for f:
          df = five
          zf_status = 0

          CALL cdf_set_zero_finder(the_non_central_t,4,local)

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

            IF (zf_status/=1) EXIT

            CALL local_cum_nc_t(t,df,pnonc,try_cum,try_ccum,status)

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

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

          END DO

        CASE (4)
! Start for the non-centrality parameter

! Start value for pnonc:
          pnonc = five
          zf_status = 0

          CALL cdf_set_zero_finder(the_non_central_t,5,local)

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

            IF (zf_status/=1) EXIT

            CALL local_cum_nc_t(t,df,pnonc,try_cum,try_ccum,status)

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

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

          END DO

        END SELECT

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

        RETURN

      END SUBROUTINE cdf_nc_t

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

      FUNCTION cum_nc_t(t,df,pnonc,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: cum_nc_t
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: df, pnonc, t
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_nc_t(which=1,cum=cum_nc_t,t=t,df=df,pnonc=pnonc, &
          status=status,check_input=check_input)

        RETURN

      END FUNCTION cum_nc_t

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

      FUNCTION inv_nc_t(cum,ccum,df,pnonc,status,check_input)
! Solves the INVERSE Poisson problem:
! Given cum (or/and ccum), and df, computes t.
! .. Function Return Value ..
        REAL (dpkind) :: inv_nc_t
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: ccum, cum
        REAL (dpkind), INTENT (IN) :: df, pnonc
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_nc_t(which=2,cum=cum,ccum=ccum,t=inv_nc_t,df=df, &
          pnonc=pnonc,status=status,check_input=check_input)

        RETURN

      END FUNCTION inv_nc_t

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

      SUBROUTINE local_cum_nc_t(t,df,pnonc,cum,ccum,status)
!----------------------------------------------------------------------

!                              Function

!     Upper tail    of  the  cumulative  noncentral t   using
!     formulae from page 532  of Johnson, Kotz,  Balakrishnan, Coninuous
!     Univariate Distributions, Vol 2, 2nd Edition.  Wiley (1995)
!     This implementation starts the calculation at i = lambda,
!     which is near the largest Di.  It then sums forward and backward.
!     t     --> Upper limit of integration of the t-density.
!     df    --> Degrees of freedom of the t-distribution
!     pnonc --> the non-centrality parameter
!     cum   <-- Cumulative t-distribution.
!     ccum  <-- Compliment of Cumulative t-distribution.
!     status <-- status of the computation.
!                Set to 10 if cdf_t or cdf_beta has no answer.

!                         Method

!     Formula  26.5.27  of   Abramowitz   and  Stegun,   Handbook   of
!     Mathematical Functions  (1966) is used to reduce the computation
!     of the cumulative distribution function to that of an incomplete
!     beta.
!------------------------------------------------------------------
! .. Use Statements ..
        USE biomath_mathlib_mod
        USE cdf_beta_mod
        USE cdf_normal_mod
        USE cdf_t_mod
! ..
! .. Parameters ..
        REAL (dpkind), PARAMETER :: conv = 1.0E-7_dpkind
        REAL (dpkind), PARAMETER :: onep5 = 1.5E0_dpkind
        REAL (dpkind), PARAMETER :: tiny = 1.0E-10_dpkind
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (OUT) :: ccum, cum
        REAL (dpkind), INTENT (IN) :: df, pnonc, t
        INTEGER, OPTIONAL, INTENT (OUT) :: status
! ..
! .. Local Scalars ..
        REAL (dpkind) :: alghdf, b, bb, bbcent, bcent, cent, d, dcent, &
          dpnonc, dum1, dum2, e, ecent, halfdf, lambda, lnomx, lnx, omx, &
          pnonc2, s, scent, ss, sscent, t2, term, tt, twoi, x, xi, xlnd, &
          xlne
        INTEGER :: local_status
        LOGICAL :: has_status, qrevs
! ..
! .. Intrinsic Functions ..
        INTRINSIC ABS, EXP, INT, LOG, MAX, MIN, PRESENT
! ..
        has_status = PRESENT(status)

! Case pnonc essentially zero

        IF (ABS(pnonc)<=tiny) THEN
          CALL cdf_t(1,cum,ccum,t,df,status=local_status)

          IF (local_status/=0) THEN
! cdf_t has NO answer.

            IF (has_status) THEN
              status = 10
            ELSE
              WRITE (*,*) 'Error in local_cum_nc_t call to cdf_t'
              WRITE (*,*) 'Status: ', local_status

              STOP 'Error in local_cum_nc_t call to cdf_t'

            END IF
          END IF

          RETURN
        END IF

        qrevs = (t<zero)
        IF (qrevs) THEN
          tt = -t
          dpnonc = -pnonc
        ELSE
          tt = t
          dpnonc = pnonc
        END IF

        pnonc2 = dpnonc*dpnonc
        t2 = tt*tt

        IF (ABS(tt)<=tiny) THEN
! NORMAL has NO errors (other than bounds -- but we checked)

          CALL cdf_normal(which=1,cum=cum,ccum=ccum,x=-pnonc)

          RETURN
        END IF

        lambda = half*pnonc2
        x = df/(df+t2)
        omx = one - x

        lnx = LOG(x)
        lnomx = LOG(omx)

        halfdf = half*df
        alghdf = gamln(halfdf)

! ***** Case i = lambda *****

        cent = INT(lambda)

        cent = MAX(one,cent)

! Compute d=T(2i) in log space and offset by exp(-lambda)

        xlnd = cent*LOG(lambda) - gamln(cent+one) - lambda

        dcent = EXP(xlnd)

! Compute e=t(2i+1) in log space offset by exp(-lambda)

        xlne = (cent+half)*LOG(lambda) - gamln(cent+onep5) - lambda
        ecent = EXP(xlne)

        IF (dpnonc<zero) ecent = -ecent

! Compute bcent=B(2*cent)

        CALL cdf_beta(which=1,cum=bcent,ccum=dum1,x=x,a=halfdf, &
          b=cent+half,check_input=.FALSE.,status=local_status)

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

          IF (PRESENT(status)) THEN
            status = 10

            RETURN
          ELSE
            WRITE (*,*) 'Error in local_cum_nc_t call to cdf_beta'
            WRITE (*,*) 'Status: ', local_status

            STOP 'Error in local_cum_nc_t call to cdf_beta'

          END IF
        END IF

! Compute bbcent=B(2*cent+1)

        CALL cdf_beta(which=1,cum=bbcent,ccum=dum2,x=x,a=halfdf, &
          b=cent+one,check_input=.FALSE.,status=local_status)

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

          IF (PRESENT(status)) THEN
            status = 10

            RETURN
          ELSE
            WRITE (*,*) 'Error in local_cum_nc_t call to cdf_beta'
            WRITE (*,*) 'Status: ', local_status

            STOP 'Error in local_cum_nc_t call to cdf_beta'

          END IF
        END IF

! Case bcent and bbcent are essentially zero
! Thus t is effectively infinite

        IF (bcent+bbcent<tiny) THEN
          IF (qrevs) THEN
            cum = zero
            ccum = one
          ELSE
            cum = one
            ccum = zero
          END IF

          RETURN

        END IF

! Case bcent and bbcent are essentially one
! Thus t is effectively zero

        IF (dum1+dum2<tiny) THEN
          CALL cdf_normal(which=1,cum=cum,ccum=ccum,x=-pnonc)

          RETURN
        END IF

! First term in ccum is D*B + E*BB

        ccum = dcent*bcent + ecent*bbcent

! Compute: s(cent) = B(2*(cent+1)) - B(2*cent))

        scent = gamln(halfdf+cent+half) - gamln(cent+onep5) - alghdf + &
          halfdf*lnx + (cent+half)*lnomx
        scent = EXP(scent)

! Compute: ss(cent) = B(2*cent+3) - B(2*cent+1)

        sscent = gamln(halfdf+cent+one) - gamln(cent+two) - alghdf + &
          halfdf*lnx + (cent+one)*lnomx
        sscent = EXP(sscent)

! ***** Sum FORWARD *****

        xi = cent + one
        twoi = two*xi

        d = dcent
        e = ecent
        b = bcent
        bb = bbcent
        s = scent
        ss = sscent

        DO
          b = b + s
          bb = bb + ss

          d = (lambda/xi)*d
          e = (lambda/(xi+half))*e

          term = d*b + e*bb
          ccum = ccum + term

          s = s*omx*(df+twoi-one)/(twoi+one)
          ss = ss*omx*(df+twoi)/(twoi+two)

          xi = xi + one
          twoi = two*xi

          IF (ABS(term)<=conv*ccum) THEN
            EXIT
          END IF

        END DO

! ***** Sum BACKWARD *****

        xi = cent
        twoi = two*xi

        d = dcent
        e = ecent
        b = bcent
        bb = bbcent

        s = scent*(one+twoi)/((df+twoi-one)*omx)
        ss = sscent*(two+twoi)/((df+twoi)*omx)

        DO
          b = b - s
          bb = bb - ss

          d = d*(xi/lambda)
          e = e*((xi+half)/lambda)

          term = d*b + e*bb
          ccum = ccum + term

          xi = xi - one

          IF (xi<half) THEN
            EXIT
          END IF

          twoi = two*xi

          s = s*(one+twoi)/((df+twoi-one)*omx)
          ss = ss*(two+twoi)/((df+twoi)*omx)

          IF (ABS(term)<=conv*ccum) THEN
            EXIT
          END IF

        END DO

        IF (qrevs) THEN
          cum = half*ccum
          ccum = one - cum
        ELSE
          ccum = half*ccum
          cum = one - ccum
        END IF

! Due to roundoff error the answer may not lie between zero and one
! Force it to do so

        cum = MAX(MIN(cum,one),zero)
        ccum = MAX(MIN(ccum,one),zero)

      END SUBROUTINE local_cum_nc_t

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

    END MODULE cdf_nc_t_mod


          PROGRAM MAIN

          USE OMP_LIB
          IMPLICIT NONE

          INTEGER :: i

          INTEGER, PARAMETER :: num_steps = 100000
          REAL :: x, pi, sum, step

          sum = 0.0

          step = 1.0/num_steps

!$omp parallel do simd private(x) reduction(+:sum)
          DO i = 1, num_steps
             x = (i - 0.5) * step
             sum = sum + 4.0 / (1.0 + x * x)
          ENDDO
!$omp end parallel do simd

          pi = step * sum

          print *, "pi=", pi
          END PROGRAM MAIN


! Test compile-time analysis of shapes.

module m1
  integer(8), parameter :: a0s(*) = shape(3.14159)
  real :: a1(5,5,5)
  integer(8), parameter :: a1s(*) = shape(a1)
  integer(8), parameter :: a1ss(*) = shape(a1s)
  integer(8), parameter :: a1sss(*) = shape(a1ss)
  integer(8), parameter :: a1rs(*) = [rank(a1),rank(a1s),rank(a1ss),rank(a1sss)]
  integer(8), parameter :: a1n(*) = [size(a1),size(a1,1),size(a1,2)]
  integer(8), parameter :: a1sn(*) = [size(a1s),size(a1ss),size(a1sss)]
  integer(8), parameter :: ac1s(*) = shape([1])
  integer(8), parameter :: ac2s(*) = shape([1,2,3])
  integer(8), parameter :: ac3s(*) = shape([(1,j=1,4)])
  integer(8), parameter :: ac3bs(*) = shape([(1,j=4,1,-1)])
  integer(8), parameter :: ac4s(*) = shape([((j,k,j*k,k=1,3),j=1,4)])
  integer(8), parameter :: ac5s(*) = shape([((0,k=5,1,-2),j=9,2,-3)])
  integer(8), parameter :: rss(*) = shape(reshape([(0,j=1,90)], -[2,3]*(-[5_8,3_8])))
 contains
  subroutine subr(x,n1,n2)
    real, intent(in) :: x(:,:)
    integer, intent(in) :: n1(3), n2(:)
    real, allocatable :: a(:,:,:)
    a = reshape(x,n1)
    a = reshape(x,n2(10:30:9)) ! fails if we can't figure out triplet shape
  end subroutine
end module m1
!Expect: m1.mod
! module m1
! integer(8),parameter::a0s(1_8:*)=[INTEGER(8)::]
! intrinsic::shape
! real(4)::a1(1_8:5_8,1_8:5_8,1_8:5_8)
! integer(8),parameter::a1s(1_8:*)=[INTEGER(8)::5_8,5_8,5_8]
! integer(8),parameter::a1ss(1_8:*)=[INTEGER(8)::3_8]
! integer(8),parameter::a1sss(1_8:*)=[INTEGER(8)::1_8]
! integer(8),parameter::a1rs(1_8:*)=[INTEGER(8)::3_8,1_8,1_8,1_8]
! integer(8),parameter::a1n(1_8:*)=[INTEGER(8)::125_8,5_8,5_8]
! integer(8),parameter::a1sn(1_8:*)=[INTEGER(8)::3_8,1_8,1_8]
! integer(8),parameter::ac1s(1_8:*)=[INTEGER(8)::1_8]
! integer(8),parameter::ac2s(1_8:*)=[INTEGER(8)::3_8]
! integer(8),parameter::ac3s(1_8:*)=[INTEGER(8)::4_8]
! integer(8),parameter::ac3bs(1_8:*)=[INTEGER(8)::4_8]
! integer(8),parameter::ac4s(1_8:*)=[INTEGER(8)::36_8]
! integer(8),parameter::ac5s(1_8:*)=[INTEGER(8)::9_8]
! integer(8),parameter::rss(1_8:*)=[INTEGER(8)::10_8,9_8]
! intrinsic::reshape
! contains
! subroutine subr(x,n1,n2)
! real(4),intent(in)::x(:,:)
! integer(4),intent(in)::n1(1_8:3_8)
! integer(4),intent(in)::n2(:)
! end
! end


!*****************************************************************************************
!> author: Jacob Williams
!  date: 10/5/2015
!
!  2D data regridding using the bspline module.

    program bspline_regridding_test

    use bspline_module
    use bspline_kinds_module, only: wp, ip

    implicit none

    integer(ip),parameter :: kx     = 4    !! x bspline order
    integer(ip),parameter :: ky     = 4    !! y bspline order
    integer(ip),parameter :: idx    = 0    !! [[db2val]] input
    integer(ip),parameter :: idy    = 0    !! [[db2val]] input
    integer(ip),parameter :: nx     = 6    !! number of points in x dimension in original grid
    integer(ip),parameter :: ny     = 5    !! number of points in y dimension in original grid
    integer(ip),parameter :: nx_new = 11   !! number of points in x dimension for new grid
    integer(ip),parameter :: ny_new = 9    !! number of points in y dimension for new grid
    integer(ip),parameter :: iknot  = 0    !! automatically select the knots
    real(wp),dimension(nx),parameter :: x = [0.0_wp,2.0_wp,4.0_wp,6.0_wp,8.0_wp,10.0_wp]  !! x points in original grid
    real(wp),dimension(ny),parameter :: y = [0.0_wp,2.0_wp,4.0_wp,6.0_wp,8.0_wp]          !! y points in original grid

    real(wp),dimension(nx_new,ny_new) :: fcn_new  !! new grid function evaluations
    real(wp),dimension(nx_new)        :: x_new    !! new grid x points
    real(wp),dimension(ny_new)        :: y_new    !! new grid y points
    real(wp),dimension(nx+kx)         :: tx       !! x knots
    real(wp),dimension(ny+ky)         :: ty       !! y knots
    real(wp),dimension(nx,ny)         :: fcn_2d   !! original grid function evaluations
    real(wp) :: val,tru,err,errmax
    integer(ip) :: i,j
    integer(ip) :: iflag  !! status flag
    integer(ip) :: inbvx,inbvy,iloy
    real(wp),dimension(ky)           :: w1 !! work array
    real(wp),dimension(3*max(kx,ky)) :: w2 !! work array

    !function evaluations for original grid:
    do i=1,nx
       do j=1,ny
           fcn_2d(i,j) = test_func(x(i),y(j))
       end do
    end do

    !display original data:
    write(*,*) '-----------------'
    write(*,*) '  INITIAL DATA:'
    write(*,*) '-----------------'
    write(*,'(A/,*(F12.6,1X))') 'x:', x
    write(*,*) ''
    write(*,'(A/,*(F12.6,1X))') 'y:', y
    write(*,*) ''
    write(*,'(A)') 'fcn(x,y):'
    do i=1,nx
        write(*,'(5F12.6)') fcn_2d(i,:)
    end do
    write(*,*) ''

    !regrid:

    inbvx = 1
    inbvy = 1
    iloy  = 1

    call db2ink(x,nx,y,ny,fcn_2d,kx,ky,iknot,tx,ty,fcn_2d,iflag)
    if (iflag/=0) error stop 'error calling db2ink'
    errmax = 0.0_wp
    do i=1,nx_new
        x_new(i) = real(i-1,wp)
        do j=1,ny_new
            y_new(j) = real(j-1,wp)
            call db2val(x_new(i),y_new(j),idx,idy,tx,ty,nx,ny,kx,ky,fcn_2d,val,iflag,&
                        inbvx,inbvy,iloy,w1,w2)
            if (iflag/=0) error stop 'error calling db2val'
            fcn_new(i,j) = val
            tru    = test_func(x_new(i),y_new(j))  !truth value
            err    = abs(tru-val)
            errmax = max(err,errmax)
        end do
    end do

    !display new grid:
    write(*,*) '-----------------'
    write(*,*) '  NEW GRID:'
    write(*,*) '-----------------'
    write(*,'(A/,*(F12.6,1X))') 'x:', x_new
    write(*,*) ''
    write(*,'(A/,*(F12.6,1X))') 'y:', y_new
    write(*,*) ''
    write(*,'(A)') 'fcn(x,y):'
    do i=1,nx_new
        write(*,'(11F12.6)') fcn_new(i,:)
    end do
    write(*,*) ''
    write(*,*) ' max error:', errmax
    write(*,*) ''

    contains

        function test_func(x,y) result(f)
        !! 2d test function

        implicit none

        real(wp) :: f
        real(wp),intent(in) :: x,y

        real(wp),parameter :: deg2rad = acos(-1.0_wp)/180.0_wp  !! degrees to radians conversion factor

        f = sin(deg2rad*(x+y))

        end function test_func

    end program bspline_regridding_test


! Compute pi using six basic MPI subroutines
        program darts
          use lcgenerator
          implicit none
          include 'mpif.h'
          integer :: num_trials = 1000000, i = 0, Ncirc = 0
          real :: pi = 0.0, x = 0.0, y = 0.0, r = 1.0
          real :: r2 = 0.0

          integer :: rank, np, manager = 0
          integer :: mpistatus, mpierr, j
          integer :: my_trials, temp

          call MPI_Init(mpierr)
          call MPI_Comm_size(MPI_COMM_WORLD, np, mpierr)
          call MPI_Comm_rank(MPI_COMM_WORLD, rank, mpierr)
          r2 = r*r
          my_trials = num_trials/np
          if (mod(num_trials, np) .gt. rank) then
           my_trials = my_trials+1
          end if
          call seed(rank)

          do i = 1, my_trials
            x = lcgrandom()
            y = lcgrandom()
            if ((x*x + y*y) .le. r2) then
              Ncirc = Ncirc+1
            end if
          end do

          if (rank .eq. manager) then
            do j = 1, np-1
              call MPI_Recv(temp, 1, MPI_INTEGER, j, j,
     &          MPI_COMM_WORLD, mpistatus, mpierr)
              Ncirc = Ncirc + temp
            end do
            pi = 4.0*((1.0*Ncirc)/(1.0*num_trials))
            print*, '     '
            print*, '     Computing pi using six basic MPI functions:'
            print*, '     For ', num_trials, ' trials, pi = ', pi
            print*, '     '
          else
            call MPI_Send(Ncirc, 1, MPI_INTEGER, manager, rank,
     &        MPI_COMM_WORLD, mpierr)
          end if
          call MPI_Finalize(mpierr)
        end


! Reference - https://www.ibm.com/docs/en/xffbg/121.141?topic=control-associate-construct-fortran-2003
program associate_04

    real :: myreal, x, y, theta, a
    x = 0.42
    y = 0.35
    myreal = 9.1
    theta = 1.5
    a = 0.4

    associate ( z => -(x*2 + y*2) * cos(theta), v => myreal)
        print *, a + z, a - z, v
        v = v * 4.6
    end associate

    print *, myreal

    if ((myreal - 41.86) > 1e-5 .or. myreal - 41.86 < -1e-5) error stop

end program associate_04


      subroutine dblas2()
*
      CALL DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
*
      CALL DGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
*
      CALL DSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
*
      CALL DSBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
*
      CALL DSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
*
      CALL DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
*
      CALL DTBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
*
      CALL DTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
*
      CALL DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
*
      CALL DTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
*
      CALL DTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
*
      CALL DGER  ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
*
      CALL DSYR  ( UPLO, N, ALPHA, X, INCX, A, LDA )
*
      CALL DSPR  ( UPLO, N, ALPHA, X, INCX, AP )
*
      CALL DSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
*
      CALL DSPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
*
      stop
      end


      function erfc(xx)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    erfc is the complementary error function;
!!    erf(B) is the error function for B

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    xx          |              |
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    erfc        |
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    c1          |              |
!!    c2          |              |
!!    c3          |              |
!!    c4          |              |
!!    erf         |              |
!!    x           |none          |variable to hold intermediate
!!                               |calculation result
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Abs

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      real, parameter :: c1 = .19684, c2 = .115194
      real, parameter :: c3 = .00034, c4 = .019527
      real, intent (in) :: xx
      real :: x, erf, erfc

      x = 0.
      erf = 0.
      erfc = 0.

      x = Abs(1.4142 * xx)
      erf = 1. - (1. + c1 * x + c2 * x * x + c3 * x**3 + c4 * x**4) **
     &                                                              (-4)
      if (xx < 0.) erf = -erf

      erfc = 1. - erf

      return
      end


module sisen
	implicit none
	integer, parameter :: imax=1000,jmax=1000
	real, parameter :: dx=10.0,dy=10.0,pie=3.1415927
	integer,dimension(imax,jmax) :: VAL,VISIT
	real,dimension(imax,jmax) :: DEM
! VISIT :: dummy

contains
    integer function point_view(is,js,ie,je)
	integer is,js,ie,je
	integer x,y,x1,x2,y1,y2
	integer ise,jse
	integer inc
	real xx,yy,dx,dy
	real zs,ze,za,zb,z1,z2

	zs=DEM(is,js)
	ze=DEM(ie,je)
	ise=abs(is-ie) ; jse=abs(js-je)
!	write(*,*) ise,jse
	inc=1 ; point_view=1
	if (max(ise,jse).le.1) then
		point_view=0 ; return
	endif
	if (ise .ge. jse) then
		if (is .ge. ie) then
			inc=-inc
		endif
!		do x=is+inc,ie-inc,inc
		do x=ie-inc,is+inc,-inc
			xx=real(x)
			yy=js+(je-js)*(xx-is)/(ie-is)
			y1=int(yy) ; y2=y1+1 ; dy=yy-y1
			za=zs+(ze-zs)*(xx-is)/(ie-is)
			z1=DEM(x,y1) ; z2=DEM(x,y2)
			zb=z1+(z2-z1)*dy
			if (zb .gt. za) then
				point_view=0 ; return
			endif
		enddo
	else
		if (js .ge. je) then
			inc=-inc
		endif
!		do y=js+inc,je-inc,inc
		do y=je-inc,js+inc,-inc
			yy=real(y)
			xx=is+(ie-is)*(yy-js)/(je-js)
			x1=int(xx) ; x2=x1+1 ; dx=xx-x1
			za=zs+(ze-zs)*(yy-js)/(je-js)
			z1=DEM(x1,y) ; z2=DEM(x2,y)
			zb=z1+(z2-z1)*dx
			if (zb .gt. za) then
				point_view=0 ; return
			endif
		enddo
	endif
	return
    end function point_view

    subroutine view(is,js)
	integer is,js
	integer ie,je
	VAL=0
	do je=3,jmax-2
	do ie=3,imax-2
		VAL(ie,je)=point_view(is,js,ie,je)
	enddo
	enddo
    end subroutine view

end module sisen


SUBROUTINE clawpack5_setaux(mbc,mx,my,xlower,ylower,dx,dy,maux,aux)
  IMPLICIT NONE

  INTEGER mbc,mx,my,maux
  DOUBLE PRECISION xlower,ylower,dx,dy
  DOUBLE PRECISION aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)
  DOUBLE PRECISION psi

  INTEGER i,j
  DOUBLE PRECISION xll, yll, zll
  !! # constant velocities which are used if tperiod=0 is specified
  !! # in setprob.data

  zll = 0.d0
  DO  i=1-mbc,mx+mbc
     DO  j=1-mbc,my+mbc

        !!  # coordinates of lower left corner of grid cell:
        xll = xlower + (i-1)*dx
        yll = ylower + (j-1)*dy

        !!  # difference stream function psi to get normal velocities:
        aux(1,i,j) = -(psi(xll, yll+dy, zll) - psi(xll,yll,zll)) / dy
        aux(2,i,j) =  (psi(xll+dx, yll,zll) - psi(xll,yll,zll)) / dx
     ENDDO
  ENDDO
  RETURN
END SUBROUTINE clawpack5_setaux


MODULE pzcon

IMPLICIT NONE

PRIVATE

PUBLIC :: p_from_z

CONTAINS

PURE SUBROUTINE p_from_z(cnvrsn,grav,dynz,prsdb,depth)
!http://sam.ucsd.edu/sio210/propseawater/ppsw_fortran/pzcon.f
!     title:
!     *****
!
!       pzcon  -- convert pressure in decibars to depth in meters
!                 (or visa versa)
!
!     system:
!     ******
!
!       pacodf hydrographic data library
!
!     purpose:
!     *******
!
!       to calculate depth in meters (mantyla,saunders)
!       from pressure in decibars (or pressure from depth).
!
!       ref: journ. physical ocean.,vol 11 no. 4, april, 1981
!            (saunders)
!            private correspondence 1982-1983
!            (mantyla)
!
!     method:
!     ******
!
!       a standard ocean (salinity=35.0,t=0.0) is used plus a dynamic
!       height correction to account for deviations from the standard
!       ocean. pressure to depth conversion is effected as:
!
!       z = p/(b*c) + dynz/b
!
!       where:
!
!          p    = insitu pressure (decibars)
!          b    = insitu gravity as a function of latitude and pressure
!                 (decameters/sec/sec)
!          c    = insitu mean density rho(35.0,0.0,p)
!                 (grams/centimeter**3)
!          dynz = dynamic height in dynamic meters
!          z    = depth in meters
!
!     parameters:
!     **********
!
!       cnvrsn  -> conversion to be performed:
!                  0 = pressure to depth
!                  1 = depth to pressure
!       grav    -> acceleration of gravity meters/sec/sec
!                  at station latitude, pressure =0.0db
!       dynz    -> dynamic height in dynamic meters
!       prsdb   -> pressure in decibars (cnvrsn=0)
!               <- pressure in decibars (cnvrsn=1)
!       depth   <- depth in meters (cnvrsn=0)
!               -> depth in meters (cnvrsn=1)
!
  INTEGER, INTENT(IN) :: cnvrsn
  REAL, INTENT(IN)    :: grav,dynz
  REAL, INTENT(INOUT) :: prsdb,depth
!
!     variables:
!     *********
!
  REAL*4 :: a,b,c
  REAL*8 :: dd,dg,dh,da,db,dc
!
!     external functions:
!     ******** *********
!
  INTEGER :: isnan
!	  /* test for Not-A-Number */

!-------------------------------------------------------------------------------
!     (convert pressure to depth):
!-------------------------------------------------------------------------------
  if(cnvrsn.eq.0) then
    a = 2.2e-6*prsdb
! /* pressure correction to gravity */
    b = 0.1*(grav+0.5*a)
! /* insitu gravity decameters/sec/sec */
    c = 1.0285+a
! /* insitu mean density rho(35.0,0.0,p) */
    depth = prsdb/(b*c)
! /* pressure to depth conversion in standard ocean */
!   (dynamic height):
    if(isnan(dynz).eq.0) then
      depth = depth + dynz/b
    endif

  else
!-------------------------------------------------------------------------------
! (convert depth to pressure):
!-------------------------------------------------------------------------------
    dd = dble(depth)
    dg = dble(grav*0.1)
    dh = dble(dynz)
    da = 2.42d-13*dd
    db = dd*(1.13135d-7+2.2e-6*dg)-1.0
    dc = dg*dd
!   select
!   (dynamic height):
    if(isnan(dynz).eq.0) then
      db = db - 2.2d-6*dh
      dc = dc-dh
    else
      dc = 1.0285d0*dc
      prsdb  = 0.0
      if(da.ne.0.0) then
        prsdb  = sngl((-db-dsqrt(db*db-4.0d0*da*dc))/(da+da))
      endif
    endif

  endif

END SUBROUTINE p_from_z

PURE INTEGER FUNCTION isnan(r)
!http://sam.ucsd.edu/sio210/propseawater/ppsw_fortran/isnan.f
!
!	title:
!	*****
!
!	  isnan -- test for missing real*4 value
!
!	purpose:
!	*******
!
!	  to test for a real number flagged as missing
!
!	parameters:
!	**********
!
!	  r     -> real value to test
!	  isnan <- 0 iff number, 1 iff missing
!
  REAL, INTENT(IN) :: r

  if(r.eq.9.9e37) then
    isnan = 1
  else
    isnan = 0
  endif

END FUNCTION isnan

END MODULE pzcon


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                 mnfour : fourco test program                       cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real c(20),t(20),wrk1(20),wrk2(20),alfa(10),ress(10),resc(10)
      integer i,ier,j,k,k1,m,n,nk1
      real ak,rc,rs
c  as an example we calculate some integrals of the form
c          / 1                               / 1
c         !    x * sin(alfa*x) dx  and      !   x * cos(alfa*x) dx
c      0 /                               0 /
c
c  we will represent y = x as a cubic spline.
      k = 3
      k1 = k+1
c  we fetch the knots of the cubic spline
      n = 2*k1+4
c  the boundary knots
      j = n
      do 10 i=1,k1
         t(i) = 0.
         t(j) = 0.1e+01
         j = j-1
  10  continue
c  the interior knots
      t(5) = 0.1e+0
      t(6) = 0.3e+0
      t(7) = 0.4e+0
      t(8) = 0.8e+0
c  find the b-spline representation of y=x
      nk1 = n-k1
      ak = k
      c(1) = 0.
      do 20 i=2,nk1
         j = i+k
         c(i) = c(i-1)+(t(j)-t(i))/ak
  20  continue
c  print the data for the spline.
      write(6,900) k
      write(6,905)
      write(6,910) (t(i),i=1,n)
      write(6,915)
      write(6,920) (c(i),i=1,nk1)
c  fetch the different values for alfa
      m = 8
      alfa(1) = 0.
      alfa(2) = 0.1e-02
      do 30 i=3,m
        alfa(i) = -alfa(i-1)*0.1e+02
  30  continue
c  calculate the fourier integrals of the cubic spline
      call fourco(t,n,c,alfa,m,ress,resc,wrk1,wrk2,ier)
c  print the results
      write(6,925)
      do 40 i=1,m
c  fetch the exact values of the integrals
        call exfour(alfa(i),rs,rc)
        write(6,930) alfa(i),ress(i),rs,resc(i),rc
  40  continue
      stop
c  format statements.
 900  format(25h0degree of the spline k =,i2)
 905  format(1x,21hposition of the knots)
 910  format(5x,12f5.1)
 915  format(1x,21hb-spline coefficients)
 920  format(5x,8f9.5)
 925  format(1h0,2x,4halfa,9x,4hress,9x,4hexas,9x,4hresc,9x,4hexac)
 930  format(1x,e8.1,4f13.5)
      end
      subroutine exfour(alfa,rs,rc)
c  subroutine exfour calculates the integrals
c                 / 1
c      rs =      !    x*sin(alfa*x) dx    and
c             0 /
c                 / 1
c      rc =      !    x*cos(alfa*x) dx
c             0 /
      integer k,k2
      real aa,ak,alfa,cc,c1,half,one,rc,rs,ss,s1,three
c  ..function references..
      real cos,sin,abs
c  set constants
      one = 0.1e+01
      three = 0.3e+01
      half = 0.5e0
      if(abs(alfa).lt.one) go to 10
c  integration by parts
      aa = one/alfa
      cc = cos(alfa)
      ss = sin(alfa)
      rs = (ss*aa-cc)*aa
      rc = ((cc-one)*aa+ss)*aa
      go to 50
c  using the series expansions of sin(alfa*x) and cos(alfa*x)
  10  rs = 0.
      rc = half
      if(alfa.eq.0.) go to 50
      rs = alfa/three
      ss = rs
      cc = rc
      aa = -alfa*alfa
      do 20 k=1,21
        k2 = 2*(k-1)
        ak = (k2+2)*(k2+5)
        ss = ss*aa/ak
        s1 = rs+ss
        if(s1.eq.rs)go to 30
        rs = s1
  20  continue
  30  do 40 k=1,21
        k2 = 2*(k-1)
        ak = (k2+1)*(k2+4)
        cc = cc*aa/ak
        c1 = rc+cc
        if(c1.eq.rc)go to 50
        rc = c1
  40  continue
  50  return
      end


! f2py -m fortran_interp -c fortran_interp.f90 --opt='-O3 -fPIC'
!----------------------------------------
  subroutine adv_upwind(u,v,du,dv,nh,m,n)

    implicit none

    integer,intent(in):: n,m,nh
    real*8,dimension(m,n) :: u,v,du,dv

!f2py intent(inplace)::u,v,du,dv

    integer::i,j

    real*8:: idx2, idy2
    real*8:: omega, omega_i, omega_j, vu, uv

    idx2 = 1.
    idy2 = 1.

    ! main and single double do-loop
    do j=nh,m-nh
       do i=nh,n-nh
          ! vorticity
          omega = (v(j, i+1)-v(j, i))-(u(j+1, i)-u(j, i))
          ! v at u-point ! v is the contravariant component
          vu = 0.25*(v(j, i)+v(j, i+1)+v(j-1, i)+v(j-1, i+1))
          ! u at v-point ! u is the contravariant component
          uv = 0.25*(u(j, i)+u(j, i-1)+u(j+1, i)+u(j+1, i-1))
          omega_j = omega ! upwinded interpolation at u point along j
          omega_i = omega ! upwinded interpolation at v point along i

          du(j, i) = du(j, i) + vu * omega_j * idy2
          dv(j, i) = dv(j, i) - uv * omega_i * idx2
       enddo
    enddo

  end subroutine adv_upwind


\ Program to calculate big factorial
\ Michel Jean - December 2021

create answer 10000 cells allot \ Size of the answer
0 value answer_size

: calcul { x | carry product }
    answer_size 0 do
    i cells answer + @ x * carry + to product
    product 10 mod answer i cells + !
    product 10 / to carry
    loop

    begin
    carry 0 > while
    carry 10 mod answer answer_size cells + !
    carry 10 / to carry
    1 +to answer_size
    repeat
;
: output ( -- )
    cr
    answer_size 1- to answer_size
    begin
    answer_size 0 >= while
    answer_size cells answer + ?
    answer_size 1- to answer_size
    answer_size 30 mod 0 = if cr then \ number by line
    repeat
;
: factorial { input | x }
    1 answer 0 cells + !
    1 to answer_size
    2 to x
    begin
     x input <= while
	x calcul
     x 1+ to x
     repeat
    output
;


PROGRAM main
  USE almagest

  IMPLICIT NONE

  INTEGER  :: hh, mm, ss, M, d, Y, utc_offset
  REAL(8)  :: lat, lon, sma, sml, ooe, LST, JDN

  REAL(8), DIMENSION(2) :: solp, lunp

  PRINT *, "Enter lat/lon: "
  READ  *, lat, lon

  PRINT *, "Enter Month/Day/Year: "
  READ  *, M, d, Y

  PRINT *, "Enter hour/minute/second: "
  READ  *, hh, mm, ss

  PRINT *, "Enter UTC offset: "
  READ  *, utc_offset

  call computeSolarTimeValues(M, d, Y, hh, mm, ss, utc_offset, lon, sma, sml, ooe, LST, JDN)

  solp = computeSolarPosition(lat, sma, ooe, LST, JDN)
  lunp = computeLunarPosition(lat, sma, sml, ooe, LST, JDN)

  PRINT *, "Solar Alt: ", solp(1)
  PRINT *, "Solar Azm: ", solp(2)

  PRINT *, "Lunar RA:   ", lunp(1)
  PRINT *, "Lunar Decl: ", lunp(2)
END PROGRAM main


!
!     (c) 2019 Guide Star Engineering, LLC
!     This Software was developed for the US Nuclear Regulatory Commission (US NRC)
!     under contract "Multi-Dimensional Physics Implementation into Fuel Analysis under
!     Steady-state and Transients (FAST)", contract # NRC-HQ-60-17-C-0007
!
!
!    NEMO - Numerical Engine (for) Multiphysics Operators
! Copyright (c) 2007, Stefano Toninel
!                     Gian Marco Bianchi  University of Bologna
!              David P. Schmidt    University of Massachusetts - Amherst
!              Salvatore Filippone University of Rome Tor Vergata
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
!     1. Redistributions of source code must retain the above copyright notice,
!        this list of conditions and the following disclaimer.
!     2. Redistributions in binary form must reproduce the above copyright notice,
!        this list of conditions and the following disclaimer in the documentation
!        and/or other materials provided with the distribution.
!     3. Neither the name of the NEMO project nor the names of its contributors
!        may be used to endorse or promote products derived from this software
!        without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
! ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
! ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
!---------------------------------------------------------------------------------
!
SUBMODULE (tools_math) cholesky_implementation
    IMPLICIT NONE

    CONTAINS

        MODULE PROCEDURE cholesky_solve_v
        USE class_psblas, ONLY : psb_dpk_
        IMPLICIT NONE
        !! $Id$
        !!
        !! Description:
        !!    Solves a linear system Ax=b, where A has been previously decomposed
        !!    according to the Cholesky factorization.
        !!    A: type REAL, rank 1.
        !!
        INTEGER :: i, is, j, ii, ij, ji, n, n2, nn
        REAL(psb_dpk_) :: sum, y(SIZE(b))

        is = SIZE(A)
        n  = (-1 + SQRT(REAL(1 + is * 8))) * 0.5
        n2 = 2 * n

        y(1) = b(1) / A(1)
        DO i = 2, n
            sum = b(i)
            DO j = 1, i - 1
                ij = i + (n2 - j) * (j - 1) * 0.5
                sum = sum - A(ij) * y(j)
            END DO

            ii = i + (n2 - i) * (i - 1) * 0.5
            y(i) = sum / A(ii)
        END DO

        nn = SIZE(A)
        b(n) = y(n) / A(nn)
        DO i = n - 1, 1, -1
            sum = y(i)
            DO j = i + 1, n
                ji = j + (n2 - i) * (i - 1) * 0.5
                sum = sum - A(ji) * b(j)
            END DO

            ii = i + (n2 - i) * (i - 1) * 0.5
            b(i) = sum / A(ii)
        END DO

        END PROCEDURE cholesky_solve_v

        MODULE PROCEDURE cholesky_solve_m
        USE class_psblas, ONLY : psb_dpk_
        IMPLICIT NONE
        !!
        !! Description:
        !!    Solves a linear system Ax=b, where A has been previously decomposed
        !!    according to the Cholesky factorization.
        !!    A: type REAL, rank 2.
        !!
        INTEGER :: i, j, n
        REAL(psb_dpk_) :: y(SIZE(b)), sum

        n = SIZE(b)

        y(1) = b(1) / A(1,1)
        DO i = 2, n
            sum = b(i)
            DO j = 1, i - 1
                sum = sum - A(i,j) * y(j)
            END DO

            y(i) = sum / A(i,i)
        END DO

        b(n) = y(n) / A(n,n)
        DO i = n - 1, 1, -1
            sum = y(i)
            DO j = i + 1, n
                sum = sum - A(j,i) * b(j)
            END DO

            b(i) = sum / A(i,i)
        END DO

        END PROCEDURE cholesky_solve_m

        MODULE PROCEDURE choloesky_fact_v
        USE class_psblas, ONLY : psb_dpk_
        IMPLICIT NONE
        !! Description:
        !!    Computes the Cholesky factorization of a symmetric positive definite
        !!    matrix:  A = LL'.
        !!    A: type REAL, rank 1
        !!
        INTEGER :: i, j, k
        INTEGER :: ii, ij, ik, jj, jk, is, n, n2
        REAL(psb_dpk_) :: sum

        is = SIZE(A)
        n  = (-1 + SQRT(REAL(1 + is * 8))) * 0.5
        n2 = 2 * n

        A(1) = SQRT(A(1))
        DO i = 2, n
            DO j =1, i - 1

                ij = i + (n2 - j) * (j - 1) * 0.5
                sum = A(ij)

                DO k = 1, j - 1
                    ik = i + (n2 - k) * (k - 1) * 0.5
                    jk = j + (n2 - k) * (k - 1) * 0.5
                    sum = sum - A(ik) * A(jk)
                END DO

                jj = j + (n2 - j) * (j - 1) * 0.5
                A(ij) = sum / A(jj)
            END DO

            ii = i + (n2 - i) * (i - 1) * 0.5
            sum = A(ii)

            DO k = 1, i - 1
                ik = i + (n2 - k) * (k - 1) * 0.5
                sum = sum - A(ik) ** 2
            END DO

            A(ii) = SQRT(sum)
        END DO

        END PROCEDURE choloesky_fact_v

        MODULE PROCEDURE  cholesky_fact_m
        USE class_psblas, ONLY : psb_dpk_
        IMPLICIT NONE
        !! Description:
        !!    Computes the Cholesky factorization of a symmetric positive definite
        !!    matrix A: = LL'.
        !!    A: type REAL, rank 2
        !!
        INTEGER :: i, j, k, n
        REAL(psb_dpk_) :: sum

        n = SIZE(A,1)

        A(1,1) = SQRT(A(1,1))
        DO i = 2, n
            DO j =1, i - 1
                sum = A(i,j)
                DO k = 1, j - 1
                    sum = sum - A(i,k) * A(j,k)
                END DO
                A(i,j) = sum / A(j,j)
            END DO

            sum = A(i,i)
            DO k = 1, i - 1
                sum = sum - A(i,k) ** 2
            END DO
            A(i,i) = SQRT(sum)
        END DO

        END PROCEDURE cholesky_fact_m

END SUBMODULE cholesky_implementation


module const_def

  ! ratio of heat capacities
  !real(KIND(0.d0)), parameter :: gm = 5.d0/3.d0
  !real(KIND(0.d0)), parameter :: gm = 1.4d0
  real(KIND(0.d0)), parameter :: gm = 2.d0
  real(KIND(0.d0)), parameter :: rr = 1.d0 ! gas constant
  ! heat capacity at constant volume
  real(KIND(0.d0)), parameter :: cv = rr/(gm-1.d0)
  ! heat capacity at constant pressure
  real(KIND(0.d0)), parameter :: cp = gm*cv
  real(KIND(0.d0)), parameter :: pi = 3.14159265359d0
  real(KIND(0.d0)), parameter :: pii4 = 1.d0/4.d0/pi
  real(KIND(0.d0)), parameter :: pii8 = 1.d0/8.d0/pi

end module const_def


! ==================================================================
subroutine rpn3(ixyz,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
! ==================================================================

! Riemann solver for the acoustics equations in 3d, with varying
! material properties.
!
! waves: 2
! equations: 4
! aux fields: 2
!
! Conserved quantities:
!       1 pressure
!       2 x_velocity
!       3 y_velocity
!       4 z_velocity
!
! Auxiliary variables:
!       1 impedance
!       2 sound_speed

! Note that although there are 4 eigenvectors, two eigenvalues are
! always zero and so we only need to compute 2 waves.

! Solve Riemann problems along one slice of data.
! This data is along a slice in the x-direction if ixyz=1
!                               the y-direction if ixyz=2.
!                               the z-direction if ixyz=3.

! On input, ql contains the state vector at the left edge of each cell
!           qr contains the state vector at the right edge of each cell

! Note that the i'th Riemann problem has left state qr(i-1,:)
!                                    and right state ql(i,:)
! From the basic clawpack routines, this routine is called with ql = qr

    implicit none
    double precision :: wave(meqn,mwaves,1-mbc:maxm+mbc)
    double precision ::    s(mwaves,1-mbc:maxm+mbc)
    double precision ::   ql(meqn,1-mbc:maxm+mbc)
    double precision ::   qr(meqn,1-mbc:maxm+mbc)
    double precision :: amdq(meqn,1-mbc:maxm+mbc)
    double precision :: apdq(meqn,1-mbc:maxm+mbc)
    double precision :: auxl(maux,1-mbc:maxm+mbc)
    double precision :: auxr(maux,1-mbc:maxm+mbc)
    double precision :: delta(3), zi, zim, a1, a2
    integer :: ixyz, mu, mv, mw, maxm,meqn,mwaves,mbc,mx, maux
    integer :: i,m

!     # set mu to point to  the component of the system that corresponds
!     # to velocity in the direction of this slice, mv to the orthogonal
!     # velocity.

    if (ixyz == 1) then
        mu = 2
        mv = 3
        mw = 4
    else if (ixyz == 2) then
        mu = 3
        mv = 4
        mw = 2
    else if (ixyz == 3) then
        mu = 4
        mv = 2
        mw = 3
    endif

!     # split the jump in q at each interface into waves
!     # The jump is split into a leftgoing wave traveling at speed -c
!     # relative to the material properties to the left of the interface,
!     # and a rightgoing wave traveling at speed +c
!     # relative to the material properties to the right of the interface,

!     # find a1 and a2, the coefficients of the 2 eigenvectors:
    do 20 i = 2-mbc, mx+mbc
        delta(1) = ql(1,i) - qr(1,i-1)
        delta(2) = ql(mu,i) - qr(mu,i-1)
    !        # impedances:
        zi = auxl(1,i)
        zim = auxr(1,i-1)

        a1 = (-delta(1) + zi*delta(2)) / (zim + zi)
        a2 =  (delta(1) + zim*delta(2)) / (zim + zi)

    !        # Compute the waves.

        wave(1,1,i) = -a1*zim
        wave(mu,1,i) = a1
        wave(mv,1,i) = 0.d0
        wave(mw,1,i) = 0.d0
        s(1,i) = -auxr(2,i-1)

        wave(1,2,i) = a2*zi
        wave(mu,2,i) = a2
        wave(mv,2,i) = 0.d0
        wave(mw,2,i) = 0.d0
        s(2,i) = auxl(2,i)

    20 END DO

!     # compute the leftgoing and rightgoing flux differences:
!     # Note s(i,1) < 0   and   s(i,2) > 0.

    do 220 m=1,meqn
        do 220 i = 2-mbc, mx+mbc
            amdq(m,i) = s(1,i)*wave(m,1,i)
            apdq(m,i) = s(2,i)*wave(m,2,i)
    220 END DO

    return
    end subroutine rpn3


!  Polynomial.f90
!
!  FUNCTIONS/SUBROUTINES exported from Polynomial.dll:
!  Polynomial - subroutine
!
subroutine Polynomial(deg, coef, yres, xres, yrange, xrange,output)

  ! Expose subroutine Polynomial to users of this DLL
  !
  !DEC$ ATTRIBUTES C,DLLEXPORT::polynomial
  !DEC$ ATTRIBUTES REFERENCE::deg, coef, xres, yres, xrange, yrange
    implicit none
  ! Variables
    integer     deg,xres,yres,n,m,d,cyc
    real        coef(deg+1),xrange(2),yrange(2)
    real(8)     xstp(xres),ystp(yres),coefprime(deg+1)
    complex(8)     plot,val,dval
    complex(8)     plotpoly(deg+1)
    real(8)     output(yres,xres)

  ! Body of Polynomial
    do n=1,xres
        xstp(n)=xrange(1)+(n-1)*(xrange(2)-xrange(1))/xres
    enddo
    do n=1,yres
        ystp(n)=yrange(1)+(n-1)*(yrange(2)-yrange(1))/yres
    enddo
    do n=1,deg
        coefprime(n)=coef(n+1)*n
    enddo
    coefprime(deg+1)=0
    do n=1,xres
        do m=1,yres
            plot=cmplx(xstp(n),ystp(m))
            do d=0,deg
                plotpoly(d+1)=plot**d
            enddo
            val=dot_product(coef,plotpoly)
            dval=dot_product(coefprime,plotpoly)
            cyc=0
            do while (abs(val)>=0.01 .and. cyc<=10000*deg)
                plot=plot-val/dval
                do d=0,deg
                    plotpoly(d+1)=plot**d
                enddo
                val=dot_product(coef,plotpoly)
                dval=dot_product(coefprime,plotpoly)
                cyc=cyc+1
            enddo
            output(m,n)=imag(plot)
        enddo
    enddo

end subroutine Polynomial