!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine init_Ac
  use global_variables
  implicit none
  integer :: it
  real(8) :: tt

  allocate(Act(-1:Nt+1),jtz(0:Nt+1),jtz_intra(0:Nt+1),jtz_inter(0:Nt+1))

  E0_1=5.338d-9*sqrt(Iwcm2_1)
  omega_1 = omega_ev_1/(2d0*Ry)
  tpulse_1 = tpulse_fs_1/0.02418d0
  E0_2=5.338d-9*sqrt(Iwcm2_2)
  omega_2 = omega_ev_2/(2d0*Ry)
  tpulse_2 = tpulse_fs_2/0.02418d0
  Tdelay = Tdelay_fs/0.02418d0

  Act = 0d0

!Pump
  select case(envelope_1)
  case("cos4cos")
    do it = 0,Nt+1
      tt = dt*dble(it)
      if(abs(tt-0.5d0*tpulse_1) < 0.5d0*tpulse_1)then
        Act(it) = -(E0_1/omega_1)*cos(pi*(tt-0.5d0*tpulse_1)/tpulse_1)**4 &
          *sin(omega_1*(tt-0.5d0*tpulse_1))
      end if
    end do
  case("cos2cos")
    do it = 0,Nt+1
      tt = dt*dble(it)
      if(abs(tt-0.5d0*tpulse_1) < 0.5d0*tpulse_1)then
        Act(it) = -(E0_1/omega_1)*cos(pi*(tt-0.5d0*tpulse_1)/tpulse_1)**2 &
          *sin(omega_1*(tt-0.5d0*tpulse_1))
      end if
    end do
  case default
    stop "Invalid envelope_1"
  end select

!Probe
  select case(envelope_2)
  case("cos4cos")
    do it = 0,Nt+1
      tt = dt*dble(it)

      if(abs(tt-0.5d0*tpulse_1-Tdelay) < 0.5d0*tpulse_2)then
        Act(it) = Act(it) -(E0_2/omega_2) &
          *cos(pi*(tt-0.5d0*tpulse_1-Tdelay)/tpulse_2)**4 &
          *sin(omega_2*(tt-0.5d0*tpulse_1-Tdelay))
      end if
    end do
  case("cos2cos")
    do it = 0,Nt+1
      tt = dt*dble(it)
      if(abs(tt-0.5d0*tpulse_1-Tdelay) < 0.5d0*tpulse_2)then
        Act(it) = Act(it) -(E0_2/omega_2) &
          *cos(pi*(tt-0.5d0*tpulse_1-Tdelay)/tpulse_2)**4 &
          *sin(omega_2*(tt-0.5d0*tpulse_1-Tdelay))
      end if
    end do
  case default
    stop "Invalid envelope_2"
  end select

  return
end subroutine init_Ac


Module NPTopt_MOD
implicit none

CONTAINS

SUBROUTINE BIOLOGY
USE PARAM_MOD
IMPLICIT NONE
integer :: k, i

!INPUT PARAMETERS:
real :: par_

!Local variables
real :: KN, mu0, aI0, Mm, Emort, p, NO3, NPPt = 0.
real, parameter :: Ez = 0.65, phi = 0.5, PHYmax = 200.

KN   = exp(params(iKN))
mu0  = exp(params(imu0))
aI0  = exp(params(iaI0))
Mm   = exp(params(iMm))

DO k = nlev, 1, -1
   ! Check whether in the MLD or not
   if (k < N_MLD) then
      par_ = PAR(k)
   else
      par_ = PARavg
   endif

   Varout(oPAR_,k) = par_
   NO3    = Vars(iNO3,    k)

!=============================================================
!! Solve ODE functions:
!All rates have been multiplied by dtdays to get the real rate correponding to the actual time step
   Tchl      = 0.
   mu_avg    = 0.
   mumax_avg = 0.
   PHYt      = sum(Vars(iPHY(:,k)))
   NPPt      = 0.
   do j = 1, NG
      do i = 1,NTAXA

         p = Vars(iPHY((j-1)*NG+i), k)

         IF (mod(it, nsave) .EQ. 1) THEN
           !Use nonmixed light to calculate NPP

           call growth(temp(k), NO3, PAR(k), mu0, Topt(i), KN,         &
                     aI0, mu, QN, theta, mumax)
           NPPt = NPPt + p * mu/QN * 12.
         ENDIF

         !Phytoplankton growth rate
         call growth(temp(k), NO3, par_, mu0, Topt(i), KN,         &
                     aI0, mu, QN, theta, mumax)

         Tchl     = Tchl      + p / QN * theta
         mu_avg   = mu_avg    + mu*p
         mumax_avg= mumax_avg + mumax*p

         !Maintain diversity using Record et al. (2014)
         Emort    = exp(TK(temp(k))*Ez)
         mort     = Emort * Mm * p**(1.+phi) * PHYt**(1.-phi)

         p = p + dtdays*(mu*p - mort)
         Vars(iPHY((j-1)*NG+i), k) = min(max(p, 0.), PHYmax)

         !Compute total phyto. uptake - mortality
         total_uptake = total_uptake + (mu*p - mort)
       enddo
   enddo
   mu_avg    = mu_avg/PHYt
   mumax_avg = mumax_avg/PHYt

   ! Save some model outputs:
   Varout(oCHLt, k) = Tchl
   Varout(oNPP,  k) = NPPt

   NO3 = NO3 + dtdays*(-total_uptake)
   NO3 = min(max(NO3, 0.), PHYmax)
   Varout(oNO3,  k) = NO3

ENDDO
END SUBROUTINE BIOLOGY

!phytoplankton growth rate, Chl:C and N:C function
subroutine growth(t, N, par,r0,To, KN, aI0, gr, QN, theta, um)
IMPLICIT NONE
real, intent(in)  :: t     !Environmental Temperature (ºC)
real, intent(in)  :: N     !Nitrate (mmol m-3)
real, intent(in)  :: par   !light (mol E m-2 d-1)
real, intent(in)  :: r0    !Normalized growth rate for mumax (d-1)
real, intent(in)  :: To    !Optimal temperature (ºC)
real, intent(in)  :: KN    !Half-saturation constant  (mmol m-3)
real, intent(in)  :: aI0   !Slope of P_I curve (W m-2)-1 d-1
real, intent(out) :: gr    !Specific growth rate (d-1)
real, intent(out) :: QN    !Phyto. N:C ratio
real, intent(out) :: theta !Phyto. Chl:C ratio (gChl molC-1)
real, intent(out) :: um    !Phyto. maximal growth rate (excluding N and light limitation)

real, parameter   :: Q0N      = 0.05  !Minimal N:C ratio
real, parameter   :: Qm       = 0.15  !Maximal N:C ratio
real, parameter   :: thetamin = 0.02  !Minimal Chl:C ratio (gChl molC-1)
real, parameter   :: thetamax = 0.63  !Maximal Chl:C ratio (gChl molC-1)
real, parameter   :: Ea       = 0.81  !Activation energy (eV)
real, parameter   :: dED      = 1.74  !Eh - Ea (eV)

real :: par_, SI, fN

um   = Johnson(t, mu0(To, r0), Ea, dED, To)
fN   = N / (N + KN)
if (um < 0.01) then
  SI = 1.
else
  SI = 1. - exp(-aI0*par_/um)
endif
QN   = Q0N/(1.-(1.-Q0N/Qm)*fN)
gr   = um*SI*fN  !Growth rate
theta= thetamin + gr/par_/aI0 * (thetamax-thetamin)   !Unit: gChl/molC

return
end subroutine growth

real function Johnson(tC, mu0, Ea, dED, To) result(y)
implicit none
real,   intent(in)  :: tC, mu0, Ea, dED, To
real,   parameter   :: kb   = 8.62D-5
real,   parameter   :: T0   = 273.15D0
real,   parameter   :: Tref = 15D0
real                :: ED, a, b

if (dED .le. 0d0) then
  stop "dED must be positive!"
else
  ED = dED + Ea
   a = Ea/dED
   b = exp(ED/kb*(1D0/(To+T0)-1D0/(tC+T0)))
   b = a*b
   a = Ea/kb*(1D0/(Tref+T0) - 1D0/(tC+T0))
   y = mu0*exp(a)/(1D0+b)
endif
return
End function Johnson

pure real function TK(tC)
implicit none
!DESCRIPTION:
!The temperature dependence of plankton rates are fomulated according to the Arrhenuis equation.
! tC: in situ temperature
! Tr: reference temperature
!
!INPUT PARAMETERS:
real, intent (in) :: tC
! boltzman constant constant [ eV /K ]
real, parameter   :: kb = 8.62d-5, Tr = 15.0

TK = -(1./kb)*(1./(273.15 + tC) - 1./(273.15 + Tr))
return
end function TK

real function mu0(x, mu0p)
implicit none
real, intent(in) :: x           !Topt in ºC
real, intent(in) :: mu0p        !Normalized growth rate
real, parameter  :: E0 = -0.41  !Nominal AE of growth rate normalizations
mu0 =  mu0p * exp(TK(x) * E0)
end function mu0

END Module NPTopt_MOD


c inicia_pefrompgt calcula la pe a partir de Pg y T usando Saha
c solo para le H
    	subroutine inicia_pefrompgt(t,pg,pe)
 	real*4 t,pg,pe,nu,saha,aaa,bbb,ccc,ybh

    	nu=0.9091       ! only Hydrogen is ionized
	saha=-0.4771+2.5*alog10(t)-alog10(pg)-(13.6*5040./t)
	saha=10**saha
	aaa=1.d0+saha
	bbb=-(nu-1.)*saha
	ccc=-saha*nu

	ybh=(-bbb+sqrt(bbb*bbb-4.*aaa*ccc))/(2.*aaa)! ionization fraction

	pe=pg*ybh/(1.+ybh)
c       pe=pg*ybh

	return
	end


      SUBROUTINE NON_LINEAR06

C     Check rules for multiplication

      read *, n
      i = n*n+2
      print *, i

      END


module outerprod
    use types

    implicit none
    public outerprod_d

contains

function outerprod_d(a, b)
    real(dp), intent(in) :: a(:), b(:)
    real(dp) :: outerprod_d(size(a), size(b))

    outerprod_d = spread(a, dim=2, ncopies=size(b)) * &
                    spread(b, dim=1, ncopies=size(a))

end function outerprod_d

end module outerprod


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

!   Initialization expressions containing PARAMETER references

module cc
 real, parameter, dimension(5) :: pp = (/ 1,2,3,4,5 /)
 real, parameter, dimension(10) :: qq = (/ pp,pp /)
end module

use cc
real,expect(10)
expect(1:5) = pp
expect(6:10) = pp
call check(qq,expect,10)
end


          program demo_real
             use,intrinsic :: iso_fortran_env, only : dp=>real64
             implicit none
             complex              :: zr = (1.0, 2.0)
             doubleprecision      :: xd=huge(3.0d0)
             complex(kind=dp) :: zd=cmplx(4.0e0_dp,5.0e0_dp,kind=dp)

             print *, real(zr), aimag(zr)
             print *, dble(zd), aimag(zd)

             write(*,*)xd,real(xd,kind=kind(0.0d0)),dble(xd)
          end program demo_real


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! DEXROU (Double EXample Roots Of Unity)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the Nth order roots of unity by solving a
! corresponding unitary eigenvalue problem two different ways.
!
! 1) Form upper hessenberg permutation matrix and compute its
!    eigenvalues using DOHFQR
!
! 2) Construct the factorization directly and compute its
!    eigenvalues using DOFFQR
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
program DEXROU

  implicit none

  ! compute variables
  integer, parameter :: N = 16
  integer :: ii, INFO, cpair
  real(8) :: WORK(4*N), Q(2*(N-1)), D(2*N)
  real(8) :: H(N,N), Z
  integer :: ITS(N-1)

  ! print banner
  print*,""
  print*,"DEXROU: Double EXample Roots Of Unity"
  print*,""

  ! initialize H to be an upper hessenberg permutation matrix
  H = 0d0
  do ii=1,N-1
    H(ii+1,ii) = 1d0
  end do
  H(1,N) = 1d0

  ! call dohfqr
  call DOHFQR('N',N,H,Z,ITS,WORK,INFO)

  ! check INFO
  if (INFO.NE.0) then
    print*,"DOHFQR failed."
    print*,"INFO:",INFO
  end if

  ! print diag of H
  cpair = 0
  print*,"Roots computed using DOHFQR:"
  do ii=1,N
    if (cpair.EQ.0) then
      if (H(ii,ii+1).EQ.0) then
        print*,H(ii,ii)
      else
        print*,H(ii,ii),H(ii,ii+1)
        print*,H(ii+1,ii+1),H(ii+1,ii)
        cpair = 1
      end if
    else
      cpair = 0
    end if
  end do
  print*,""

  ! initialize Q and D to be an upper hessenberg permutation matrix
  do ii=1,N-1
    Q(2*ii-1) = 0d0
    Q(2*ii) = 1d0
  end do
  do ii=1,N-1
    D(2*ii-1) = 1d0
    D(2*ii) = 0d0
  end do
  D(2*N-1) = (-1d0)**(N-1)
  D(2*N) = 0d0

  ! call doffqr
  call DOFFQR('N',N,Q,D,Z,ITS,INFO)

  ! check INFO
  if (INFO.NE.0) then
    print*,"DOFFQR failed."
    print*,"INFO:",INFO
  end if

  ! print D
  print*,"Roots computed using DOFFQR:"
  do ii=1,N
    print*,D(2*ii-1),D(2*ii)
  end do
  print*,""

