!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceedf.h'

      integer ceed,err
      integer x,y
      integer r
      integer i
      integer*8 aoffset,yoffset

      integer ne
      parameter(ne=3)

      integer*4 ind(2*ne)
      real*8 a(ne+1)
      real*8 yy(2*ne)
      real*8 diff

      character arg*32

      call getarg(1,arg)
      call ceedinit(trim(arg)//char(0),ceed,err)

      call ceedvectorcreate(ceed,ne+1,x,err)

      do i=1,ne+1
        a(i)=10+i-1
      enddo

      aoffset=0
      call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,a,aoffset,err)

      do i=1,ne
        ind(2*i-1)=i-1
        ind(2*i  )=i
      enddo

      call ceedelemrestrictioncreate(ceed,ne,2,1,1,ne+1,ceed_mem_host,&
     & ceed_use_pointer,ind,r,err)

      call ceedvectorcreate(ceed,2*ne,y,err);
      call ceedvectorsetvalue(y,0.d0,err);
      call ceedelemrestrictionapply(r,ceed_notranspose,x,y,&
     & ceed_request_immediate,err)

      call ceedvectorgetarrayread(y,ceed_mem_host,yy,yoffset,err)
      do i=1,ne*2
        diff=10+i/2-yy(i+yoffset)
        if (abs(diff) > 1.0D-15) then
! LCOV_EXCL_START
          write(*,*) 'Error in restricted array y(',i,')=',yy(i+yoffset)
! LCOV_EXCL_STOP
        endif
      enddo
      call ceedvectorrestorearrayread(y,yy,yoffset,err)

      call ceedvectordestroy(x,err)
      call ceedvectordestroy(y,err)
      call ceedelemrestrictiondestroy(r,err)
      call ceeddestroy(ceed,err)

      end
!-----------------------------------------------------------------------


c     =====================================================
      subroutine clawpack46_qinit(maxmx,maxmy,meqn,mbc,
     &      mx,my, xlower,ylower,dx,dy,q,maux,aux)
c     =====================================================

c     # Set initial conditions for q.
c     # Sample scalar equation with data that is piecewise constant with
c     # q = 1.0  if  0.1 < x < 0.6   and   0.1 < y < 0.6
c     #     0.1  otherwise

       implicit none

       integer maxmx, maxmy, meqn, mbc, mx, my, maux
       double precision xlower, ylower, dx, dy
       double precision q(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn)
       double precision aux(1-mbc:mx+mbc, 1-mbc:my+mbc, maux)

       integer i, j, mq, blockno, fc2d_clawpack46_get_block
       double precision xlow, ylow, w

       blockno = fc2d_clawpack46_get_block()

       do mq = 1,meqn
          do i = 1-mbc,mx+mbc
             do j = 1-mbc,my+mbc
                xlow = xlower + (i-1)*dx
                ylow = ylower + (j-1)*dy
                call cellave2(blockno,xlow,ylow,dx,dy,w)
                q(i,j,mq) = w
             enddo
          enddo
       enddo

       end


program prog4
implicit none

complex :: cx

cx = cmplx(3d0,5d0)

write(*,*)cx

end program prog4


! { dg-do run }
! { dg-options "-O0" }
!
! Tests fix for PR21459 - This is the original example.
!
program format_string
  implicit none
  character(len=*), parameter :: rform='(F15.5)', &
  cform="(' (', F15.5, ',' F15.5, ') ')"
  call print_a_number(cform)
contains
subroutine print_a_number(style)
  character(len=*) :: style
  write(*, style) cmplx(42.0, 99.0) ! { dg-output "99.00000" }
end subroutine print_a_number
end program format_string


module mc_walk

implicit none
integer :: nwalks

contains

subroutine random_walk(i0, j0, max_steps, ub, iabort)

    use problem_description, only: nx,ny,ax,ay,dx,dy,uboundary

    implicit none
    integer, intent(in) :: i0,j0,max_steps
    real(kind=8), intent(out) :: ub
    integer, intent(out) :: iabort

    real(kind=4), allocatable :: r(:)
    integer i,j,istep
    real(kind=4) :: rr
    real(kind=8) :: xb,yb

    allocate(r(max_steps))

    i = i0
    j = j0
    call random_number(r)

    do istep=1,max_steps
        rr = r(istep)
        if (rr < 0.25d0) then
            i = i-1
          else if (rr < 0.5d0) then
            i = i+1
          else if (rr < 0.75d0) then
            j = j-1
          else
            j = j+1
          endif

        if (i*j*(nx+1-i)*(ny+1-j) == 0) then
            xb = ax + i*dx
            yb = ay + j*dy
            ub = uboundary(xb, yb)
            exit  ! end the walk
            endif
        enddo

    if (istep == max_steps+1) then
        iabort = 1
        ub = 0.d0  ! this value should not be used
    else
        iabort = 0
    endif

    nwalks = nwalks + 1

end subroutine random_walk

subroutine many_walks(i0, j0, max_steps, n_mc, u_mc, n_success)
    implicit none
    integer, intent(in) :: i0,j0,max_steps,n_mc
    integer, intent(out) :: n_success
    real(kind=8), intent(out) :: u_mc

    integer :: k, iabort, nb_sum
    real(kind=8) :: ub,ub_sum

    ub_sum = 0.d0
    nb_sum = 0

    do k=1,n_mc
        call random_walk(i0, j0, max_steps, ub, iabort)
        if (iabort == 0) then
            ub_sum = ub_sum + ub
            nb_sum = nb_sum + 1
            endif
        enddo

    u_mc = ub_sum / nb_sum
    n_success = nb_sum

end subroutine many_walks

end module mc_walk