end program DEXROU


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! test for subtraction operation of quad precision in flang2.

program test
  integer, parameter :: n = 4
  real(16) :: q1, q2, qa1, qa2, qsub
  real(16) :: result(n), expect(n)
  qsub(qa1, qa2) = qa1 - qa2

  q1 = 1.0_16
  q2 = 2.0_16

  expect = (/ 1.0_16, -2.0_16, -1.0_16, 3.0_16 /)

  ! op2 is 0.0
  result(1) = q1 - 0.0_16
  ! op1 is 0.0
  result(2) = 0.0_16 - q2
  ! op1 and op2 is constant
  result(3) = qsub(1.0_16, 2.0_16)
  ! a - -b
  result(4) = q1 - (-q2)

  if (any(result /= expect)) STOP 1

  print *, 'PASS'

end program


** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*   Intrinsics and generics: AIMAG and CONJG.

	program p
	implicit complex (c)
	parameter (n = 17 )
	real rslts(n), expect(n)
	complex crslts(4)
	equivalence (crslts, rslts(10))

	complex ca(3)
	data c12 / (1.0, 2.0) /
	data x3, i2 / 3.0, 2 /
	data ca / (1.0, 2.0), (3.0, 4.0), (5.0, 6.0) /

	rslts(1) = aimag(c12)
	rslts(2) = aimag( (3.5, -5.1e26) )
	rslts(3) = aimag(c12 + c12)
	rslts(4) = 2.0 * aimag(c12 * 5.0)
	rslts(5) = aimag( ca(i2) ) + x3
	rslts(6) = aimag( conjg(c12) )
	rslts(7) = conjg(c12 + c12)

c      complex function cf returns successive values:
c        (10,-10), (20,-20), (30,-30), ...

	rslts(8) = aimag(cf())
	rslts(9) = aimag( conjg(cf()) )

	crslts(1) = conjg((1.2, -2.3))
	crslts(2) = -conjg(c12 + c12)
	crslts(3) = c12 * conjg(ca(1))
	crslts(4) = conjg(cf()) + c12

c ---- check results:

	call check(rslts, expect, n)
	data expect / 2.0, -5.1e26, 4.0, 20.0, 7.0, -2.0, 2.0,
     +                -10.0, 20.0,
     +                1.2, 2.3,        -2.0, 4.0,
     +                5.0, 0.0,        31.0, 32.0             /
	end

	complex function cf()
	common c
	complex c
	data c / (10.0, -10.0) /
	cf = c
	c = c + (10.0, -10.0)
	return
	end


      program P0208
c>> 1997-06-20 Krogh Generate plots for ch02-08.tex
      integer MAXPT
      real RMAXPT, XA, XB, XSIZE, YSIZE
      parameter (MAXPT=101, RMAXPT=101.E0)
      parameter (XA = 0.0E0, XB = 1.0E0)
      parameter (XSIZE=3.2E0, YSIZE=2.5E0)
      real DX, OPT(19), X(MAXPT), Y(MAXPT, 2)
      external SCPLTK, SCPLTE
      real SCPLTK, SCPLTE
      integer I
      character COPT*47
      real PLOUNI, PLOTXT, PLONY, PLOBOR, PLOYMX, PLOANL
      parameter (PLOUNI=1.E0, PLOTXT=14.E0, PLONY=2.E0, PLOBOR=4.E0,
     1   PLOYMX=9.E0, PLOANL=16.E0)
c                   1     2       3     4      5       6      7     8
c            9    10    11    12     13     14      15
      data OPT / 0.E0, PLONY, RMAXPT, 2.E0, PLOTXT, .5E0, 2.2E0, 0.E0,
     1  PLOTXT, .6E0, .9E0, 0.E0, PLOANL, 0.E0, 3120.E0,
     2  PLOYMX, 0.E0, 5.E0, 0.E0 /
c                          11111111112222222222333333333344444444
c                 12345678901234567890123456789012345678901234567
      data COPT /'F{pl02-08.tex}{$K(m)$}{$E(m)$}{$\frac{\pi}{2}$}'/
c
      DX = (XB - XA) / (MAXPT-1)
      do 100 I = 1, MAXPT
         X(I) = real(I - 1) * DX
         if (X(I) .ge. 1.E0) X(I) = .99999E0
         Y(I,1) = SCPLTK(X(I))
         Y(I,2) = SCPLTE(X(I))
  100 continue
      OPT(14) = Y(I, 1)
      call SPLOT(XSIZE, YSIZE, X, MAXPT, Y, OPT, COPT)
      stop
      end


      subroutine swirl_setprob(ex_in)
      implicit none

      double precision pi, pi2
      integer example, ex_in

      common /compi/ pi
      common /comex/ example

      example = ex_in

      pi = 4.d0*datan(1.d0)
      pi2 = 2.d0*pi

      end


c
c    1-D Cubic Spline Package.
c    Interpolates a function x(s) from discrete x(i) points.
c
c                                              Mark Drela
c                                              1985
c
c    Usage:
c
cC---- fill S(i), X(i) arrays
c      S(i) = ...
c      X(i) = ...
c
cC---- or.. for a space curve X(i), Y(i), the spline parameter S(i)
cC-     can be computed by
c      CALL SCALC(X,Y,S,N)
c
cC---- calculate spline coefficients XS(i), YS(i)
cC-    (or can use SPLIND,SPLINA,SEGSPL,SEGSPD instead as needed)
c      CALL SPLINE(X,XS,S,N)
c      CALL SPLINE(Y,YS,S,N)
c
cC---- The above calls are done once, which then enables any number
cC     of calls to the spline interrogation routines.  Examples are below.
cC. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
cC---- evaluate splined x(s) and/or its derivatives
cC-     at any number of s points SS
c      XX   = SEVAL(SS,X,XS,S,N)
c      XXS  = DEVAL(SS,X,XS,S,N)
c      XXSS = D2VAL(SS,X,XS,S,N)
c
cC---- also evaluate y(s), etc
c      YY   = SEVAL(SS,Y,YS,S,N)
c      YYS  = DEVAL(SS,Y,YS,S,N)
c
cC---- evaluate curvature k(s) of x,y curve
c      CV = CURV(SS,X,XS,Y,YS,S,N)
c
cC---- alternative to calling SEVAL,DEVAL,D2VAL separately
cC-     (slightly more efficient if all three quantities are needed)
c      CALL SEVALL(SS,X,XS,S,N, XX,XXS,XXSS)
c
c

      SUBROUTINE SPLINE(X,XS,S,N)
      DIMENSION X(N),XS(N),S(N)
      PARAMETER (NMAX=5001)
      DIMENSION A(NMAX),B(NMAX),C(NMAX)
C-------------------------------------------------------
C     Calculates spline coefficients for X(S).          |
C     Natural end conditions are used (zero 3rd         |
C      derivative over first, last intervals).          |
C                                                       |
C     To evaluate the spline at some value of S,        |
C     use SEVAL and/or DEVAL.                           |
C                                                       |
C     S        independent variable array (input)       |
C     X        dependent variable array   (input)       |
C     XS       dX/dS array                (calculated)  |
C     N        number of points           (input)       |
C                                                       |
C-------------------------------------------------------
      IF(N.GT.NMAX) STOP 'SPLINE: array overflow, increase NMAX'
C
      DO 1 I=2, N-1
        DSM = S(I) - S(I-1)
        DSP = S(I+1) - S(I)
        B(I) = DSP
        A(I) = 2.0*(DSM+DSP)
        C(I) = DSM
        XS(I) = 3.0*((X(I+1)-X(I))*DSM/DSP + (X(I)-X(I-1))*DSP/DSM)
    1 CONTINUE
C
C---- set zero 3rd derivative end conditions
      A(1) = 1.0
      C(1) = 1.0
      XS(1) = 2.0*(X(2)-X(1)) / (S(2)-S(1))
C
      B(N) = 1.0
      A(N) = 1.0
      XS(N) = 2.0*(X(N)-X(N-1)) / (S(N)-S(N-1))
C
      IF(N.EQ.2) THEN
C----- if only two points are present, specify zero 2nd derivative instead
C-     (straight line interpolation will result)
       B(N) = 1.0
       A(N) = 2.0
       XS(N) = 3.0*(X(N)-X(N-1)) / (S(N)-S(N-1))
      ENDIF
C
C---- solve for derivative array XS
      CALL TRISOL(A,B,C,XS,N)
C
      RETURN
      END ! SPLINE

      SUBROUTINE SPLIND(X,XS,S,N,XS1,XS2)
      DIMENSION X(N),XS(N),S(N)
      PARAMETER (NMAX=5001)
      DIMENSION A(NMAX),B(NMAX),C(NMAX)
C-------------------------------------------------------
C     Calculates spline coefficients for X(S).          |
C     Same as SPLINE, but also allows specified-slope   |
C     or zero-curvature end conditions to be imposed.   |
C                                                       |
C     To evaluate the spline at some value of S,        |
C     use SEVAL and/or DEVAL.                           |
C                                                       |
C     S        independent variable array (input)       |
C     X        dependent variable array   (input)       |
C     XS       dX/dS array                (calculated)  |
C     N        number of points           (input)       |
C     XS1,XS2  endpoint derivatives       (input)       |
C              If =  999.0, then usual zero second      |
C              derivative end condition(s) are used     |
C              If = -999.0, then zero third             |
C              derivative end condition(s) are used     |
C                                                       |
C     Note: specifying both XS1,XS2 = -999.0            |
C           is equivalent to using SPLINE.              |
C                                                       |
C-------------------------------------------------------
      IF(N.GT.NMAX) STOP 'SPLIND: array overflow, increase NMAX'
C
      DO 1 I=2, N-1
        DSM = S(I) - S(I-1)
        DSP = S(I+1) - S(I)
        B(I) = DSP
        A(I) = 2.0*(DSM+DSP)
        C(I) = DSM
        XS(I) = 3.0*((X(I+1)-X(I))*DSM/DSP + (X(I)-X(I-1))*DSP/DSM)
    1 CONTINUE
C
      IF(XS1.EQ.999.0) THEN
C----- set zero second derivative end condition
       A(1) = 2.0
       C(1) = 1.0
       XS(1) = 3.0*(X(2)-X(1)) / (S(2)-S(1))
      ELSE IF(XS1.EQ.-999.0) THEN
C----- set zero third derivative end condition
       A(1) = 1.0
       C(1) = 1.0
       XS(1) = 2.0*(X(2)-X(1)) / (S(2)-S(1))
      ELSE
C----- set specified first derivative end condition
       A(1) = 1.0
       C(1) = 0.
       XS(1) = XS1
      ENDIF
C
      IF(XS2.EQ.999.0) THEN
       B(N) = 1.0
       A(N) = 2.0
       XS(N) = 3.0*(X(N)-X(N-1)) / (S(N)-S(N-1))
      ELSE IF(XS2.EQ.-999.0) THEN
       B(N) = 1.0
       A(N) = 1.0
       XS(N) = 2.0*(X(N)-X(N-1)) / (S(N)-S(N-1))
      ELSE
       A(N) = 1.0
       B(N) = 0.
       XS(N) = XS2
      ENDIF
C
      IF(N.EQ.2 .AND. XS1.EQ.-999.0 .AND. XS2.EQ.-999.0) THEN
       B(N) = 1.0
       A(N) = 2.0
       XS(N) = 3.0*(X(N)-X(N-1)) / (S(N)-S(N-1))
      ENDIF
C
C---- solve for derivative array XS
      CALL TRISOL(A,B,C,XS,N)
C
      RETURN
      END ! SPLIND

      SUBROUTINE SPLINA(X,XS,S,N)
      DIMENSION X(N),XS(N),S(N)
      LOGICAL LEND
C-------------------------------------------------------
C     Calculates spline coefficients for X(S) by a      |
C     simple averaging of adjacent segment slopes.      |
C                                                       |
C     Interpolated X(S) is less likely to oscillate     |
C     than with SPLINE, but does not have continuity    |
C     in curvature.                                     |
C                                                       |
C     To evaluate the spline at some value of S,        |
C     use SEVAL and/or DEVAL.                           |
C                                                       |
C     S        independent variable array (input)       |
C     X        dependent variable array   (input)       |
C     XS       dX/dS array                (calculated)  |
C     N        number of points           (input)       |
C                                                       |
C-------------------------------------------------------
C
      LEND = .TRUE.
      DO 1 I=1, N-1
        DS = S(I+1)-S(I)
        IF (DS.EQ.0.) THEN
          XS(I) = XS1
          LEND = .TRUE.
         ELSE
          DX = X(I+1)-X(I)
          XS2 = DX / DS
          IF (LEND) THEN
            XS(I) = XS2
            LEND = .FALSE.
           ELSE
            XS(I) = 0.5*(XS1 + XS2)
          ENDIF
        ENDIF
        XS1 = XS2
    1 CONTINUE
      XS(N) = XS1
C
      RETURN
      END ! SPLINA

      SUBROUTINE TRISOL(A,B,C,D,KK)
      DIMENSION A(KK),B(KK),C(KK),D(KK)
C-----------------------------------------
C     Solves KK long, tri-diagonal system |
C                                         |
C             A C          D              |
C             B A C        D              |
C               B A .      .              |
C                 . . C    .              |
C                   B A    D              |
C                                         |
C     The righthand side D is replaced by |
C     the solution.  A, C are destroyed.  |
C-----------------------------------------
C
      DO 1 K=2, KK
        KM = K-1
        C(KM) = C(KM) / A(KM)
        D(KM) = D(KM) / A(KM)
        A(K) = A(K) - B(K)*C(KM)
        D(K) = D(K) - B(K)*D(KM)
    1 CONTINUE
C
      D(KK) = D(KK)/A(KK)
C
      DO 2 K=KK-1, 1, -1
        D(K) = D(K) - C(K)*D(K+1)
    2 CONTINUE
C
      RETURN
      END ! TRISOL

      FUNCTION GEVAL(SS,X,XS,S,N)
      DIMENSION X(N),XS(N),S(N)
C--------------------------------------------------
C     Calculates int( X(SS) ) dS                   |
C     XS array must have been calculated by SPLINE |
C--------------------------------------------------
      ILOW = 1
      I = N
C
   10 IF(I-ILOW .LE. 1) GO TO 11
C
      IMID = (I+ILOW)/2
      IF(SS .LT. S(IMID)) THEN
       I = IMID
      ELSE
       ILOW = IMID
      ENDIF
      GO TO 10
C
   11 CONTINUE
C
C---- first integrate up to I-1 point
      GEVAL = 0.
      DO K = 2, I-1
        DS = S(K) - S(K-1)
C
C------ Int X(t) dt  for t = 0..1
        DGEV = 0.5*(X(K) + X(K-1)) + (XS(K-1) - XS(K))*DS/12.0
C
        GEVAL = GEVAL + DGEV*DS
      ENDDO
C
C---- now integrate up to SS value in I-1..I interval
      DS = S(I) - S(I-1)
      T = (SS - S(I-1)) / DS
      CX1 = DS*XS(I-1) - X(I) + X(I-1)
      CX2 = DS*XS(I)   - X(I) + X(I-1)
C
      DGEV =      0.5*T*T *X(I)
     &     + (T - 0.5*T*T)*X(I-1)
     &     + (6.0 - 8.0*T + 3.0*T*T)*T*T*CX1/12.0
     &     + (    - 4.0*T + 3.0*T*T)*T*T*CX2/12.0
C
      GEVAL = GEVAL + DGEV*DS
C
      RETURN
      END ! GEVAL

      FUNCTION SEVAL(SS,X,XS,S,N)
      DIMENSION X(N),XS(N),S(N)
C--------------------------------------------------
C     Calculates X(SS)                             |
C     XS array must have been calculated by SPLINE |
C--------------------------------------------------
      ILOW = 1
      I = N
C
   10 IF(I-ILOW .LE. 1) GO TO 11
C
      IMID = (I+ILOW)/2
      IF(SS .LT. S(IMID)) THEN
       I = IMID
      ELSE
       ILOW = IMID
      ENDIF
      GO TO 10
C
   11 DS = S(I) - S(I-1)
      T = (SS - S(I-1)) / DS
      CX1 = DS*XS(I-1) - X(I) + X(I-1)
      CX2 = DS*XS(I)   - X(I) + X(I-1)
      SEVAL = T*X(I) + (1.0-T)*X(I-1) + (T-T*T)*((1.0-T)*CX1 - T*CX2)
      RETURN
      END ! SEVAL

      FUNCTION DEVAL(SS,X,XS,S,N)
      DIMENSION X(N),XS(N),S(N)
C--------------------------------------------------
C     Calculates dX/dS(SS)                         |
C     XS array must have been calculated by SPLINE |
C--------------------------------------------------
      ILOW = 1
      I = N
C
   10 IF(I-ILOW .LE. 1) GO TO 11
C
      IMID = (I+ILOW)/2
      IF(SS .LT. S(IMID)) THEN
       I = IMID
      ELSE
       ILOW = IMID
      ENDIF
      GO TO 10
C
   11 DS = S(I) - S(I-1)
      T = (SS - S(I-1)) / DS
      CX1 = DS*XS(I-1) - X(I) + X(I-1)
      CX2 = DS*XS(I)   - X(I) + X(I-1)
      DEVAL = X(I) - X(I-1) + (1.-4.0*T+3.0*T*T)*CX1 + T*(3.0*T-2.)*CX2
      DEVAL = DEVAL/DS
      RETURN
      END ! DEVAL

      FUNCTION D2VAL(SS,X,XS,S,N)
      DIMENSION X(N),XS(N),S(N)
C--------------------------------------------------
C     Calculates d2X/dS2(SS)                       |
C     XS array must have been calculated by SPLINE |
C--------------------------------------------------
      ILOW = 1
      I = N
C
   10 IF(I-ILOW .LE. 1) GO TO 11
C
      IMID = (I+ILOW)/2
      IF(SS .LT. S(IMID)) THEN
       I = IMID
      ELSE
       ILOW = IMID
      ENDIF
      GO TO 10
C
   11 DS = S(I) - S(I-1)
      T = (SS - S(I-1)) / DS
      CX1 = DS*XS(I-1) - X(I) + X(I-1)
      CX2 = DS*XS(I)   - X(I) + X(I-1)
      D2VAL = (6.*T-4.)*CX1 + (6.*T-2.0)*CX2
      D2VAL = D2VAL/DS**2
      RETURN
      END ! D2VAL

      SUBROUTINE SEVALL(SS,X,XS,S,N,
     &                  XX, XXS, XXSS )
      DIMENSION X(N),XS(N),S(N)
C--------------------------------------------------
C     Calculates all spline derivatives.           |
C     (Combines SEVAL, DEVAL, D2VAL)               |
C     XS array must have been calculated by SPLINE |
C--------------------------------------------------
      ILOW = 1
      I = N
C
   10 IF(I-ILOW .LE. 1) GO TO 11
C
      IMID = (I+ILOW)/2
      IF(SS .LT. S(IMID)) THEN
       I = IMID
      ELSE
       ILOW = IMID
      ENDIF
      GO TO 10
C
   11 DS = S(I) - S(I-1)
      T = (SS - S(I-1)) / DS
C
      F0 = X(I-1)
      F1 = DS*XS(I-1)
      F2 = -DS*(2.0*XS(I-1) + XS(I)) + 3.0*(X(I) - X(I-1))
      F3 =  DS*(    XS(I-1) + XS(I)) - 2.0*(X(I) - X(I-1))
C
      XX = F0 + T*(F1 + T*(    F2 + T*    F3))
      XXS =        F1 + T*(2.0*F2 + T*3.0*F3)
      XXSS =               2.0*F2 + T*6.0*F3
C
      XXS = XXS/DS
      XXSS = XXSS/DS**2
C
      RETURN
      END ! SEVALL

      SUBROUTINE SEVLIN(SS,X,S,N, XX,XXS)
      DIMENSION X(N),S(N)
C------------------------------------------------------------
C     Calculates X(SS) and dX/ds(SS) using piecewise-linear  |
C     interpolation. This is intended for intepolating very  |
C     noisy data for which a cubic spline is inappropriate.  |
C------------------------------------------------------------
      ILOW = 1
      I = N
C
   10 IF(I-ILOW .LE. 1) GO TO 11
C
      IMID = (I+ILOW)/2
      IF(SS .LT. S(IMID)) THEN
       I = IMID
      ELSE
       ILOW = IMID
      ENDIF
      GO TO 10
C
   11 DS = S(I) - S(I-1)
      T = (SS - S(I-1)) / DS
      XX = T*X(I) + (1.0-T)*X(I-1)
      XXS =  (X(I) - X(I-1))/DS
C
      RETURN
      END ! SEVLIN

      FUNCTION CURV(SS,X,XS,Y,YS,S,N)
      DIMENSION X(N), XS(N), Y(N), YS(N), S(N)
C-----------------------------------------------
C     Calculates curvature of splined 2-D curve |
C     at S = SS                                 |
C                                               |
C     S        arc length array of curve        |
C     X, Y     coordinate arrays of curve       |
C     XS,YS    derivative arrays                |
C              (calculated earlier by SPLINE)   |
C-----------------------------------------------
C
      ILOW = 1
      I = N
C
   10 IF(I-ILOW .LE. 1) GO TO 11
C
      IMID = (I+ILOW)/2
      IF(SS .LT. S(IMID)) THEN
       I = IMID
      ELSE
       ILOW = IMID
      ENDIF
      GO TO 10
C
   11 DS = S(I) - S(I-1)
      T = (SS - S(I-1)) / DS
C
      F1 = DS*XS(I-1)
      F2 = -DS*(2.0*XS(I-1) + XS(I)) + 3.0*(X(I) - X(I-1))
      F3 =  DS*(    XS(I-1) + XS(I)) - 2.0*(X(I) - X(I-1))
C
      XD = F1 + T*(2.0*F2 + T*3.0*F3)
      XDD =        2.0*F2 + T*6.0*F3
C
C
      G1 = DS*YS(I-1)
      G2 = -DS*(2.0*YS(I-1) + YS(I)) + 3.0*(Y(I) - Y(I-1))
      G3 =  DS*(    YS(I-1) + YS(I)) - 2.0*(Y(I) - Y(I-1))
C
      YD = G1 + T*(2.0*G2 + T*3.0*G3)
      YDD =        2.0*G2 + T*6.0*G3
C
C
      CURV = (XD*YDD - YD*XDD) / SQRT((XD*XD + YD*YD)**3)
C
      RETURN
      END ! CURV

      FUNCTION CURVS(SS,X,XS,Y,YS,S,N)
      DIMENSION X(N), XS(N), Y(N), YS(N), S(N)
C-----------------------------------------------
C     Calculates curvature derivative of        |
C     splined 2-D curve at S = SS               |
C                                               |
C     S        arc length array of curve        |
C     X, Y     coordinate arrays of curve       |
C     XS,YS    derivative arrays                |
C              (calculated earlier by SPLINE)   |
C-----------------------------------------------
C
      ILOW = 1
      I = N
C
   10 IF(I-ILOW .LE. 1) GO TO 11
C
      IMID = (I+ILOW)/2
      IF(SS .LT. S(IMID)) THEN
       I = IMID
      ELSE
       ILOW = IMID
      ENDIF
      GO TO 10
C
   11 DS = S(I) - S(I-1)
      T = (SS - S(I-1)) / DS
C
      CX1 = DS*XS(I-1) - X(I) + X(I-1)
      CX2 = DS*XS(I)   - X(I) + X(I-1)
      XD = X(I) - X(I-1) + (1.0-4.0*T+3.0*T*T)*CX1 + T*(3.0*T-2.0)*CX2
      XDD = (6.0*T-4.0)*CX1 + (6.0*T-2.0)*CX2
      XDDD = 6.0*CX1 + 6.0*CX2
C
      CY1 = DS*YS(I-1) - Y(I) + Y(I-1)
      CY2 = DS*YS(I)   - Y(I) + Y(I-1)
      YD = Y(I) - Y(I-1) + (1.0-4.0*T+3.0*T*T)*CY1 + T*(3.0*T-2.0)*CY2
      YDD = (6.0*T-4.0)*CY1 + (6.0*T-2.0)*CY2
      YDDD = 6.0*CY1 + 6.0*CY2
C

      F1 = DS*XS(I-1)
      F2 = -DS*(2.0*XS(I-1) + XS(I)) + 3.0*(X(I) - X(I-1))
      F3 =  DS*(    XS(I-1) + XS(I)) - 2.0*(X(I) - X(I-1))
C
      XD = F1 + T*(2.0*F2 + T*3.0*F3)
      XDD =        2.0*F2 + T*6.0*F3
      XDDD =                  6.0*F3
C
C
      G1 = DS*YS(I-1)
      G2 = -DS*(2.0*YS(I-1) + YS(I)) + 3.0*(Y(I) - Y(I-1))
      G3 =  DS*(    YS(I-1) + YS(I)) - 2.0*(Y(I) - Y(I-1))
C
      YD = G1 + T*(2.0*G2 + T*3.0*G3)
      YDD =        2.0*G2 + T*6.0*G3
      YDDD =                  6.0*G3
C
      SQRTB = SQRT(XD*XD + YD*YD)
      BOT = SQRTB**3
      DBOTDT = 3.0*SQRTB*(XD*XDD + YD*YDD)
C
      TOP = XD*YDD - YD*XDD
      DTOPDT = XD*YDDD - YD*XDDD
C
      CURVS = (DTOPDT*BOT - DBOTDT*TOP) / BOT**2  / DS
C
      RETURN
      END ! CURVS

      SUBROUTINE SINVRT(SI,XI,X,XS,S,N)
      DIMENSION X(N),XS(N),S(N)
C----------------------------------------------------
C     Calculates the "inverse" spline function S(X). |
C     Since S(X) can be multi-valued or not defined, |
C      this is not a "black-box" routine.  The call- |
C      ing program must pass via SI a sufficiently   |
C      good initial guess for S(XI).                 |
C                                                    |
C     XI      specified X value       (input)        |
C     SI      calculated S(XI) value  (input,output) |
C     X,XS,S  usual spline arrays     (input)        |
C                                                    |
C----------------------------------------------------
C
      STOL = (S(N) - S(1)) * 1.0E-6
C
      DO 10 ITER=1, 10
        CALL SEVALL(SI,X,XS,S,N, XX,XXS,XXSS)
        DS = (XI-XX)/XXS
        SI = SI + DS
        IF(ABS(DS) .LT. STOL) RETURN
   10 CONTINUE
      WRITE(*,*) 'SINVRT: spline inversion failed.  ds/smax =', DS/STOL
      RETURN