!  *********************************************************************
!  *                                                                   *
!  *                          function randu                           *
!  *                                                                   *
!  *********************************************************************
!  Single Precision Version 2.0
!  Adapted from Press etal. "Numerical Recipes in Fortran", 2nd Ed.,
!  RAN1 program, pg 271
!  by Gordon A. Fenton, TUNS, Oct 14, 1996
!
!  PURPOSE  returns a pseudo-random number uniformly distributed on the
!           interval (0,1)
!
!  This routine uses a pair of multiplicative congruential generators to
!  produce a sequence of random numbers uniformly distributed on the interval
!  (0,1) which exceeds Park and Miller's ``Minimal Standard.'' The generator
!  has a period of about 2.3E+18 and uses a shuffling algorithm due to Bays
!  and Durham to remove low-order serial correlations. This routine is
!  about 2.0 times slower than the minimal routine `RAN0' presented in
!  Numerical Recipes. The endpoints of the interval (0,1) are excluded.
!
!  Arguments to the function are as follows;
!
!      jseed    integer seed. If jseed is zero, the next pseudo random number
!               in the sequence is returned. Otherwise if jseed is positive,
!               it is used to initialize the generator and the first value
!               in the sequence is returned. (input)
!
!  Notes:
!    1) if you always call this routine without initializing it (using
!       a positive seed) then you'll always get the same sequence of
!       pseudo-random numbers.
!
!  REVISION HISTORY:
!  2.0	implemented RAN2 from 2nd Edition of Numerical Recipes
!-----------------------------------------------------------------------------
      real function randu2(jseed)
      integer jseed, idumm,IM1,IM2,IMM1,IA1,IA2,IQ1,IQ2,IR1,IR2,NTAB,NDIV
      real AM,EPS,RNMX
      PARAMETER (IM1  = 2147483563, &
                IM2  = 2147483399,  &
                AM   = 1./IM1,      &
                IMM1 = IM1-1,       &
                IA1  = 40014,       &
                IA2  = 40692,       &
                IQ1  = 53668,       &
                IQ2  = 52774,       &
                IR1  = 12211,       &
                IR2  = 3791,        &
                NTAB = 32,          &
                NDIV = 1+IMM1/NTAB, &
                EPS  = 1.2e-7,      &
                RNMX = 1.-EPS)
      INTEGER idum22,j,k,ivv(NTAB),iyy
      SAVE ivv,iyy,idumm,idum22,ifirst2
      DATA idum22/123456789/, ivv/NTAB*0/, iyy/0/, ifirst2/0/

      if( (jseed .gt. 0) .or. (ifirst2 .eq. 0) ) then
         ifirst2 = 1
         idumm   = max0(jseed,1)
         idum22  = idumm
         do 10 j = NTAB+8, 1, -1
            k    = idumm/IQ1
            idumm = IA1*(idumm-k*IQ1) - k*IR1
            if( idumm .lt. 0 ) idumm  = idumm + IM1
            if( j .le. NTAB ) ivv(j) = idumm
  10     continue
         iyy = ivv(1)
      endif

      k    = idumm/IQ1
      idumm = IA1*(idumm-k*IQ1) - k*IR1
      if( idumm .lt. 0 ) idumm = idumm + IM1
      k     = idum22/IQ2
      idum22 = IA2*(idum22-k*IQ2) - k*IR2
      if( idum22 .lt. 0 ) idum22 = idum22 + IM2
      j     = 1 + iyy/NDIV
      iyy    = ivv(j) - idum22
      ivv(j) = idumm
      if( iyy .lt. 1 ) iyy = iyy + IMM1
      randu2 = amin1( AM*iyy, RNMX )
      return
      end


      subroutine clock(time)
c--------------------------------------------------------------------
c      corrects times in (yr,day,hr,min,sec) format when seconds
c  are greater than 60 or less than 0.0.  routine never corrects
c  greater than one minute per call.  ie if seconds are greater than
c  120 seconds the correction will not be complete.  routine works
c  for any day of the year and over new years including leap years.
c
c  arguments -
c    time - 5 component floating point array holding time in
c           sequence - (yr,day,hr,min,sec)
c  language - 1977 ansi standard fortran
c--------------------------------------------------------------------
      real time(5)
      if(time(5).ge.60.0) then
            time(5) = time(5) - 60.0
            time(4) = time(4) + 1.0
            if(time(4).ge.60.0) then
                  time(4) = time(4) - 60.0
                  time(3) = time(3) + 1.0
                  if(time(3).ge.24.0) then
                        time(3) = time(3) - 24.0
                        time(2) = time(2) + 1.0
                        if(time(2).gt.365.0) then
                              if(mod(time(1),4.0).ne.0.0) then
                                    time(1) = time(1) + 1.0
                                    time(2) = 0.0
                              elseif(time(2).gt.366) then
                                    time(1) = time(1) + 1.0
                                    time(2) = 0.0
                              endif
                        endif
                  endif
            endif
      elseif(time(5).lt.0.0) then
            time(5) = time(5) + 60.0
            time(4) = time(4) - 1.0
            if(time(4).lt.0.0) then
                  time(4) = time(4) + 60.0
                  time(3) = time(3) - 1.0
                  if(time(3).lt.0.0) then
                        time(3) = time(3) + 24.0
                        time(2) = time(2) - 1.0
                        if(time(2).lt.0.0) then
                              time(1) = time(1) - 1.0
                              if(mod(time(1),4.0).eq.0.0) then
                                    time(2) = 366.
                              else
                                    time(2) = 365.
                              endif
                        endif
                  endif
            endif
      endif
      return
      end

c $Id$


MODULE param

! DECLARATION SECTION

INTEGER, PARAMETER :: nx = 101 ! number of cells in x direction
INTEGER, PARAMETER :: nz = 10 ! number of layers

REAL :: htotal(0:nx+1) ! initial bathymetry
REAL :: hzero(nz,0:nx+1) ! initial layer thicknesses
REAL :: h(nz,0:nx+1) ! actual layer thicknesses
REAL :: dp(0:nz,0:nx+1) ! dynamic pressure
REAL :: eta(nz+1,0:nx+1) ! actual interface displacements
REAL :: etan(nz,0:nx+1) ! interface displacements at time level n+1
REAL :: eta0(nz+1,0:nx+1) ! initial interface displacements
REAL :: dhdt(nz,0:nx+1) ! actual layer-thickness change
REAL :: u(nz,0:nx+1) ! actual lateral velocity
REAL :: un(nz,0:nx+1) ! lateral velocity at time level n+1
REAL :: dt, dx, g ! time step, grid spacing, acceleration due to gravity
REAL :: eps ! parameter for Shapiro filter
REAL :: rho(0:nz) ! layer densities
REAL :: hmin ! minimum layer thickness
INTEGER :: i,k  ! layer index and cell index
INTEGER :: wet(nz,0:nx+1)  ! wet and dry pointer

END MODULE param


!PR fortran/32242
! { dg-do compile }
! { dg-options "-Wreturn-type" }

MODULE kahan_sum
  INTEGER, PARAMETER :: dp=KIND(0.0D0)
  INTERFACE accurate_sum
    MODULE PROCEDURE kahan_sum_d1, kahan_sum_z1
  END INTERFACE accurate_sum
  TYPE pw_grid_type
     REAL (KIND=dp), DIMENSION ( : ), POINTER :: gsq
  END TYPE pw_grid_type
  TYPE pw_type
     REAL (KIND=dp), DIMENSION ( : ), POINTER :: cr
     COMPLEX (KIND=dp), DIMENSION ( : ), POINTER :: cc
     TYPE ( pw_grid_type ), POINTER :: pw_grid
  END TYPE pw_type
CONTAINS
 FUNCTION kahan_sum_d1(array,mask) RESULT(ks)         ! { dg-warning "not set" }
   REAL(KIND=dp), DIMENSION(:), INTENT(IN)  :: array
   LOGICAL, DIMENSION(:), INTENT(IN), &
     OPTIONAL                               :: mask
   REAL(KIND=dp)                            :: ks
 END FUNCTION kahan_sum_d1
  FUNCTION kahan_sum_z1(array,mask) RESULT(ks)        ! { dg-warning "not set" }
    COMPLEX(KIND=dp), DIMENSION(:), &
      INTENT(IN)                             :: array
    LOGICAL, DIMENSION(:), INTENT(IN), &
      OPTIONAL                               :: mask
    COMPLEX(KIND=dp)                         :: ks
  END FUNCTION kahan_sum_z1

FUNCTION pw_integral_a2b ( pw1, pw2 ) RESULT ( integral_value )
    TYPE(pw_type), INTENT(IN)                :: pw1, pw2
    REAL(KIND=dp)                            :: integral_value
     integral_value = accurate_sum ( REAL ( CONJG ( pw1 % cc ( : ) ) &
          *  pw2 % cc ( : ) ,KIND=dp) * pw1 % pw_grid % gsq ( : ) )
END FUNCTION pw_integral_a2b
END MODULE


************************************************************************
* Projects boundary nodes back to the boundary (on the old bndry. component)
*
* In:
*  DXN,DYN (dp): x/y coordinate of a point
*  DPAR (dp): (old) parameter value of the point
*  IBCT (int): index of the boundary container
*
* Out:
*  DXN,DYN: new coordinates of the point after projection to the boundary
*  DPAR: new parameter value after projection
************************************************************************

      SUBROUTINE BNDPRJ(DXN,DYN,DPAR,IBCT)

      IMPLICIT NONE

      DOUBLE PRECISION PI
      PARAMETER (PI=3.1415926535897931D0)

      INCLUDE 'cmem.inc'
      INCLUDE 'cparqdata.inc'

      DOUBLE PRECISION DXN,DYN,DPAR
      INTEGER IBCT

      INTEGER ICOMP,ICPTR,IICOMP,ITYP,IPPTR
      INTEGER KXPAR,KYPAR
      DOUBLE PRECISION DNORM1,DNORM2,DPROD
      DOUBLE PRECISION DXM,DYM,DRAD,DPHI1,DPHI2,DX1,DX2,DY1,DY2,DPHI

      DOUBLE PRECISION PARX,PARY

C *** determine old parameter value and the segment (boundary component)
      ICOMP=DPAR+1D0
C *** determine ityp
      ICPTR=KWORK(L(LICPTR)+IBCT-1)
      IICOMP=ICPTR+ICOMP-1
      ITYP=KWORK(L(LITYP)+IICOMP)
      IPPTR=KWORK(L(LIPPTR)+IICOMP)
      KXPAR=L(LXPAR)+IPPTR
      KYPAR=L(LYPAR)+IPPTR
C
C
C *** ITYP=1 LINE
      IF (ITYP.EQ.1) THEN
        DNORM1=DSQRT(DWORK(KXPAR+1)*DWORK(KXPAR+1)+
     *               DWORK(KYPAR+1)*DWORK(KYPAR+1))
        DXN=DXN-DWORK(KXPAR)
        DYN=DYN-DWORK(KYPAR)
        DPROD=DXN*DWORK(KXPAR+1)+DYN*DWORK(KYPAR+1)
        DXN=DPROD*DWORK(KXPAR+1)/(DNORM1*DNORM1)+DWORK(KXPAR)
        DYN=DPROD*DWORK(KYPAR+1)/(DNORM1*DNORM1)+DWORK(KYPAR)
        DNORM2=DSQRT((DXN-DWORK(KXPAR))*
     *               (DXN-DWORK(KXPAR))+
     *               (DYN-DWORK(KYPAR))*
     *               (DYN-DWORK(KYPAR)))
        DPAR=DNORM2/DNORM1
        IF (DPAR.GT.1D0) DPAR=0.9999d0
        DPAR=DPAR+ICOMP-1
C
C
C *** ITYP=2 PART OF A CIRCLE
      ELSE IF (ITYP.EQ.2) THEN
        DXM=DWORK(KXPAR)
        DYM=DWORK(KYPAR)
        DRAD=DWORK(KXPAR+1)
        DPHI1=DWORK(KXPAR+2)
        DPHI2=DWORK(KYPAR+2)
C
        DX1=DXN
        DX2=DYN
        DY1=DXM+DRAD*COS(DPHI1)
        DY2=DYM+DRAD*SIN(DPHI1)
C
        DPHI=ACOS((DX1*DY1+DX2*DY2)/
     *             (DSQRT(DX1*DX1+DX2*DX2)*DSQRT(DY1*DY1+DY2*DY2)))
        IF (DY1*DX2-DY2*DX1.LT.0D0) DPHI=2*PI-DPHI
C
c        DPAR=DPHI/(DPHI2-DPHI1)
        DPAR=DPHI/(DPHI2-DPHI1)+ICOMP-1D0
C
C
      ELSE
        WRITE (*,FMT='(A)') 'ityp=3 not supportet yet'
        STOP
      END IF !ITYP

      DXN=PARX(DPAR,IBCT)
      DYN=PARY(DPAR,IBCT)
C
      END SUBROUTINE


      SUBROUTINE pzextr(iest,xest,yest,yz,dy,nv)
      INTEGER iest,nv,IMAX,NMAX
      REAL xest,dy(nv),yest(nv),yz(nv)
      PARAMETER (IMAX=13,NMAX=50)
      INTEGER j,k1
      REAL delta,f1,f2,q,d(NMAX),qcol(NMAX,IMAX),x(IMAX)
      SAVE qcol,x
      x(iest)=xest
      do 11 j=1,nv
        dy(j)=yest(j)
        yz(j)=yest(j)
11    continue
      if(iest.eq.1) then
        do 12 j=1,nv
          qcol(j,1)=yest(j)
12      continue
      else
        do 13 j=1,nv
          d(j)=yest(j)
13      continue
        do 15 k1=1,iest-1
          delta=1./(x(iest-k1)-xest)
          f1=xest*delta
          f2=x(iest-k1)*delta
          do 14 j=1,nv
            q=qcol(j,k1)
            qcol(j,k1)=dy(j)
            delta=d(j)-q
            dy(j)=f1*delta
            d(j)=f2*delta
            yz(j)=yz(j)+dy(j)
14        continue
15      continue
        do 16 j=1,nv
          qcol(j,iest)=dy(j)
16      continue
      endif
      return
      END

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


module orbit_symplectic_quasi

use field_can_mod
use orbit_symplectic

implicit none
save

logical, parameter :: exact_steps = .False.
integer, parameter :: S_MAX_GAUSS = 3

type(FieldCan) :: f
type(FieldCan) :: fs(S_MAX_GAUSS)
type(SymplecticIntegrator) :: si
!$omp threadprivate(f, si)

contains

!
! Wrapper routines for ODEPACK
!

subroutine f_exact_quasi(n, x, fvec, iflag)
  integer, intent(in) :: n
  double precision, intent(in) :: x(n)
  double precision, intent(out) :: fvec(n)
  integer, intent(in) :: iflag

  type(FieldCan) :: f2

  f2 = f

  call eval_field(f2, x(1), si%z(2), si%z(3), 0)
  call get_derivatives(f2, si%z(4))

  fvec(1) = f%pth - f2%pth

  f%H = f2%H

end subroutine f_exact_quasi

subroutine f_euler1_quasi(n, x, fvec, iflag)
  integer, intent(in) :: n
  double precision, intent(in) :: x(n)
  double precision, intent(out) :: fvec(n)
  integer, intent(in) :: iflag

  call eval_field(f, x(1), si%z(2), si%z(3), 0)
  call get_derivatives(f, x(2))

  fvec(1) = f%dpth(1)*(f%pth - si%pthold) &
    + si%dt*(f%dH(2)*f%dpth(1) - f%dH(1)*f%dpth(2))
  fvec(2) = f%dpth(1)*(x(2) - si%z(4)) &
    + si%dt*(f%dH(3)*f%dpth(1) - f%dH(1)*f%dpth(3))

end subroutine f_euler1_quasi

subroutine f_euler2_quasi(n, x, fvec, iflag)
  integer, intent(in) :: n
  double precision, intent(in) :: x(n)
  double precision, intent(out) :: fvec(n)
  integer, intent(in) :: iflag

  call eval_field(f, x(1), x(2), x(3), 0)
  call get_derivatives(f, si%z(4))

  fvec(1) = f%pth - si%pthold
  fvec(2) = f%dpth(1)*(x(2) - si%z(2)) - si%dt*f%dH(1)
  fvec(3) = f%dpth(1)*f%hph*(x(3) - si%z(3)) &
    - si%dt*(f%dpth(1)*f%vpar - f%dH(1)*f%hth)

end subroutine f_euler2_quasi

subroutine f_midpoint_quasi(n, x, fvec, iflag)
    integer, intent(in) :: n
    double precision, intent(in) :: x(n)
    double precision, intent(out) :: fvec(n)
    integer, intent(in) :: iflag

    double precision :: dpthmid, pthdotbar

    call eval_field(f, x(5), 0.5*(x(2) + si%z(2)), 0.5*(x(3) + si%z(3)), 0)
    call get_derivatives(f, 0.5*(x(4) + si%z(4)))

    fvec(2) = f%dpth(1)*(x(2) - si%z(2)) - si%dt*f%dH(1)
    fvec(3) = f%dpth(1)*f%hph*(x(3) - si%z(3)) &
      - si%dt*(f%dpth(1)*f%vpar - f%dH(1)*f%hth)
    fvec(4) = f%dpth(1)*(x(4) - si%z(4)) &
      + si%dt*(f%dH(3)*f%dpth(1) - f%dH(1)*f%dpth(3))
    fvec(5) = f%dpth(1)*(f%pth - si%pthold) &
      + si%dt/2.0d0*(f%dpth(1)*f%dH(2)-f%dpth(2)*f%dH(1))

    ! save evaluation from midpoint
    dpthmid = f%dpth(1)
    pthdotbar = f%dpth(1)*f%dH(2) - f%dpth(2)*f%dH(1)

    ! evaluate at endpoint
    call eval_field(f, x(1), x(2), x(3), 0)
    call get_derivatives(f, x(4))
    fvec(1) = dpthmid*(f%pth - si%pthold) + si%dt*pthdotbar

end subroutine f_midpoint_quasi

subroutine f_rk_gauss_quasi(n, x, fvec, iflag)

  integer, intent(in) :: n
  double precision, intent(in) :: x(n)  ! = (rend, thend, phend, pphend, rmid)
  double precision, intent(out) :: fvec(n)
  integer, intent(in) :: iflag

  double precision :: a(n/4,n/4), b(n/4), c(n/4), Hprime(n/4)
  integer :: k,l  ! counters

  call coeff_rk_gauss(n/4, a, b, c)  ! TODO: move this to preprocessing

  ! evaluate stages
  do k = 1, n/4
    call eval_field(fs(k), x(4*k-3), x(4*k-2), x(4*k-1), 0)
    call get_derivatives(fs(k), x(4*k))
    Hprime(k) = fs(k)%dH(1)/fs(k)%dpth(1)
  end do

  do k = 1, n/4
    fvec(4*k-3) = fs(k)%pth - si%pthold
    fvec(4*k-2) = x(4*k-2)  - si%z(2)
    fvec(4*k-1) = x(4*k-1)  - si%z(3)
    fvec(4*k)   = x(4*k)    - si%z(4)
    do l = 1, n/4
      fvec(4*k-3) = fvec(4*k-3) &
        + si%dt*a(k,l)*(fs(l)%dH(2) - Hprime(l)*fs(l)%dpth(2))       ! pthdot
      fvec(4*k-2) = fvec(4*k-2) - si%dt*a(k,l)*Hprime(l)             ! thdot
      fvec(4*k-1) = fvec(4*k-1) &
        - si%dt*a(k,l)*(fs(l)%vpar - Hprime(l)*fs(l)%hth)/fs(l)%hph  ! phdot
      fvec(4*k)   = fvec(4*k) &
        + si%dt*a(k,l)*(fs(l)%dH(3) - Hprime(l)*fs(l)%dpth(3))       ! pphdot
    end do
  end do

end subroutine f_rk_gauss_quasi

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
! Lobatto (IIIA)-(IIIB) Runge-Kutta method, s stages (n=4*s-2 variables)
!
subroutine f_rk_lobatto_quasi(n, x, fvec)
  !
  integer, intent(in) :: n
  double precision, intent(in) :: x(n)
  double precision, intent(out) :: fvec(n)

  call f_rk_lobatto(si, fs, (n+2)/4, x, fvec, 0)

  end subroutine f_rk_lobatto_quasi

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
subroutine orbit_timestep_quasi(ierr)

  integer, intent(out) :: ierr

  select case (si%mode)
    case (0)
     call orbit_timestep_rk45(ierr)
    case (1)
      call timestep_euler1_quasi(ierr)
    case (2)
        call timestep_euler2_quasi(ierr)
    case (3)
      call timestep_midpoint_quasi(ierr)
    case (4)
      call timestep_rk_gauss_quasi(1, ierr)
    case (5)
      call timestep_rk_gauss_quasi(2, ierr)
    case (6)
      call timestep_rk_gauss_quasi(3, ierr)
    case (7)
      call timestep_rk_gauss_quasi(4, ierr)
    case (15)
      call timestep_rk_lobatto_quasi(3, ierr)
    case default
      print *, 'invalid mode for orbit_timestep_quasi: ', si%mode
      stop
  end select

end subroutine orbit_timestep_quasi

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
subroutine orbit_timestep_multi_quasi(mi, ierr)
!
    type(MultistageIntegrator), intent(inout) :: mi

    integer, intent(out) :: ierr

    integer :: kstage

    si = mi%stages(1)
    call orbit_timestep_quasi(ierr)

    do kstage = 2, 2*mi%s
      mi%stages(kstage)%z = si%z
      mi%stages(kstage)%pthold = f%pth
      si = mi%stages(kstage)
      call orbit_timestep_quasi(ierr)
    end do
    mi%stages(1)%z = si%z
    mi%stages(1)%pthold = f%pth

  end subroutine orbit_timestep_multi_quasi

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
subroutine timestep_midpoint_quasi(ierr)
!
  integer, intent(out) :: ierr

  integer, parameter :: n = 5
  integer, parameter :: maxit = 16

  double precision, dimension(n) :: x
  double precision :: fvec(n)
  integer :: ktau, info

  ierr = 0
  ktau = 0
  do while(ktau .lt. si%ntau)
    si%pthold = f%pth

    x(1:4) = si%z
    x(5) = si%z(1)

    call hybrd1(f_midpoint_quasi, n, x, fvec, si%rtol, info)

    if (x(1) > 1.0) then
      ierr = 1
      return
    end if

    if (x(1) < 0.0) then
      print *, 'r<0, z = ', x(1), si%z(2), si%z(3), x(2)
      x(1) = 0.01
    end if

    si%z = x(1:4)

    si%kt = si%kt+1
    ktau = ktau+1
  enddo

end subroutine timestep_midpoint_quasi

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
subroutine timestep_euler1_quasi(ierr)
  !
  integer, intent(out) :: ierr

  integer, parameter :: n = 2
  integer, parameter :: maxit = 16

  double precision, dimension(n) :: x
  double precision :: fvec(n)
  integer :: ktau, info

  ierr = 0
  ktau = 0
  do while(ktau .lt. si%ntau)
    si%pthold = f%pth

    x(1)=si%z(1)
    x(2)=si%z(4)

    call hybrd1(f_euler1_quasi, n, x, fvec, si%rtol, info)

    if (x(1) > 1.0) then
      ierr = 1
      return
    end if

    if (x(1) < 0.0) then
      print *, 'r<0, z = ', x(1), si%z(2), si%z(3), x(2)
      x(1) = 0.01
    end if

    si%z(1) = x(1)
    si%z(4) = x(2)

    call eval_field(f, si%z(1), si%z(2), si%z(3), 0)
    call get_derivatives(f, si%z(4))

    si%z(2) = si%z(2) + si%dt*f%dH(1)/f%dpth(1)
    si%z(3) = si%z(3) + si%dt*(f%vpar - f%dH(1)/f%dpth(1)*f%hth)/f%hph

    if (exact_steps) then
      call hybrd1(f_exact_quasi, 1, x, fvec, si%rtol, info)
      si%z(1) = x(1)
      call eval_field(f, si%z(1), si%z(2), si%z(3), 0)
      call get_derivatives(f, si%z(4))
    end if

    si%kt = si%kt+1
    ktau = ktau+1
  enddo

end subroutine timestep_euler1_quasi

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
subroutine timestep_euler2_quasi(ierr)
!
  integer, intent(out) :: ierr

  integer, parameter :: n = 3
  integer, parameter :: maxit = 16

  double precision, dimension(n) :: x
  double precision :: fvec(n)
  integer :: ktau, info

  ierr = 0
  ktau = 0
  do while(ktau .lt. si%ntau)
    si%pthold = f%pth

    x = si%z(1:3)

    call hybrd1(f_euler2_quasi, n, x, fvec, si%rtol, info)

    if (x(1) > 1.0) then
      ierr = 1
      return
    end if

    if (x(1) < 0.0) then
      print *, 'r<0, z = ', x(1), si%z(2), si%z(3), x(2)
      x(1) = 0.01
    end if

    si%z(1:3) = x

    call eval_field(f, si%z(1), si%z(2), si%z(3), 0)
    call get_derivatives(f, si%z(4))

    f%pth = si%pthold - si%dt*(f%dH(2) - f%dH(1)*f%dpth(2)/f%dpth(1))
    si%z(4) = si%z(4) - si%dt*(f%dH(3) - f%dH(1)*f%dpth(3)/f%dpth(1))

    if (exact_steps) then
      call hybrd1(f_exact_quasi, 1, x, fvec, si%rtol, info)
      si%z(1) = x(1)
      call eval_field(f, si%z(1), si%z(2), si%z(3), 0)
      call get_derivatives(f, si%z(4))
    end if

    si%kt = si%kt+1
    ktau = ktau+1
  enddo

end subroutine timestep_euler2_quasi

subroutine timestep_rk_gauss_quasi(s, ierr)
!
  integer, intent(out) :: ierr

  integer, parameter :: maxit = 16

  integer, intent(in) :: s
  double precision, dimension(4*s) :: x
  double precision :: fvec(4*s)
  integer :: ktau, info, k, l

  double precision :: a(s,s), b(s), c(s), Hprime(s)

  do k = 1,s
    fs(k) = f
  end do

  ierr = 0
  ktau = 0
  do while(ktau .lt. si%ntau)
    si%pthold = f%pth

    do k = 1,s
      x((4*k-3):(4*k)) = si%z
    end do

    call hybrd1(f_rk_gauss_quasi, 4*s, x, fvec, si%rtol, info)

    if (x(1) > 1.0) then
      ierr = 1
      return
    end if

    if (x(1) < 0.0) then
      print *, 'r<0, z = ', x(1), si%z(2), si%z(3), x(2)
      x(1) = 0.01
    end if

    call coeff_rk_gauss(s, a, b, c)

    f = fs(s)
    f%pth = si%pthold
    si%z(1) = x(4*s-3)

    do l = 1, s
      Hprime(l) = fs(l)%dH(1)/fs(l)%dpth(1)
      f%pth = f%pth - si%dt*b(l)*(fs(l)%dH(2) - Hprime(l)*fs(l)%dpth(2))
      si%z(2) = si%z(2) + si%dt*b(l)*Hprime(l)
      si%z(3) = si%z(3) + si%dt*b(l)*(fs(l)%vpar-Hprime(l)*fs(l)%hth)/fs(l)%hph
      si%z(4) = si%z(4) - si%dt*b(l)*(fs(l)%dH(3) - Hprime(l)*fs(l)%dpth(3))
    end do

    si%kt = si%kt+1
    ktau = ktau+1
  enddo

end subroutine timestep_rk_gauss_quasi

subroutine timestep_rk_lobatto_quasi(s, ierr)
!
  integer, intent(out) :: ierr

  integer, parameter :: maxit = 16

  integer, intent(in) :: s
  double precision, dimension(4*s-2) :: x
  double precision :: fvec(4*s-2)
  integer :: ktau, info, k, l

  double precision :: a(s,s), ahat(s,s), b(s), c(s), Hprime(s)

  do k = 1,s
    fs(k) = f
  end do

  ierr = 0
  ktau = 0
  do while(ktau .lt. si%ntau)
    si%pthold = f%pth

    x(1) = si%z(1)
    x(2) = si%z(4)
    do k = 2,s
      x((4*k-3-2):(4*k-2)) = si%z
    end do

    !
    ! q1 = q0
    ! q2 = q0 + h*(a21*f(w1) + a22*f(z2) + a23*f(z3)
    ! q3 = q0 + h*(a31*f(w1) + a32*f(z2) + a33*f(z3))
    !
    ! p1(w1) = p0 + h*(o11*f(z1) + o12*f(z2))
    ! p2(z2) = p0 + h*(o21*f(z1) + o22*f(z2))
    ! p3(z3) = p0 + h*(o31*f(z1) + o32*f(z2))
    !
    ! 0 0 0 0 0 0
    ! x x x x x x
    ! x x x x x x
    ! x x x x 0 0
    ! x x x x 0 0
    ! x x x x 0 0
    !
    ! effectively
    !
    ! x x x x x
    ! x x x x x
    ! x x x 0 0
    ! x x x 0 0
    ! x x x 0 0

    call hybrd1(f_rk_lobatto_quasi, 4*s-2, x, fvec, si%rtol, info)

    call coeff_rk_lobatto(s, a, ahat, b, c)

    call eval_field(fs(1), x(1), si%z(2), si%z(3), 0)
    call get_derivatives(fs(1), x(2))
    Hprime(1) = fs(1)%dH(1)/fs(1)%dpth(1)

    do k = 2, s
      call eval_field(fs(k), x(4*k-3-2), x(4*k-2-2), x(4*k-1-2), 0)
      call get_derivatives(fs(k), x(4*k-2))
      Hprime(k) = fs(k)%dH(1)/fs(k)%dpth(1)
    end do

    f = fs(s)
    f%pth   = si%pthold
    si%z(1) = x(4*s-3-2)

    do l = 1, s
      f%pth   = f%pth   - si%dt*b(l)*(fs(l)%dH(2) - Hprime(l)*fs(l)%dpth(2))
      si%z(2) = si%z(2) + si%dt*b(l)*Hprime(l)
      si%z(3) = si%z(3) + si%dt*b(l)*(fs(l)%vpar-Hprime(l)*fs(l)%hth)/fs(l)%hph
      si%z(4) = si%z(4) - si%dt*b(l)*(fs(l)%dH(3) - Hprime(l)*fs(l)%dpth(3))
    end do

    si%kt = si%kt+1
    ktau = ktau+1
  enddo

end subroutine timestep_rk_lobatto_quasi

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
subroutine f_ode(tau, z, zdot)
!

  double precision, intent(in)  :: tau
  double precision, intent(in)  :: z(4)
  double precision, intent(out) :: zdot(4)
  double precision :: Hprime

  call eval_field(f, z(1), z(2), z(3), 0)
  call get_derivatives(f, z(4))

  Hprime = f%dH(1)/f%dpth(1)

  zdot(1) = -(f%dH(2) - f%hth/f%hph*f%dH(3))/f%dpth(1)
  zdot(2) = Hprime
  zdot(3) = (f%vpar-Hprime*f%hth)/f%hph
  zdot(4) = -(f%dH(3) - Hprime*f%dpth(3))

end subroutine f_ode

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
subroutine orbit_timestep_rk45(ierr)
!
  integer, intent(out) :: ierr
  integer :: ktau

  ierr = 0
  ktau = 0
  do while(ktau .lt. si%ntau)
    call odeint_allroutines(si%z, 4, ktau*si%dt, (ktau+1)*si%dt, si%rtol, f_ode)
    si%kt = si%kt+1
    ktau = ktau+1
  end do
end subroutine orbit_timestep_rk45

end module orbit_symplectic_quasi


      program main
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C                                                                      %
C Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
C Junior University.  All rights reserved.                             %
C                                                                      %
C The programs in GSLIB are distributed in the hope that they will be  %
C useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
C responsibility to anyone for the consequences of using them or for   %
C whether they serve any particular purpose or work at all, unless he  %
C says so in writing.  Everyone is granted permission to copy, modify  %
C and redistribute the programs in GSLIB, but only under the condition %
C that this notice and the above copyright notice remain intact.       %
C                                                                      %
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
c-----------------------------------------------------------------------
c
c                 Boolean Simulation of Ellipsoids
c                 ********************************
c
c The program is executed with no command line arguments.  The user
c will be prompted for the name of a parameter file.  The parameter
c file is described in the documentation (see the example ellipsim.par)
c and should contain the following information:
c
c The output file will be a GEOEAS file containing the simulated integer
c code ordered by x, y, and then simulation.
c
c
c
c AUTHOR: Clayton V. Deutsch                             DATE: 1989-1999
c-----------------------------------------------------------------------
      use       msflib
      parameter(MAXELP=25)
      parameter(KORDEI=12,MAXOP1=KORDEI+1,MAXINT=2**30,MAXROT=MAXELP,
     +          EPSLON=1.0e-10,VERSION=2.907)
c
c Variable declaration:
c
      real      aa(MAXELP),anis1(MAXELP),anis2(MAXELP),ang1(MAXELP),
     +          ang2(MAXELP),ang3(MAXELP),wt(MAXELP),tmp(50)
      real*8    rotmat(MAXROT,3,3),sdist,sqdist
      integer   test
      character outfl*512,str*512
      logical   testfl
c
c Declare dynamic arrays:
c
      integer,allocatable :: sim(:)
c
c For random number generator:
c
      real*8  acorni
      common /iaco/ ixv(MAXOP1)
      data   ixv/MAXOP1*0.0/
      data   lin/1/,lout/2/
c
c Note VERSION number:
c
      write(*,9999) VERSION
 9999 format(/' ELLIPSIM Version: ',f5.3/)
c
c Get the name of the parameter file - try the default name if no input:
c
      do i=1,512
            str(i:i) = ' '
      end do
      call getarg(1,str)
      if(str(1:1).eq.' ')then
            write(*,*) 'Which parameter file do you want to use?'
            read (*,'(a)') str
      end if
      if(str(1:1).eq.' ') str(1:20) = 'ellipsim.par        '
      inquire(file=str,exist=testfl)
      if(.not.testfl) then
            write(*,*) 'ERROR - the parameter file does not exist,'
            write(*,*) '        check for the file and try again  '
            write(*,*)
            if(str(1:20).eq.'ellipsim.par        ') then
                  write(*,*) '        creating a blank parameter file'
                  call makepar
                  write(*,*)
            end if
            stop
      endif
      open(lin,file=str,status='OLD')
c
c Find Start of Parameters:
c
 1    read(lin,'(a4)',end=99) str(1:4)
      if(str(1:4).ne.'STAR') go to 1
c
c Read Input Parameters:
c
      write(*,*) ' Starting to read input parameters'

      read(lin,'(a512)',err=99) outfl
      call chknam(outfl,512)
      write(*,*) ' output file: ',outfl(1:40)

      read(lin,*,err=99) nsim
      write(*,*) ' number of realizations = ',nsim

      read(lin,*,err=99) nx,xmn,xsiz
      write(*,*) ' nx, xmn, and xsiz = ',nx,xmn,xsiz

      read(lin,*,err=99) ny,ymn,ysiz
      write(*,*) ' ny, ymn, and ysiz = ',ny,ymn,ysiz

      read(lin,*,err=99) nz,zmn,zsiz
      write(*,*) ' nz, zmn, and zsiz = ',nz,zmn,zsiz

      read(lin,*,err=99) ixv(1)
      write(*,*) ' random number seed = ',ixv(1)
      do i=1,10000
            zz = real(acorni(idum))
      end do

      read(lin,*,err=99) targprop
      write(*,*) ' target proportion = ',targprop
      targprop = targprop * nx * ny * nz

      nelp  = 0
      sumwt = 0.0
 2    read(lin,*,end=3,err=98) (tmp(i),i=1,7)
      nelp = nelp + 1
      aa(nelp)    = tmp(1)
      anis1(nelp) = tmp(2) / max(aa(nelp),EPSLON)
      anis2(nelp) = tmp(3) / max(aa(nelp),EPSLON)
      ang1(nelp)  = tmp(4)
      ang2(nelp)  = tmp(5)
      ang3(nelp)  = tmp(6)
      wt(nelp)    = tmp(7)
      sumwt       = sumwt + wt(nelp)
      dmax = max(dmax,aa(nelp))
      go to 2

 3    close(lin)
      if(nelp.lt.1.or.sumwt.lt.EPSLON) then
            write(*,*) 'ERROR: no ellipsoid geometries '
            stop
      end if
c
c Get CDF of ellipsoid specifications:
c
      do i=1,nelp
            wt(i) = wt(i) / sumwt
      end do
      wt(1) = wt(1) / sumwt
      do i=2,nelp
            wt(i) = wt(i-1) + wt(i)/sumwt
      end do
c
c Border zone:
c
      ixa = 1 + int(dmax/max(xsiz,EPSLON))
      iya = 1 + int(dmax/max(ysiz,EPSLON))
      iza = 1 + int(dmax/max(zsiz,EPSLON))
      write(*,*)
      write(*,*) 'Read in ',nelp,' possible ellipsoid geometries'
      write(*,*)
c
c Perform some quick error checking:
c
      nxyz = nx * ny * nz
c
c Set up the rotation/anisotropy matrices for each ellipsoid:
c
      write(*,*) 'Setting up rotation matrices for ellipsoids'
      write(*,*)
      do ielp=1,nelp
            call setrot(ang1(ielp),ang2(ielp),ang3(ielp),anis1(ielp),
     +                  anis2(ielp),ielp,MAXROT,rotmat)
      end do
      open(lout,file=outfl,status='UNKNOWN')
      write(lout,200)
 200  format('Output from ELLIPSIM')
      write(lout,201) 1,nx,ny,nz
 201  format(4(1x,i4))
      write(lout,202)
 202  format('binary code')
c
c Allocate the needed memory:
c
      allocate(sim(nxyz),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  'insufficient memory.'
                  stop
            end if
c
c Loop over all simulations:
c
      do isim=1,nsim
            write(*,*) ' Starting simulation ',isim
            do i=1,nxyz
                  sim(i) = 0
            end do
            prop = 0.0
c
c Keep looping until target proportion is reached:
c
 20         if(prop.ge.targprop) go to 21
c
c Randomly choose the parameters for the ellipsoid:
c
            rnum = real(acorni(idum))
            do i=1,nelp
                  if(rnum.lt.wt(i)) then
                        ielp = i
                        go to 10
                  end if
            end do
 10         continue
            radsqd = aa(ielp) * aa(ielp)
            nxc = max(min((1+int(aa(ielp)/max(xsiz,EPSLON))),nx),1)
            nyc = max(min((1+int(aa(ielp)/max(ysiz,EPSLON))),ny),1)
            nzc = max(min((1+int(aa(ielp)/max(zsiz,EPSLON))),nz),1)
c
c Centroid of the ellipsoid:
c
            ixc = -ixa + int(real(acorni(idum)) * (nx+2*ixa))
            iyc = -iya + int(real(acorni(idum)) * (ny+2*iya))
            izc = -iza + int(real(acorni(idum)) * (nz+2*iza))
            if(nx.eq.1) ixc = 1
            if(ny.eq.1) iyc = 1
            if(nz.eq.1) izc = 1
c
c Fill the ellipsoid:
c
            do 40 ix=-nxc,nxc
                  i = ixc + ix
                  if(i.le.0.or.i.gt.nx) go to 40
                  do 41 iy=-nyc,nyc
                        j = iyc + iy
                        if(j.le.0.or.j.gt.ny) go to 41
                        do 42 iz=-nzc,nzc
                              k = izc + iz
                              if(k.le.0.or.k.gt.nz) go to 42

                              xx = real(ix) * xsiz
                              yy = real(iy) * ysiz
                              zz = real(iz) * zsiz

                              sdist = sqdist(0.,0.,0.,xx,yy,zz,
     +                                       ielp,MAXROT,rotmat)
                              if(real(sdist).lt.radsqd) then
                                    ind = i+(j-1)*nx+(k-1)*nx*ny
                                    if(sim(ind).eq.0) then
                                          sim(ind) = 1
                                          prop = prop + 1.
                                    endif
                              endif

 42                     continue
 41               continue
 40         continue
c
c Go back for another ellipse:
c
            go to 20
 21         continue
c
c Write out simulation and go back for another:
c
            do i=1,nxyz
                  write(lout,'(i1)') sim(i)
            end do
      end do
c
c Finished:
c
      close(lout)
      write(*,9998) VERSION
 9998 format(/' ELLIPSIM Version: ',f5.3, ' Finished'/)
      stop
 98   stop 'ERROR in data file'
 99   stop 'ERROR in parameter file'
      end

      subroutine makepar
c-----------------------------------------------------------------------
c
c                      Write a Parameter File
c                      **********************
c
c
c
c-----------------------------------------------------------------------
      lun = 99
      open(lun,file='ellipsim.par',status='UNKNOWN')
      write(lun,10)
 10   format('                  Parameters for ELLIPSIM',/,
     +       '                  ***********************',/,/,
     +       'START OF PARAMETERS:')

      write(lun,11)
 11   format('ellipsim.out              ',
     +       '-file for output realizations')
      write(lun,12)
 12   format('1                         ',
     +       '-number of realizations')
      write(lun,13)
 13   format('100  0. 1.0               ',
     +       '-nx,xmn,xsiz')
      write(lun,14)
 14   format('100  0. 1.0               ',
     +       '-ny,ymn,ysiz')
      write(lun,15)
 15   format('1    0. 1.0               ',
     +       '-nz,zmn,zsiz')
      write(lun,16)
 16   format('69069                     ',
     +       '-random number seed')
      write(lun,17)
 17   format('0.25                      ',
     +       '-target proportion (in ellipsoids)')
      write(lun,18)
 18   format(' 10.0  10.0   4.0  0.0 0.0 0.0   1.0 ',
     +       '-radius[1,2,3],angle[1,2,3],weight')
      write(lun,19)
 19   format('  2.0   2.0   2.0  0.0 0.0 0.0   1.0 ',
     +       '-radius[1,2,3],angle[1,2,3],weight')
      write(lun,20)
 20   format('  1.0   1.0   1.0  0.0 0.0 0.0   1.0 ',
     +       '-radius[1,2,3],angle[1,2,3],weight')

      close(lun)
      return
      end


      double precision function
     &      fclaw2d_clawpatch_compute_slopes(sl,sr,mth)
      implicit none

      double precision sl,sr, s, sc, philim, slim
      integer mth

c     # ------------------------------------------------
c     # Slope limiting done in amrclaw - see filpatch.f
c       dupc = valp10 - valc
c       dumc = valc   - valm10
c       ducc = valp10 - valm10
c       du   = dmin1(dabs(dupc),dabs(dumc))        <--
c       du   = dmin1(2.d0*du,.5d0*dabs(ducc))      <-- Not quite sure I follow
c
c       fu = dmax1(0.d0,dsign(1.d0,dupc*dumc))
c
c       dvpc = valp01 - valc
c       dvmc = valc   - valm01
c       dvcc = valp01 - valm01
c       dv   = dmin1(dabs(dvpc),dabs(dvmc))
c       dv   = dmin1(2.d0*dv,.5d0*dabs(dvcc))
c       fv = dmax1(0.d0,dsign(1.d0,dvpc*dvmc))
c
c       valint = valc + eta1*du*dsign(1.d0,ducc)*fu
c      .      + eta2*dv*dsign(1.d0,dvcc)*fv
c     # ------------------------------------------------

c     # ------------------------------------------------
c     # To see what Chombo does, look in InterpF.ChF
c     # (in Chombo/lib/src/AMRTools) for routine 'interplimit'
c     # Good luck.
c     # ------------------------------------------------

      if (mth .le. 4) then
c        # Use minmod, superbee, etc.
         slim = philim(sl,sr,mth)
         fclaw2d_clawpatch_compute_slopes = slim*sl
      else
c        # Use AMRClaw slopes  (use minimum in absolute value;  sign is
c        # chosen from centered (sc) slope
         sc = (sl + sr)/2.d0
         fclaw2d_clawpatch_compute_slopes =
     &         min(2*abs(sl),2*abs(sr),abs(sc))*
     &         max(0.d0,sign(1.d0,sl*sr))*sign(1.d0,sc)

c        # Do this to guarantee that ghost cells are used; this is a check
c        # on the ghost-fill procedures.  Could raise an exception if face
c        # a patch communicates with more two or more procs.  If this
c        # is uncommented, also uncomment warning in fclaw2d_ghost_fill.cpp
c         fclaw2d_clawpatch_compute_slopes = sc

      endif

      end

      subroutine fclaw2d_clawpatch_build_transform(transform_ptr,a,f)
      implicit none

      integer a(2,2)
      integer*8 transform_ptr
      integer f(2)
      integer mi(4),mj(4)
      integer i1,j1

c     # Assume index mapping fclaw2d_transform_face_half has the
c     # the form
c     #
c     #       T(ic,jc) = A*(ic,jc) + F = (iff,jff)
c     #
c     # where (ic,jc) is the coarse grid index, and (iff,jff)
c     # is the first fine grid index.
c     #
c     # We can recover coefficients A(2,2) with the following
c     # calls to T.

      i1 = 0
      j1 = 0
      call fclaw2d_clawpatch_transform_face_half(i1,j1,mi,mj,
     &      transform_ptr)
      f(1) = mi(1)
      f(2) = mj(1)

      i1 = 1
      j1 = 0
      call fclaw2d_clawpatch_transform_face_half(i1,j1,mi,mj,
     &      transform_ptr)
      a(1,1) = mi(1) - f(1)
      a(2,1) = mj(1) - f(2)

      i1 = 0
      j1 = 1
      call fclaw2d_clawpatch_transform_face_half(i1,j1,mi,mj,
     &      transform_ptr)
      a(1,2) = mi(1) - f(1)
      a(2,2) = mj(1) - f(2)

      end

      logical function fclaw2d_clawpatch_check_indices(iff,jff,i2,j2)
      implicit none

      integer iff,jff,i2(0:3),j2(0:3)
      integer m
      logical found_iff, found_jff

      found_iff = .false.
      do m = 0,3
         if (i2(m) .eq. iff) then
            found_iff = .true.
            exit
         endif
      enddo

      found_jff = .false.
      do m = 0,3
         if (j2(m) .eq. jff) then
            found_jff = .true.
            exit
         endif
      enddo

      fclaw2d_clawpatch_check_indices = found_iff .and. found_jff

      end

      logical function fclaw2d_clawpatch_is_valid_interp(i,j,mx,my,mbc)
      implicit none
      integer i,j,mx, my, mbc

      logical i1, i2
      logical j1, j2

      i1 = 1-mbc .le. i .and. i .le. mx+mbc
      j1 = 1-mbc .le. j .and. j .le. my+mbc

      fclaw2d_clawpatch_is_valid_interp = i1 .and. j1

      end

      logical function fclaw2d_clawpatch_is_valid_average(i,j,mx,my)
      implicit none

      integer i,j,mx,my
      logical i1, j1

      i1 = 1 .le. i .and. i .le. mx
      j1 = 1 .le. j .and. j .le. my

      fclaw2d_clawpatch_is_valid_average = i1 .and. j1

      end


SUBROUTINE CALC_K0(M, N, K, a, b, D11, D12, D16, D22, D26, D66, w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
    REAL*8, INTENT(IN) :: D11, D12, D16, D22, D26, D66
    INTEGER, INTENT(IN) :: M, N
    REAL*8, INTENT(IN) :: a, b
    REAL*8, INTENT(IN) :: w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry
    REAL*8, INTENT(OUT) :: K(M*N, M*N)

    INTEGER row, col, i1, j1, k1, l1
    REAL*8 fAwxixifBwxixi, fAwfBwxixi, fAwxixifBw, fAwxifBwxixi, fAwxixifBwxi, fAwfBw, fAwfBwxi, fAwxifBw, fAwxifBwxi
    REAL*8 gAwetaetagBwetaeta, gAwgBwetaeta, gAwetaetagBw, gAwetagBwetaeta, gAwetaetagBweta, gAwgBw, gAwgBweta, gAwetagBw, gAwetagBweta

    DO j1=1, N
        DO l1=1, N

            CALL integral_fxixifxixi(j1, l1, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwetaetagBwetaeta)
            CALL integral_ffxixi(j1, l1, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwgBwetaeta)
            CALL integral_ffxixi(l1, j1, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwetaetagBw)
            CALL integral_fxifxixi(j1, l1, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwetagBwetaeta)
            CALL integral_fxifxixi(l1, j1, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwetaetagBweta)
            CALL integral_ff(j1, l1, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwgBw)
            CALL integral_ffxi(j1, l1, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwgBweta)
            CALL integral_ffxi(l1, j1, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwetagBw)
            CALL integral_fxifxi(j1, l1, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwetagBweta)

            DO i1=1, M
                DO k1=1, M

                    row = 1*((j1-1)*M + (i1-1)) + 1
                    col = 1*((l1-1)*M + (k1-1)) + 1

                    IF (row > col) THEN
                        CYCLE
                    END IF

                    CALL integral_fxixifxixi(i1, k1, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxixifBwxixi)
                    CALL integral_ffxixi(i1, k1, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwfBwxixi)
                    CALL integral_ffxixi(k1, i1, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxixifBw)
                    CALL integral_fxifxixi(i1, k1, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxifBwxixi)
                    CALL integral_fxifxixi(k1, i1, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxixifBwxi)
                    CALL integral_ff(i1, k1, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwfBw)
                    CALL integral_ffxi(i1, k1, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwfBwxi)
                    CALL integral_ffxi(k1, i1, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxifBw)
                    CALL integral_fxifxi(i1, k1, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxifBwxi)

                    K(row, col) = 4*D11*b*fAwxixifBwxixi*gAwgBw/(a*a*a) + 4*D12*(fAwfBwxixi*gAwetaetagBw + fAwxixifBw*gAwgBwetaeta)/(a*b) + 8*D16*(fAwxifBwxixi*gAwetagBw + fAwxixifBwxi*gAwgBweta)/(a*a) + 4*D22*a*fAwfBw*gAwetaetagBwetaeta/(b*b*b) + 8*D26*(fAwfBwxi*gAwetaetagBweta + fAwxifBw*gAwetagBwetaeta)/(b*b) + 16*D66*fAwxifBwxi*gAwetagBweta/(a*b)

                END DO
            END DO
        END DO
    END DO

END SUBROUTINE

SUBROUTINE CALC_KG0(M, N, K, a, b, Nxx, Nyy, Nxy, w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
    INTEGER, INTENT(IN) :: M, N
    REAL*8, INTENT(IN) :: a, b, Nxx, Nyy, Nxy
    REAL*8, INTENT(IN) :: w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry
    REAL*8, INTENT(OUT) :: K(M*N, M*N)

    INTEGER row, col, i1, j1, k1, l1
    REAL*8 fAwfBw, fAwfBwxi, fAwxifBw, fAwxifBwxi
    REAL*8 gAwgBw, gAwgBweta, gAwetagBw, gAwetagBweta

    DO j1=1, N
        DO l1=1, N

            CALL integral_ff(j1, l1, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwgBw)
            CALL integral_ffxi(j1, l1, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwgBweta)
            CALL integral_ffxi(l1, j1, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwetagBw)
            CALL integral_fxifxi(j1, l1, w1ty, w1ry, w2ty, w2ry, w1ty, w1ry, w2ty, w2ry, gAwetagBweta)

            DO i1=1, M
                DO k1=1, M

                    row = 1*((j1-1)*M + (i1-1)) + 1
                    col = 1*((l1-1)*M + (k1-1)) + 1

                    IF (row > col) THEN
                        CYCLE
                    END IF

                    CALL integral_ff(i1, k1, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwfBw)
                    CALL integral_ffxi(i1, k1, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwfBwxi)
                    CALL integral_ffxi(k1, i1, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxifBw)
                    CALL integral_fxifxi(i1, k1, w1tx, w1rx, w2tx, w2rx, w1tx, w1rx, w2tx, w2rx, fAwxifBwxi)

                    K(row, col) = Nxx*b*fAwxifBwxi*gAwgBw/a + Nxy*(fAwfBwxi*gAwetagBw + fAwxifBw*gAwgBweta) + Nyy*a*fAwfBw*gAwetagBweta/b

                END DO
            END DO
        END DO
    END DO

END SUBROUTINE


C-----------------------------------------------------------------------
      SUBROUTINE SPFFT(IMAX,INCW,INCG,KMAX,W,G,IDIR)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  SPFFT      PERFORM MULTIPLE FAST FOURIER TRANSFORMS
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-02-20
C
C ABSTRACT: THIS SUBPROGRAM PERFORMS MULTIPLE FAST FOURIER TRANSFORMS
C           BETWEEN COMPLEX AMPLITUDES IN FOURIER SPACE AND REAL VALUES
C           IN CYCLIC PHYSICAL SPACE.
C           SUBPROGRAM SPFFT MUST BE INVOKED FIRST WITH IDIR=0
C           TO INITIALIZE TRIGONEMETRIC DATA.  USE SUBPROGRAM SPFFT1
C           TO PERFORM AN FFT WITHOUT PREVIOUS INITIALIZATION.
C           THIS VERSION INVOKES THE IBM ESSL FFT.
C
C PROGRAM HISTORY LOG:
C 1998-12-18  IREDELL
C
C USAGE:    CALL SPFFT(IMAX,INCW,INCG,KMAX,W,G,IDIR)
C
C   INPUT ARGUMENT LIST:
C     IMAX     - INTEGER NUMBER OF VALUES IN THE CYCLIC PHYSICAL SPACE
C                (SEE LIMITATIONS ON IMAX IN REMARKS BELOW.)
C     INCW     - INTEGER FIRST DIMENSION OF THE COMPLEX AMPLITUDE ARRAY
C                (INCW >= IMAX/2+1)
C     INCG     - INTEGER FIRST DIMENSION OF THE REAL VALUE ARRAY
C                (INCG >= IMAX)
C     KMAX     - INTEGER NUMBER OF TRANSFORMS TO PERFORM
C     W        - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR>0
C     G        - REAL(INCG,KMAX) REAL VALUES IF IDIR<0
C     IDIR     - INTEGER DIRECTION FLAG
C                IDIR=0 TO INITIALIZE INTERNAL TRIGONOMETRIC DATA
C                IDIR>0 TO TRANSFORM FROM FOURIER TO PHYSICAL SPACE
C                IDIR<0 TO TRANSFORM FROM PHYSICAL TO FOURIER SPACE
C
C   OUTPUT ARGUMENT LIST:
C     W        - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR<0
C     G        - REAL(INCG,KMAX) REAL VALUES IF IDIR>0
C
C SUBPROGRAMS CALLED:
C   SCRFT        IBM ESSL COMPLEX TO REAL FOURIER TRANSFORM
C   SRCFT        IBM ESSL REAL TO COMPLEX FOURIER TRANSFORM
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C REMARKS:
C   THE RESTRICTIONS ON IMAX ARE THAT IT MUST BE A MULTIPLE
C   OF 1 TO 25 FACTORS OF TWO, UP TO 2 FACTORS OF THREE,
C   AND UP TO 1 FACTOR OF FIVE, SEVEN AND ELEVEN.
C
C   IF IDIR=0, THEN W AND G NEED NOT CONTAIN ANY VALID DATA.
C   THE OTHER PARAMETERS MUST BE SUPPLIED AND CANNOT CHANGE
C   IN SUCCEEDING CALLS UNTIL THE NEXT TIME IT IS CALLED WITH IDIR=0.
C
C   THIS SUBPROGRAM IS NOT THREAD-SAFE WHEN IDIR=0. ON THE OTHER HAND,
C   WHEN IDIR IS NOT ZERO, IT CAN BE CALLED FROM A THREADED REGION.
C
C$$$
        IMPLICIT NONE
        INTEGER,INTENT(IN):: IMAX,INCW,INCG,KMAX,IDIR
        COMPLEX,INTENT(INOUT):: W(INCW,KMAX)
        REAL,INTENT(INOUT):: G(INCG,KMAX)
        INTEGER,SAVE:: NAUX1=0
        REAL,SAVE,ALLOCATABLE:: AUX1CR(:),AUX1RC(:)
        INTEGER:: NAUX2
        REAL:: AUX2(20000+INT(0.57*IMAX))
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
        NAUX2=20000+INT(0.57*IMAX)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  INITIALIZATION.
C  ALLOCATE AND FILL AUXILIARY ARRAYS WITH TRIGONOMETRIC DATA
        SELECT CASE(IDIR)
          CASE(0)
            IF(NAUX1.GT.0) DEALLOCATE(AUX1CR,AUX1RC)
            NAUX1=25000+INT(0.82*IMAX)
            ALLOCATE(AUX1CR(NAUX1),AUX1RC(NAUX1))
            CALL SCRFT(1,W,INCW,G,INCG,IMAX,KMAX,-1,1.,
     &                 AUX1CR,NAUX1,AUX2,NAUX2,0.,0)
            CALL SRCFT(1,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX,
     &                 AUX1RC,NAUX1,AUX2,NAUX2,0.,0)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  FOURIER TO PHYSICAL TRANSFORM.
          CASE(1:)
            CALL SCRFT(0,W,INCW,G,INCG,IMAX,KMAX,-1,1.,
     &                 AUX1CR,NAUX1,AUX2,NAUX2,0.,0)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  PHYSICAL TO FOURIER TRANSFORM.
          CASE(:-1)
            CALL SRCFT(0,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX,
     &                 AUX1RC,NAUX1,AUX2,NAUX2,0.,0)
        END SELECT
      END SUBROUTINE


      SUBROUTINE MB03GZ( Z11, Z12, Z22, H11, H12, CO1, SI1, CO2, SI2 )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute a unitary matrix Q and a unitary symplectic matrix U
C     for a complex regular 2-by-2 skew-Hamiltonian/Hamiltonian pencil
C     aS - bH with S = J Z' J' Z, where
C
C            (  Z11  Z12  )         (  H11  H12  )
C        Z = (            ) and H = (            ),
C            (   0   Z22  )         (   0  -H11' )
C
C     such that U' Z Q, (J Q J' )' H Q are both upper triangular, but the
C     eigenvalues of (J Q J')' ( aS - bH ) Q are in reversed order.
C     The matrices Q and U are represented by
C
C            (  CO1  SI1  )         (  CO2  SI2  )
C        Q = (            ) and U = (            ), respectively.
C            ( -SI1' CO1  )         ( -SI2' CO2  )
C
C     The notation M' denotes the conjugate transpose of the matrix M.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     Z11     (input) COMPLEX*16
C             Upper left element of the non-trivial factor Z in the
C             factorization of S.
C
C     Z12     (input) COMPLEX*16
C             Upper right element of the non-trivial factor Z in the
C             factorization of S.
C
C     Z22     (input) COMPLEX*16
C             Lower right element of the non-trivial factor Z in the
C             factorization of S.
C
C     H11     (input) COMPLEX*16
C             Upper left element of the Hamiltonian matrix H.
C
C     H12     (input) COMPLEX*16
C             Upper right element of the Hamiltonian matrix H.
C
C     CO1     (output) DOUBLE PRECISION
C             Upper left element of Q.
C
C     SI1     (output) COMPLEX*16
C             Upper right element of Q.
C
C     CO2     (output) DOUBLE PRECISION
C             Upper left element of U.
C
C     SI2     (output) COMPLEX*16
C             Upper right element of U.
C
C     METHOD
C
C     The algorithm uses unitary and unitary symplectic transformations
C     as described on page 37 in [1].
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
C         Numerical Computation of Deflating Subspaces of Embedded
C         Hamiltonian Pencils.
C         Tech. Rep. SFB393/99-15, Technical University Chemnitz,
C         Germany, June 1999.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, April 21, 2009.
C
C     REVISIONS
C
C     V. Sima, Aug. 2009 (SLICOT version of the routine ZHAFEX).
C     V. Sima, Dec. 2010.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Eigenvalue exchange, skew-Hamiltonian/Hamiltonian pencil, upper
C     triangular matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D+0 )
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION   CO1, CO2
      COMPLEX*16         H11, H12, SI1, SI2, Z11, Z12, Z22
C
C     .. Local Scalars ..
      COMPLEX*16         D, G, TMP
C
C     .. External Subroutines ..
      EXTERNAL           ZLARTG
C
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DCONJG
C
C     .. Executable Statements ..
C
C     Computations.
C
      G = TWO*DBLE( H11*DCONJG( Z11 )*Z22 )
      D = Z22*DCONJG( Z11 )*H12 +
     $      ( DCONJG( Z22 )*Z12 - DCONJG( Z12 )*Z22 )*DCONJG( H11 )
      CALL ZLARTG( D, G, CO1, SI1, TMP )
      D =  Z11*CO1 - Z12*DCONJG( SI1 )
      G = -Z22*DCONJG( SI1 )
      CALL ZLARTG( D, G, CO2, SI2, TMP )
      SI2 = -SI2
C
      RETURN
C *** Last line of MB03GZ ***
      END


! Simple randaom number generator in the range [0,1]
! ranset_(iseed) initializes with iseed
! ranf_() returns next random numer

      real function ranf_()
       implicit none
       real rand_
!       ranf_ = rand_(0)
        call random_number(ranf_)
       return
      end

      subroutine ranset_(iseed)
      implicit none
      real rand_,ranf_
      integer iseed, i, m, nsteps
!      i = rand_(1) ! reinitialize (reset)
      nsteps = iseed*10000
      do i = 1,nsteps
	m = ranf_()
!	m = rand_(0)
      end do
      return
      end

      real function rand_(iseed)
      implicit none
      integer iseed
      integer ia1, ia0, ia1ma0, ic, ix1, ix0, iy0, iy1
      save ia1, ia0, ia1ma0, ic, ix1, ix0
      data ix1, ix0, ia1, ia0, ia1ma0, ic/0,0,1536,1029,507,1731/
      if (iseed.ne.0) then
	ia1 = 1536
        ia0 = 1029
        ia1ma0 = 507
        ic = 1731
        ix1 = 0
        ix0 = 0
	rand_ = 0
      else
       iy0 = ia0*ix0
       iy1 = ia1*ix1 + ia1ma0*(ix0-ix1) + iy0
       iy0 = iy0 + ic
       ix0 = mod (iy0, 2048)
       iy1 = iy1 + (iy0-ix0)/2048
       ix1 = mod (iy1, 2048)
       rand_ = ix1*2048 + ix0
       rand_ = rand_ / 4194304.
      end if
      return
      end


! This source file is part of the Limited-area GAME version (L-GAME), which is released under the MIT license.
! Github repository: https://github.com/OpenNWP/L-GAME

module averaging

  use definitions, only: t_grid,wp
  use run_nml,     only: nlays,nlays_oro,nlins,ncols

  ! This module contains averaging operators.

  implicit none

  private

  public :: vertical_contravariant_corr
  public :: hor_cov_to_con
  public :: horizontal_covariant_x
  public :: horizontal_covariant_y

  contains

  function vertical_contravariant_corr(vector_field_x,vector_field_y,ji,jk,jl,grid)

    ! calculates (the vertical contravariant component - the vertical covariant component)
    ! of a vector field out of the horizontal contravariant components

    real(wp),     intent(in) :: vector_field_x(:,:,:) ! x-component of vector field to work with
    real(wp),     intent(in) :: vector_field_y(:,:,:) ! y-component of vector field to work with
    integer,      intent(in) :: ji,jk,jl              ! spatial indices
    type(t_grid), intent(in) :: grid                  ! model grid

    real(wp) :: vertical_contravariant_corr
    vertical_contravariant_corr = 0._wp

    if (jl >= nlays - nlays_oro + 1) then
        ! highest level following orography
      if (jl == nlays - nlays_oro + 1) then
        vertical_contravariant_corr = vertical_contravariant_corr &
        - 0.5_wp*vector_field_x(ji+1,jk+1,jl  )*grid%slope_x(ji+1,jk+1,jl  )*grid%inner_product_weights(ji,jk,jl  ,1) &
        - 0.5_wp*vector_field_y(ji+1,jk+1,jl  )*grid%slope_y(ji+1,jk+1,jl  )*grid%inner_product_weights(ji,jk,jl  ,2) &
        - 0.5_wp*vector_field_x(ji+1,jk  ,jl  )*grid%slope_x(ji+1,jk  ,jl  )*grid%inner_product_weights(ji,jk,jl  ,3) &
        - 0.5_wp*vector_field_y(ji  ,jk+1,jl  )*grid%slope_y(ji  ,jk+1,jl  )*grid%inner_product_weights(ji,jk,jl  ,4)
      ! levels in between
      else
        vertical_contravariant_corr = vertical_contravariant_corr &
        - 0.5_wp*vector_field_x(ji+1,jk+1,jl-1)*grid%slope_x(ji+1,jk+1,jl-1)*grid%inner_product_weights(ji,jk,jl-1,1) &
        - 0.5_wp*vector_field_y(ji+1,jk+1,jl-1)*grid%slope_y(ji+1,jk+1,jl-1)*grid%inner_product_weights(ji,jk,jl-1,2) &
        - 0.5_wp*vector_field_x(ji+1,jk  ,jl-1)*grid%slope_x(ji+1,jk  ,jl-1)*grid%inner_product_weights(ji,jk,jl-1,3) &
        - 0.5_wp*vector_field_y(ji  ,jk+1,jl-1)*grid%slope_y(ji  ,jk+1,jl-1)*grid%inner_product_weights(ji,jk,jl-1,4)
        vertical_contravariant_corr = vertical_contravariant_corr &
        - 0.5_wp*vector_field_x(ji+1,jk+1,jl  )*grid%slope_x(ji+1,jk+1,jl  )*grid%inner_product_weights(ji,jk,jl  ,1) &
        - 0.5_wp*vector_field_y(ji+1,jk+1,jl  )*grid%slope_y(ji+1,jk+1,jl  )*grid%inner_product_weights(ji,jk,jl  ,2) &
        - 0.5_wp*vector_field_x(ji+1,jk  ,jl  )*grid%slope_x(ji+1,jk  ,jl  )*grid%inner_product_weights(ji,jk,jl  ,3) &
        - 0.5_wp*vector_field_y(ji  ,jk+1,jl  )*grid%slope_y(ji  ,jk+1,jl  )*grid%inner_product_weights(ji,jk,jl  ,4)
      endif
    endif

  end function vertical_contravariant_corr

  subroutine hor_cov_to_con(result_field_x,result_field_y,result_field_z,grid)

    ! This subroutine computes the terrain correction of the gradient.
    real(wp),     intent(inout) :: result_field_x(:,:,:) ! x-component of resulting vector field
    real(wp),     intent(inout) :: result_field_y(:,:,:) ! y-component of resulting vector field
    real(wp),     intent(in)    :: result_field_z(:,:,:) ! z-component of resulting vector field
    type(t_grid), intent(in)    :: grid                  ! the grid properties

    ! local variables
    integer                     :: ji,jk,jl              ! loop indices

    ! correction to the x-component
    !$OMP PARALLEL
    !$OMP DO PRIVATE(ji,jk,jl)
    do ji=1,nlins
      do jk=1,ncols-1
        do jl=1,nlays
          result_field_x(ji,jk,jl) = result_field_x(ji,jk,jl) &
          - grid%slope_x(ji+1,jk+1,jl)*remap_ver2hor_x(result_field_z,grid,ji,jk,jl)
        enddo
      enddo
    enddo
    !$OMP END DO
    !$OMP END PARALLEL

    ! correction to the y-component
    !$OMP PARALLEL
    !$OMP DO PRIVATE(ji,jk,jl)
    do ji=1,nlins-1
      do jk=1,ncols
        do jl=1,nlays
          result_field_y(ji,jk,jl) = result_field_y(ji,jk,jl) &
          - grid%slope_y(ji+1,jk+1,jl)*remap_ver2hor_y(result_field_z,grid,ji,jk,jl)
        enddo
      enddo
    enddo
    !$OMP END DO
    !$OMP END PARALLEL

  end subroutine hor_cov_to_con

  function remap_ver2hor_x(vertical_cov,grid,ji,jk,jl)

    ! This function remaps a vertical covariant component of
    ! a vector field to a position of a vector component in x-direction.

    real(wp),     intent(in)    :: vertical_cov(:,:,:)   ! z-component of vector field to work with
    type(t_grid), intent(in)    :: grid                  ! the grid properties
    integer,      intent(in)    :: ji,jk,jl              ! positional indices

    real(wp)                    :: remap_ver2hor_x       ! the result

    remap_ver2hor_x = grid%inner_product_weights(ji,jk  ,jl,5)*vertical_cov(ji,jk  ,jl)
    remap_ver2hor_x = remap_ver2hor_x + grid%inner_product_weights(ji,jk+1,jl,5)*vertical_cov(ji,jk+1,jl)
    ! layer below
    if (jl < nlays) then
      remap_ver2hor_x = remap_ver2hor_x + grid%inner_product_weights(ji,jk  ,jl,6)*vertical_cov(ji,jk  ,jl+1)
      remap_ver2hor_x = remap_ver2hor_x + grid%inner_product_weights(ji,jk+1,jl,6)*vertical_cov(ji,jk+1,jl+1)
    endif
    ! horizontal average
    remap_ver2hor_x = 0.5_wp*remap_ver2hor_x

  end function remap_ver2hor_x

  function remap_ver2hor_y(vertical_cov,grid,ji,jk,jl)

    ! This function remaps a vertical covariant component of
    ! a vector field to a position of a vector component in y-direction.

    real(wp),     intent(in)    :: vertical_cov(:,:,:)   ! z-component of vector field to work with
    type(t_grid), intent(in)    :: grid                  ! the grid properties
    integer,      intent(in)    :: ji,jk,jl              ! positional indices

    real(wp)                    :: remap_ver2hor_y       ! the result

    remap_ver2hor_y = grid%inner_product_weights(ji  ,jk,jl,5)*vertical_cov(ji  ,jk,jl)
    remap_ver2hor_y = remap_ver2hor_y + grid%inner_product_weights(ji+1,jk,jl,5)*vertical_cov(ji+1,jk,jl)
    ! layer below
    if (jl < nlays) then
      remap_ver2hor_y = remap_ver2hor_y + grid%inner_product_weights(ji  ,jk,jl,6)*vertical_cov(ji  ,jk,jl+1)
      remap_ver2hor_y = remap_ver2hor_y + grid%inner_product_weights(ji+1,jk,jl,6)*vertical_cov(ji+1,jk,jl+1)
    endif
    ! horizontal average
    remap_ver2hor_y = 0.5_wp*remap_ver2hor_y

  end function remap_ver2hor_y

  function horizontal_covariant_x(hor_comp_x,vert_comp,grid,ji,jk,jl)

    ! This function calculates the horizontal covariant component of a vector field in x-direction.

    real(wp),     intent(in) :: hor_comp_x(:,:,:) ! horizontal component in x-direction of vector field to work with
    real(wp),     intent(in) :: vert_comp(:,:,:)  ! vertical component of vector field to work with
    type(t_grid), intent(in) :: grid              ! model grid
    integer,      intent(in) :: ji,jk,jl          ! positional indices

    ! output
    real(wp)                 :: horizontal_covariant_x

    horizontal_covariant_x = hor_comp_x(ji,jk,jl)
    if (jl > nlays - nlays_oro) then
      horizontal_covariant_x = horizontal_covariant_x &
      ! more self-consistency is not required, more accuracy would be an option however
      + grid%slope_x(ji,jk,jl)*0.25_wp*(vert_comp(ji,jk,jl)+vert_comp(ji,jk+1,jl) &
      + vert_comp(ji,jk,jl+1)+vert_comp(ji,jk+1,jl+1))
    endif

  end function horizontal_covariant_x

  function horizontal_covariant_y(hor_comp_y,vert_comp,grid,ji,jk,jl)

    ! This function calculates the horizontal covariant component of a vector field in y-direction.

    real(wp),     intent(in) :: hor_comp_y(:,:,:) ! horizontal component in x-direction of vector field to work with
    real(wp),     intent(in) :: vert_comp(:,:,:)  ! vertical component of vector field to work with
    type(t_grid), intent(in) :: grid              ! model grid
    integer,      intent(in) :: ji,jk,jl          ! positional indices

    ! output
    real(wp)                 :: horizontal_covariant_y

    horizontal_covariant_y = hor_comp_y(ji,jk,jl)
    if (jl > nlays - nlays_oro) then
      horizontal_covariant_y = horizontal_covariant_y &
      ! more self-consistency is not required, more accuracy would be an option however
      + grid%slope_y(ji,jk,jl)*0.25_wp*(vert_comp(ji,jk,jl)+vert_comp(ji+1,jk,jl) &
      + vert_comp(ji,jk,jl+1)+vert_comp(ji+1,jk,jl+1))
    endif

  end function horizontal_covariant_y

end module averaging


!
! 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 implied-do loop containing function call that some of actual
! arguments are array constructor.

module m
  implicit none
contains
  subroutine test1()
    integer :: i, j, k, ii
    integer, allocatable :: rslt(:)
    integer :: expect(45)

    rslt = [(((9, i = 1, foo([j])), (99, i = 1, foo([k])), 999, j = 1, 3), &
             k = 1, 3)]
    if (sizeof(rslt) /= sizeof(expect)) STOP 1
    ii = 1
    do k = 1, 3
      do j = 1, 3
        do i = 1, foo([j])
          expect(ii) = 9
          ii = ii + 1
        enddo
        do i = 1, foo([k])
          expect(ii) = 99
          ii = ii + 1
        enddo
        expect(ii) = 999
        ii = ii + 1
      enddo
    enddo
    if (any(rslt /= expect)) STOP 2
  end subroutine

  subroutine test2()
    integer :: i, j, k, ii
    integer, allocatable :: rslt(:)
    integer :: expect(45)

    rslt = [(((9 * foo([i]), i = 1, foo([j])), &
              (99 * foo([k]), i = 1, foo([k])), 999 * foo([k]), j = 1, 3), &
            k = 1, 3)]
    if (sizeof(rslt) /= sizeof(expect)) STOP 3
    ii = 1
    do k = 1, 3
      do j = 1, 3
        do i = 1, foo([j])
          expect(ii) = 9 * foo([i])
          ii = ii + 1
        enddo
        do i = 1, foo([k])
          expect(ii) = 99 * foo([k])
          ii = ii + 1
        enddo
        expect(ii) = 999 * foo([k])
        ii = ii + 1
      enddo
    enddo
    if (any(rslt /= expect)) STOP 4
  end subroutine

  subroutine test3()
    integer :: i, j, k, ii
    integer, allocatable :: rslt(:)
    integer :: expect(40)

    rslt = [((9 * foo([j]), 1 : foo([k]), (99 * foo([k]), i = 1, foo([k])), &
              999 * foo([k]), j = 1, foo([k])), k = 1, 3)]
    if (sizeof(rslt) /= sizeof(expect)) STOP 5
    ii = 1
    do k = 1, 3
      do j = 1, foo([k])
        expect(ii) = 9 * foo([j])
        ii = ii + 1
        do i = 1, foo([k])
          expect(ii) = i
          ii = ii + 1
        enddo
        do i = 1, foo([k])
          expect(ii) = 99 * foo([k])
          ii = ii + 1
        enddo
        expect(ii) = 999 * foo([k])
        ii = ii + 1
      enddo
    enddo
    if (any(rslt /= expect)) STOP 6
  end subroutine

  subroutine test4()
    integer :: i, j, k, ii, jj
    integer, allocatable :: rslt(:)
    integer :: expect(63)

    rslt = [(((9, i = 1, foo([j])), ((ii, ii = 1, i), i = 1, foo([k])), 999, &
              j = 1, 3), (99, i = 1, foo([k])), k = 1, 3)]

    if (sizeof(rslt) /= sizeof(expect)) STOP 7
    jj = 1
    do k = 1, 3
      do j = 1, 3
        do i = 1, foo([j])
          expect(jj) = 9
          jj = jj + 1
        enddo
        do i = 1, foo([k])
          do ii = 1, i
            expect(jj) = ii
            jj = jj + 1
          enddo
        enddo
        expect(jj) = 999
        jj = jj + 1
      enddo
      do i = 1, foo([k])
        expect(jj) = 99
        jj = jj + 1
      enddo
    enddo
    if (any(rslt /= expect)) STOP 8
  end subroutine

  function foo(x) result(z)
    integer :: x(:)
    integer :: z
    z = x(1)
  end function
end module

program p
  use m
  implicit none
  call test1()
  call test2()
  call test3()
  call test4()
  print *, "PASS"
end program


module setup_config_mod

use constants_mod

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

real(dp), parameter :: init_time = 0.0_dp
!real(dp), parameter :: stop_time = 0.25_dp
real(dp), parameter :: stop_time = 1.0_dp

real(dp), parameter :: CFL = 0.8_dp

real(dp), parameter :: beta = 0.2_dp

real(dp), parameter :: dt_checkpoint = 1e-2_dp

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

real(dp), parameter :: dt_analyze = dt_checkpoint

real(dp), parameter :: chkpt_init_time = init_time
real(dp), parameter :: chkpt_stop_time = stop_time

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

real(dp), parameter :: diameter = 0.5_dp

real(dp), parameter :: xlim(2) = diameter * ((/0.0_dp,1.0_dp/) - 0.5_dp)
real(dp), parameter :: ylim(2) = diameter * ((/0.0_dp,1.0_dp/) - 0.5_dp)

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

real(dp), parameter :: blast_energy = 1.0_dp
real(dp), parameter :: blast_sigma = 5e-3_dp

real(dp), parameter :: blast_ener_normalized = blast_energy/SQRT((2*pi)**N_DIMS)/blast_sigma**N_DIMS

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

real(dp), parameter :: dens0 = 1e-0_dp
!real(dp), parameter :: pres0 = 1e-2_dp
!real(dp), parameter :: pres0 = 1e-5_dp
real(dp), parameter :: pres0 = 1e-14_dp

real(dp), parameter :: velx0 = 0.0_dp
real(dp), parameter :: vely0 = 0.0_dp

real(dp), parameter :: kappa = 7.0_dp/5.0_dp

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

integer, parameter :: mesh_minlevel = 5
integer, parameter :: mesh_maxlevel = 5

real(dp), parameter :: setup_amr_threshold_refine = -6
real(dp), parameter :: setup_amr_threshold_coarsen = -7

real(dp), parameter :: dens_refine_threshold = 1.3*dens0
real(dp), parameter :: dens_coarse_threshold = 1.2*dens0

real(dp), parameter :: init_amr_min_diameter = 0.2* 0.5_dp*diameter

# if DO_PROFILING
integer, parameter :: prof_report_rate = 64
# endif

end module


program q2

  use mqc_gaussian

  implicit none
  character(len=:),allocatable::fileName
  type(mqc_gaussian_unformatted_matrix_file)::fileInfo
  type(mqc_scf_integral)::alpha_MOs,density
  integer::nAlpha,nBeta
  logical::found

  call mqc_get_command_argument(1,fileName)
  write(6,'(A14,1X,A)') 'Input file is:',fileName
  call fileInfo%load(fileName)

  call fileInfo%getESTObj('mo coefficients',est_integral=alpha_MOs,foundObj=found)
  call alpha_MOs%print(6,'alpha MOs')
  nAlpha = fileInfo%getVal('nalpha')
  nBeta = fileInfo%getVal('nbeta')
  alpha_MOs = alpha_MOs%orbitals('occupied',[nAlpha],[nBeta])
  call alpha_MOs%print(6,'occupied alpha MOs')
  density = matmul(alpha_MOs,dagger(alpha_MOs))
  call density%print(6,'alpha density matrix')

end program q2


      function ran(idum)

      implicit none

      integer, parameter :: k4b=selected_int_kind(9)
      integer(k4b), intent(inout) :: idum
      real :: ran
      integer(k4b), parameter :: ia=16807
      integer(k4b), parameter :: im=2147483647
      integer(k4b), parameter :: iq=127773
      integer(k4b), parameter :: ir=2836
      real, save :: am
      integer(k4b), save :: ix=1
      integer(k4b), save :: iy=-1,k

      if (idum <= 0 .or. iy < 0) then
          am=nearest(1.0,-1.0) / im
          iy = ior(ieor(888889999,abs(idum)),1)
          ix = ieor(777755555,abs(idum))
          idum = abs(idum) + 1
      end if
      ix=ieor(ix,ishft(ix,13))
      ix=ieor(ix,ishft(ix,-17))
      ix=ieor(ix,ishft(ix,5))
      k = iy / iq
      iy = ia * (iy-k*iq) - ir * k
      if (iy < 0) iy = iy + im
      ran=am*ior(iand(im,ieor(ix,iy)),1)
      end function ran


      module polylag_5
        integer, parameter :: mp=6
      contains
!
      subroutine indef(u,umin,dum1,nup,indu)
! defines interval for 1D interpolation on uniform mesh, normally
! looks for the central interval of stencil, but
! stops moving of stencil at the boundary (works for mp=4 only!)
! Input:
!    u - coordinate of a point (to be interpolated)
!    umin - minimal value of u
!    dum1 = 1./h reciprocal to length of mesh interval
!    nup - total number of mesh points
! Output:
!    indu(mp) - relative index of stencil points
!
! the power 5 of polinomial is fixed strictly:
!
      implicit integer (i-n)
      implicit double precision (a-h,o-z)
!
      integer indu(mp)

      indu(1) = int((u-umin)*dum1)+1
      if( indu(1) .le. 0 ) indu(1) = 1
      indu(mp) = indu(1) + mp - 1
      if( indu(mp) .gt. nup ) then
         indu(mp) = nup
         indu(1) = indu(mp) - mp + 1
      endif
      do i=2,mp-1
         indu(i) = indu(i-1) + 1
      enddo

      return
      end subroutine indef
!---------------------------------------------------------------------
      subroutine indsmp(index,nup,indu)
! defines interval for 1D interpolation on uniform mesh
! by known index.
! Normally looks for the central interval of stencil, but
! stops moving of stencil at the boundary (works for mp=5 only!)
! Input:
!    index - number of a cell on the mesh
!    nup - total number of mesh points
! Output:
!    indu(mp) - relative index of stencil points

      implicit integer (i-n)
! the power 3 of polinomial is fixed strictly:
      integer indu(mp)

      indu(1) = index - 2
      if( indu(1) .le. 0 ) indu(1) = 1
      indu(mp) = indu(1) + mp - 1
      if( indu(mp) .gt. nup ) then
         indu(mp) = nup
         indu(1) = indu(mp) - mp + 1
      endif
      do i=2,mp-1
         indu(i) = indu(i-1) + 1
      enddo

      return
      end subroutine indsmp
!---------------------------------------------------------------------
      subroutine plag1d(x,fp,dxm1,xp,polyl1d,p1x1d)
! 1D interpolation by means of Lagrange polynomial
! the power 5 is fixed strictly:
! uniform mesh (increasingly ordered) in all dimensions is implied
!
! Input parameters:
!   x - coordinate of the point for interpolation
!   dxm1 - 1./h_x
!   xp - vertices of stencil
!
! Output parameters:
! polyl1d - polynomial itself
! poly1x - its derivative
!
      implicit integer (i-n)
      implicit double precision (a-h,o-z)
!
      dimension cx(mp),xp(mp),cx1(mp),fp(mp)
!
      call coefs(x,xp,dxm1,cx)
      polyl1d = 0.d0
      do i=1,mp
         polyl1d = polyl1d + fp(i)*cx(i)
      enddo
!
      call coefs1(x,xp,dxm1,cx1)
      p1x1d = 0.d0
      do i=1,mp
         p1x1d = p1x1d + fp(i)*cx1(i)
      enddo
!
      return
      end subroutine plag1d
!---------------------------------------------------------------------
      subroutine plag3d(x,y,z,fp,dxm1,dym1,dzm1,xp,yp,zp
     $     ,polyl3d,poly1x,poly1y,poly1z)
!
      implicit integer (i-n)
      implicit double precision (a-h,o-z)
!
! 3D interpolation by means of Lagrange polynomial
! the power 5 is fixed strictly:
! uniform mesh (increasingly ordered) in all dimensions is implied
!
! Input parameters:
!   x,y,z - coordinates of the point for interpolation
!   dxm1,dym1,dzm1 - steps in each direction
!   xp,yp,zp - vertices of stencil
!
! Output parameters:
! polyl3d - polynomial itself
! poly1x - its x-derivative
! poly1y - its y-derivative
! poly1z - its z-derivative
      dimension cx(mp),cy(mp),cz(mp),fp(mp,mp,mp),xp(mp)
      dimension yp(mp),zp(mp),cx1(mp),cy1(mp),cz1(mp)
!
      call coefs(x,xp,dxm1,cx)
      call coefs(y,yp,dym1,cy)
      call coefs(z,zp,dzm1,cz)
!
      polyl3d = 0.d0
      do k=1,mp
         do j=1,mp
            do i=1,mp
               polyl3d = polyl3d + fp(i,j,k)*cx(i)*cy(j)*cz(k)
            enddo
         enddo
      enddo
!
      call coefs1(x,xp,dxm1,cx1)
      call coefs1(y,yp,dym1,cy1)
      call coefs1(z,zp,dzm1,cz1)
!
      poly1x = 0.d0
      do k=1,mp
         do j=1,mp
            do i=1,mp
               poly1x = poly1x + fp(i,j,k)*cx1(i)*cy(j)*cz(k)
            enddo
         enddo
      enddo
!
      poly1y = 0.d0
      do k=1,mp
         do j=1,mp
            do i=1,mp
               poly1y = poly1y + fp(i,j,k)*cx(i)*cy1(j)*cz(k)
            enddo
         enddo
      enddo
!
      poly1z = 0.d0
      do k=1,mp
         do j=1,mp
            do i=1,mp
               poly1z = poly1z + fp(i,j,k)*cx(i)*cy(j)*cz1(k)
            enddo
         enddo
      enddo
!
      return
      end subroutine plag3d
!---------------------------------------------------------------------
      subroutine coefs(u,up,dum1,cu)
!
      implicit double precision (a-h,o-z)
!
      dimension up(mp),cu(mp)
      du5 = dum1**5
      cu(1) = (u - up(2)) * (u - up(3)) * (u - up(4)) *
     *        (u - up(5)) * (u - up(6)) * (-du5)/120.d0
      cu(2) = (u - up(1)) * (u - up(3)) * (u - up(4)) *
     *        (u - up(5)) * (u - up(6)) * (du5)/24.d0
      cu(3) = (u - up(1)) * (u - up(2)) * (u - up(4)) *
     *        (u - up(5)) * (u - up(6)) * (-du5)/12.d0
      cu(4) = (u - up(1)) * (u - up(2)) * (u - up(3)) *
     *        (u - up(5)) * (u - up(6)) * (du5)/12.d0
      cu(5) = (u - up(1)) * (u - up(2)) * (u - up(3)) *
     *        (u - up(4)) * (u - up(6)) * (-du5)/24.d0
      cu(6) = (u - up(1)) * (u - up(2)) * (u - up(3)) *
     *        (u - up(4)) * (u - up(5)) * (du5)/120.d0
      return
      end subroutine coefs
!---------------------------------------------------------------------
      subroutine coefs1(u,up,dum1,cu1)
!
      implicit double precision (a-h,o-z)
!
      dimension up(mp), cu1(mp)
      du5 = dum1**5
      cu1(1) = ((u - up(3)) * (u - up(4)) *
     *          (u - up(5)) * (u - up(6)) +
     +          (u - up(2)) * (u - up(4)) *
     *          (u - up(5)) * (u - up(6)) +
     +          (u - up(2)) * (u - up(3)) *
     *          (u - up(5)) * (u - up(6)) +
     +          (u - up(2)) * (u - up(3)) *
     *          (u - up(4)) * (u - up(6)) +
     +          (u - up(2)) * (u - up(3)) *
     *          (u - up(4)) * (u - up(5)))*(-du5)/120.d0
      cu1(2) = ((u - up(3)) * (u - up(4)) *
     *          (u - up(5)) * (u - up(6)) +
     +          (u - up(1)) * (u - up(4)) *
     *          (u - up(5)) * (u - up(6)) +
     +          (u - up(1)) * (u - up(3)) *
     *          (u - up(5)) * (u - up(6)) +
     +          (u - up(1)) * (u - up(3)) *
     *          (u - up(4)) * (u - up(6)) +
     +          (u - up(1)) * (u - up(3)) *
     *          (u - up(4)) * (u - up(5)))*(du5)/24.d0
      cu1(3) = ((u - up(2)) * (u - up(4)) *
     *          (u - up(5)) * (u - up(6)) +
     +          (u - up(1)) * (u - up(4)) *
     *          (u - up(5)) * (u - up(6)) +
     +          (u - up(1)) * (u - up(2)) *
     *          (u - up(5)) * (u - up(6)) +
     +          (u - up(1)) * (u - up(2)) *
     *          (u - up(4)) * (u - up(6)) +
     +          (u - up(1)) * (u - up(2)) *
     *          (u - up(4)) * (u - up(5)))*(-du5)/12.d0
      cu1(4) = ((u - up(2)) * (u - up(3)) *
     *          (u - up(5)) * (u - up(6)) +
     +          (u - up(1)) * (u - up(3)) *
     *          (u - up(5)) * (u - up(6)) +
     +          (u - up(1)) * (u - up(2)) *
     *          (u - up(5)) * (u - up(6)) +
     +          (u - up(1)) * (u - up(2)) *
     *          (u - up(3)) * (u - up(6)) +
     +          (u - up(1)) * (u - up(2)) *
     *          (u - up(3)) * (u - up(5)))*(du5)/12.d0
      cu1(5) = ((u - up(2)) * (u - up(3)) *
     *          (u - up(4)) * (u - up(6)) +
     +          (u - up(1)) * (u - up(3)) *
     *          (u - up(4)) * (u - up(6)) +
     +          (u - up(1)) * (u - up(2)) *
     *          (u - up(4)) * (u - up(6)) +
     +          (u - up(1)) * (u - up(2)) *
     *          (u - up(3)) * (u - up(6)) +
     +          (u - up(1)) * (u - up(2)) *
     *          (u - up(3)) * (u - up(4)))*(-du5)/24.d0
      cu1(6) = ((u - up(2)) * (u - up(3)) *
     *          (u - up(4)) * (u - up(5)) +
     +          (u - up(1)) * (u - up(3)) *
     *          (u - up(4)) * (u - up(5)) +
     +          (u - up(1)) * (u - up(2)) *
     *          (u - up(4)) * (u - up(5)) +
     +          (u - up(1)) * (u - up(2)) *
     *          (u - up(3)) * (u - up(5)) +
     +          (u - up(1)) * (u - up(2)) *
     *          (u - up(3)) * (u - up(4)))*(du5)/120.d0
      return
      end subroutine coefs1
!
      end module


SUBROUTINE interpolationInitialize()
! Subroutine initializing interpolation kernels for all cells
! in OpenFOAM relaxation zones.
! This function should be called from OpenFOAM as a pre-process.
!
! Input :
!
! Output : The struct Interpolation defined in GlobalVariables should be
!          initialized.
!
! Written by Bo Terp Paulsen (botp), botp@mek.dtu.dk

USE Precision
USE GlobalVariables
IMPLICIT NONE

! Local variables
!
!INTEGER :: STAT
INTEGER :: Nx, Ny, Nz, order, Nzp, i, rankx, ranky, rankz, x, y, z, &
left, right
INTEGER, DIMENSION(:), ALLOCATABLE :: idx
REAL(KIND=long), DIMENSION(:) :: x0(3)
REAL(KIND=long), DIMENSION(:,:), ALLOCATABLE :: xStencil, yStencil, zStencil
! Temporary pointers/variables
!
Nx = FineGrid%Nx
Ny = FineGrid%Ny
Nz = FineGrid%Nz

! Rank of stencils
!
rankx = 2*alpha+1
ranky = 2*beta+1
rankz = 2*gamma+1

! Allocation of local stencils
!
ALLOCATE( xStencil(rankx,rankx) )
ALLOCATE( yStencil(ranky,ranky) )
ALLOCATE( zStencil(rankz,rankz) )

! Expansion point
!The equidistant grid imply that derivatives for any interior
!point are similar. Notice that values are updated in if statements below
!
x0 = zero

! Initialization of x-derivative.
!It is assumed that OceanWave3D mesh always is
!larger than the OpenFOAM grid, so no interpolation near the boundaries is
!necessary.
!
ALLOCATE(Interpolation%dx(rankx,rankx),STAT = STAT)
IF (STAT/=0) THEN
	PRINT*,'Error: Could not allocate memory for interpolation stencil (X).'
	STOP
ENDIF
IF (Nx>1) THEN
        x = GhostGridX + alpha + 2
        x0(1) = FineGrid%x(x,1)! Expansion point, only x0(1) is used!

        !CALL interpolation1D(xStencil,x0,FineGrid%x(x - alpha :x + alpha,1),rankx)

        CALL  weights(x0,FineGrid%x(x-alpha:x+alpha,1),2*alpha,2*alpha,2*alpha,xStencil)
        Interpolation%dx = xStencil

        !CALL weights(x0,FineGrid%x(x - alpha :x+alpha,1), &
                !2*alpha,2*alpha+1,2*alpha,xStencil)

ENDIF

! Initialization of y-derivative.
!It is assumed that OceanWave3D mesh always is
!larger than the OpenFOAM grid, so no interpolation near the boundaries is
!necessary.
!
ALLOCATE(Interpolation%dy(ranky,ranky),STAT = STAT)
Interpolation%dy = zero
IF (STAT/=0) THEN
	PRINT*,'Error: Could not allocate memory for interpolation stencil (Y).'
	STOP
ENDIF
IF (Ny>1) THEN

        y = GhostGridY + beta + 2
        x0(1) = FineGrid%y(1,y)! Expansion point, only x0(1) is used!

        !CALL interpolation1D(yStencil,x0,FineGrid%y(1,y - beta : y + beta),ranky)

        CALL  weights(x0,FineGrid%y(1,y-beta:y+beta),2*beta,2*beta,2*beta,yStencil)
        Interpolation%dy = yStencil
ENDIF

! Initialization of z-derivatives
! This part is copied from PreProcessDiffStencilsZ.f90!!!
!
!One-sided stencils near free surface.
!One-side stencils near bottom, and if ghost points
!are supported then the directional ghost point
!is included in stencil.
!
IF (GhostGridZ==0) THEN; Nzp = Nz; ELSE; Nzp = Nz+1; ENDIF
ALLOCATE( Interpolation%dz(rankz,rankz,Nzp),STAT=STAT)
IF (STAT/=0) THEN
	PRINT*,'Error: Could not allocate memory for differentiation stencil (Z).'
	STOP
ENDIF

DO i = 1, Nzp
! Expansion point
!
        x0(1) = FineGrid%z(i)

! One sided schemes at boundaries
!
        IF(i<=gamma) THEN
            left = i - 1
            right = 2*gamma -left
        ELSE
                IF (i>=Nzp-gamma) THEN
                    right = Nzp - i
                    left = 2*gamma - right
                ELSE
                    left = gamma
                    right = gamma
                END IF

        END IF
! Calculate derivativatives at x0
!
        !CALL interpolation1D(zStencil,x0,FineGrid%z(i - left : i + right),rankz)

        CALL  weights(x0,FineGrid%z(i-left:i+right),2*gamma,2*gamma,2*gamma,zStencil)

! Save interpolation stencil
!
        Interpolation%dz(:,:,i) = zStencil

END DO

! Allocation of local interpolation stencils
        ALLOCATE(interpolation%stencilX(2*alpha+1))
        ALLOCATE(interpolation%stencilY(2*beta+1))
        ALLOCATE(interpolation%stencilZ(2*gamma+1))

        ALLOCATE(interpolation%NN(3))
        ALLOCATE(interpolation%inOrOut)

END SUBROUTINE interpolationInitialize


cc      program testpart
cc
cc      real temp(10),fpartition(10)
cc      data temp /100., 204., 1345.,
cc     &     2400., 3425., 4567., 7300., 15000., 17000.,20000./
cc
cc      call h2opartf2001(10,temp,fpartition)
cc
cc      do i=1,10
cc        print*,temp(i),fpartition(i)
cc      enddo
cc
cc      end

      subroutine h2opartf2001(ntau,temp,fpartition)
*
* Calculates partition function for Joergensen et al. 2001
* line list.
*
      implicit none
      integer i,ntau,index
      real Qvib(40),Tvib(40),temp(ntau),fpartition(ntau),Qv,Qrot,a,
     &     Qrb,Qra,B
      data Qvib / 1.0000, 1.0032, 1.0227, 1.0633, 1.1239, 1.2036,
     &            1.3018, 1.4186, 1.5541, 1.7085, 1.8825, 2.0767,
     &            2.2919, 2.5289, 2.7886, 3.0721, 3.3804, 3.7144,
     &            4.0752, 4.4637, 4.8807, 5.3272, 5.8038, 6.3112,
     &            6.8499, 7.4203, 8.0227, 8.6572, 9.3238, 10.0225,
     &            10.7531, 11.5153, 12.3085, 13.1325, 13.9864,
     &            14.8698, 15.7819, 16.7218, 17.6889, 18.6821/

      do i=1,40
        Tvib(i)=200.*float(i)
      enddo
      do i=1,ntau
        if (temp(i).le.200.) then
          Qv=1.0
        else if (temp(i).ge.8000.) then
          a=(temp(i)-Tvib(40))/(Tvib(40)-Tvib(30))
          Qv=a*(sqrt(Qvib(40))-sqrt(Qvib(30)))+sqrt(Qvib(40))
          Qv=Qv**2
        else
          index=int(temp(i)/200.)
          print*,index,Qvib(index),Qvib(index+1)
          a=(temp(i)-Tvib(index))/(Tvib(index+1)-Tvib(index))
          Qv=a*(sqrt(Qvib(index+1))-sqrt(Qvib(index)))+sqrt(Qvib(index))
          Qv=Qv**2
        endif
        Qra=sqrt(3.14159/(27.88063*14.52177*9.27771)*
     &                            (temp(i)/1.43877)**3)
        print*,'T, Qra',temp(i),Qra
        B=(1.-sqrt(14.52177*9.27771)/27.88063)*
     &         sqrt(14.52177*9.27771)*1.43877/temp(i)
        print*,'T, B',temp(i),B
        Qrb=(Qra*exp(.25*sqrt(14.52177*9.27771)*1.43877/temp(i))*
     &             (1.+B/12.+B**2*7./480.))*2.
        print*,'T, Qrb',temp(i),Qrb
        fpartition(i)=Qrb*Qv
        print*,'T,partf ',temp(i),fpartition(i)
      enddo
      return
      end


      subroutine sclmz (rho, lmaxp1, mmaxp1, ileg)
      implicit double precision (a-h, o-z)

c     Set CLM(Z) for current leg.
c     Makes clm(z) (eq B11).  Fills array clmi in /clmz/ for ileg,
c     elements clm(0,0) -> clm(lmax+1,mmax+1).
c     If mmaxp1 > lmaxp1, fills m only to lmaxp1.

c     calculates energy dependent factors
c     c(il,im) = c_l^(m)z**m/m! = c_lm    by recursion
c     c_l+1,m = c_l-1,m-(2l+1)z(c_l,m-c_l,m-1, l ne m
c     c_m,m = (-z)**m (2m)!/(2**m m!) with z = 1/i rho
c
c     To test pw approx, set z = 0

      include 'const.h'
      include 'dim.h'
      include 'clmz.h'

      complex*16 rho(legtot)
      complex*16 z, cmm

      cmm = 1
      z = -coni / rho(ileg)

      clmi(1,1,ileg) = (1,0)
      clmi(2,1,ileg) = clmi(1,1,ileg) - z

      lmax = lmaxp1-1

      do 10  il = 2, lmax
         clmi(il+1,1,ileg) =
     1           clmi(il-1,1,ileg) - z*(2*il-1)*clmi(il,1,ileg)
   10 continue
      mmxp1 = min (mmaxp1, lmaxp1)
      do 20  im = 2, mmxp1
         m = im-1
         imp1 = im+1
         cmm = -cmm * (2*m-1) * z
         clmi(im,im,ileg) = cmm
         clmi(imp1,im,ileg) = cmm * (2*m+1) * (1-im*z)
         do 20  il = imp1, lmax
            l = il-1
            clmi(il+1,im,ileg) = clmi(l,im,ileg) -
     1          (2*l+1) * z * (clmi(il,im,ileg) + clmi(il,m,ileg))
   20 continue

      return
      end


module profile_setup_mod

contains

! subroutine added by LAB to convert from flux to rz for numerical profiles.
!
!***************************************************************************
!
      subroutine flux_to_rz(nnodex, nnodey, profile_in, &
         profile_out, rho, nrho, rho_ij)

      implicit none

      real :: profile_in(nrho), profile_out(nnodex,nnodey)
      real :: rho(nrho), rho_ij(nnodex,nnodey)
      integer :: nnodex, nnodey, nrho, i, j, k

      do i = 1, nnodex
         do j = 1, nnodey
          do k = 1, nrho

             if(rho_ij(i,j) .le. rho(1)) then
             !  need one sided to the left

!              call flush(6)
              profile_out(i,j) = profile_in(1) + &
                  (profile_in(2) - profile_in(1)) / &
                  (rho(2) - rho(1)) * (rho_ij(i,j) - rho(1))

             elseif(rho_ij(i,j) .ge.rho(nrho)) then
             ! need one sidded to the right.

                profile_out(i,j) = profile_in(nrho) + &
                  (profile_in(nrho) - profile_in(nrho - 1)) / &
                  (rho(nrho) - rho(nrho-1)) * (rho_ij(i,j) - rho(nrho))

               elseif(rho_ij(i,j) - rho(k) .ge. 0.0 .and. &
                   rho_ij(i,j) -rho(k+1) .lt. 0.0 ) then
                ! standard  caseprint*, 'last if'
              profile_out(i,j) = profile_in(k)  + &
                  (profile_in(k+1) - profile_in(k))/ &
                  (rho(k+1) - rho(k)) * (rho_ij(i,j) - rho(k))
               endif

             if (profile_out(i,j) .lt. 0.0) profile_out(i,j) = 1.0e-10

          enddo
       end do
      end do

      end subroutine flux_to_rz

!
!***************************************************************************
!
      subroutine fluxavg3(f, favg, rho, nxdim, nydim, nrhodim, &
         nnodex, nnodey, nnoderho, drho, dx, dy, capr, r0, vol)

      implicit none

      integer nxdim, nydim, nrhodim, nnodex, nnodey, nnoderho
      integer n, i, j

      real f(nxdim, nydim), favg(nrhodim), rho(nxdim, nydim), r0, &
         drho, dx, dy, fvol(nrhodim), vol(nrhodim), capr(nxdim)

      do n = 1, nnoderho
          fvol(n) = 0.0
          vol(n) = 0.0
          favg(n) = 0.0
      end do

      do i = 1, nnodex
         do j = 1, nnodey
            n = int(rho(i,j) / drho) + 1
            if(n .le. nnoderho)then
               fvol(n) = fvol(n) + dx * dy * capr(i) / r0 * f(i,j)
               vol(n) =  vol(n) + dx * dy * capr(i) / r0
            end if
         end do
      end do

      do n = 1, nnoderho
         favg(n) = 0.0
         if(vol(n) .ne. 0.0)favg(n) = fvol(n) / vol(n)
      end do

      do n = 2, nnoderho -1
         if(favg(n) .eq. 0.0)then
            favg(n) = (favg(n-1) + favg(n+1)) / 2.0
         end if
      end do

      if (favg(1) .eq. 0.0) favg(1) = favg(2)
      if (favg(nnoderho) .eq. 0.0) favg(nnoderho) = favg(nnoderho - 1)

  100 format (1i10, 1p8e12.4)
  102 format (2i10)
      return
      end subroutine fluxavg3

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

      subroutine plasma_state(ndata, ndim, rhod, xneavg, tekev, tikev, &
           xn_beam, e_beam, zeffavg, nsmooth)

      implicit none

      integer n, ndata, ndim, ismooth, nsmooth

      real q

      real rhod(ndim), xneavg(ndim), tekev(ndim), tikev(ndim), &
           omega(ndim), zeffavg(ndim), xn_beam(ndim), e_beam(ndim)

      q = 1.6e-19

!     ---------------------
!     read the profile data
!     ---------------------

      open(unit=70, file='n_electron.txt', status='unknown', &
                                                form='formatted')
      open(unit=71, file='T_electron.txt', status='unknown', &
                                                form='formatted')
      open(unit=72, file='T_ion.txt', status='unknown', &
                                                form='formatted')
      open(unit=73, file='n_beam.txt', status='unknown', &
                                                form='formatted')
      open(unit=74, file='beam_energy.txt', status='unknown', &
                                                form='formatted')
      open(unit=75, file='Z_eff.txt', status='unknown', &
                                                form='formatted')

      read(70, 1312) ndata
      write(6, 1312) ndata

      do n = 1, ndata
         read (70, 2314)rhod(n), xneavg(n)
         read (71, 2314)rhod(n), tekev(n)
         read (72, 2314)rhod(n), tikev(n)
         read (73, 2314)rhod(n), xn_beam(n)
         read (74, 2314)rhod(n), e_beam(n)
         read (75, 2314)rhod(n), zeffavg(n)

         xneavg(n) = xneavg(n) * 1.0e+19
         tekev(n)  = tekev(n)  * 1.0e+03 * q
         tikev(n)  = tikev(n)  * 1.0e+03 * q
       xn_beam(n)= xn_beam(n) * 1.0e+19
!         e_beam(n) = e_beam(n) * 1.0e+03 * q * 2./3.
         e_beam(n) = e_beam(n) * 1.0e+03 * q

!     ---------------------------------------
!     For LDRD project, turn off beam n and T
!     ---------------------------------------
!         xn_beam(n) = 0.0
!         e_beam(n)  = 0.0

         write(6, 2313)rhod(n), xneavg(n), tekev(n), tikev(n), &
            xn_beam(n), e_beam(n), zeffavg(n)

      end do

!     -----------
!     Smooth data
!     -----------

      ismooth = 1

      do n = 1, nsmooth
         call smooth1d(xneavg, ismooth, ndim)
         call smooth1d(tekev,  ismooth, ndim)
         call smooth1d(tikev,  ismooth, ndim)
         call smooth1d(xneavg, ismooth, ndim)
         call smooth1d(xn_beam,ismooth, ndim)
         call smooth1d(e_beam, ismooth, ndim)
         call smooth1d(zeffavg,ismooth, ndim)
      end do

 1312 format(1i10, 1p8e12.4)
 2313 format(1p8e12.4)
 2314 format(1pe11.4, 1pe11.4)

      return
      end subroutine plasma_state

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

!     1D smoothing algorithm

      subroutine smooth1d(x, ismooth, nr)

      real x(nr)
      real, dimension(:), allocatable :: y

      integer :: ismooth
      integer :: ir,nr,k,kmin,kmax

      allocate(y(nr))

!     Apply smoothing operation

      do ir = 1, nr
        y(ir) = 0.0

        kmin = max(1, ir-ismooth)
      kmax = min(nr, ir+ismooth)

        do k = kmin, kmax
          y(ir) = y(ir) + x(k)
        enddo

        y(ir) = y(ir) / real((1+kmax - kmin))
      enddo

      x = y

      deallocate(y)

      end subroutine smooth1d

end module profile_setup_mod