C
      END ! SINVRT

      SUBROUTINE SCALC(X,Y,S,N)
      DIMENSION X(N),Y(N),S(N)
C----------------------------------------
C     Calculates the arc length array S  |
C     for a 2-D array of points (X,Y).   |
C----------------------------------------
C
      S(1) = 0.
      DO 10 I=2, N
        S(I) = S(I-1) + SQRT((X(I)-X(I-1))**2 + (Y(I)-Y(I-1))**2)
   10 CONTINUE
C
      RETURN
      END ! SCALC

      SUBROUTINE SEGSPL(X,XS,S,N)
      DIMENSION X(N),XS(N),S(N)
C-----------------------------------------------
C     Splines X(S) array just like SPLINE,      |
C     but allows derivative discontinuities     |
C     at segment joints.  Segment joints are    |
C     defined by identical successive S values. |
C-----------------------------------------------
C
      IF(S(1).EQ.S(2)  ) STOP 'SEGSPL:  First input point duplicated'
      IF(S(N).EQ.S(N-1)) STOP 'SEGSPL:  Last  input point duplicated'
C
      ISEG0 = 1
      DO 10 ISEG=2, N-2
        IF(S(ISEG).EQ.S(ISEG+1)) THEN
         NSEG = ISEG - ISEG0 + 1
         CALL SPLINE(X(ISEG0),XS(ISEG0),S(ISEG0),NSEG)
         ISEG0 = ISEG+1
        ENDIF
   10 CONTINUE
C
      NSEG = N - ISEG0 + 1
      CALL SPLINE(X(ISEG0),XS(ISEG0),S(ISEG0),NSEG)
C
      RETURN
      END ! SEGSPL

      SUBROUTINE SEGSPD(X,XS,S,N,XS1,XS2)
      DIMENSION X(N),XS(N),S(N)
C-----------------------------------------------
C     Splines X(S) array just like SPLIND,      |
C     but allows derivative discontinuities     |
C     at segment joints.  Segment joints are    |
C     defined by identical successive S values. |
C-----------------------------------------------
C
      IF(S(1).EQ.S(2)  ) STOP 'SEGSPD:  First input point duplicated'
      IF(S(N).EQ.S(N-1)) STOP 'SEGSPD:  Last  input point duplicated'
C
      ISEG0 = 1
      DO 10 ISEG=2, N-2
        IF(S(ISEG).EQ.S(ISEG+1)) THEN
         NSEG = ISEG - ISEG0 + 1
         CALL SPLIND(X(ISEG0),XS(ISEG0),S(ISEG0),NSEG,XS1,XS2)
         ISEG0 = ISEG+1
        ENDIF
   10 CONTINUE
C
      NSEG = N - ISEG0 + 1
      CALL SPLIND(X(ISEG0),XS(ISEG0),S(ISEG0),NSEG,XS1,XS2)
C
      RETURN
      END ! SEGSPD

      SUBROUTINE INTERS(OK,SS1,SS2,
     &                  X1,XS1,Y1,YS1,S1,N1,
     &                  X2,XS2,Y2,YS2,S2,N2 )
      LOGICAL OK
      DIMENSION X1(N1),XS1(N1),Y1(N1),YS1(N1),S1(N1)
      DIMENSION X2(N2),XS2(N2),Y2(N2),YS2(N2),S2(N2)
C-------------------------------------------------------
C     Finds spline coordinate values SS1, SS2 at the
C     intersection of two space curves (X1,Y1), (X2,Y2).
C-------------------------------------------------------
      LOGICAL CLIP1, CLIP2
      DATA EPS / 1.0E-5 /
C
      OK = .TRUE.
ccc      SS1 = S1(1)
ccc      SS2 = S2(1)
      RS1 = 1.0E12
      RS2 = 1.0E12
      DS1 = 0.0
      DS2 = 0.0
C
      DO 1000 ITER=1, 12
C
        RLX = 1.0
        SS1OLD = SS1
        SS2OLD = SS2
        RS1OLD = ABS(RS1)
        RS2OLD = ABS(RS2)
C
        DO 10 IRLX=1, 16
C
          CLIP1 = .FALSE.
          CLIP2 = .FALSE.
          SS1 = SS1OLD + RLX*DS1
          SS2 = SS2OLD + RLX*DS2
C
          IF(SS1.LT.S1(1) .OR. SS1.GT.S1(N1)) THEN
           CLIP1 = .TRUE.
           SS1 = MAX(SS1,S1(1 ))
           SS1 = MIN(SS1,S1(N1))
          ENDIF
          IF(SS2.LT.S2(1) .OR. SS2.GT.S2(N2)) THEN
           CLIP2 = .TRUE.
           SS2 = MAX(SS2,S2(1 ))
           SS2 = MIN(SS2,S2(N2))
          ENDIF
C
          XX1 = SEVAL(SS1,X1,XS1,S1,N1)
          XX2 = SEVAL(SS2,X2,XS2,S2,N2)
          YY1 = SEVAL(SS1,Y1,YS1,S1,N1)
          YY2 = SEVAL(SS2,Y2,YS2,S2,N2)
C
          RS1 = XX1 - XX2
          RS2 = YY1 - YY2
C
          IF(ABS(RS1).LT.RS1OLD .AND.
     &       ABS(RS2).LT.RS2OLD     ) GO TO 11
C
          RLX = 0.5*RLX
C
 10     CONTINUE
        WRITE(*,*) 'INTERS: Under-relaxation loop failed.'
 11     CONTINUE
C
        A11 =  DEVAL(SS1,X1,XS1,S1,N1)
        A12 = -DEVAL(SS2,X2,XS2,S2,N2)
        A21 =  DEVAL(SS1,Y1,YS1,S1,N1)
        A22 = -DEVAL(SS2,Y2,YS2,S2,N2)
C
        DET =   A11*A22 - A12*A21
        DS1 = -(RS1*A22 - A12*RS2)/DET
        DS2 = -(A11*RS2 - RS1*A21)/DET
C
        IF(ABS(DS1) .LT. EPS*(S1(N1)-S1(1)) .AND.
     &     ABS(DS2) .LT. EPS*(S2(N2)-S2(1))      ) RETURN
C
 1000 CONTINUE
      WRITE(*,*) 'INTERS: Convergence failed. Res =', RS1, RS2
      IF(CLIP1)
     & WRITE(*,*)'        S1 clip:', S1(1), S1(N1), SS1, DS1
      IF(CLIP2)
     & WRITE(*,*)'        S2 clip:', S2(1), S2(N2), SS2, DS2
      OK = .FALSE.
C
      RETURN
      END ! INTERS

      SUBROUTINE NEARPT(XPNT,YPNT,SNEAR,X,XP,Y,YP,S,N)
      IMPLICIT REAL (A-H,M,O-Z)
      DIMENSION X(N),XP(N),Y(N),YP(N),S(N)
C========================================================
C     Finds arc length position S=SNEAR of a point
C     on a 2-D splined curve X(S),Y(S) nearest the
C     specified point XPNT,YPNT.
C
C     Assumes the value passed in via SNEAR is a good
C     initial guess.
C========================================================
C
C---- convergence tolerance
      EPS = 1.0E-4 * (S(N) - S(1))
C
C---- Newton iteration loop
      DO 215 IPASS=1, 10
        CALL SEVALL(SNEAR,X,XP,S,N,XXI,XPI,X2I)
        CALL SEVALL(SNEAR,Y,YP,S,N,YYI,YPI,Y2I)
C
C------ residual is dot product with curve tangent vector
        RES   = (XXI-XPNT)*XPI + (YYI-YPNT)*YPI
C
        RES_S = (XPI     )*XPI + (YPI     )*YPI
     &        + (XXI-XPNT)*X2I + (YYI-YPNT)*Y2I
C
        DSN = -RES/RES_S
        SNEAR = SNEAR + DSN
        IF(ABS(DSN) .LT. EPS) GO TO 216
C
  215 CONTINUE
      WRITE(*,*) 'NEARPT: Convergence failed.  Continuing...'
  216 CONTINUE
C
      RETURN
      END ! NEARPT


module setup_init_mod

use constants_mod

contains

subroutine fill(quad)

    use setup_config_mod
    use equations_const_mod

    use mesh_types_mod, only: quad_t
    use quad_utils_mod, only: quad_get_coords

    type(quad_t), intent(inout) :: quad

    real(dp) :: dens(N_NODES,N_NODES,N_NODES)

    real(dp) :: velx(N_NODES,N_NODES,N_NODES)
    real(dp) :: vely(N_NODES,N_NODES,N_NODES)
    real(dp) :: velz(N_NODES,N_NODES,N_NODES)

    real(dp) :: momx(N_NODES,N_NODES,N_NODES)
    real(dp) :: momy(N_NODES,N_NODES,N_NODES)
    real(dp) :: momz(N_NODES,N_NODES,N_NODES)

    real(dp) :: magx(N_NODES,N_NODES,N_NODES)
    real(dp) :: magy(N_NODES,N_NODES,N_NODES)
    real(dp) :: magz(N_NODES,N_NODES,N_NODES)

    real(dp) :: pres(N_NODES,N_NODES,N_NODES)
    real(dp) :: ener(N_NODES,N_NODES,N_NODES)
    real(dp) :: glmp(N_NODES,N_NODES,N_NODES)

    real(dp) :: coords(N_NODES,N_NODES,N_NODES,N_DIMS)
    real(dp) :: radius(N_NODES,N_NODES,N_NODES)

    coords = quad_get_coords(quad)

    where (coords(:,:,:,X_DIR) < 0.05_dp)

        dens =  3.86859_dp

        velx =  11.2536_dp
        vely =  0.0_dp
        velz =  0.0_dp

        pres =  167.345_dp

        magx =  0.0_dp
        magy =  2.1826182_dp
        magz = -2.1826182_dp

    else where

        dens = 1.0_dp

        velx = 0.0_dp
        vely = 0.0_dp
        velz = 0.0_dp

        pres = 1.0_dp

        magx = 0.0_dp
        magy = 0.56418958_dp
        magz = 0.56418958_dp

    end where

    glmp = 0.0_dp

    radius = SQRT(&
        (coords(:,:,:,X_DIR) - 0.25_dp)**2 + &
        (coords(:,:,:,Y_DIR) - 0.5_dp)**2 + &
        (coords(:,:,:,Z_DIR) - 0.5_dp)**2)

    where (radius <= 0.15_dp)
        dens = 10.0_dp
    end where

    momx = dens * velx
    momy = dens * vely
    momz = dens * velz

    ener = pres/(kappa-1.0_dp) &
        + 0.5_dp*dens*(velx**2+vely**2+velz**2) &
        + 0.5_dp/mu0*(magx**2+magy**2+magz**2) &
        + 0.5_dp/mu0*glmp**2

    quad%pld%hydro%state(:,:,:,DENS_VAR) = dens

    quad%pld%hydro%state(:,:,:,MOMX_VAR) = momx
    quad%pld%hydro%state(:,:,:,MOMY_VAR) = momy
    quad%pld%hydro%state(:,:,:,MOMZ_VAR) = momz

    quad%pld%hydro%state(:,:,:,ENER_VAR) = ener

    quad%pld%hydro%state(:,:,:,MAGX_VAR) = magx
    quad%pld%hydro%state(:,:,:,MAGY_VAR) = magy
    quad%pld%hydro%state(:,:,:,MAGZ_VAR) = magz

    quad%pld%hydro%state(:,:,:,GLMP_VAR) = glmp

end subroutine

subroutine hook_init_810

    use share_mod, only: mesh

    use mesh_utils_mod, only: mesh_iterate_quads
    use setup_amr_mod, only: setup_amr_adapt

    integer :: level

    do level = mesh%minlevel,mesh%maxlevel-1
        call mesh_iterate_quads(mesh,fill)
        call setup_amr_adapt()
    end do
    call mesh_iterate_quads(mesh,fill)

end subroutine

end module


#include "defs.h"

      Subroutine InputRegulatedEOS
      Implicit none

      double precision :: e0, p0, cs2

      double precision :: PEOSdata(EOSDATALENGTH),
     &                    SEOSdata(EOSDATALENGTH),
     &                    TEOSdata(EOSDATALENGTH)
      common /EOSdata/PEOSdata, SEOSdata, TEOSdata

      double precision :: EOSe0         ! min (first) energy density
      double precision :: EOSde         ! energy density step
      double precision :: EOSEend       ! max (last) energy density
      Integer :: EOSne = EOSDATALENGTH  ! number of table rows
      common /EOSdatastructure/ EOSe0, EOSde, EOSEend, EOSne

      double precision :: escale, epow, sscale, spow
      common /EOScoeffs/ escale, epow, sscale, spow

      character(len=1000) :: find_data_file

      ! read EOS data from binary file
      open(5, file=find_data_file('eos.dat'), status='old',
     &     access='stream')
      read(5) EOSe0, EOSEend, PEOSdata, SEOSdata, TEOSdata
      close(5)

      ! save energy density step size
      EOSde = (EOSEend - EOSe0)/(EOSne - 1)

      ! Prepare for extrapolating EOS beyond end of table.
      ! Assume a modified power-law ansatz for pressure in the high
      ! energy density limit:
      !
      !   p(e) = e/3 + a*e^b
      !
      ! For b < 1, this converges to the ideal gas limit as e -> inf and
      ! the speed of sound c_s^2 = dp/de -> 1/3 as e -> inf.
      ! The coefficients (a, b) may be determined from the pressure and
      ! its derivative (i.e. the speed of sound) at some reference
      ! energy density e0.  Use the second-to-last table entry as the
      ! reference point and estimate the derivative using a finite
      ! difference.
      e0 = EOSEend - EOSde
      p0 = PEOSdata(EOSne - 1)
      cs2 = (PEOSdata(EOSne) - PEOSdata(EOSne - 2)) / (2*EOSde)

      ! Use variable 'epow' for the exponent 'b' and 'escale' for the
      ! scale factor 'a'.
      epow = e0*(1 - 3*cs2)/(e0 - 3*p0)
      escale = (p0 - e0/3) * e0**(-epow)

      ! Having extrapolated p(e), the entropy density follows from the
      ! differential equation
      !
      !   (e + p(e))/s(e) = 1/(ds(e)/de)
      !
      ! (Note: both sides of this equation are the temperature.)
      ! For the chosen p(e) ansatz this diffeq can be analytically
      ! integrated for s(e).  These coefficients (spow, sscale) are used
      ! in SEOSL7, below.
      spow = 3/(4*(1 - epow))
      sscale = SEOSdata(EOSne - 1) * (e0**epow/(e0 + p0))**spow

      end

C====EOS from table===================================================
      Double Precision Function PEOSL7(e)  ! for lattice P(e)
      Implicit none

      double precision :: e

      double precision :: PEOSdata(EOSDATALENGTH),
     &                    SEOSdata(EOSDATALENGTH),
     &                    TEOSdata(EOSDATALENGTH)
      common /EOSdata/PEOSdata, SEOSdata, TEOSdata

      double precision :: EOSe0         ! min (first) energy density
      double precision :: EOSde         ! energy density step
      double precision :: EOSEend       ! max (last) energy density
      Integer :: EOSne                  ! number of table rows
      common /EOSdatastructure/ EOSe0, EOSde, EOSEend, EOSne

      double precision :: escale, epow, sscale, spow
      common /EOScoeffs/ escale, epow, sscale, spow

      e = abs(e)

      if (e.lt.EOSe0) then
        PEOSL7 = PEOSdata(1)*e/EOSe0
      else if (e.lt.EOSEend) then
        call interpCubic(PEOSdata, EOSne, EOSe0, EOSde, e, PEOSL7)
      else
        ! extrapolate, see notes above
        PEOSL7 = e/3 + escale*e**epow
      endif

      return
      end

      Double Precision Function SEOSL7(e)  ! for lattice S(e)
      Implicit none

      double precision :: e
      double precision :: PEOSL7

      double precision :: PEOSdata(EOSDATALENGTH),
     &                    SEOSdata(EOSDATALENGTH),
     &                    TEOSdata(EOSDATALENGTH)
      common /EOSdata/PEOSdata, SEOSdata, TEOSdata

      double precision :: EOSe0         ! min (first) energy density
      double precision :: EOSde         ! energy density step
      double precision :: EOSEend       ! max (last) energy density
      Integer :: EOSne                  ! number of table rows
      common /EOSdatastructure/ EOSe0, EOSde, EOSEend, EOSne

      double precision :: escale, epow, sscale, spow
      common /EOScoeffs/ escale, epow, sscale, spow

      e = abs(e)

      if (e.lt.EOSe0) then
        SEOSL7 = SEOSdata(1)*e/EOSe0
      else if (e.lt.EOSEend) then
        call interpCubic(SEOSdata, EOSne, EOSe0, EOSde, e, SEOSL7)
      else
        ! extrapolate, see notes above
        SEOSL7 = sscale * ((e + PEOSL7(e))/e**epow)**spow
      endif

      return
      end

      Double Precision Function TEOSL7(e)  ! for lattice T(e)
      Implicit none

      double precision :: e
      double precision :: PEOSL7, SEOSL7

      double precision :: PEOSdata(EOSDATALENGTH),
     &                    SEOSdata(EOSDATALENGTH),
     &                    TEOSdata(EOSDATALENGTH)
      common /EOSdata/PEOSdata, SEOSdata, TEOSdata

      double precision :: EOSe0         ! min (first) energy density
      double precision :: EOSde         ! energy density step
      double precision :: EOSEend       ! max (last) energy density
      Integer :: EOSne                  ! number of table rows
      common /EOSdatastructure/ EOSe0, EOSde, EOSEend, EOSne

      double precision :: escale, epow, sscale, spow
      common /EOScoeffs/ escale, epow, sscale, spow

      e = abs(e)

      if (e.lt.EOSe0) then
        TEOSL7 = TEOSdata(1)*e/EOSe0
      else if (e.lt.EOSEend) then
        call interpCubic(TEOSdata, EOSne, EOSe0, EOSde, e, TEOSL7)
      else
        ! use extrapolated pressure and entropy density
        ! T = (e + p)/s
        TEOSL7 = (e + PEOSL7(e))/SEOSL7(e)
      endif

      return
      end


module methods
	use ChemicalSystem
	use MKL_wrappers
	implicit none

	type solver_options
		real(kind=4) :: theta    = -1.0
	    real(kind=4) :: eta1     =  1.0
	    real(kind=4) :: eta2     =  1.0
	    logical      :: Jacobian = .true.
	    real(kind=8), dimension(:,:),   allocatable :: tht, et1, et2
	    real(kind=8), dimension(:,:,:), allocatable :: tht_bi, et1_bi, et2_bi
	    real(kind=8), dimension(:),     allocatable :: stab_loc
	    real(kind=8), dimension(:),     allocatable :: stab_width
	end type solver_options

	type solver_info
		real(kind=8)    :: time		 = -1.0
		real(kind=8)    :: residual	 = -1.0
		integer(kind=4) :: iter 	 = -1
		integer(kind=4) :: neg_steps = -1
	end type solver_info

	type (solver_options) :: default_solver_options

	! arrays with values local to each thread
    real(kind=8), dimension(:,:), allocatable :: theta_tau
    real(kind=8), dimension(:,:), allocatable :: Y_buf

contains
	include "ssTauLeap.f90"
	include "ssTauLeap_old.f90"
	include "ssTauLeapBistable.f90"
	include "ThetaTauLeap.f90"
	include "SSA.f90"
	include "estimate_parameters.f90"
	include "estimate_stationary_parameters.f90"
	include "estimate_parameters_bistable.f90"
	!include "estimate_parameters_old.f90"

end module methods


*> \brief \b CHPTRS
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CHPTRS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE CHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            INFO, LDB, N, NRHS
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       COMPLEX            AP( * ), B( LDB, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CHPTRS solves a system of linear equations A*X = B with a complex
*> Hermitian matrix A stored in packed format using the factorization
*> A = U*D*U**H or A = L*D*L**H computed by CHPTRF.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          Specifies whether the details of the factorization are stored
*>          as an upper or lower triangular matrix.
*>          = 'U':  Upper triangular, form is A = U*D*U**H;
*>          = 'L':  Lower triangular, form is A = L*D*L**H.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrix B.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in] AP
*> \verbatim
*>          AP is COMPLEX array, dimension (N*(N+1)/2)
*>          The block diagonal matrix D and the multipliers used to
*>          obtain the factor U or L as computed by CHPTRF, stored as a
*>          packed triangular matrix.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (N)
*>          Details of the interchanges and the block structure of D
*>          as determined by CHPTRF.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is COMPLEX array, dimension (LDB,NRHS)
*>          On entry, the right hand side matrix B.
*>          On exit, the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complexOTHERcomputational
*
*  =====================================================================
      SUBROUTINE CHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX            AP( * ), B( LDB, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX            ONE
      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J, K, KC, KP
      REAL               S
      COMPLEX            AK, AKM1, AKM1K, BK, BKM1, DENOM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           CGEMV, CGERU, CLACGV, CSSCAL, CSWAP, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CONJG, MAX, REAL
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CHPTRS', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 .OR. NRHS.EQ.0 )
     $   RETURN
*
      IF( UPPER ) THEN
*
*        Solve A*X = B, where A = U*D*U**H.
*
*        First solve U*D*X = B, overwriting B with X.
*
*        K is the main loop index, decreasing from N to 1 in steps of
*        1 or 2, depending on the size of the diagonal blocks.
*
         K = N
         KC = N*( N+1 ) / 2 + 1
   10    CONTINUE
*
*        If K < 1, exit from loop.
*
         IF( K.LT.1 )
     $      GO TO 30
*
         KC = KC - K
         IF( IPIV( K ).GT.0 ) THEN
*
*           1 x 1 diagonal block
*
*           Interchange rows K and IPIV(K).
*
            KP = IPIV( K )
            IF( KP.NE.K )
     $         CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
*           Multiply by inv(U(K)), where U(K) is the transformation
*           stored in column K of A.
*
            CALL CGERU( K-1, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
     $                  B( 1, 1 ), LDB )
*
*           Multiply by the inverse of the diagonal block.
*
            S = REAL( ONE ) / REAL( AP( KC+K-1 ) )
            CALL CSSCAL( NRHS, S, B( K, 1 ), LDB )
            K = K - 1
         ELSE
*
*           2 x 2 diagonal block
*
*           Interchange rows K-1 and -IPIV(K).
*
            KP = -IPIV( K )
            IF( KP.NE.K-1 )
     $         CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
*
*           Multiply by inv(U(K)), where U(K) is the transformation
*           stored in columns K-1 and K of A.
*
            CALL CGERU( K-2, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
     $                  B( 1, 1 ), LDB )
            CALL CGERU( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1,
     $                  B( K-1, 1 ), LDB, B( 1, 1 ), LDB )
*
*           Multiply by the inverse of the diagonal block.
*
            AKM1K = AP( KC+K-2 )
            AKM1 = AP( KC-1 ) / AKM1K
            AK = AP( KC+K-1 ) / CONJG( AKM1K )
            DENOM = AKM1*AK - ONE
            DO 20 J = 1, NRHS
               BKM1 = B( K-1, J ) / AKM1K
               BK = B( K, J ) / CONJG( AKM1K )
               B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
               B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
   20       CONTINUE
            KC = KC - K + 1
            K = K - 2
         END IF
*
         GO TO 10
   30    CONTINUE
*
*        Next solve U**H *X = B, overwriting B with X.
*
*        K is the main loop index, increasing from 1 to N in steps of
*        1 or 2, depending on the size of the diagonal blocks.
*
         K = 1
         KC = 1
   40    CONTINUE
*
*        If K > N, exit from loop.
*
         IF( K.GT.N )
     $      GO TO 50
*
         IF( IPIV( K ).GT.0 ) THEN
*
*           1 x 1 diagonal block
*
*           Multiply by inv(U**H(K)), where U(K) is the transformation
*           stored in column K of A.
*
            IF( K.GT.1 ) THEN
               CALL CLACGV( NRHS, B( K, 1 ), LDB )
               CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
     $                     LDB, AP( KC ), 1, ONE, B( K, 1 ), LDB )
               CALL CLACGV( NRHS, B( K, 1 ), LDB )
            END IF
*
*           Interchange rows K and IPIV(K).
*
            KP = IPIV( K )
            IF( KP.NE.K )
     $         CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
            KC = KC + K
            K = K + 1
         ELSE
*
*           2 x 2 diagonal block
*
*           Multiply by inv(U**H(K+1)), where U(K+1) is the transformation
*           stored in columns K and K+1 of A.
*
            IF( K.GT.1 ) THEN
               CALL CLACGV( NRHS, B( K, 1 ), LDB )
               CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
     $                     LDB, AP( KC ), 1, ONE, B( K, 1 ), LDB )
               CALL CLACGV( NRHS, B( K, 1 ), LDB )
*
               CALL CLACGV( NRHS, B( K+1, 1 ), LDB )
               CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B,
     $                     LDB, AP( KC+K ), 1, ONE, B( K+1, 1 ), LDB )
               CALL CLACGV( NRHS, B( K+1, 1 ), LDB )
            END IF
*
*           Interchange rows K and -IPIV(K).
*
            KP = -IPIV( K )
            IF( KP.NE.K )
     $         CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
            KC = KC + 2*K + 1
            K = K + 2
         END IF
*
         GO TO 40
   50    CONTINUE
*
      ELSE
*
*        Solve A*X = B, where A = L*D*L**H.
*
*        First solve L*D*X = B, overwriting B with X.
*
*        K is the main loop index, increasing from 1 to N in steps of
*        1 or 2, depending on the size of the diagonal blocks.
*
         K = 1
         KC = 1
   60    CONTINUE
*
*        If K > N, exit from loop.
*
         IF( K.GT.N )
     $      GO TO 80
*
         IF( IPIV( K ).GT.0 ) THEN
*
*           1 x 1 diagonal block
*
*           Interchange rows K and IPIV(K).
*
            KP = IPIV( K )
            IF( KP.NE.K )
     $         CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
*           Multiply by inv(L(K)), where L(K) is the transformation
*           stored in column K of A.
*
            IF( K.LT.N )
     $         CALL CGERU( N-K, NRHS, -ONE, AP( KC+1 ), 1, B( K, 1 ),
     $                     LDB, B( K+1, 1 ), LDB )
*
*           Multiply by the inverse of the diagonal block.
*
            S = REAL( ONE ) / REAL( AP( KC ) )
            CALL CSSCAL( NRHS, S, B( K, 1 ), LDB )
            KC = KC + N - K + 1
            K = K + 1
         ELSE
*
*           2 x 2 diagonal block
*
*           Interchange rows K+1 and -IPIV(K).
*
            KP = -IPIV( K )
            IF( KP.NE.K+1 )
     $         CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
*
*           Multiply by inv(L(K)), where L(K) is the transformation
*           stored in columns K and K+1 of A.
*
            IF( K.LT.N-1 ) THEN
               CALL CGERU( N-K-1, NRHS, -ONE, AP( KC+2 ), 1, B( K, 1 ),
     $                     LDB, B( K+2, 1 ), LDB )
               CALL CGERU( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1,
     $                     B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
            END IF
*
*           Multiply by the inverse of the diagonal block.
*
            AKM1K = AP( KC+1 )
            AKM1 = AP( KC ) / CONJG( AKM1K )
            AK = AP( KC+N-K+1 ) / AKM1K
            DENOM = AKM1*AK - ONE
            DO 70 J = 1, NRHS
               BKM1 = B( K, J ) / CONJG( AKM1K )
               BK = B( K+1, J ) / AKM1K
               B( K, J ) = ( AK*BKM1-BK ) / DENOM
               B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
   70       CONTINUE
            KC = KC + 2*( N-K ) + 1
            K = K + 2
         END IF
*
         GO TO 60
   80    CONTINUE
*
*        Next solve L**H *X = B, overwriting B with X.
*
*        K is the main loop index, decreasing from N to 1 in steps of
*        1 or 2, depending on the size of the diagonal blocks.
*
         K = N
         KC = N*( N+1 ) / 2 + 1
   90    CONTINUE
*
*        If K < 1, exit from loop.
*
         IF( K.LT.1 )
     $      GO TO 100
*
         KC = KC - ( N-K+1 )
         IF( IPIV( K ).GT.0 ) THEN
*
*           1 x 1 diagonal block
*
*           Multiply by inv(L**H(K)), where L(K) is the transformation
*           stored in column K of A.
*
            IF( K.LT.N ) THEN
               CALL CLACGV( NRHS, B( K, 1 ), LDB )
               CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
     $                     B( K+1, 1 ), LDB, AP( KC+1 ), 1, ONE,
     $                     B( K, 1 ), LDB )
               CALL CLACGV( NRHS, B( K, 1 ), LDB )
            END IF
*
*           Interchange rows K and IPIV(K).
*
            KP = IPIV( K )
            IF( KP.NE.K )
     $         CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
            K = K - 1
         ELSE
*
*           2 x 2 diagonal block
*
*           Multiply by inv(L**H(K-1)), where L(K-1) is the transformation
*           stored in columns K-1 and K of A.
*
            IF( K.LT.N ) THEN
               CALL CLACGV( NRHS, B( K, 1 ), LDB )
               CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
     $                     B( K+1, 1 ), LDB, AP( KC+1 ), 1, ONE,
     $                     B( K, 1 ), LDB )
               CALL CLACGV( NRHS, B( K, 1 ), LDB )
*
               CALL CLACGV( NRHS, B( K-1, 1 ), LDB )
               CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE,
     $                     B( K+1, 1 ), LDB, AP( KC-( N-K ) ), 1, ONE,
     $                     B( K-1, 1 ), LDB )
               CALL CLACGV( NRHS, B( K-1, 1 ), LDB )
            END IF
*
*           Interchange rows K and -IPIV(K).
*
            KP = -IPIV( K )
            IF( KP.NE.K )
     $         CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
            KC = KC - ( N-K+2 )
            K = K - 2
         END IF
*
         GO TO 90
  100    CONTINUE
      END IF
*
      RETURN
*
*     End of CHPTRS
*
      END


      subroutine computepdfuncertainty(PDFarray,PDFcentral,
     & PDFperror,PDFnerror,PDFerror)
c--- Routine to compute PDF uncertainty given an array of results
c--- for different PDF uncertainty sets (PDFarray).
c--- Returns central value (PDFcentral), positive and negative
c--- excursions (PDFperror, PDFnerror) and symmetric uncertainty (PDFerror).
c--- Note that the appropriate method for computing uncertainties
c--- is chosen according to the value of "PDFname" used in LHAPDF
c--- (as a result the logic may need to be updated in the future,
c---  it is current as of 9/2013)
c---
c--- This routine is similar to the one provided natively in LHAPDFv5.8.5
c--- onwards ("uncertainties.f", written by Graeme Watt)
      implicit none
      include 'lhapdf.f'
      include 'PDFerrors.f'
      integer j
      double precision PDFarray(0:1000),PDFcentral,PDFperror,PDFnerror,
     & PDFerror,sum1,sum2,PDFMCav,PDFMCer
      logical first
      data first/.true./
      save first

c--- NNPDF: just compute average and standard deviation
      if ((index(PDFname,'NNPDF') .gt. 0) .or.
     &    (index(PDFname,'nnpdf') .gt. 0)) then
        if (first) then
        write(6,*)'****************************************************'
        write(6,*)'*    Using MC prescription for PDF uncertainties,  *'
        write(6,*)'*    appropriate for NNPDF sets                    *'
        write(6,*)'*                                                  *'
        write(6,*)'*   (for details and references, see Eqn. (158)    *'
        write(6,*)'*    in Appendix B of arXiv:0808.1231 [hep-ph])    *'
        write(6,*)'****************************************************'
        first=.false.
        endif
        sum1=0d0
        sum2=0d0
        do j=1,maxPDFsets
           if (PDFarray(j) .ne. 0.) then
             sum1=sum1+PDFarray(j)
             sum2=sum2+PDFarray(j)**2d0
           endif
        enddo
        PDFMCav = sum1/maxPDFsets
        PDFMCer = dsqrt(sum2/maxPDFsets -  PDFMCav**2d0)

        PDFperror=PDFMCer
        PDFnerror=PDFMCer
        PDFerror=PDFMCer
        PDFcentral=PDFMCav
        return
      endif

c--- Alekhin et al: Hessian approach (symmetric)
      if ((index(PDFname,'ABM') .gt. 0) .or.
     &    (index(PDFname,'ABKM') .gt. 0) .or.
     &    (index(PDFname,'A02M') .gt. 0).or.
     &    (index(PDFname,'abm') .gt. 0) .or.
     &    (index(PDFname,'abkm') .gt. 0) .or.
     &    (index(PDFname,'a02m') .gt. 0)) then
        if (first) then
        write(6,*)'****************************************************'
        write(6,*)'*   Using symmetric Hessian prescription for PDF   *'
        write(6,*)'*   uncertainties, appropriate for Alekhin et al.  *'
        write(6,*)'****************************************************'
        first=.false.
        endif
        PDFerror=0d0
        do j=1,maxPDFsets
           if (PDFarray(j) .ne. 0.) then
             PDFerror=PDFerror+(PDFarray(j)-PDFarray(0))**2d0
           endif
        enddo
        PDFerror=dsqrt(PDFerror)
        PDFperror=PDFerror
        PDFnerror=PDFerror
        PDFcentral=PDFarray(0)
        return
      endif

c--- everyone else (CTEQ and MSTW): Hessian approach (asymmetric)
        if (first) then
        write(6,*)'****************************************************'
        write(6,*)'*   Using asymmetric Hessian prescription for PDF  *'
        write(6,*)'*   uncertainties, appropriate for CTEQ, MSTW      *'
        write(6,*)'*                                                  *'
        write(6,*)'*        (see, for example Eqn. (43) of            *'
        write(6,*)'*         J.Campbell, J.Huston, W.J.Stirling,      *'
        write(6,*)'*         Rep. Prog. Phys. 70 (2007) 89)           *'
        write(6,*)'****************************************************'
        first=.false.
        endif
        PDFperror=0d0
        PDFnerror=0d0
        PDFerror=0d0
        do j=1,maxPDFsets-1,2
           if (PDFarray(j) .ne. 0.) then
              PDFperror=PDFperror+max(0d0,
     &        PDFarray(j)-PDFarray(0),PDFarray(j+1)-PDFarray(0))**2
              PDFnerror=PDFnerror+max(0d0,
     &        PDFarray(0)-PDFarray(j),PDFarray(0)-PDFarray(j+1))**2
              PDFerror=PDFerror+(PDFarray(j)-PDFarray(j+1))**2
           endif
        enddo
        PDFerror=0.5d0*dsqrt(PDFerror)
        PDFperror=dsqrt(PDFperror)
        PDFnerror=dsqrt(PDFnerror)
        PDFcentral=PDFarray(0)
        return

      return
      end


use plantfem

type(FEMDomain_) :: mesh

call mesh%create(meshtype="Cube3D")
call mesh%vtk("mesh_10x10x10")
call mesh%remesh(meshtype="Sphere3D",x_num=10,y_num=10,z_num=10)
call mesh%move(x=3.0d0)
call mesh%vtk("mesh_2x2x2")

end


!=======================================================================
! This is part of the 2DECOMP&FFT library
!
! 2DECOMP&FFT is a software framework for general-purpose 2D (pencil)
! decomposition. It also implements a highly scalable distributed
! three-dimensional Fast Fourier Transform (FFT).
!
! Copyright (C) 2009-2011 Ning Li, the Numerical Algorithms Group (NAG)
!
!=======================================================================

! This is the 'generic' implementation of the FFT library

module decomp_2d_fft

  use decomp_2d  ! 2D decomposition module
  use glassman

  !YK: 11 Aug 2020
  use time_stamp, only: put_time_stamp, timer_fft, timer_transpose

  implicit none

  private        ! Make everything private unless declared public

  ! engine-specific global variables
  complex(mytype), allocatable, dimension(:) :: buf, scratch

  ! common code used for all engines, including global variables,
  ! generic interface definitions and several subroutines
#include "fft_common.f90"

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  This routine performs one-time initialisations for the FFT engine
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine init_fft_engine

    implicit none

    integer :: cbuf_size

    if (nrank==0) then
       write(*,*) ' '
       write(*,*) '***** Using the generic FFT engine *****'
       write(*,*) ' '
    end if

    cbuf_size = max(ph%xsz(1), ph%ysz(2))
    cbuf_size = max(cbuf_size, ph%zsz(3))
    allocate(buf(cbuf_size))
    allocate(scratch(cbuf_size))

    return
  end subroutine init_fft_engine

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  This routine performs one-time finalisations for the FFT engine
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine finalize_fft_engine

    implicit none

    deallocate(buf,scratch)

    return
  end subroutine finalize_fft_engine

  ! Following routines calculate multiple one-dimensional FFTs to form
  ! the basis of three-dimensional FFTs.

  ! c2c transform, multiple 1D FFTs in x direction
  subroutine c2c_1m_x(inout, isign, decomp)

    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT) :: inout
    integer, intent(IN) :: isign
    TYPE(DECOMP_INFO), intent(IN) :: decomp

    integer :: i,j,k

    do k=1,decomp%xsz(3)
       do j=1,decomp%xsz(2)
          do i=1,decomp%xsz(1)
             buf(i) = inout(i,j,k)
          end do
          call spcfft(buf,decomp%xsz(1),isign,scratch)
          do i=1,decomp%xsz(1)
             inout(i,j,k) = buf(i)
          end do
       end do
    end do

    return

  end subroutine c2c_1m_x

  ! c2c transform, multiple 1D FFTs in y direction
  subroutine c2c_1m_y(inout, isign, decomp)

    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT) :: inout
    integer, intent(IN) :: isign
    TYPE(DECOMP_INFO), intent(IN) :: decomp

    integer :: i,j,k

    do k=1,decomp%ysz(3)
       do i=1,decomp%ysz(1)
          do j=1,decomp%ysz(2)
             buf(j) = inout(i,j,k)
          end do
          call spcfft(buf,decomp%ysz(2),isign,scratch)
          do j=1,decomp%ysz(2)
             inout(i,j,k) = buf(j)
          end do
       end do
    end do

    return

  end subroutine c2c_1m_y

  ! c2c transform, multiple 1D FFTs in z direction
  subroutine c2c_1m_z(inout, isign, decomp)

    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT) :: inout
    integer, intent(IN) :: isign
    TYPE(DECOMP_INFO), intent(IN) :: decomp

    integer :: i,j,k

    do j=1,decomp%zsz(2)
       do i=1,decomp%zsz(1)
          do k=1,decomp%zsz(3)
             buf(k) = inout(i,j,k)
          end do
          call spcfft(buf,decomp%zsz(3),isign,scratch)
          do k=1,decomp%zsz(3)
             inout(i,j,k) = buf(k)
          end do
       end do
    end do

    return

  end subroutine c2c_1m_z

  ! r2c transform, multiple 1D FFTs in x direction
  subroutine r2c_1m_x(input, output)

    implicit none

    real(mytype), dimension(:,:,:), intent(IN)  ::  input
    complex(mytype), dimension(:,:,:), intent(OUT) :: output

    integer :: i,j,k, s1,s2,s3, d1

    s1 = size(input,1)
    s2 = size(input,2)
    s3 = size(input,3)
    d1 = size(output,1)

    do k=1,s3
       do j=1,s2
          ! Glassman's FFT is c2c only,
          ! needing some pre- and post-processing for r2c
          ! pack real input in complex storage
          do i=1,s1
             buf(i) = cmplx(input(i,j,k),0._mytype, kind=mytype)
          end do
          call spcfft(buf,s1,-1,scratch)
          ! note d1 ~ s1/2+1
          ! simply drop the redundant part of the complex output
          do i=1,d1
             output(i,j,k) = buf(i)
          end do
       end do
    end do

    return

  end subroutine r2c_1m_x

  ! r2c transform, multiple 1D FFTs in z direction
  subroutine r2c_1m_z(input, output)

    implicit none

    real(mytype), dimension(:,:,:), intent(IN)  ::  input
    complex(mytype), dimension(:,:,:), intent(OUT) :: output

    integer :: i,j,k, s1,s2,s3, d3

    s1 = size(input,1)
    s2 = size(input,2)
    s3 = size(input,3)
    d3 = size(output,3)

    do j=1,s2
       do i=1,s1
          ! Glassman's FFT is c2c only,
          ! needing some pre- and post-processing for r2c
          ! pack real input in complex storage
          do k=1,s3
             buf(k) = cmplx(input(i,j,k),0._mytype, kind=mytype)
          end do
          call spcfft(buf,s3,-1,scratch)
          ! note d3 ~ s3/2+1
          ! simply drop the redundant part of the complex output
          do k=1,d3
             output(i,j,k) = buf(k)
          end do
       end do
    end do

    return

  end subroutine r2c_1m_z

  ! c2r transform, multiple 1D FFTs in x direction
  subroutine c2r_1m_x(input, output)

    implicit none

    complex(mytype), dimension(:,:,:), intent(IN)  ::  input
    real(mytype), dimension(:,:,:), intent(OUT) :: output

    integer :: i,j,k, d1,d2,d3

    d1 = size(output,1)
    d2 = size(output,2)
    d3 = size(output,3)

    do k=1,d3
       do j=1,d2
          ! Glassman's FFT is c2c only,
          ! needing some pre- and post-processing for c2r
          do i=1,d1/2+1
             buf(i) = input(i,j,k)
          end do
          ! expanding to a full-size complex array
          ! For odd N, the storage is:
          !  1, 2, ...... N/2+1   integer division rounded down
          !     N, ...... N/2+2   => a(i) is conjugate of a(N+2-i)
          ! For even N, the storage is:
          !  1, 2, ...... N/2  , N/2+1
          !     N, ...... N/2+2  again a(i) conjugate of a(N+2-i)
          do i=d1/2+2,d1
             buf(i) =  conjg(buf(d1+2-i))
          end do
          call spcfft(buf,d1,1,scratch)
          do i=1,d1
             ! simply drop imaginary part
             output(i,j,k) = real(buf(i), kind=mytype)
          end do
       end do
    end do

    return

  end subroutine c2r_1m_x

  ! c2r transform, multiple 1D FFTs in z direction
  subroutine c2r_1m_z(input, output)

    implicit none

    complex(mytype), dimension(:,:,:), intent(IN)  ::  input
    real(mytype), dimension(:,:,:), intent(OUT) :: output

    integer :: i,j,k, d1,d2,d3

    d1 = size(output,1)
    d2 = size(output,2)
    d3 = size(output,3)

    do j=1,d2
       do i=1,d1
          do k=1,d3/2+1
             buf(k) = input(i,j,k)
          end do
          do k=d3/2+2,d3
             buf(k) =  conjg(buf(d3+2-k))
          end do
          call spcfft(buf,d3,1,scratch)
          do k=1,d3
             output(i,j,k) = real(buf(k), kind=mytype)
          end do
       end do
    end do

    return

  end subroutine c2r_1m_z

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! 3D FFT - complex to complex
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine fft_3d_c2c(in, out, isign)

    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT) :: in
    complex(mytype), dimension(:,:,:), intent(OUT) :: out
    integer, intent(IN) :: isign

#ifndef OVERWRITE
    complex(mytype), allocatable, dimension(:,:,:) :: wk1
#endif

    if (format==PHYSICAL_IN_X .AND. isign==DECOMP_2D_FFT_FORWARD .OR.  &
         format==PHYSICAL_IN_Z .AND. isign==DECOMP_2D_FFT_BACKWARD) then

       ! ===== 1D FFTs in X =====
#ifdef OVERWRITE
       call c2c_1m_x(in,isign,ph)
#else
       allocate (wk1(ph%xsz(1),ph%xsz(2),ph%xsz(3)))
       wk1 = in
       call c2c_1m_x(wk1,isign,ph)
#endif

       ! ===== Swap X --> Y; 1D FFTs in Y =====

       if (dims(1)>1) then
#ifdef OVERWRITE
          call transpose_x_to_y(in,wk2_c2c,ph)
#else
          call transpose_x_to_y(wk1,wk2_c2c,ph)
#endif
          call c2c_1m_y(wk2_c2c,isign,ph)
       else
#ifdef OVERWRITE
          call c2c_1m_y(in,isign,ph)
#else
          call c2c_1m_y(wk1,isign,ph)
#endif
       end if

       ! ===== Swap Y --> Z; 1D FFTs in Z =====
       if (dims(1)>1) then
          call transpose_y_to_z(wk2_c2c,out,ph)
       else
#ifdef OVERWRITE
          call transpose_y_to_z(in,out,ph)
#else
          call transpose_y_to_z(wk1,out,ph)
#endif
       end if
       call c2c_1m_z(out,isign,ph)

    else if (format==PHYSICAL_IN_X .AND. isign==DECOMP_2D_FFT_BACKWARD &
         .OR. &
         format==PHYSICAL_IN_Z .AND. isign==DECOMP_2D_FFT_FORWARD) then

       ! ===== 1D FFTs in Z =====
#ifdef OVERWRITE
       call c2c_1m_z(in,isign,ph)
#else
       allocate (wk1(ph%zsz(1),ph%zsz(2),ph%zsz(3)))
       wk1 = in
       call c2c_1m_z(wk1,isign,ph)
#endif

       ! ===== Swap Z --> Y; 1D FFTs in Y =====
       if (dims(1)>1) then
#ifdef OVERWRITE
          call transpose_z_to_y(in,wk2_c2c,ph)
#else
          call transpose_z_to_y(wk1,wk2_c2c,ph)
#endif
          call c2c_1m_y(wk2_c2c,isign,ph)
       else  ! out==wk2_c2c if 1D decomposition
#ifdef OVERWRITE
          call transpose_z_to_y(in,out,ph)
#else
          call transpose_z_to_y(wk1,out,ph)
#endif
          call c2c_1m_y(out,isign,ph)
       end if

       ! ===== Swap Y --> X; 1D FFTs in X =====
       if (dims(1)>1) then
          call transpose_y_to_x(wk2_c2c,out,ph)
       end if
       call c2c_1m_x(out,isign,ph)

    end if

    return
  end subroutine fft_3d_c2c

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! 3D forward FFT - real to complex
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine fft_3d_r2c(in_r, out_c)

    implicit none

    real(mytype), dimension(:,:,:), intent(IN) :: in_r
    complex(mytype), dimension(:,:,:), intent(OUT) :: out_c

    if (format==PHYSICAL_IN_X) then

       ! ===== 1D FFTs in X =====

       if (nrank == 0) call put_time_stamp(timer_fft) ! YK
       call r2c_1m_x(in_r,wk13)
       if (nrank == 0) call put_time_stamp(timer_fft) ! YK

       ! ===== Swap X --> Y; 1D FFTs in Y =====
       if (dims(1)>1) then
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
          call transpose_x_to_y(wk13,wk2_r2c,sp)
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK

          if (nrank == 0) call put_time_stamp(timer_fft) ! YK
          call c2c_1m_y(wk2_r2c,-1,sp)
          if (nrank == 0) call put_time_stamp(timer_fft) ! YK
       else
          if (nrank == 0) call put_time_stamp(timer_fft) ! YK
          call c2c_1m_y(wk13,-1,sp)
          if (nrank == 0) call put_time_stamp(timer_fft) ! YK
       end if

       ! ===== Swap Y --> Z; 1D FFTs in Z =====
       if (dims(1)>1) then
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
          call transpose_y_to_z(wk2_r2c,out_c,sp)
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
       else
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
          call transpose_y_to_z(wk13,out_c,sp)
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
       end if

       if (nrank == 0) call put_time_stamp(timer_fft) ! YK
       call c2c_1m_z(out_c,-1,sp)
       if (nrank == 0) call put_time_stamp(timer_fft) ! YK

    else if (format==PHYSICAL_IN_Z) then

       ! ===== 1D FFTs in Z =====
       if (nrank == 0) call put_time_stamp(timer_fft) ! YK
       call r2c_1m_z(in_r,wk13)
       if (nrank == 0) call put_time_stamp(timer_fft) ! YK

       ! ===== Swap Z --> Y; 1D FFTs in Y =====
       if (dims(1)>1) then
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
          call transpose_z_to_y(wk13,wk2_r2c,sp)
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK

          if (nrank == 0) call put_time_stamp(timer_fft) ! YK
          call c2c_1m_y(wk2_r2c,-1,sp)
          if (nrank == 0) call put_time_stamp(timer_fft) ! YK
       else  ! out_c==wk2_r2c if 1D decomposition
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
          call transpose_z_to_y(wk13,out_c,sp)
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK

          if (nrank == 0) call put_time_stamp(timer_fft) ! YK
          call c2c_1m_y(out_c,-1,sp)
          if (nrank == 0) call put_time_stamp(timer_fft) ! YK
       end if

       ! ===== Swap Y --> X; 1D FFTs in X =====
       if (dims(1)>1) then
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
          call transpose_y_to_x(wk2_r2c,out_c,sp)
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
       end if

       if (nrank == 0) call put_time_stamp(timer_fft) ! YK
       call c2c_1m_x(out_c,-1,sp)
       if (nrank == 0) call put_time_stamp(timer_fft) ! YK

    end if

    return
  end subroutine fft_3d_r2c

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! 3D inverse FFT - complex to real
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine fft_3d_c2r(in_c, out_r)

    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT) :: in_c
    real(mytype), dimension(:,:,:), intent(OUT) :: out_r

#ifndef OVERWRITE
    complex(mytype), allocatable, dimension(:,:,:) :: wk1
#endif

    if (format==PHYSICAL_IN_X) then

       ! ===== 1D FFTs in Z =====
#ifdef OVERWRITE
       if (nrank == 0) call put_time_stamp(timer_fft) ! YK
       call c2c_1m_z(in_c,1,sp)
       if (nrank == 0) call put_time_stamp(timer_fft) ! YK
#else
       allocate(wk1(sp%zsz(1),sp%zsz(2),sp%zsz(3)))
       wk1 = in_c

       if (nrank == 0) call put_time_stamp(timer_fft) ! YK
       call c2c_1m_z(wk1,1,sp)
       if (nrank == 0) call put_time_stamp(timer_fft) ! YK
#endif

       ! ===== Swap Z --> Y; 1D FFTs in Y =====
#ifdef OVERWRITE
       if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
       call transpose_z_to_y(in_c,wk2_r2c,sp)
       if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
#else
       if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
       call transpose_z_to_y(wk1,wk2_r2c,sp)
       if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
#endif
       if (nrank == 0) call put_time_stamp(timer_fft) ! YK
       call c2c_1m_y(wk2_r2c,1,sp)
       if (nrank == 0) call put_time_stamp(timer_fft) ! YK

       ! ===== Swap Y --> X; 1D FFTs in X =====
       if (dims(1)>1) then
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
          call transpose_y_to_x(wk2_r2c,wk13,sp)
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK

          if (nrank == 0) call put_time_stamp(timer_fft) ! YK
          call c2r_1m_x(wk13,out_r)
          if (nrank == 0) call put_time_stamp(timer_fft) ! YK
       else
          if (nrank == 0) call put_time_stamp(timer_fft) ! YK
          call c2r_1m_x(wk2_r2c,out_r)
          if (nrank == 0) call put_time_stamp(timer_fft) ! YK
       end if

    else if (format==PHYSICAL_IN_Z) then

       ! ===== 1D FFTs in X =====
#ifdef OVERWRITE
       if (nrank == 0) call put_time_stamp(timer_fft) ! YK
       call c2c_1m_x(in_c,1,sp)
       if (nrank == 0) call put_time_stamp(timer_fft) ! YK
#else
       allocate(wk1(sp%xsz(1),sp%xsz(2),sp%xsz(3)))
       wk1 = in_c

       if (nrank == 0) call put_time_stamp(timer_fft) ! YK
       call c2c_1m_x(wk1,1,sp)
       if (nrank == 0) call put_time_stamp(timer_fft) ! YK
#endif

       ! ===== Swap X --> Y; 1D FFTs in Y =====
       if (dims(1)>1) then
#ifdef OVERWRITE
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
          call transpose_x_to_y(in_c,wk2_r2c,sp)
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
#else
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
          call transpose_x_to_y(wk1,wk2_r2c,sp)
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
#endif
          if (nrank == 0) call put_time_stamp(timer_fft) ! YK
          call c2c_1m_y(wk2_r2c,1,sp)
          if (nrank == 0) call put_time_stamp(timer_fft) ! YK
       else  ! in_c==wk2_r2c if 1D decomposition
#ifdef OVERWRITE
          if (nrank == 0) call put_time_stamp(timer_fft) ! YK
          call c2c_1m_y(in_c,1,sp)
          if (nrank == 0) call put_time_stamp(timer_fft) ! YK
#else
          if (nrank == 0) call put_time_stamp(timer_fft) ! YK
          call c2c_1m_y(wk1,1,sp)
          if (nrank == 0) call put_time_stamp(timer_fft) ! YK
#endif
       end if

       ! ===== Swap Y --> Z; 1D FFTs in Z =====
       if (dims(1)>1) then
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
          call transpose_y_to_z(wk2_r2c,wk13,sp)
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
       else
#ifdef OVERWRITE
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
          call transpose_y_to_z(in_c,wk13,sp)
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
#else
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
          call transpose_y_to_z(wk1,wk13,sp)
          if (nrank == 0) call put_time_stamp(timer_transpose) ! YK
#endif
       end if
       if (nrank == 0) call put_time_stamp(timer_fft) ! YK
       call c2r_1m_z(wk13,out_r)
       if (nrank == 0) call put_time_stamp(timer_fft) ! YK

    end if

    return
  end subroutine fft_3d_c2r

end module decomp_2d_fft


C
C
*+ do_alpha_map

       subroutine do_alpha_map(map_array,status)
C      -----------------------------------------
C
C construct a spectral-index/error map from 2 I maps
C
C Given:
C   map data
       real*4        map_array(*)
C Returned:
C   error status word
       integer       status
C
C The spectral index is defined using the convention:
C
C   S = constant * freq**-alpha
C
C In addition to the spectral index map and error map is also constructed.
*-

C Local variables
       integer    minirt(8), iu, iv, iwarn
       integer    imap1, ip_map1, imap2, ip_map2
       integer    imapo, ip_mapo, imape, ip_mape
       integer    ifreq_1, ifreq_2
       real*4     noise_1, noise_2, gate_1, gate_2, freq_1, freq_2,
     *            val_lim_1, val_lim_2, val_alpha, val_1, val_2
       real*4     const, val_e
       character  unit*16, name*16
       integer    ipoln
       real*4     blank

C check status on entry
       if (status.ne.0) return

C read map -- 1
       call map_getmap('Map-1 : ','Default-Map','READ',imap1,status)
       call io_getr('Noise 1-map : ','0.0',noise_1,status)
       call io_getr('Gate-1 : ','0.0',gate_1,status)
       call entype(freq_1,ipoln,name,unit,status)
C read map -- 2
       call map_getmap('Map-2 : ','Default-Map','READ',imap2,status)
       call io_getr('Noise 2-Map : ','0.0',noise_2,status)
       call io_getr('Gate-2 : ','0.0',gate_2,status)
       call entype(freq_2,ipoln,name,unit,status)
       if (status.ne.0) goto 999

C check frequencies of the two maps
       if (abs(freq_1-freq_2).lt.1.0E-12) then
         call cmd_wrerr('ALPHA-MAP',
     *        'Map frequencies equal, unable to make ALPHA map: STOP')
         goto 999
       end if
       if (freq_1.le.0.0) then
         call cmd_wrerr('ALPHA-MAP','Frequency map-1 <= 0.0: STOP')
         goto 999
       end if
       if (freq_2.le.0.0) then
         call cmd_wrerr('ALPHA-MAP','Frequency map-2 <= 0.0: STOP')
         goto 999
       end if

C check redtape
       iwarn = 2
       call redt_comp(imap1,imap2,iwarn,status)
       if (status.ne.0. .or. iwarn.gt.5) goto 999

C allocate maps
       call map_alloc_in(imap1,'SEQUENTIAL',map_array,ip_map1,status)
       call map_alloc_in(imap2,'SEQUENTIAL',map_array,ip_map2,status)
       call map_alloc_out(0,0,'SEQUENTIAL',imapo,ip_mapo,status)
       call map_alloc_out(0,0,'SEQUENTIAL',imape,ip_mape,status)
       if (status.ne.0) goto 999

C determine limiting map values and constants
       call ennull(blank,status)
       val_lim_1 = noise_1*gate_1
       val_lim_2 = noise_2*gate_2
       call enminirt(minirt,status)
       const = 1.0/log(freq_2/freq_1)
      if (status.ne.0) goto 999

C construct the alpha map
       do iv = minirt(3),minirt(4),-1
         call map_row_read(imap1,iv,map_array,ip_map1,status)
         call map_row_read(imap2,iv,map_array,ip_map2,status)
         do iu = 1,minirt(5)
           val_1 = map_array(ip_map1+iu-1)
           val_2 = map_array(ip_map2+iu-1)
           if (val_1.gt.val_lim_1 .and. val_2.gt.val_lim_2) then
             val_alpha = const * log(val_1/val_2)
             map_array(ip_mapo+iu-1) = val_alpha
             val_e = abs(const)*
     *               sqrt((noise_1/val_1)**2 + (noise_2/val_2)**2)
             map_array(ip_mape+iu-1) = val_e
           else
             map_array(ip_mapo+iu-1) = 0.0
             map_array(ip_mape+iu-1) = blank
           end if
         end do
         call map_row_write(imapo,iv,map_array,ip_mapo,status)
         call map_row_write(imape,iv,map_array,ip_mape,status)
         if (status.ne.0) goto 999
       end do

C update redtapes
       ifreq_1 = freq_1 + 0.5
       ifreq_2 = freq_2 + 0.5
       write (unit,10)ifreq_1,ifreq_2
10     format('a :',i6,':',i6)
       call redt_update(' ',13,0.0,'Error Sp-Index',unit,status)
       call adredt('created','ALPH-ERR',status)

C end error map
999    continue
       call map_end_alloc(imape,map_array,status)

C main map
       call redt_update(' ',13,0.0,'Spectral Index',unit,status)
       call adredt('created','ALPH-MAP',status)
       call map_end_alloc(imapo,map_array,status)

C input maps
       call map_end_alloc(imap1,map_array,status)
       call map_end_alloc(imap2,map_array,status)

C check status value
       call cmd_err(status,'ALPHA-MAP','Failed')
       end


*     AB08ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          MPMAX
      PARAMETER        ( MPMAX = MAX( MMAX, PMAX ) )
      INTEGER          LDA, LDB, LDC, LDD, LDAF, LDBF, LDQ, LDZ
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDD = PMAX, LDAF = NMAX+MPMAX,
     $                   LDBF = NMAX+PMAX, LDQ = 1, LDZ = 1 )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( MAX( MPMAX+1, NMAX ) +
     $                                 MAX( 3*(MPMAX+1), NMAX+MPMAX ),
     $                                 8*NMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          DINFZ, I, INFO, J, M, N, NINFZ, NKROL, NKROR,
     $                 NU, P, RANK
      CHARACTER*1      EQUIL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), AF(LDAF,NMAX+PMAX), ALFI(NMAX),
     $                 ALFR(NMAX), B(LDB,MMAX), BETA(NMAX),
     $                 BF(LDBF,MMAX+NMAX), C(LDC,NMAX), D(LDD,MMAX),
     $                 DWORK(LDWORK), Q(LDQ,1), Z(LDZ,1)
      INTEGER          INFZ(NMAX), IWORK(MPMAX+1), KRONL(NMAX+1),
     $                 KRONR(NMAX+1)
*     .. External Subroutines ..
      EXTERNAL         AB08ND, DGEGV
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, EQUIL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99972 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99971 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99970 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Check the observability and compute the ordered set of
*              the observability indices (call the routine with M = 0).
               CALL AB08ND( EQUIL, N, 0, P, A, LDA, B, LDB, C, LDC, D,
     $                      LDD, NU, RANK, DINFZ, NKROR, NKROL, INFZ,
     $                      KRONR, KRONL, AF, LDAF, BF, LDBF, TOL,
     $                      IWORK, DWORK, LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99994 ) ( KRONL(I), I = 1,P )
                  IF ( NU.EQ.0 ) THEN
                     WRITE ( NOUT, FMT = 99993 )
                  ELSE
                     WRITE ( NOUT, FMT = 99992 ) N - NU
                     WRITE ( NOUT, FMT = 99991 )
                     WRITE ( NOUT, FMT = 99990 )
                     DO 20 I = 1, NU
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( AF(I,J), J = 1,NU )
   20                CONTINUE
                  END IF
               END IF
*              Check the controllability and compute the ordered set of
*              the controllability indices (call the routine with P = 0)
               CALL AB08ND( EQUIL, N, M, 0, A, LDA, B, LDB, C, LDC, D,
     $                      LDD, NU, RANK, DINFZ, NKROR, NKROL, INFZ,
     $                      KRONR, KRONL, AF, LDAF, BF, LDBF, TOL,
     $                      IWORK, DWORK, LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99988 ) ( KRONR(I), I = 1,M )
                  IF ( NU.EQ.0 ) THEN
                     WRITE ( NOUT, FMT = 99987 )
                  ELSE
                     WRITE ( NOUT, FMT = 99986 ) N - NU
                     WRITE ( NOUT, FMT = 99985 )
                     WRITE ( NOUT, FMT = 99990 )
                     DO 40 I = 1, NU
                        WRITE ( NOUT, FMT = 99989 )
     $                        ( AF(I,J), J = 1,NU )
   40                CONTINUE
                  END IF
               END IF
*              Compute the structural invariants of the given system.
               CALL AB08ND( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D,
     $                      LDD, NU, RANK, DINFZ, NKROR, NKROL, INFZ,
     $                      KRONR, KRONL, AF, LDAF, BF, LDBF, TOL,
     $                      IWORK, DWORK, LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99984 ) NU
                  IF ( NU.GT.0 ) THEN
*                    Compute the invariant zeros of the given system.
*                    Workspace: need 8*NU.
                     WRITE ( NOUT, FMT = 99983 )
                     CALL DGEGV( 'No vectors', 'No vectors', NU, AF,
     $                           LDAF, BF, LDBF, ALFR, ALFI, BETA, Q,
     $                           LDQ, Z, LDZ, DWORK, LDWORK, INFO )
*
                     IF ( INFO.NE.0 ) THEN
                        WRITE ( NOUT, FMT = 99997 ) INFO
                     ELSE
                        WRITE ( NOUT, FMT = 99981 )
                        DO 60 I = 1, NU
                           IF ( ALFI(I).EQ.ZERO ) THEN
                              WRITE ( NOUT, FMT = 99980 )
     $                                ALFR(I)/BETA(I)
                           ELSE
                              WRITE ( NOUT, FMT = 99979 )
     $                                ALFR(I)/BETA(I),
     $                                ALFI(I)/BETA(I)
                           END IF
   60                   CONTINUE
                        WRITE ( NOUT, FMT = 99982 )
                     END IF
                  END IF
                  NINFZ = 0
                  DO 80 I = 1, DINFZ
                     IF ( INFZ(I).GT.0 ) THEN
                        NINFZ = NINFZ + INFZ(I)*I
                     END IF
   80             CONTINUE
                  WRITE ( NOUT, FMT = 99978 ) NINFZ
                  IF ( NINFZ.GT.0 ) THEN
                     DO 100 I = 1, DINFZ
                        WRITE ( NOUT, FMT = 99977 ) INFZ(I), I
  100                CONTINUE
                  END IF
                  WRITE ( NOUT, FMT = 99976 ) NKROR
                  IF ( NKROR.GT.0 ) WRITE ( NOUT, FMT = 99975 )
     $                                      ( KRONR(I), I = 1,NKROR )
                  WRITE ( NOUT, FMT = 99974 ) NKROL
                  IF ( NKROL.GT.0 ) WRITE ( NOUT, FMT = 99973 )
     $                                      ( KRONL(I), I = 1,NKROL )
               END IF
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' AB08ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB08ND = ',I2)
99997 FORMAT (' INFO on exit from DGEGV = ',I2)
99994 FORMAT (' The left Kronecker indices of (A,C) are ',/(20(I3,2X)))
99993 FORMAT (/' The system (A,C) is completely observable ')
99992 FORMAT (/' The dimension of the observable subspace = ',I3)
99991 FORMAT (/' The output decoupling zeros are the eigenvalues of th',
     $       'e matrix AF. ')
99990 FORMAT (/' The matrix AF is ')
99989 FORMAT (20(1X,F8.4))
99988 FORMAT (//' The right Kronecker indices of (A,B) are ',/(20(I3,2X)
     $       ))
99987 FORMAT (/' The system (A,B) is completely controllable ')
99986 FORMAT (/' The dimension of the controllable subspace = ',I3)
99985 FORMAT (/' The input decoupling zeros are the eigenvalues of the',
     $       ' matrix AF. ')
99984 FORMAT (//' The number of finite invariant zeros = ',I3)
99983 FORMAT (/' The finite invariant zeros are ')
99982 FORMAT (/' which correspond to the generalized eigenvalues of (l',
     $       'ambda*BF - AF).')
99981 FORMAT (/' real  part     imag  part ')
99980 FORMAT (1X,F9.4)
99979 FORMAT (1X,F9.4,6X,F9.4)
99978 FORMAT (//' The number of infinite zeros = ',I3)
99977 FORMAT ( I4,' infinite zero(s) of order ',I3)
99976 FORMAT (/' The number of right Kronecker indices = ',I3)
99975 FORMAT (/' Right Kronecker (column) indices of (A,B,C,D) are ',
     $       /(20(I3,2X)))
99974 FORMAT (/' The number of left Kronecker indices = ',I3)
99973 FORMAT (/' The left Kronecker (row) indices of (A,B,C,D) are ',
     $       /(20(I3,2X)))
99972 FORMAT (/' N is out of range.',/' N = ',I5)
99971 FORMAT (/' M is out of range.',/' M = ',I5)
99970 FORMAT (/' P is out of range.',/' P = ',I5)
      END