      program bfivept
c-----------------------------------------------------------------------
c main program for generating BLOCK 5 point and 7-point matrices in the
c Harwell-Boeing format.  Creates a file with containing a
c harwell-boeing matrix.
c
c max block size = 5
c max number of grid points = 8000  = ( nx * ny * nz .le. 8000)
c matrix dimension =  (nx*ny*nz* Block-size**2) .le. 8000 * 25= 200,000
c
c typical session:
c Enter nx, ny, nz : 10 10 1
c enter block-size : 4
c enter filename for matrix: test.mat
c output matrix in data file : test.mat
c
c nz =1 will create a 2-D problem
c-----------------------------------------------------------------------
      parameter (nxmax = 20, nmx = nxmax*nxmax*nxmax, ntot=nmx*25)
      integer ia(ntot),ja(ntot),iau(ntot), iao(ntot),jao(ntot)
      real*8 stencil(7,100), a(ntot), ao(ntot)
      character title*72,key*8,type*3, matfile*50, guesol*2
c-----------------------------------------------------------------------
      write (6,*)  '  '
      write(6,'(22hEnter  nx, ny, nz   : ,$)')
      read (5,*) nx, ny, nz
      write(6,'(22hnfree (Block size)  : ,$)')
      read (5,*) nfree

      write(6,'(22hFilename for matrix : ,$)')

      read(5,'(a50)') matfile
      open (unit=7,file=matfile)
c
      write (6,*) ' output in data file : ', matfile

c------------------------------------------------------
      na = nfree*nfree
c
      call gen57bl (nx,ny,nz,nfree,na,n,a,ja,ia,iau,stencil)
c------------------------------------------------------

      print *, ' n=', n, ' nfree ', nfree, ' na =', na

      call bsrcsr(1,n,nfree, na, a, ja, ia, ao, jao, iao)
      n = n * nfree ! Apr. 21, 1995

      guesol='NN'

      title =
     *     ' BLOCK 5-POINT TEST MATRIX FROM SPARSKIT               '
      type  = 'RUA'
      key   = 'BLOCK5PT'
C              12345678
      ifmt = 15
      job = 2
      iout = 7
      call prtmt (n,n,ao,jao,iao,rhs,guesol,title,key,type,
     1     ifmt,job,iout)
      print *, ' output in data file : ', matfile
c
      stop
      end


MODULE FUN_xyUNITVECTOR
!!#### PURPOSE
!! Determine a unit vector <U>, from:
!!  @ a vector <V>,
!!  @ two points <PP>, or
!!  @ two points in a list <P2>.

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

!!#### EXTERNAL PARAMETERS
USE PAR_Constants_Rsp,ONLY: c_0_Rsp => c_0     !!((02-A-PAR_Constants_Rsp.f90))
USE PAR_Constants_Rdp,ONLY: c_0_Rdp => c_0     !!((02-A-PAR_Constants_Rdp.f90))

!!#### EXTERNAL PROCEDURES
USE FUN_xyNORM,ONLY: xyNORM_V                  !!((03-A-FUN_xyNORM.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyUNITVECTOR_V
 MODULE PROCEDURE xyUNITVECTOR_V_Rsp
 MODULE PROCEDURE xyUNITVECTOR_V_Rdp
END INTERFACE

INTERFACE xyUNITVECTOR_PP
 MODULE PROCEDURE xyUNITVECTOR_PP_Rsp
 MODULE PROCEDURE xyUNITVECTOR_PP_Rdp
END INTERFACE

INTERFACE xyUNITVECTOR_P2
 MODULE PROCEDURE xyUNITVECTOR_P2_Rsp
 MODULE PROCEDURE xyUNITVECTOR_P2_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyUNITVECTOR_P2
PUBLIC :: xyUNITVECTOR_PP
PUBLIC :: xyUNITVECTOR_V

CONTAINS

PURE FUNCTION xyUNITVECTOR_V_Rsp( V ) RESULT( xyU )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rsp
INCLUDE "04-A-FUN_xyUNITVECTOR_V.f90.hdr"
!!--begin--
INCLUDE "04-A-FUN_xyUNITVECTOR_V.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyUNITVECTOR_V_Rdp( V ) RESULT( xyU )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rdp
INCLUDE "04-A-FUN_xyUNITVECTOR_V.f90.hdr"
!!--begin--
INCLUDE "04-A-FUN_xyUNITVECTOR_V.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyUNITVECTOR_PP_Rsp( P_a , P_b ) RESULT( xyU )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-A-FUN_xyUNITVECTOR_PP.f90.hdr"
!!--begin--
INCLUDE "04-A-FUN_xyUNITVECTOR_PP.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyUNITVECTOR_PP_Rdp( P_a , P_b ) RESULT( xyU )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-A-FUN_xyUNITVECTOR_PP.f90.hdr"
!!--begin--
INCLUDE "04-A-FUN_xyUNITVECTOR_PP.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyUNITVECTOR_P2_Rsp( P2 ) RESULT( xyU )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-A-FUN_xyUNITVECTOR_P2.f90.hdr"
!!--begin--
INCLUDE "04-A-FUN_xyUNITVECTOR_P2.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyUNITVECTOR_P2_Rdp( P2 ) RESULT( xyU )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-A-FUN_xyUNITVECTOR_P2.f90.hdr"
!!--begin--
INCLUDE "04-A-FUN_xyUNITVECTOR_P2.f90.bdy"
!!--end--
END FUNCTION

END MODULE


      subroutine distmin(ndim,n1,n2,c1,c2,rad1,rad2,dmin)
      implicit double precision(a-h,o-z)
      dimension c1(ndim,3),c2(ndim,3),rad1(ndim),rad2(ndim)

c find the minimum distance (rel to VdW radius)
c betweem two groups

      dmin=1.d6
      do j1=1,n1
      do j2=1,n2

      d=0.d0
      do k=1,3
       d=d+(c1(j1,k)-c2(j2,k))**2
      enddo
      d=sqrt(d)/(rad1(j1)+rad2(j2))
      if(d.lt.dmin)dmin=d

      enddo
      enddo

      return
      end


!##############################################################################
!# Tutorial 008c: Create a 2x2 block system with diffusion/convection/reaction
!##############################################################################

module tutorial008c

  ! Include basic Feat-2 modules
  use fsystem
  use storage
  use genoutput

  use triangulation
  use meshgeneration

  use derivatives
  use element
  use cubature
  use spatialdiscretisation
  use linearsystemscalar
  use linearsystemblock

  use scalarpde
  use derivatives
  use bilinearformevaluation

  use matrixio

  implicit none
  private

  public :: start_tutorial008c

contains

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

  subroutine start_tutorial008c

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialDiscretisation) :: rspatialDiscr
    type(t_blockDiscretisation) :: rblockDiscr

    type(t_matrixScalar) :: rtemplateMatrix
    type(t_matrixBlock) :: rmatrix

    type(t_scalarCubatureInfo), target :: rcubatureInfo
    type(t_bilinearForm) :: rform
    character(LEN=SYS_STRLEN) :: spostdir

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 008c")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 5x5-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 4, 4)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Create a block discretisation that encapsules
    ! two equations, both discretised with Q1.
    ! =================================

    ! Set up a Q1 discretisation
    call spdiscr_initDiscr_simple (rspatialDiscr,EL_Q1_2D,rtriangulation)

    ! Set up a block discretisation for two equations. Both equations are Q1.
    call spdiscr_initBlockDiscr (rblockDiscr,rtriangulation)
    call spdiscr_appendBlockComponent (rblockDiscr,rspatialDiscr)
    call spdiscr_appendBlockComponent (rblockDiscr,rspatialDiscr)
    call spdiscr_commitBlockDiscr (rblockDiscr)

    ! =================================
    ! Create a 2x2 block matrix with
    ! entries in (1,1) and (2,2)
    ! =================================

    ! Create a template matrix for the FEM space. CSR structure.
    call bilf_createMatrixStructure (rspatialDiscr,LSYSSC_MATRIX9,rtemplateMatrix)

    ! Use the block discretisation to create a basic system matrix.
    call lsysbl_createMatrix (rblockDiscr,rmatrix)

    ! Create (1,1) and (2,2) using the template matrix.
    ! Structure is "shared" (no new memory is allocated), content is allocated.
    call lsysbl_duplicateMatrix (rtemplateMatrix,rmatrix,1,1,&
        LSYSSC_DUP_SHARE,LSYSSC_DUP_EMPTY)

    call lsysbl_duplicateMatrix (rtemplateMatrix,rmatrix,2,2,&
        LSYSSC_DUP_SHARE,LSYSSC_DUP_EMPTY)

    ! =================================
    ! Clear the matrix
    ! =================================

    call lsysbl_clearMatrix (rmatrix)

    ! =================================
    ! Use a 3-point Gauss Formula for the assembly
    ! =================================

    call spdiscr_createDefCubStructure (rspatialDiscr,rcubatureInfo,CUB_GEN_AUTO_G3)

    ! =================================
    ! Block (1,1): -Laplace(u) + beta grad(u)
    ! =================================

    ! Set up a bilinear for for Laplace + convection. There are 4 terms...
    rform%itermCount = 4

    ! We have constant coefficients, given in rform%Dcoefficients.
    rform%ballCoeffConstant = .true.

    ! Term 1/2: -Laplace  =>  (1 phi_x psi_x  +  1 phi_y psi_y)
    rform%Dcoefficients(1)  = 1.0_DP
    rform%Idescriptors(1,1) = DER_DERIV2D_X
    rform%Idescriptors(2,1) = DER_DERIV2D_X

    rform%Dcoefficients(2)  = 1.0_DP
    rform%Idescriptors(1,2) = DER_DERIV2D_Y
    rform%Idescriptors(2,2) = DER_DERIV2D_Y

    ! Term 3/4: Convection  beta*grad  =>  beta_1 phi_x psi  +  beta_2 phi_y psi
    ! We take beta=(2,0.5).
    rform%Dcoefficients(3)  = 2.0_DP
    rform%Idescriptors(1,3) = DER_DERIV2D_X
    rform%Idescriptors(2,3) = DER_FUNC2D

    rform%Dcoefficients(4)  = 0.5_DP
    rform%Idescriptors(1,4) = DER_DERIV2D_Y
    rform%Idescriptors(2,4) = DER_FUNC2D

    ! Build the matrix block (1,1)
    call bilf_buildMatrixScalar (rform,.false.,rmatrix%RmatrixBlock(1,1),rcubatureInfo)

    ! =================================
    ! Block (2,2): -Laplace(u) + u
    ! =================================

    ! Set up a bilinear for for Laplace + convection. There are 4 terms...
    rform%itermCount = 3

    ! We have constant coefficients:
    rform%ballCoeffConstant = .true.

    ! Term 1/2: -Laplace  =>  (1 phi_x psi_x  +  1 phi_y psi_y)
    rform%Dcoefficients(1)  = 1.0_DP
    rform%Idescriptors(1,1) = DER_DERIV2D_X
    rform%Idescriptors(2,1) = DER_DERIV2D_X

    rform%Dcoefficients(2)  = 1.0_DP
    rform%Idescriptors(1,2) = DER_DERIV2D_Y
    rform%Idescriptors(2,2) = DER_DERIV2D_Y

    ! Term 3/4: Reaction.  =>  (1 phi psi)
    rform%Dcoefficients(3)  = 1.0_DP
    rform%Idescriptors(1,3) = DER_FUNC2D
    rform%Idescriptors(2,3) = DER_FUNC2D

    ! Build the matrix block (2,2)
    call bilf_buildMatrixScalar (rform,.false.,rmatrix%RmatrixBlock(2,2),rcubatureInfo)

    ! =================================
    ! Output of the matrix
    ! =================================
    call output_line ("Writing matrix to text files...")

    if (sys_getenv_string("POSTDIR",spostdir)) then
      ! Write the matrix to a text file, omit nonexisting entries in the matrix.
      call matio_writeBlockMatrixHR (rmatrix, "matrix", .true., 0, &
          trim(spostdir)//"/tutorial008c_matrix.txt", "(E11.2)")

      ! Write the matrix to a MATLAB file.
      call matio_spyBlockMatrix(&
          trim(spostdir)//"/tutorial008c_matrix.m","matrix",rmatrix,.true.)

      ! Write the matrix to a MAPLE file
      call matio_writeBlockMatrixMaple (rmatrix, "matrix", 0, &
          trim(spostdir)//"/tutorial008c_matrix.maple", "(E11.2)")
    else
      ! Write the matrix to a text file, omit nonexisting entries in the matrix.
      call matio_writeBlockMatrixHR (rmatrix, "matrix", .true., 0, &
          "./post/tutorial008c_matrix.txt", "(E11.2)")

      ! Write the matrix to a MATLAB file.
      call matio_spyBlockMatrix(&
          "./post/tutorial008c_matrix.m","matrix",rmatrix,.true.)

      ! Write the matrix to a MAPLE file
      call matio_writeBlockMatrixMaple (rmatrix, "matrix", 0, &
          "./post/tutorial008c_matrix.maple", "(E11.2)")
    end if

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the cubature formula
    call spdiscr_releaseCubStructure (rcubatureInfo)

    ! Release the matrix
    call lsysbl_releaseMatrix (rmatrix)

    ! ... and the FEM template matrix
    call lsyssc_releaseMatrix (rtemplateMatrix)

    ! Release the block discretisation
    call spdiscr_releaseBlockDiscr (rblockDiscr)

    ! Release the Q1-discretisation
    call spdiscr_releaseDiscr (rspatialDiscr)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


C $VERSION "08/16/95 @(#)calcpath.f	7.1"
c
c	---------------------------------------------------------------
c	|						CalcPath
c	| calculate the path length a beam of
c	| light given the slope and aspect of the
c	| ground and the angle of the sun.  This
c	| is returns a unitless ratio that is
c	| multiplied with the height of the canopy
c	| to give you the path length through
c	| the canopy.
c
c	| changed to use Shinsuke's equations 94/2/10
c   First test for Git - Hieu

c
	subroutine calcpath(nohrs,slope,aspect,path)
c
	IMPLICIT NONE
	integer    mh
	parameter (mh=98)
c
c	-----
c	| parameters
c
	integer nohrs
	real	slope
	real	aspect
	real	path(mh)
c
c	------
c	| commons
c
	real	pi
	real	pid180
	real	pid2
	real	sigma
	integer	iwrite(9,99)
	integer kmax
	common/misc1/pi,pid180,pid2,sigma,iwrite,kmax
c
	real 	radtop(3,mh)
	real	fbeam1(3,mh)
	real	coszen(mh)
	real	zenang(mh)
	real	hfday
	real	ratiod
	real	ration
	real	ratio(mh)
	common /rad3/radtop,fbeam1,coszen,zenang
     &		     	,hfday,ratiod,ration,ratio
c
	real	sunazm(mh)
	real	nozenv
	real	viewzn(10)
	real	noazmv
	real	viewaz(50)
	real	xintv(10,50)
	common /deg/sunazm,nozenv,viewzn,noazmv,viewaz,xintv
c
c	------
c	| Local
c
	integer	i
	real	term1
	real	term2
	real	sqs
	real	e
c
c
	do 2000, i = 1, nohrs
c
	    if (zenang(i) .lt. pid2*.998) then
c
		if (sunazm(i).eq.0.0) then
		    ! write(*,*)'sunazm of i = ',i,' equals 0.0'
		    write(*,*) 'zenang of i = ',zenang(i)
		    stop
		endif
c
      	        path(i)= cos(zenang(i))*cos(slope)+sin(zenang(i))
     &				*sin(slope)*cos(aspect-sunazm(i))
		  if(path(i).eq.0.)path(i)=1.0e-11
		  path(i)=1./path(i)
 		if (path(i).le.0.0.or.path(i).gt.1.0e10) then
c		if (path(i).le.0.0) then
		    path(i)=-1.0
		endif
c
	    else
c	 	----------
c		| Sun  below horizon
c
		path(i) = -1.0
	    endif
c
2000	continue
	return
	end


      PROGRAM MAIN

C     RESULT REPORTING
C     CHARACTER(LEN=*), PARAMETER  :: FMT1 = "(F18.15)"
      CHARACTER(LEN=*), PARAMETER  :: FMT1 = "(E12.6)"

C     ----------------------------------------------
C     Variables and data for FUNDARG
C     ----------------------------------------------
      DOUBLE PRECISION T, LR, LPR, FR, DR, OMR
      DOUBLE PRECISION    L,  LP,  F,  D,  OM
      DATA T, LR, LPR, FR, DR, OMR/0.07995893223819302D0,
     .   2.291187512612069099D0,
     .   6.212931111003726414D0,
     .   3.658025792050572989D0,
     .   4.554139562402433228D0,
     .   -0.5167379217231804489D0/

C     CALL FUNDARG
      CALL FUNDARG(T, L, LP, F, D, OM)

C     REPORT RESULTS
      PRINT *, '----------------------------------------'
      PRINT *, '> FUNDARG Results:'
      PRINT *, '----------------------------------------'
      WRITE(*, FMT1) DABS(L-LR)
      WRITE(*, FMT1) DABS(LP-LPR)
      WRITE(*, FMT1) DABS(F-FR)
      WRITE(*, FMT1) DABS(D-DR)
      WRITE(*, FMT1) DABS(OM-OMR)

C     ALL DONE
      END


module mtxmul

use iso_c_binding, only: c_double, c_int
implicit none

contains

subroutine do_mtxmul(m, n, o, A, B, Out) bind(c)
  integer(c_int), intent(in) :: m, n, o
  real(c_double), intent(in) :: A(m,n), B(n,o)
  real(c_double), intent(inout) :: Out(m,o)
  Out = matmul(A,B)
end subroutine

end module


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      REAL FUNCTION RAN1(idum)

C  This function returns a pseudo-random number for each invocation.
C  It is a FORTRAN 77 adaptation of the "Integer Version 2" minimal
C  standard number generator whose Pascal code appears in the article:

C     Park, Steven K. and Miller, Keith W., "Random Number Generators:
C     Good Ones are Hard to Find", Communications of the ACM,
C     October, 1988.

      PARAMETER (MPLIER=16807,MODLUS=2147483647,MOBYMP=127773,
     +           MOMDMP=2836)

      data jseed /123456789/
      data ifrst /0/

      INTEGER HVLUE, LVLUE, TESTV, NEXTN
      SAVE    NEXTN

      IF (IFRST .EQ. 0) THEN
        if (idum .ne. 0) then
          nextn = idum
        else
          NEXTN = JSEED
        end if

        IFRST = 1
      ENDIF

      HVLUE = NEXTN / MOBYMP
      LVLUE = MOD(NEXTN, MOBYMP)
      TESTV = MPLIER*LVLUE - MOMDMP*HVLUE
      IF (TESTV .GT. 0) THEN
        NEXTN = TESTV
      ELSE
        NEXTN = TESTV + MODLUS
      ENDIF
      RAN1 = REAL(NEXTN)/REAL(MODLUS)

      RETURN
      END


*DECK CASINH
      COMPLEX FUNCTION CASINH (Z)
C***BEGIN PROLOGUE  CASINH
C***PURPOSE  Compute the arc hyperbolic sine.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4C
C***TYPE      COMPLEX (ASINH-S, DASINH-D, CASINH-C)
C***KEYWORDS  ARC HYPERBOLIC SINE, ASINH, ELEMENTARY FUNCTIONS, FNLIB,
C             INVERSE HYPERBOLIC SINE
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C CASINH(Z) calculates the complex arc hyperbolic sine of Z.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CASIN
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  CASINH
      COMPLEX Z, CI, CASIN
      SAVE CI
      DATA CI /(0.,1.)/
C***FIRST EXECUTABLE STATEMENT  CASINH
      CASINH = -CI*CASIN (CI*Z)
C
      RETURN
      END


      SUBROUTINE CROSS(Z,L,N)
      COMPLEX Z(1),TEMP,B1
C     OBTAIN TWO FFT'S OF REAL-VALUED TIME HISTORIES SIMULTANEDUSLY
      NN=N
      CALL FOUR(Z,NN,-1)
      NH=N/2
      NH1=NH+1
      B1=AIMAG(Z(1))
      Z(1)=REAL(Z(1))
      DO 112 I=2,NH
      TEMP=0.5*(Z(I)+CONJG(Z(N+2-I)))
      Z(N+2-I)=(0.,-0.5)*(Z(I)-CONJG(Z(N+2-I)))
  112 Z(I)=TEMP
C     COMPUTE THE RAW CROSS SPECTRUM,S
      FN=FLOAT(N*L)
      Z(1)=CONJG(Z(1))*B1/FN
      DO 113 I=2,NH
  113 Z(I)=CONJG(Z(I))*Z(N+2-I)/FN
      Z(NH1)=AIMAG(Z(NH1))*REAL(Z(NH1))/FN
      DO 114 I=2,NH
  114 Z(N+2-I)=CONJG(Z(I))
C     COMPUTE THE INVERS FFT OF S TO OBTAIN THE CROSS CORRELATION
      CALL FOUR(Z,NN,1)
      A=REAL(Z(1))
      WRITE(6,5) A
    5 FORMAT(42H1CROSSCOVARIANCE FUNCTION AT THE ORIGIN = ,1PE10.3)
      WRITE(6,6)
    6 FORMAT(1H ,50X,29H CROSSCORRELATION COEFFICIENT)
      WRITE(6,7) SIG
    7 FORMAT(1X,1PE10.3)
      SIG=1.
      Z(1)=Z(1)/SIG
      DO 115 I=2,L
      Z(N+2-I)=Z(N+2-I)*FLOAT(L)/(SIG*FLOAT(L+1-I))
  115 Z(I)=Z(I)*FLOAT(L)/(SIG*FLOAT(L+1-I))
      RETURN
      END


Function pygamm(x)
  Dimension b(8)
  Data b/ -0.57719165, 0.98820589, -0.89705694, 0.91820686, -0.75670408, 0.48219939, -0.19352782, 0.03586834/
  nx = int(x)
  dx = x - nx
  pygamm = 1.
  Do i = 1, 8
    pygamm = pygamm + b(i)*dx**i
  End Do
  If (x<1.) Then
    pygamm = pygamm/x
  Else
    Do ix = 1, nx - 1
      pygamm = (x-ix)*pygamm
    End Do
  End If
  Return
End Function pygamm


module PlanarSWEModule
!> @file PlanarSWE.f90
!> Data structure for representing solutions of the shallow water equations in a beta-plane.
!> @author Peter Bosler, Sandia National Laboratories, Center for Computing Research
!>
!> @defgroup PlanarSWE PlanarSWE
!> @brief Data structure for representing solutions of the shallow water equations in a beta-plane.
!>
!> Combines a @ref PolyMesh2d with data @ref Field objects relevant to the shallow water equations.  @n
!> Solutions are integrated in time using the @ref SWEPlaneSolver module.
!>
!> In addition to the variables carried by the base @ref Particles object (e.g., physical and Lagrangian coordinates),
!> the BVEMesh data type adds @ref Field structures for relative vorticity @f$ \zeta(x,y,t) @f$, divergence @f$ \delta(x,y,t) @f$,
!> the materially conserved absolute vorticity @f$ q(x_0,y_0) @f$, velocity @f$ \vec{u}(x,y,t) @f$ and the fluid depth @f$ h(x,y,t) @f$.
!> Users may also specify bottom topography @f$ \eta_B(x,y) @f$.
!> These variables are related by the equation
!> @f{align}{
!> 	q &= \frac{\zeta + f}{h}, \\
!> \eta &= \eta_B + h,
!> @f}
!> where @f$ f = f_0 + \beta y(t) @f$ is the Coriolis parameter with constants @f$ f_0 @f$ and @f$ \beta @f$, and
!> @f$ \eta @f$ is the fluid surface height.
!>
!>
!> @image html SWEVariables.png "Illustration of variable definitions used in the shallow water equations."
!>
!> We again use Green's function for the Poisson equation with free boundaries in the plane to solve the PDE.
!>
!> Following a discretization by an LPM particle set, we have
!> @f{align*}{
!>  \vec{u}(\vec{x},t) &= \int_{\mathbb{R}^2} \left(\vec{K}_\zeta(\vec{x},\vec{y})\zeta(\vec{y}) + \vec{K}_\delta(\vec{x},\vec{y})\delta(\vec{y})\right)\, dA(\vec{y}), \\
!>  \frac{d\vec{x}}{dt} &= \vec{u}(\vec{x},t), \\
!>  \frac{d\zeta}{dt} &= -\beta \frac{dy}{dt} - (\zeta + f)\delta, \\
!>  \frac{d\delta}{dt} &= f\zeta -\vec{u}\cdot(\nabla\times f\vec{k}) - \nabla\vec{u}:\nabla\vec{u} - g\nabla^2 \eta, \\
!>  \frac{dh}{dt} &= -h\delta, \\
!>  \frac{dA}{dt} &= \delta A,
!> @f}
!> where the kernels @f$ \vec{K}_\zeta = -\nabla \times G @f$ and @f$ \vec{K}_\delta = \nabla G @f$ result from
!> applying the appropriate differential operators to the free space Green's function
!> @f[
!>	G(\vec{x},\vec{y}) = \frac{1}{4\pi}\log( |\vec{x}-\vec{y}|^2).
!> @f]
!> The double dot product @f$ \nabla\vec{u}:\nabla\vec{u}@f$ is evaluated by again differentiating the kernels @f$ \vec{K}_\zeta @f$
!> and @f$ \vec{K}_\delta @f$. @n
!> The Laplacian of the fluid surface is evaluated on the particles using Particle Strength Exchange (PSE).
!> See @ref PSEDirectSum for additional details.
!>
!>
!> @{
use NumberKindsModule
use OutputWriterModule
use UtilitiesModule
use LoggerModule
use ParticlesModule
use EdgesModule, only : MaxEdgeLength
use FacesModule
use PolyMesh2dModule
use FieldModule
use MPISetupModule
use PSEDirectSumModule

implicit none

include 'mpif.h'

private
public SWEMesh, New, Delete, Copy
public AddTracers
public LogStats
public OutputToVTKFile
public SetBottomHeightOnMesh, SetInitialDivergenceOnMesh, SetInitialHOnMesh, SetInitialPotVortOnMesh
public SetInitialVelocityOnMesh, SetInitialVorticityOnMesh, SetFieldN
public SetVelocityOnMesh

!> @brief Defines a mesh (via @ref PolyMesh2d) and data fields (via @ref Field) suitable for solving the planar Shallow Water Equations (SWE).
type SWEMesh
	type(PolyMesh2d) :: mesh !< Planar mesh
	type(Field) :: relVort !< relative vorticity at each particle
	type(Field) :: potVort !< potential vorticity carried by each particle
	type(Field) :: divergence !< divergence of the fluid velocity at each particle
	type(Field) :: velocity !< velocity of each particle
	type(Field) :: h !< fluid depth at each particle
	type(Field) :: hBottom !< bottom height at each particle
	type(Field), dimension(:), allocatable :: tracers !< Tracers carried by each particle
	real(kreal) :: f0 = 0.0_kreal !< beta plane parameter
	real(kreal) :: beta = 0.0_kreal !< beta plane parameter
	real(kreal) :: g = 0.0_kreal !< gravitational constant
	real(kreal) :: pseEps = 0.0_kreal !< Regularization parameter for Particle Strength Exchange
	type(MPISetup) :: mpiParticles !< Distributes work on particles across available MPI ranks
	contains
		final :: deletePrivate
end type

interface New
	module procedure newPrivate
end interface

interface Copy
	module procedure copyPrivate
end interface

interface Delete
	module procedure deletePrivate
end interface

interface LogStats
	module procedure logStatsPrivate
end interface

interface SetVelocityOnMesh
	module procedure setVelocityFromFieldData
end interface

!
!----------------
! Logging
!----------------
!
logical(klog), save :: logInit = .FALSE.
type(Logger) :: log
character(len=28), save :: logKey = 'SWE'
integer(kint), parameter :: logLevel = DEBUG_LOGGING_LEVEL

!interface
!	real(8) function scalarFnOf2DSpace( x, y)
!		real(8), intent(in) :: x, y
!	end function
!end interface
!
!interface
!	function vectorFnOf2DSpace( x, y)
!		real(8), dimension(2) :: vectorFnOf2DSpace
!		real(8), intent(in) :: x, y
!	end function
!end interface

contains
!
!----------------
! public methods
!----------------
!

!> @brief Allocates memory and initializes a planar mesh for solving the shallow water equations.
!>
!> @param[out] self new SWE mesh
!> @param[in] meshSeed mesh seed integer, as defined in @ref NumberKinds
!> @param[in] initNest initial level of uniform refinement
!> @param[in] maxNest maximum level of uniform refinment
!> @param[in] amrLimit maximum number of times an individual face can be divided beyond initNest
!> @param[in] meshRadius maximum extent of mesh from the origin
!> @param[in] f0 constant for Coriolis approximation with the beta plane
!> @param[in] beta constant for Coriolis approximation with the beta plane
!> @param[in] g gravitational constant
subroutine newPrivate(self, meshSeed, initNest, maxNest, amrLimit, meshRadius, f0, beta, g )
	type(SWEMesh), intent(out) :: self
	integer(kint), intent(in) :: meshSeed
	integer(kint), intent(in) :: initNest
	integer(kint), intent(in) :: maxNest
	integer(kint), intent(in) :: amrLimit
	real(kreal), intent(in) :: meshRadius
	real(kreal), intent(in) :: f0, beta, g

	if ( .NOT. logInit ) call InitLogger(log, procRank)

	if ( meshSeed /= TRI_HEX_SEED .AND. meshSeed /= QUAD_RECT_SEED ) then
		call LogMessage(log, ERROR_LOGGING_LEVEL, trim(logKey), "new SWEMesh ERROR : invalid meshSeed.")
		return
	endif

	call New(self%mesh, meshSeed, initNest, maxNest, amrLimit, meshRadius )

	call New(self%relVort, 1, self%mesh%particles%N, "relVort", "1/s")
	call New(self%potVort, 1, self%mesh%particles%N, "potVort", "1/s")
	call New(self%divergence, 1, self%mesh%particles%N, "divergence", "1/s")
	call New(self%velocity, 2, self%mesh%particles%N, "velocity", "m/s")
	call New(self%h, 1, self%mesh%particles%N, "h", "m")
	call New(self%hBottom, 1, self%mesh%particles%N, "hB", "m")
	call New(self%mpiParticles, self%mesh%particles%N, numProcs)

	self%f0 = f0
	self%beta = beta
	self%g = g
end subroutine

!> @brief Performs a deep copy of a SWE mesh
!> @todo This subroutine is incomplete.
!> @warning Cannot do remesh/remap until it is done.
subroutine copyPrivate(self, other)
	type(SWEMesh), intent(inout) :: self
	type(SWEMesh), intent(in) :: other
	!
	integer(kint) :: i

	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey)//" copyPrivate : ", "entering")

	self%g = other%g
	self%f0 = other%f0
	self%beta = other%beta
	self%pseEps = other%pseEps

	call Copy(self%mesh, other%mesh)
	call Copy(self%relVort, other%relVort)
	call Copy(self%potVort, other%potVort)
	call Copy(self%divergence, other%divergence)
	call Copy(self%velocity, other%velocity)
	call Copy(self%h, other%h)
	call Copy(self%hBottom, other%hBottom)
	call Copy(self%mpiParticles, other%mpiParticles)

	if (allocated(other%tracers) .AND. (size(self%tracers) == size(other%tracers)) ) then
		do i = 1, size(self%tracers)
			call Copy(self%tracers(i), other%tracers(i))
		enddo
	endif
end subroutine

!> @brief Deletes and frees memory associated with a SWEMesh
!> @param[inout] self SWEMesh
subroutine deletePrivate(self)
	type(SWEMesh), intent(inout) :: self
	!
	integer(kint) :: i

	call Delete(self%mpiParticles)
	call Delete(self%hBottom)
	call Delete(self%relVort)
	call Delete(self%potVort)
	call Delete(self%divergence)
	call Delete(self%velocity)
	call Delete(self%h)
	call Delete(self%mesh)
	if ( allocated(self%tracers)) then
		do i = 1, size(self%tracers)
			call Delete(self%tracers(i))
		enddo
		deallocate(self%tracers)
	endif
end subroutine

subroutine SetFieldN(self)
	type(SWEMesh), intent(inout) :: self
	!
	integer(kint) :: nn

	nn = self%mesh%particles%N

	self%hBottom%N = nn
	self%relVort%N = nn
	self%potVort%N = nn
	self%divergence%N = nn
	self%velocity%N = nn
	self%h%N = nn

end subroutine

!> @brief Computes the fluid velocity at each particle in parallel using direct summation.
!> @todo Verify whether or not this subroutine is ever used.
subroutine SWEComputeVelocity(self, velocity, x, y, relVort, divergence, area )
	type(SWEMesh), intent(inout) :: self
	type(Field), intent(inout) :: velocity
	real(kreal), intent(in) :: x(:), y(:), relVort(:), divergence(:), area(:)
	!
	integer(kint) :: i, j, mpiErrCode
	real(kint) :: denom

	call SetFieldToZero(velocity)
	velocity%N = self%mesh%particles%N

	do i = self%mpiParticles%indexStart(procRank), self%mpiParticles%indexEnd(procRank)
		do j = 1, self%mesh%particles%N
			if ( i /= j .AND. self%mesh%particles%isActive(j) ) then
				denom = 2.0_kreal * PI * ( (x(i) - x(j))**2 + (y(i) - y(j))**2)
				velocity%xComp(i) = velocity%xComp(i) + (( y(i) - y(j) ) * relVort(j) + (x(i) - x(j)) * divergence(j)) * &
					area(j) / denom
				velocity%yComp(i) = velocity%yComp(i) + (-(x(i) - x(j) ) * relVort(j) + (y(i) - y(j)) * divergence(j)) * &
					area(j) / denom
			endif
		enddo
	enddo

	do i = 0, numProcs - 1
		call MPI_BCAST(velocity%xComp(self%mpiParticles%indexStart(i):self%mpiParticles%indexEnd(i)), &
				self%mpiParticles%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
		call MPI_BCAST(velocity%yComp(self%mpiParticles%indexStart(i):self%mpiParticles%indexEnd(i)), &
				self%mpiParticles%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	enddo
end subroutine

subroutine logStatsPrivate(self, aLog)
	type(SWEMesh), intent(in) :: self
	type(Logger), intent(inout) :: aLog
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "SWE Mesh "," stats : ")
	call LogStats(self%mesh, aLog)
	call LogStats(self%h, aLog)
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "Coriolis f0 = ", self%f0)
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "Coriolis beta = ", self%beta)
	call LogStats(self%relVort, aLog)
	call LogStats(self%potVort, aLog)
	call LogStats(self%divergence, aLog)
	call LogStats(self%velocity, aLog)
	call LogStats(self%hBottom, aLog)
	call LogStats(self%mpiParticles, aLog)
end subroutine

subroutine SetCoriolis(self, f0, beta)
	type(SWEMesh), intent(inout) :: self
	real(kreal), intent(in) :: f0, beta
	self%f0 = f0
	self%beta = beta
end subroutine

subroutine AddTracers( self, nTracers, tracerDims )
	type(SWEMesh), intent(inout) :: self
	integer(kint), intent(in) :: nTracers
	integer(kint), dimension(:), intent(in) :: tracerDims
	!
	integer(kint) :: i

	if ( size(tracerDims) /= nTracers ) then
		call LogMessage(log, ERROR_LOGGING_LEVEL, trim(logkey)//" AddTracers ERROR : ", &
			" must specify dimension of each tracer field.")
		return
	endif

	allocate(self%tracers(nTracers))
	do i = 1, nTracers
		call New(self%tracers(i), tracerDims(i), self%mesh%particles%N)
	enddo
end subroutine

subroutine OutputToVTKFile( self, filename )
	type(SWEMesh), intent(in) :: self
	character(len=*), intent(in) :: filename
	!
	integer(kint) :: i, writeStat

	open(unit=WRITE_UNIT_1, file=filename, status="REPLACE", action="WRITE", iostat=writeStat)
		if ( writeStat /= 0 ) then
			call LogMessage(log, ERROR_LOGGING_LEVEL, trim(logkey)//" OutputToVTK ERROR writing to file = ", trim(filename))
			return
		endif
		!
		!	write points and topology
		!
		call WriteVTKFileHeader(WRITE_UNIT_1)
		write(WRITE_UNIT_1, '(A,I8,A)') "POINTS ", self%mesh%particles%N, " double"
		do i = 1, self%mesh%particles%N
			write(WRITE_UNIT_1,*) self%mesh%particles%x(i), self%mesh%particles%y(i), &
								  self%h%scalar(i) + self%hBottom%scalar(i)
		enddo
		call WriteFacesToVTKPolygons( self%mesh%faces, WRITE_UNIT_1)
		!
		!	write particle data
		!
		call WriteVTKPointDataSectionHeader(WRITE_UNIT_1, self%mesh%particles%N)
		call WriteVTKLagCoords(self%mesh%particles, WRITE_UNIT_1) ! always has to be first point data call
		call WriteFieldToVTKPointData(self%h, WRITE_UNIT_1)
		call WriteFieldToVTKPointData(self%relVort, WRITE_UNIT_1)
		call WriteFieldToVTKPointData(self%potVort, WRITE_UNIT_1)
		call WriteFieldToVTKPointData(self%divergence, WRITE_UNIT_1)
		call WriteFieldToVTKPointData(self%velocity, WRITE_UNIT_1)
		call WriteFieldToVTKPointData(self%hBottom, WRITE_UNIT_1)
		if ( allocated(self%tracers)) then
			do i = 1, size(self%tracers)
				call WriteFieldToVTKPointData(self%tracers(i), WRITE_UNIT_1)
			enddo
		endif
		!
		!	write face data
		!
		call WriteFaceAreaToVTKCellData(self%mesh%faces, self%mesh%particles, WRITE_UNIT_1) ! always has to be first face data call
	close(WRITE_UNIT_1)
end subroutine

subroutine OutputToToMatlabMFile( self, filename )
	type(SWEMesh), intent(in) :: self
	character(len=*), intent(in) :: filename
	!
	integer(kint) :: writeStat
	open(unit=WRITE_UNIT_1, file=filename, status="REPLACE", action="WRITE", iostat=writeStat)
		if ( writeStat /= 0 ) then
			call LogMessage(log, ERROR_LOGGING_LEVEL, trim(logkey)//" OutputToVTK ERROR writing to file = ", trim(filename))
			return
		endif
	close(WRITE_UNIT_1)
end subroutine

subroutine SetInitialVorticityOnMesh(self, vorticityFn )
	type(SWEMesh), intent(inout) :: self
	procedure(scalarFnOf2DSpace) :: vorticityFn
	!
	integer(kint) :: i

	do i = 1, self%mesh%particles%N
		call InsertScalarToField(self%relVort, vorticityFn( self%mesh%particles%x(i), self%mesh%particles%y(i) ) )
	enddo
end subroutine

subroutine SetInitialDivergenceOnMesh(self, divergenceFn )
	type(SWEMesh), intent(inout) :: self
	procedure(scalarFnOf2DSpace) :: divergenceFn
	!
	integer(kint) :: i

	do i = 1, self%mesh%particles%N
		call InsertScalarToField(self%divergence, divergenceFn( self%mesh%particles%x(i), self%mesh%particles%y(i) ) )
	enddo
end subroutine

subroutine SetInitialHOnMesh(self, hFn )
	type(SWEMesh), intent(inout) :: self
	procedure(scalarFnOf2DSpace) :: hFn
	!
	integer(kint) :: i

	do i = 1, self%mesh%particles%N
		call InsertScalarToField(self%h, hFn( self%mesh%particles%x(i), self%mesh%particles%y(i) ))
	enddo
end subroutine

subroutine SetBottomHeightOnMesh( self, depthFn)
	type(SWEMesh), intent(inout) :: self
	procedure(scalarFnOf2DSpace) :: depthFn
	!
	integer(kint) :: i

	self%hBottom%N = self%mesh%particles%N
	do i = 1, self%mesh%particles%N
		self%hBottom%scalar(i) = depthFn( self%mesh%particles%x(i), self%mesh%particles%y(i) )
	enddo
end subroutine

subroutine SetInitialVelocityOnMesh(self, velFn)
	type(SWEMesh), intent(inout) :: self
	procedure(vectorFnOf2DSpace) :: velFn
	!
	integer(kint) :: i

	do i = 1, self%mesh%particles%N
		call InsertVectorToField(self%velocity, velFn( self%mesh%particles%x(i), self%mesh%particles%y(i)))
	enddo
end subroutine

subroutine setVelocityFromFieldData(self)
	type(SWEMesh), intent(inout) :: self
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: rotStrength, potStrength
	real(kreal) :: sqDist, denom

	call MPI_BARRIER(MPI_COMM_WORLD, mpiErrCode)
	print *, "remesh proc ", procRank
	call MPI_BARRIER(MPI_COMM_WORLD, mpiErrCode)

	call LogMessage(log, ERROR_LOGGING_LEVEL, trim(logKey)//" setVelocityFromFieldData : ", " entering.")
	call LogStats(self, log)

!	call SWEComputeVelocity(self, self%velocity, self%mesh%particles%x, self%mesh%particles%y, &
!		self%relVort%scalar, self%divergence%scalar, self%mesh%particles%area )

!	if (procRank == 1) then
!
!	endif
!	call MPI_BARRIER(MPI_COMM_WORLD, mpiErrCode)
!
	do i = self%mpiParticles%indexStart(procRank), self%mpiParticles%indexEnd(procRank)
		self%velocity%xComp(i) = 0.0_kreal
		self%velocity%yComp(i) = 0.0_kreal
!		print *, "proc ", procRank, ": i = ", i
		do j = 1, self%mesh%particles%N
			if ( i /= j .AND. self%mesh%particles%isActive(j)) then
				sqDist = (self%mesh%particles%x(i) - self%mesh%particles%x(j))**2 + &
						 (self%mesh%particles%y(i) - self%mesh%particles%y(j))**2
				denom = 2.0_kreal * PI * sqDist

				rotStrength = self%relVort%scalar(j) * self%mesh%particles%area(j) / denom
				potStrength = self%divergence%scalar(j) * self%mesh%particles%area(j) / denom

				self%velocity%xComp(i) = self%velocity%xComp(i) - &
						(self%mesh%particles%y(i) - self%mesh%particles%y(j)) * rotStrength + &
						(self%mesh%particles%x(i) - self%mesh%particles%x(j)) * potStrength
				self%velocity%yComp(i) = self%velocity%yComp(i) + &
						(self%mesh%particles%x(i) - self%mesh%particles%x(j)) * rotStrength + &
						(self%mesh%particles%y(i) - self%mesh%particles%y(j)) * potStrength
			endif
		enddo
	enddo
!
!	print *, "proc ", procRank, " velocity work done, waiting for broadcast."

	do i = 0, numProcs - 1
		call MPI_BCAST(self%velocity%xComp(self%mpiParticles%indexStart(i):self%mpiParticles%indexEnd(i)), &
			self%mpiParticles%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
		call MPI_BCAST(self%velocity%yComp(self%mpiParticles%indexStart(i):self%mpiParticles%indexEnd(i)), &
			self%mpiParticles%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	enddo
	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey)//" setVelocityFromFieldData : ", " done.")
end subroutine

subroutine SetInitialPotVortOnMesh( self )
	type(SWEMesh), intent(inout) :: self
	!
	integer(kint) :: i
	real(kreal) :: pv

	do i = 1, self%mesh%particles%N
		if ( self%h%scalar(i) > 0.0_kreal ) then
			pv = (self%relVort%scalar(i) + self%f0 + self%beta*self%mesh%particles%y(i)) / self%h%scalar(i)
		else
			pv = 0.0_kreal
		endif
		call InsertScalarToField( self%potVort, pv )
	enddo
end subroutine

!
!----------------
! private methods
!----------------
!

subroutine InitLogger(aLog,rank)
! Initialize a logger for this module and processor
	type(Logger), intent(out) :: aLog
	integer(kint), intent(in) :: rank
	write(logKey,'(A,A,I0.2,A)') trim(logKey),'_',rank,' : '
	if ( rank == 0 ) then
		call New(aLog,logLevel)
	else
		call New(aLog,ERROR_LOGGING_LEVEL)
	endif
	logInit = .TRUE.
end subroutine

!> @}
end module


!> Orchid -- 2D/3D Euler/MagnetoHydroDynamics solver.
!> Copyright (C) Butakov Oleg 2019.

Module orchid_solver_hydro_flux_hlle
Use orchid_solver_params
Use orchid_solver_hydro_flux_godunov
Implicit None
Type, Extends(MhdHydroFlux) :: MhdHydroFluxHLLE
    Contains
    Procedure, Public, NoPass, Non_Overridable :: &
        calc1D => mhd_hydro_calc_flux_hlle1D, &
        calc2D => mhd_hydro_calc_flux_hlle2D, &
        calc3D => mhd_hydro_calc_flux_hlle3D, &
        calc3D_mhd => mhd_hydro_calc_flux_hlle3D_mhd
End Type MhdHydroFluxHLLE
Contains
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_wave_speed_hlle(qp, sp, qm, sm)
    !> Calculate the Wave Speeds.
    !> REFERENCES:
    !> [1] Eleuterio F. Toro,
    !>     "Riemann Solvers and Numerical Methods
    !>      for Fluid Dynamics" (Third Edition, 2009).
    !> {{{
    Type(MhdHydroVars), Intent(In) :: qp, qm
    Real(8), Intent(Out) :: sp, sm
    !> }}}
    Real(8) :: rp, rm, d, n
    !> [1], Eq. (10.53-10.54).
    rp = Sqrt(qp%Rho)
    rm = Sqrt(qm%Rho)
    n = 0.5D0*rp*rm/( rp + rm )**2
    d = ( rp*qp%c2snd + rm*qm%c2snd )/( rp + rm ) + n*( qp%Vn - qm%Vn )**2
    d = Sqrt(d)
    !> [1], Eq. (10.52).
    sp = 0.5D0*( qp%Vn + qm%Vn ) + d
    sm = 0.5D0*( qp%Vn + qm%Vn ) - d
End Subroutine mhd_hydro_calc_wave_speed_hlle
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_flux_hlle1D(nx, &
                                      qp, qm, flux)
    !> Calculate the HLLE Fluxes in 1D.
    !> REFERENCES:
    !> [1] Eleuterio F. Toro,
    !>     "Riemann Solvers and Numerical Methods
    !>      for Fluid Dynamics" (Third Edition, 2009).
    !> {{{
    Type(MhdHydroVars1D), Intent(In) :: qp, qm
    Real(8), Dimension(1:3), Intent(Out) :: flux
    Real(8), Intent(In) :: nx
    !> }}}
    Real(8) :: sp, sm
    !> Calculate Wave speeds.
    Call mhd_hydro_calc_wave_speed_hlle(qp%MhdHydroVars, sp, &
                                        qm%MhdHydroVars, sm)
    !> Calculate Fluxes: [1], Eq. (10.20-10.21).
    If ( sp < 0.0D0 ) Then
        flux = qp%F
    Else If ( sm > 0.0D0 ) Then
        flux = qm%F
    Else
        flux = ( sp*qm%F - sm*qp%F + sp*sm*( qp%U - qm%U ) )/( sp - sm )
    End If
End Subroutine mhd_hydro_calc_flux_hlle1D
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_flux_hlle2D(nx, ny, &
                                      qp, qm, flux)
    !> Calculate the HLLE Fluxes in 2D.
    !> REFERENCES:
    !> [1] Eleuterio F. Toro,
    !>     "Riemann Solvers and Numerical Methods
    !>      for Fluid Dynamics" (Third Edition, 2009).
    !> {{{
    Type(MhdHydroVars2D), Intent(In) :: qp, qm
    Real(8), Dimension(1:4), Intent(Out) :: flux
    Real(8), Intent(In) :: nx, ny
    !> }}}
    Real(8) :: sp, sm
    !> Calculate Wave speeds.
    Call mhd_hydro_calc_wave_speed_hlle(qp%MhdHydroVars, sp, &
                                        qm%MhdHydroVars, sm)
    !> Calculate Fluxes: [1], Eq. (10.20-10.21).
    If ( sp < 0.0D0 ) Then
        flux = qp%F
    Else If ( sm > 0.0D0 ) Then
        flux = qm%F
    Else
        flux = ( sp*qm%F - sm*qp%F + sp*sm*( qp%U - qm%U ) )/( sp - sm )
    End If
End Subroutine mhd_hydro_calc_flux_hlle2D
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_flux_hlle3D(nx, ny, nz, &
                                      qp, qm, flux)
    !> Calculate the HLLE Fluxes in 3D.
    !> REFERENCES:
    !> [1] Eleuterio F. Toro,
    !>     "Riemann Solvers and Numerical Methods
    !>      for Fluid Dynamics" (Third Edition, 2009).
    !> {{{
    Type(MhdHydroVars3D), Intent(In) :: qp, qm
    Real(8), Dimension(1:5), Intent(Out) :: flux
    Real(8), Intent(In) :: nx, ny, nz
    !> }}}
    Real(8) :: sp, sm
    !> Calculate Wave speeds.
    Call mhd_hydro_calc_wave_speed_hlle(qp%MhdHydroVars, sp, &
                                        qm%MhdHydroVars, sm)
    !> Calculate Fluxes: [1], Eq. (10.20-10.21).
    If ( sp <= 0.0D0 ) Then
        flux = qp%F
    Else If ( sm >= 0.0D0 ) Then
        flux = qm%F
    Else
        flux = ( sp*qm%F - sm*qp%F + sp*sm*( qp%U - qm%U ) )/( sp - sm )
    End If
End Subroutine mhd_hydro_calc_flux_hlle3D
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_flux_hlle3D_mhd(nx, ny, nz, &
                                          qp, qm, flux)
    !> Calculate the HLLE Fluxes in 3D for the MHD Equations.
    !> [1] Eleuterio F. Toro,
    !>     "Riemann Solvers and Numerical Methods
    !>      for Fluid Dynamics" (Third Edition, 2009).
    !> {{{
    Type(MhdHydroVars3DMHD), Intent(In) :: qp, qm
    Real(8), Dimension(1:8), Intent(Out) :: flux
    Real(8), Intent(In) :: nx, ny, nz
    !> }}}
    Type(MhdHydroVars2D) :: qs
    Real(8) :: sp, sm
    !> Calculate Wave speeds.
    sp = Max(qp%Vn + qp%c_fms, qm%Vn + qm%c_fms)
    sm = Max(qp%Vn - qp%c_fms, qm%Vn - qm%c_fms)
    !> Calculate Fluxes: [1], Eq. (10.20-10.21).
    If ( sp < 0.0D0 ) Then
        flux = qp%F
    Else If ( sm > 0.0D0 ) Then
        flux = qm%F
    Else
        flux = ( sp*qm%F - sm*qp%F + sp*sm*( qp%U - qm%U ) )/( sp - sm )
    End If
End Subroutine mhd_hydro_calc_flux_hlle3D_mhd
!########################################################################################################
!########################################################################################################
!########################################################################################################
End Module orchid_solver_hydro_flux_hlle

Module orchid_solver_hydro_flux_hllc
Use orchid_solver_params
Use orchid_solver_hydro_flux_godunov
Implicit None
Integer :: hllc_variation = 0
Type, Extends(MhdHydroFlux) :: MhdHydroFluxHLLC
    Contains
    Procedure, Public, NoPass, Non_Overridable :: &
        calc1D => mhd_hydro_calc_flux_hllc1D, &
        calc2D => mhd_hydro_calc_flux_hllc2D, &
        calc3D => mhd_hydro_calc_flux_hllc3D, &
        calc3D_mhd => mhd_hydro_calc_flux_hllc3D_mhd
End Type MhdHydroFluxHLLC
Contains
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_wave_speed_hllc(qp, sp, qm, sm)
    !> Calculate Pressure-based Wave speeds.
    !> REFERENCES:
    !> [1] Eleuterio F. Toro,
    !>     "Riemann Solvers and Numerical Methods
    !>      for Fluid Dynamics" (Third Edition, 2009).
    !> {{{
    Type(MhdHydroVars), Intent(In) :: qp, qm
    Real(8), Intent(Out) :: sp, sm
    !> }}}
    Real(8) :: Rho, c_snd, p
    Real(8) :: gp, gm
    !> [1], Eq. (10.61-10.62).
    Rho = 0.5D0*( qp%Rho + qm%Rho )
    c_snd = 0.5D0*( qp%c_snd + qm%c_snd )
    p = Max(0.5D0*( ( qp%p + qm%p ) - Rho*c_snd*( qp%Vn - qm%Vn ) ), 0.0D0)
    !> [1], Eq. (10.60).
    If ( p > qp%p ) Then
        gp = 1.0D0 + Gamma_2*( p/qp%p - 1.0D0 )
        gp = Sqrt(gp)
    Else
        gp = 1.0D0
    End If
    If ( p > qm%p ) Then
        gm = 1.0D0 + Gamma_2*( p/qm%p - 1.0D0 )
        gm = Sqrt(gm)
    Else
        gm = 1.0D0
    End If
    !> [1], Eq. (10.59).
    sp = qp%Vn + qp%c_snd*gp
    sm = qm%Vn - qm%c_snd*gm
    End Subroutine mhd_hydro_calc_wave_speed_hllc
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_flux_hllc1D(nx, &
                                      qp, qm, flux)
    !> Calculate the HLLC Fluxes in 1D.
    !> REFERENCES:
    !> [1] Eleuterio F. Toro,
    !>     "Riemann Solvers and Numerical Methods
    !>      for Fluid Dynamics" (Third Edition, 2009).
    !> {{{
    Type(MhdHydroVars1D), Intent(In) :: qp, qm
    Real(8), Dimension(1:3), Intent(Out) :: flux
    Real(8), Intent(In) :: nx
    !> }}}
    Type(MhdHydroVars1D) :: qs
    Real(8), Dimension(1:3) :: ds
    Real(8) :: sp, &
               sm, ps, ss
    !> Calculate Wave speeds.
    Call mhd_hydro_calc_wave_speed_hllc(qp%MhdHydroVars, sp, &
                                        qm%MhdHydroVars, sm)
    !> Calculate Fluxes: [1], Eq. (10.26).
    If ( sp < 0.0D0 ) Then
        flux = qp%F
    Else If ( sm > 0.0D0 ) Then
        flux = qm%F
    Else
        !> [1], Eq. (10.37).
        ss = qm%Rho*qm%Vn*( sm - qm%Vn ) - qm%p
        ss = qp%Rho*qp%Vn*( sp - qp%Vn ) - qp%p - ss
        ss = ss/( qp%Rho*( sp - qp%Vn ) - qm%Rho*( sm - qm%Vn ) )
        Select Case ( hllc_variation )
        Case Default
            !> Original HLLC: [1], Eq. (10.38), (10.39).
            If ( ss <= 0.0D0 .AND. 0.0D0 <= sp ) Then
                qs%Rho = qp%Rho*( sp - qp%Vn )/( sp - ss )
                qs%nrg = qp%nrg + ( ss - qp%Vn )*( ss + qp%p/qp%Rho/( sp - ss ) )
                qs%Vx  = qp%Vx - nx*( qp%Vn - ss )
                qs%U(:) = [ qs%rho, &
                            qs%rho*qs%nrg, &
                            qs%rho*qs%Vx ]
                flux = qp%F + sp*( qs%U - qp%U )
            Else If ( sm <= 0.0D0 .AND. 0.0D0 <= ss ) Then
                qs%Rho = qm%Rho*( sm - qm%Vn )/( sm - ss )
                qs%nrg = qm%nrg + ( ss - qm%Vn )*( ss + qm%p/qm%Rho/( sm - ss ) )
                qs%Vx  = qm%Vx - nx*( qm%Vn - ss )
                qs%U(:) = [ qs%rho, &
                            qs%rho*qs%nrg, &
                            qs%rho*qs%Vx ]
                flux = qm%F + sm*( qs%U - qm%U )
            End If
        Case ( 1 )
            !> Variation 1 of HLLC: [1], Eq. (10.40), (10.41).
            ds = [ 0.0D0, ss, nx ]
            If ( ss <= 0.0D0 .AND. 0.0D0 <= sp ) Then
                flux = ss*( sp*qp%U - qp%F )
                flux = sp*( qp%p + qp%Rho*( sp - qp%Vn )*( ss - qp%Vn ) )*ds + flux
                flux = flux/( sp - ss )
            Else If ( sm <= 0.0D0 .AND. 0.0D0 <= ss ) Then
                flux = ss*( sm*qm%U - qm%F )
                flux = sm*( qm%p + qm%Rho*( sm - qm%Vn )*( ss - qm%Vn ) )*ds + flux
                flux = flux/( sm - ss )
            End If
        Case ( 2 )
            !> Variation 2 of HLLC: [1], Eq. (10.40), (10.42), (10.44).
            ds = [ 0.0D0, ss, nx ]
            ps = qp%p + qp%Rho*( sp - qp%Vn )*( ss - qp%Vn )
            ps = qm%p + qm%Rho*( sm - qm%Vn )*( ss - qm%Vn ) + ps
            ps = 0.5D0*ps
            If ( ss <= 0.0D0 .AND. 0.0D0 <= sp ) Then
                flux = ( ss*( sp*qp%U - qp%F ) + sp*ps*ds )/( sp - ss )
            Else If ( sm <= 0.0D0 .AND. 0.0D0 <= ss ) Then
                flux = ( ss*( sm*qm%U - qm%F ) + sm*ps*ds )/( sm - ss )
            End If
        End Select
    End If
End Subroutine mhd_hydro_calc_flux_hllc1D
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_flux_hllc2D(nx, ny, &
                                      qp, qm, flux)
    !> Calculate the HLLC Fluxes in 2D.
    !> REFERENCES:
    !> [1] Eleuterio F. Toro,
    !>     "Riemann Solvers and Numerical Methods
    !>      for Fluid Dynamics" (Third Edition, 2009).
    !> {{{
    Type(MhdHydroVars2D), Intent(In) :: qp, qm
    Real(8), Dimension(1:4), Intent(Out) :: flux
    Real(8), Intent(In) :: nx, ny
    !> }}}
    Type(MhdHydroVars2D) :: qs
    Real(8), Dimension(1:4) :: ds
    Real(8) :: sp, &
               sm, ps, ss
    !> Calculate Wave speeds.
    Call mhd_hydro_calc_wave_speed_hllc(qp%MhdHydroVars, sp, &
                                        qm%MhdHydroVars, sm)
    !> Calculate Fluxes: [1], Eq. (10.26).
    If ( sp < 0.0D0 ) Then
        flux = qp%F
    Else If ( sm > 0.0D0 ) Then
        flux = qm%F
    Else
        !> [1], Eq. (10.37).
        ss = qm%Rho*qm%Vn*( sm - qm%Vn ) - qm%p
        ss = qp%Rho*qp%Vn*( sp - qp%Vn ) - qp%p - ss
        ss = ss/( qp%Rho*( sp - qp%Vn ) - qm%Rho*( sm - qm%Vn ) )
        Select Case ( hllc_variation )
        Case Default
            !> Original HLLC: [1], Eq. (10.38), (10.39).
            If ( ss <= 0.0D0 .AND. 0.0D0 <= sp ) Then
                qs%Rho = qp%Rho*( sp - qp%Vn )/( sp - ss )
                qs%nrg = qp%nrg + ( ss - qp%Vn )*( ss + qp%p/qp%Rho/( sp - ss ) )
                qs%Vx  = qp%Vx - nx*( qp%Vn - ss )
                qs%Vy  = qp%Vy - ny*( qp%Vn - ss )
                qs%U(:) = [ qs%rho, &
                            qs%rho*qs%nrg, &
                            qs%rho*qs%Vx, qs%rho*qs%Vy ]
                flux = qp%F + sp*( qs%U - qp%U )
            Else If ( sm <= 0.0D0 .AND. 0.0D0 <= ss ) Then
                qs%Rho = qm%Rho*( sm - qm%Vn )/( sm - ss )
                qs%nrg = qm%nrg + ( ss - qm%Vn )*( ss + qm%p/qm%Rho/( sm - ss ) )
                qs%Vx  = qm%Vx - nx*( qm%Vn - ss )
                qs%Vy  = qm%Vy - ny*( qm%Vn - ss )
                qs%U(:) = [ qs%rho, &
                            qs%rho*qs%nrg, &
                            qs%rho*qs%Vx, qs%rho*qs%Vy ]
                flux = qm%F + sm*( qs%U - qm%U )
            End If
        Case ( 1 )
            !> Variation 1 of HLLC: [1], Eq. (10.40), (10.41).
            ds = [ 0.0D0, ss, nx, ny ]
            If ( ss <= 0.0D0 .AND. 0.0D0 <= sp ) Then
                flux = ss*( sp*qp%U - qp%F )
                flux = sp*( qp%p + qp%Rho*( sp - qp%Vn )*( ss - qp%Vn ) )*ds + flux
                flux = flux/( sp - ss )
            Else If ( sm <= 0.0D0 .AND. 0.0D0 <= ss ) Then
                flux = ss*( sm*qm%U - qm%F )
                flux = sm*( qm%p + qm%Rho*( sm - qm%Vn )*( ss - qm%Vn ) )*ds + flux
                flux = flux/( sm - ss )
            End If
        Case ( 2 )
            !> Variation 2 of HLLC: [1], Eq. (10.40), (10.42), (10.44).
            ds = [ 0.0D0, ss, nx, ny ]
            ps = qp%p + qp%Rho*( sp - qp%Vn )*( ss - qp%Vn )
            ps = qm%p + qm%Rho*( sm - qm%Vn )*( ss - qm%Vn ) + ps
            ps = 0.5D0*ps
            If ( ss <= 0.0D0 .AND. 0.0D0 <= sp ) Then
                flux = ( ss*( sp*qp%U - qp%F ) + sp*ps*ds )/( sp - ss )
            Else If ( sm <= 0.0D0 .AND. 0.0D0 <= ss ) Then
                flux = ( ss*( sm*qm%U - qm%F ) + sm*ps*ds )/( sm - ss )
            End If
        End Select
    End If
End Subroutine mhd_hydro_calc_flux_hllc2D
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_flux_hllc3D(nx, ny, nz, &
                                      qp, qm, flux)
    !> Calculate the HLLC Fluxes in 3D.
    !> REFERENCES:
    !> [1] Eleuterio F. Toro,
    !>     "Riemann Solvers and Numerical Methods
    !>      for Fluid Dynamics" (Third Edition, 2009).
    !> {{{
    Type(MhdHydroVars3D), Intent(In) :: qp, qm
    Real(8), Dimension(1:5), Intent(Out) :: flux
    Real(8), Intent(In) :: nx, ny, nz
    !> }}}
    Type(MhdHydroVars3D) :: qs
    Real(8), Dimension(1:5) :: ds
    Real(8) :: sp, &
               sm, ps, ss
    !> Calculate Wave speeds.
    Call mhd_hydro_calc_wave_speed_hllc(qp%MhdHydroVars, sp, &
                                        qm%MhdHydroVars, sm)
    !> Calculate Fluxes: [1], Eq. (10.26).
    If ( sp < 0.0D0 ) Then
        flux = qp%F
    Else If ( sm > 0.0D0 ) Then
        flux = qm%F
    Else
        !> [1], Eq. (10.37).
        ss = qm%Rho*qm%Vn*( sm - qm%Vn ) - qm%p
        ss = qp%Rho*qp%Vn*( sp - qp%Vn ) - qp%p - ss
        ss = ss/( qp%Rho*( sp - qp%Vn ) - qm%Rho*( sm - qm%Vn ) )
        Select Case ( hllc_variation )
        Case Default
            !> Original HLLC: [1], Eq. (10.38), (10.39).
            If ( ss <= 0.0D0 .AND. 0.0D0 <= sp ) Then
                qs%Rho = qp%Rho*( sp - qp%Vn )/( sp - ss )
                qs%nrg = qp%nrg + ( ss - qp%Vn )*( ss + qp%p/qp%Rho/( sp - ss ) )
                qs%Vx  = qp%Vx - nx*( qp%Vn - ss )
                qs%Vy  = qp%Vy - ny*( qp%Vn - ss )
                qs%Vz  = qp%Vz - nz*( qp%Vn - ss )
                qs%U(:) = [ qs%rho, &
                            qs%rho*qs%nrg, &
                            qs%rho*qs%Vx, qs%rho*qs%Vy, qs%rho*qs%Vz ]
                flux = qp%F + sp*( qs%U - qp%U )
            Else If ( sm <= 0.0D0 .AND. 0.0D0 <= ss ) Then
                qs%Rho = qm%Rho*( sm - qm%Vn )/( sm - ss )
                qs%nrg = qm%nrg + ( ss - qm%Vn )*( ss + qm%p/qm%Rho/( sm - ss ) )
                qs%Vx  = qm%Vx - nx*( qm%Vn - ss )
                qs%Vy  = qm%Vy - ny*( qm%Vn - ss )
                qs%Vz  = qm%Vz - nz*( qm%Vn - ss )
                qs%U(:) = [ qs%rho, &
                            qs%rho*qs%nrg, &
                            qs%rho*qs%Vx, qs%rho*qs%Vy, qs%rho*qs%Vz ]
                flux = qm%F + sm*( qs%U - qm%U )
            End If
        Case ( 1 )
            !> Variation 1 of HLLC: [1], Eq. (10.40), (10.41).
            ds = [ 0.0D0, ss, nx, ny, nz ]
            If ( ss <= 0.0D0 .AND. 0.0D0 <= sp ) Then
                flux = ss*( sp*qp%U - qp%F )
                flux = sp*( qp%p + qp%Rho*( sp - qp%Vn )*( ss - qp%Vn ) )*ds + flux
                flux = flux/( sp - ss )
            Else If ( sm <= 0.0D0 .AND. 0.0D0 <= ss ) Then
                flux = ss*( sm*qm%U - qm%F )
                flux = sm*( qm%p + qm%Rho*( sm - qm%Vn )*( ss - qm%Vn ) )*ds + flux
                flux = flux/( sm - ss )
            End If
        Case ( 2 )
            !> Variation 2 of HLLC: [1], Eq. (10.40), (10.42), (10.44).
            ds = [ 0.0D0, ss, nx, ny, nz ]
            ps = qp%p + qp%Rho*( sp - qp%Vn )*( ss - qp%Vn )
            ps = qm%p + qm%Rho*( sm - qm%Vn )*( ss - qm%Vn ) + ps
            ps = 0.5D0*ps
            If ( ss <= 0.0D0 .AND. 0.0D0 <= sp ) Then
                flux = ( ss*( sp*qp%U - qp%F ) + sp*ps*ds )/( sp - ss )
            Else If ( sm <= 0.0D0 .AND. 0.0D0 <= ss ) Then
                flux = ( ss*( sm*qm%U - qm%F ) + sm*ps*ds )/( sm - ss )
            End If
        End Select
    End If
End Subroutine mhd_hydro_calc_flux_hllc3D
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_flux_hllc3D_mhd(nx, ny, nz, &
                                          qp, qm, flux)
    !> Calculate the HLLC Fluxes in 3D for the MHD Equations.
    !> REFERENCES:
    !> [1] Shengtai Li,
    !>     "An HLLC Riemann Solver for Magnetohydrodynamics" (2003).
    !> [2] Takahiro Miyoshi & Kanya Kusano,
    !>     "A multi-state HLL approximate Riemann solver for
    !>      ideal Magnetohydrodynamics" (2005).
    !> {{{
    Type(MhdHydroVars3DMHD), Intent(In) :: qp, qm
    Real(8), Dimension(1:8), Intent(Out) :: flux
    Real(8), Intent(In) :: nx, ny, nz
    !> }}}
    Type(MhdHydroVars3DMHD) :: qs
    Real(8) :: gp, sp, &
               gm, sm, ps, ss
    !> Calculate Wave speeds: [2], Eq. (67).
    sp = Max(qp%Vn, qm%Vn) + Max(qp%c_fms, qm%c_fms)
    sm = Min(qp%Vn, qm%Vn) - Max(qp%c_fms, qm%c_fms)
    !> Calculate Fluxes: [1], Eq (32).
    If ( sp < 0.0D0 ) Then
        flux = qp%F
    Else If ( sm > 0.0D0 ) Then
        flux = qm%F
    Else
        !> [1], Eq. (14).
        ss = qm%Rho*qm%Vn*( sm - qm%Vn ) - qm%p_tot
        ss = qp%Rho*qp%Vn*( sp - qp%Vn ) - qp%p_tot - ss
        ss = ss/( qp%Rho*( sp - qp%Vn ) - qm%Rho*( sm - qm%Vn ) )
        !> Calculate HLL average state: [1], Eq (2), (28), (33).
        qs%U = ( ( sp*qp%U - qp%F ) - ( sm*qm%U - qm%F ) )/( sp - sm )
        qs%Rho = qs%U(1)
        qs%Vx  = qs%U(3)/qs%Rho
        qs%Vy  = qs%U(4)/qs%Rho
        qs%Vz  = qs%U(5)/qs%Rho
        qs%Bx  = qs%U(6)*0.5D0/Sqrt(Pi)
        qs%By  = qs%U(7)*0.5D0/Sqrt(Pi)
        qs%Bz  = qs%U(8)*0.5D0/Sqrt(Pi)
        qs%Bn  = qs%Bx*nx + qs%By*ny + qs%Bz*nz
        qs%BV  = qs%Bx*qs%Vx + qs%By*qs%Vy + qs%Bz*qs%Vz
        If ( ss <= 0.0D0 .AND. 0.0D0 <= sp ) Then
            !> Select Fp*: [1], Eq (17), (19-23), (31-32).
            ps = qp%p_tot + qp%Rho*( sp - qp%Vn )*( ss - qp%Vn )
            ps = qs%Bn**2 - qp%Bn**2 + ps
            gp = qp%Rho*( sp - qp%Vn )
            qs%Rho = gp/( sp - ss )
            qs%nrg = qp%nrg + ( ( ps*ss - qp%p_tot*qp%Vn ) - ( qs%Bn*qs%BV - qp%Bn*qp%BV ) )/gp
            qs%Vx  = qp%Vx - nx*( qp%Vn - ss ) - ( qs%Bn*qs%Bx - qp%Bn*qp%Bx )/gp
            qs%Vy  = qp%Vy - ny*( qp%Vn - ss ) - ( qs%Bn*qs%By - qp%Bn*qp%By )/gp
            qs%Vz  = qp%Vz - nz*( qp%Vn - ss ) - ( qs%Bn*qs%Bz - qp%Bn*qp%Bz )/gp
            qs%U(:) = [ qs%Rho, &
                        qs%Rho*qs%nrg, &
                        qs%Rho*qs%Vx, qs%Rho*qs%Vy, qs%Rho*qs%Vz, &
                        [ qs%Bx, qs%By, qs%Bz ]*2.0D0*Sqrt(Pi) ]
            flux = qp%F + sp*( qs%U - qp%U )
        Else If ( sm <= 0.0D0 .AND. 0.0D0 <= ss ) Then
            !> Select Fm*: [1], Eq (17), (19-23), (31-32).
            ps = qm%p_tot + qm%Rho*( sp - qm%Vn )*( ss - qm%Vn )
            ps = qs%Bn**2 - qm%Bn**2 + ps
            gm = qm%Rho*( sm - qm%Vn )
            qs%Rho = gm/( sm - ss )
            qs%nrg = qm%nrg + ( ( ps*ss - qm%p_tot*qm%Vn ) - ( qs%Bn*qs%BV - qm%Bn*qm%BV ) )/gm
            qs%Vx  = qm%Vx - nx*( qm%Vn - ss ) - ( qs%Bn*qs%Bx - qm%Bn*qm%Bx )/gm
            qs%Vy  = qm%Vy - ny*( qm%Vn - ss ) - ( qs%Bn*qs%By - qm%Bn*qm%By )/gm
            qs%Vz  = qm%Vz - nz*( qm%Vn - ss ) - ( qs%Bn*qs%Bz - qm%Bn*qm%Bz )/gm
            qs%U(:) = [ qs%Rho, &
                        qs%Rho*qs%nrg, &
                        qs%Rho*qs%Vx, qs%Rho*qs%Vy, qs%Rho*qs%Vz, &
                        [ qs%Bx, qs%By, qs%Bz ]*2.0D0*Sqrt(Pi) ]
            flux = qm%F + sm*( qs%U - qm%U )
        End If
    End If
End Subroutine mhd_hydro_calc_flux_hllc3D_mhd
!########################################################################################################
!########################################################################################################
!########################################################################################################
End Module orchid_solver_hydro_flux_hllc

Module orchid_solver_hydro_flux_hlld
Use orchid_solver_params
Use orchid_solver_hydro_flux_hllc
Implicit None
Type, Extends(MhdHydroFlux) :: MhdHydroFluxHLLD
    Contains
    Procedure, Public, NoPass, Non_Overridable :: &
        calc3D_mhd => mhd_hydro_calc_flux_hlld3D_mhd
End Type MhdHydroFluxHLLD
Contains
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_flux_hlld3D_mhd(nx, ny, nz, &
                                          qp, qm, flux)
    !> Calculate the HLLD Fluxes in 3D for the MHD Equations.
    !> REFERENCES:
    !> [1] Shengtai Li,
    !>     "An HLLC Riemann Solver for Magnetohydrodynamics" (2003).
    !> [2] Takahiro Miyoshi & Kanya Kusano,
    !>     "A multi-state HLL approximate Riemann solver for
    !>      ideal Magnetohydrodynamics" (2005).
    !> {{{
    Type(MhdHydroVars3DMHD), Intent(In) :: qp, qm
    Real(8), Dimension(1:8), Intent(Out) :: flux
    Real(8), Intent(In) :: nx, ny, nz
    !> }}}
    Type(MhdHydroVars3DMHD) :: qs, qps, qms
    Real(8) :: gp, sp, dp, ssp, rp, &
               gm, sm, dm, ssm, rm, ir, ps, ss, sgn, sgnr, ds
    !> Calculate Wave speeds: [2], Eq. (67).
    sp = Max(qp%Vn, qm%Vn) + Max(qp%c_fms, qm%c_fms)
    sm = Min(qp%Vn, qm%Vn) - Max(qp%c_fms, qm%c_fms)
    !> Calculate Fluxes: [2], Eq. (66).
    If ( sp < 0.0D0 ) Then
        flux = qp%F
    Else If ( sm > 0.0D0 ) Then
        flux = qm%F
    Else
        !> [2], Eq (38).
        ss = qm%Rho*qm%Vn*( sm - qm%Vn ) - qm%p_tot
        ss = qp%Rho*qp%Vn*( sp - qp%Vn ) - qp%p_tot - ss
        ss = ss/( qp%Rho*( sp - qp%Vn ) - qm%Rho*( sm - qm%Vn ) )
        !> [2], Eq (41).
        ps = qm%Rho*qp%p_tot*( sm - qm%Vn )
        ps = qp%Rho*qm%p_tot*( sp - qp%Vn ) - ps
        ps = qp%Rho*qm%Rho*( sp - qp%Vn )*( sm - qm%Vn )*( qp%Vn - qm%Vn ) + ps
        ps = ps/( qp%Rho*( sp - qp%Vn ) - qm%Rho*( sm - qm%Vn ) )
        !> Calculate Fp*: [2], Eq (43-47).
        gp = ( qp%Rho*( sp - qp%Vn )*( sp - ss ) - qp%Bn**2 )
        If ( Abs(gp) > 0.0D0  ) Then
            dp = ( qp%Rho*( sp - qp%Vn )**2 - qp%Bn**2 )/gp
            gp = ( ss - qp%Vn )/gp
            qps%Vx = qp%Vx - nx*( qp%Vn - ss ) - qp%Bn*gp*( qp%Bx - qp%Bn*nx  )
            qps%Vy = qp%Vy - ny*( qp%Vn - ss ) - qp%Bn*gp*( qp%By - qp%Bn*ny  )
            qps%Vz = qp%Vz - nz*( qp%Vn - ss ) - qp%Bn*gp*( qp%Bz - qp%Bn*nz  )
            qps%Bx = qp%Bx*dp - qp%Bn*( dp - 1.0D0 )*nx
            qps%By = qp%By*dp - qp%Bn*( dp - 1.0D0 )*ny
            qps%Bz = qp%Bz*dp - qp%Bn*( dp - 1.0D0 )*nz
        Else
            !> Prevent 0/0 operations.
            qps%Vx = qp%Vx - nx*( qp%Vn - ss )
            qps%Vy = qp%Vy - ny*( qp%Vn - ss )
            qps%Vz = qp%Vz - nz*( qp%Vn - ss )
            qps%Bx = qp%Bx
            qps%By = qp%By
            qps%Bz = qp%Bz
        End If
        qps%Rho = qp%Rho*( sp - qp%Vn )/( sp - ss )
        qps%BV  = qps%Bx*qps%Vx + qps%By*qps%Vy + qps%Bz*qps%Vz
        qps%nrg = qp%Rho*qp%nrg*( sp - qp%Vn ) + ( ps*ss - qp%p_tot*qp%Vn )
        qps%nrg = qps%nrg - qp%Bn*( qps%BV - qp%BV )
        qps%nrg = qps%nrg/( sp - ss )
        qps%U(:) = [ qps%Rho, qps%nrg, &
                     qps%Rho*qps%Vx, qps%Rho*qps%Vy, qps%Rho*qps%Vz, &
                     [ qps%Bx, qps%By, qps%Bz ]*2.0D0*Sqrt(Pi) ]
        !> Calculate Fm*: [2], Eq (43-47).
        gm = ( qm%Rho*( sm - qm%Vn )*( sm - ss ) - qm%Bn**2 )
        If ( Abs(gm) > 0.0D0 ) Then
            dm = ( qm%Rho*( sm - qm%Vn )**2 - qm%Bn**2 )/gm
            gm = ( ss - qm%Vn )/gm
            qms%Vx = qm%Vx - nx*( qm%Vn - ss ) - qm%Bn*gm*( qm%Bx - qm%Bn*nx  )
            qms%Vy = qm%Vy - ny*( qm%Vn - ss ) - qm%Bn*gm*( qm%By - qm%Bn*ny  )
            qms%Vz = qm%Vz - nz*( qm%Vn - ss ) - qm%Bn*gm*( qm%Bz - qm%Bn*nz  )
            qms%Bx = qm%Bx*dm - qm%Bn*( dm - 1.0D0 )*nx
            qms%By = qm%By*dm - qm%Bn*( dm - 1.0D0 )*ny
            qms%Bz = qm%Bz*dm - qm%Bn*( dm - 1.0D0 )*nz
        Else
            !> Prevent 0/0 operations.
            qms%Vx = qm%Vx
            qms%Vy = qm%Vy
            qms%Vz = qm%Vz
            qms%Bx = qm%Bx
            qms%By = qm%By
            qms%Bz = qm%Bz
        End If
        qms%Rho = qm%Rho*( sm - qm%Vn )/( sm - ss )
        qms%BV  = qms%Bx*qms%Vx + qms%By*qms%Vy + qms%Bz*qms%Vz
        qms%nrg = qm%Rho*qm%nrg*( sm - qm%Vn ) + ( ps*ss - qm%p_tot*qm%Vn )
        qms%nrg = qms%nrg - qm%Bn*( qms%BV - qm%BV )
        qms%nrg = qms%nrg/( sm - ss )
        qms%U(:) = [ qms%Rho, qms%nrg, &
                     qms%Rho*qms%Vx, qms%Rho*qms%Vy, qms%Rho*qms%Vz, &
                     [ qms%Bx, qms%By, qms%Bz ]*2.0D0*Sqrt(Pi) ]
        rp = Sqrt(qps%Rho)
        rm = Sqrt(qms%Rho)
        ir = 1.0D0/( rp + rm )
        If ( ss <= 0.0D0 .AND. 0.0D0 <= sp ) Then
            !> [2], Eq. (51).
            ssp = ss + Abs(qp%Bn)/rp
            If ( ssp <= 0.0D0 .AND. 0.0D0 <= sp ) Then
                !> Select Fp*: [2], Eq. (64).
                flux = qp%F + sp*( qps%U - qp%U )
            Else If ( ss <= 0.0D0 .AND. 0.0D0 <= ssp ) Then
                !> Select Fp**: [2], Eq (49), (59-63).
                sgn = Merge(Sign(1.0D0, qp%Bn), 0.0D0, qp%Bn /= 0.0D0)
                sgnr = sgn*rp*rm
                qs%Rho = qps%Rho
                qs%Vx  = ( rp*qps%Vx + rm*qms%Vx + sgn*( qps%Bx - qms%Bx ) )*ir
                qs%Vy  = ( rp*qps%Vy + rm*qms%Vy + sgn*( qps%By - qms%By ) )*ir
                qs%Vz  = ( rp*qps%Vz + rm*qms%Vz + sgn*( qps%Bz - qms%Bz ) )*ir
                qs%Bx  = ( rp*qps%Bx + rm*qms%Bx + sgnr*( qps%Vx - qms%Vx ) )*ir
                qs%By  = ( rp*qps%By + rm*qms%By + sgnr*( qps%Vy - qms%Vy ) )*ir
                qs%Bz  = ( rp*qps%Bz + rm*qms%Bz + sgnr*( qps%Vz - qms%Vz ) )*ir
                qs%BV  = qs%Bx*qs%Vx + qs%By*qs%Vy + qs%Bz*qs%Vz
                qs%nrg = qps%nrg + rp*sgn*( qps%BV - qs%BV )
                qs%U(:) = [ qs%Rho, qs%nrg, &
                            qs%Rho*qs%Vx, qs%Rho*qs%Vy, qs%Rho*qs%Vz, &
                            [ qs%Bx, qs%By, qs%Bz ]*2.0D0*Sqrt(Pi) ]
                !> [2], Eq. (65).
                flux = qp%F + ssp*qs%U - ( ssp - sp )*qps%U - sp*qp%U
            End If
        Else If ( sm <= 0.0D0 .AND. 0.0D0 <= ss ) Then
            !> [2], Eq. (51).
            ssm = ss - Abs(qm%Bn)/rm
            If ( sm <= 0.0D0 .AND. 0.0D0 <= ssm ) Then
                !> Select Fm*: [2], Eq. (64).
                flux = qm%F + sm*( qms%U - qm%U )
            Else If ( ssm <= 0.0D0 .AND. 0.0D0 <= ss ) Then
                !> Select Fm**: [2], Eq (49), (59-63).
                sgn = Merge(Sign(1.0D0, qm%Bn), 0.0D0, qm%Bn /= 0.0D0)
                sgnr = sgn*rp*rm
                qs%Rho = qms%Rho
                qs%Vx  = ( rp*qps%Vx + rm*qms%Vx + sgn*( qps%Bx - qms%Bx ) )*ir
                qs%Vy  = ( rp*qps%Vy + rm*qms%Vy + sgn*( qps%By - qms%By ) )*ir
                qs%Vz  = ( rp*qps%Vz + rm*qms%Vz + sgn*( qps%Bz - qms%Bz ) )*ir
                qs%Bx  = ( rp*qps%Bx + rm*qms%Bx + sgnr*( qps%Vx - qms%Vx ) )*ir
                qs%By  = ( rp*qps%By + rm*qms%By + sgnr*( qps%Vy - qms%Vy ) )*ir
                qs%Bz  = ( rp*qps%Bz + rm*qms%Bz + sgnr*( qps%Vz - qms%Vz ) )*ir
                qs%BV  = qs%Bx*qs%Vx + qs%By*qs%Vy + qs%Bz*qs%Vz
                qs%nrg = qms%nrg - rm*sgn*( qms%BV - qs%BV )
                qs%U(:) = [ qs%Rho, qs%nrg, &
                            qs%Rho*qs%Vx, qs%Rho*qs%Vy, qs%Rho*qs%Vz, &
                            [ qs%Bx, qs%By, qs%Bz ]*2.0D0*Sqrt(Pi) ]
                !> [2], Eq. (65).
                flux = qm%F + ssm*qs%U - ( ssm - sm )*qms%U - sm*qm%U
            End If
        End If
    End If
End Subroutine mhd_hydro_calc_flux_hlld3D_mhd
!########################################################################################################
!########################################################################################################
!########################################################################################################
End Module orchid_solver_hydro_flux_hlld


!    .................................................
        subroutine Rsq_ME(r2)
!    .................................................

        USE VAPHFB_PAR
        implicit real*8 (a-h,o-z)
        double precision rnla

        DIMENSION r2(HO%NLEV,HO%NLEV)
!initializing
        b2=HO%b_osc**2
        do ia=1,HO%NLEV
        do ib=1,HO%NLEV
           r2(ib,ia)=zero
        end do
        end do

        do ia=1,HO%NLEV
         jnla=tnljm%n(ia) ! nlindex(ia)
	 jla =tnljm%l(ia) ! lang(ia)
	 jja =tnljm%twoj(ia) ! jang(ia)
	 jma =tnljm%twom(ia) ! mjang(ia)
	 jta =tnljm%t(ia)    ! mtisos(ia)
         do ib=1,HO%NLEV
         jnlb=tnljm%n(ib) ! nlindex(ib)
         jlb =tnljm%l(ib) ! lang(ib)
         jjb =tnljm%twoj(ib) ! jang(ib)
         jmb =tnljm%twom(ib) ! mjang(ib)
         jtb =tnljm%t(ib)    ! mtisos(ib)

         if (jja.eq.jjb .and. jma.eq.jmb .and. jta.eq.jtb) then
           r2(ia,ib) = b2*rnla(jnla,jla,2,jnlb,jlb)
         endif

         end do
        end do
        end subroutine


c*************************************************************************
c                            UTIL_HILLS.F
c*************************************************************************
c This subroutine calculates the hill's sphere for the planets
c
c             Input:
c                 nbod          ==>  number of massive bodies (int scalar)
c                 mass          ==>  mass of bodies (real array)
c                 xh,yh,zh      ==>  initial position in helio coord
c                                    (real arrays)
c                 vxh,vyh,vzh   ==>  initial velocity in helio coord
c                                    (real arrays)
c             Output:
c                  r2hill       ==>  the SQUARE of the planet's hill's sphere
c                                    (real array)
c
c
c Remarks:
c Authors:  Hal Levison
c Date:    2/19/93
c Last revision: 1/6/97

      subroutine util_hills(nbod,mass,xh,yh,zh,vxh,vyh,vzh,r2hill)

      include '../swift.inc'

c...  Inputs:
      integer nbod
      real*8 mass(nbod),xh(nbod),yh(nbod),zh(nbod)
      real*8 vxh(nbod),vyh(nbod),vzh(nbod)

c...  Outputs
      real*8 r2hill(nbod)

c...  Internals
      integer i
      real*8 mu,energy,ap,rhil,r,v2

c-----
c...  Executable code

      do i=2,nbod
         if(mass(i).ne.0.0d0) then
            mu = mass(1)*mass(i)/(mass(1)+mass(i))
            r = sqrt( xh(i)*xh(i) + yh(i)*yh(i) + zh(i)*zh(i) )
            v2 =  vxh(i)*vxh(i) + vyh(i)*vyh(i) + vzh(i)*vzh(i)
            energy =-1.0d0*mass(1)*mass(i)/r + 0.5*mu*v2
            ap = -1.0d0*mass(1)*mass(i)/(2.0d0*energy)
            rhil = ap * (((mu/mass(1))/3.0)**(0.3333333333d0))
            r2hill(i) = rhil*rhil
         else
            r2hill(i) = 0.0d0
         endif
      enddo

      r2hill(1) = 0.0

      return
      end                       ! util_hills

c---------------------------------------------------


c*************************************************************************
c                        SYMBA4_HELIO_GETACCH.F
c*************************************************************************
c This subroutine calculates the acceleration on the massive particles
c in the HELIOCENTRIC frame.
c             Input:
c                 nbod        ==>  number of massive bodies (int scalor)
c                 nbodm       ==>  The last massive particle
c                                  (int scalor)
c                 mass        ==>  mass of bodies (real array)
c                 j2rp2,j4rp4   ==>  J2*radii_pl^2 and  J4*radii_pl^4
c                                     (real scalars)
c                 xh,yh,zh    ==>  position in heliocentric coord (real arrays)
c             Output:
c                 axh,ayh,azh ==>  acceleration in helio coord (real arrays)
c
c Remarks Based on helio_getacch.f
c Author:  Hal Levison
c Date:    3/20/97
c Last revision:

      subroutine symba4_helio_getacch(nbod,nbodm,mass,j2rp2,
     &     j4rp4,xh,yh,zh,axh,ayh,azh)

      include '../swift.inc'

c...  Inputs:
      integer nbod,nbodm
      real*8 mass(nbod),j2rp2,j4rp4
      real*8 xh(nbod),yh(nbod),zh(nbod)

c...  Outputs:
      real*8 axh(nbod),ayh(nbod),azh(nbod)

c...  Internals:
      integer i,j
      real*8 aoblx(NTPMAX),aobly(NTPMAX),aoblz(NTPMAX)
      real*8 ir3h(NTPMAX),irh(NTPMAX)
      real*8 dx,dy,dz,rji2,faci,facj,irij3

c----
c...  Executable code

      do i=1,nbod
         axh(i) = 0.0
         ayh(i) = 0.0
         azh(i) = 0.0
      enddo

c...  now the third terms
      do i=2,nbodm
         do j=i+1,nbod

             dx = xh(j) - xh(i)
             dy = yh(j) - yh(i)
             dz = zh(j) - zh(i)
             rji2 = dx*dx + dy*dy + dz*dz

             irij3 = 1.0d0/(rji2*sqrt(rji2))
             faci = mass(i)*irij3
             facj = mass(j)*irij3

             axh(j) = axh(j) - faci*dx
             ayh(j) = ayh(j) - faci*dy
             azh(j) = azh(j) - faci*dz

             axh(i) = axh(i) + facj*dx
             ayh(i) = ayh(i) + facj*dy
             azh(i) = azh(i) + facj*dz

         enddo
      enddo

c...  Now do j2 and j4 stuff
      if(j2rp2.ne.0.0d0) then
         call getacch_ir3(nbod,2,xh,yh,zh,ir3h,irh)
         call obl_acc(nbod,mass,j2rp2,j4rp4,xh,yh,zh,irh,
     &        aoblx,aobly,aoblz)
         do i = 2,nbod
            axh(i) = axh(i) + aoblx(i) - aoblx(1)
            ayh(i) = ayh(i) + aobly(i) - aobly(1)
            azh(i) = azh(i) + aoblz(i) - aoblz(1)
         enddo
      endif

      return
      end      ! symba4_helio_getacch

c---------------------------------------------------------------------


      double precision function dpowint(xlow,xhigh,ylow,yhigh,xval,pow)
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 Power interpolate the value of y between (xlow,ylow) and (xhigh,yhigh)
c                 for a value of x and a power pow.
c
c-----------------------------------------------------------------------
      implicit real*8 (a-h,o-z)

      parameter(EPSLON=1.0e-20)

      if((xhigh-xlow).lt.EPSLON) then
            dpowint = (yhigh+ylow)/2.0
      else
            dpowint = ylow + (yhigh-ylow)*
     +                (((xval-xlow)/(xhigh-xlow))**pow)
      end if

      return
      end


Module Time_setting
implicit NONE

real,    parameter :: d_per_s = 864d2  ! how many seconds in one day
real,    parameter :: s_per_h = 3600d0 ! how many seconds in one hour
integer, parameter :: h_per_d = 24     ! how many hours in one day
integer, parameter :: y_per_d = 365    ! how many days of one year
integer            :: NDay_Run= 365    !Total number of days for simulation

!Time of the day
integer  :: sec_of_day   = 0
integer  :: current_day  = 0
integer  :: current_DOY  = 0
integer  :: current_hour = 0
integer  :: current_year = 0
real       :: current_sec  = 0.d0

!The current step
integer  :: it           = 0

!Total number of time steps
integer  :: Nstep        = 0

!Timestep as a fraction of the day
real     :: dtdays       = 0.d0

!Timestep as seconds
real     :: dtsec        = 0.d0

!Number of iterations to save. Save everyday (86400/dtsec); save every hour (3600/dtsec)
integer  :: nsave        = 0 !

CONTAINS

subroutine update_time
!This subroutine converts current time step to the current second, second of the day, current DOY etc.
implicit none

! Calculate current timing (zero is starting time):
current_sec = dble(it-1)*dtsec

! Calculate time of the day
sec_of_day = mod(nint(current_sec), nint(d_per_s))

! Calculate DOY
! Calculate model time in days:
current_day = int(current_sec/d_per_s) + 1

! Calculate current year
current_year= int(current_day/y_per_d) + 1

! Calculate DATE OF the YEAR (DOY)
Current_DOY = mod(current_day, y_per_d)

! Calculate current hour
current_hour= int(current_sec/s_per_h)
current_hour= mod(current_hour, h_per_d)

end subroutine
end module


SUBROUTINE h3kalk(k,omega,n,nl,rho,g,A33,B33,C33,L,Br,D,M,H3)
IMPLICIT NONE
!Erklærer variable og vektorer
INTEGER::n,nl,i,j
DOUBLE PRECISION,DIMENSION(1:n)::omega,k
REAL,DIMENSION(1:n,1:nl)::A33,B33
DOUBLE PRECISION,DIMENSION(1:n,1:nl)::eta3nevner,F3A1,F3A2,F3A
DOUBLE PRECISION,DIMENSION(1:n,1:nl)::eta3A,H3
REAL,DIMENSION(1:nl)::L,Br,D,M,C33
REAL rho,g,a,b

!Beregner integralene til kreftene i hiv, skriver kontroll til skjerm
DO i=1,n
   DO j=1,nl
      F3A1(i,j) = (2.0/k(i)) * SIN((k(i) * L(j)) / 2.0 )

      F3A2(i,j) = rho*g*Br(j)* EXP(- k(i)*D(j)) - (omega(i)**2) * (A33(i,j)/L(i,j)) * &
           EXP(- k(i)*D(j)/2.0)

      eta3nevner(i,j)= SQRT(  (C33(j) - (M(j)+A33(i,jy)) * omega(i)**2 )**2 + &
           (B33(i,j) * omega(i))**2  )

      F3A(i,j) = F3A1(i,j) * F3A2(i,j)
   END DO
END DO

!Beregner eta 3
DO i=1,n
   DO j=1,nl
      eta3A(i,j)=   F3A(i,j) / eta3nevner(i,j)
   END DO
END DO

!Beregner transfer-funksjoner
DO i=1,n
   DO j=1,nl
      H3(i,j)=ABS(eta3A(i,j))
   END DO
END DO

!Skriver resultatet til fil for sjekk/ plotting
OPEN(41,FILE="eta3plot.txt",ACTION="WRITE",STATUS="UNKNOWN")
DO i=1,n
   WRITE(41,*) omega(i),eta3A(i,1),eta3A(i,2)
END DO
CLOSE(41)

RETURN
END SUBROUTINE


      DOUBLE PRECISION FUNCTION dinvnr(p,q)
C**********************************************************************
C
C     DOUBLE PRECISION FUNCTION DINVNR(P,Q)
C     Double precision NoRmal distribution INVerse
C
C
C                              Function
C
C
C     Returns X  such that CUMNOR(X)  =   P,  i.e., the  integral from -
C     infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU is P
C
C
C                              Arguments
C
C
C     P --> The probability whose normal deviate is sought.
C                    P is DOUBLE PRECISION
C
C     Q --> 1-P
C                    P is DOUBLE PRECISION
C
C
C                              Method
C
C
C     The  rational   function   on  page 95    of Kennedy  and  Gentle,
C     Statistical Computing, Marcel Dekker, NY , 1980 is used as a start
C     value for the Newton method of finding roots.
C
C
C                              Note
C
C
C     If P or Q .lt. machine EPS returns +/- DINVNR(EPS)
C
C**********************************************************************
C     .. Parameters ..
      INTEGER maxit
      PARAMETER (maxit=100)
      DOUBLE PRECISION eps
      PARAMETER (eps=1.0D-13)
      DOUBLE PRECISION r2pi
      PARAMETER (r2pi=0.3989422804014326D0)
      DOUBLE PRECISION nhalf
      PARAMETER (nhalf=-0.5D0)
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION p,q
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION strtx,xcur,cum,ccum,pp,dx
      INTEGER i
      LOGICAL qporq
C     ..
C     .. External Functions ..
      DOUBLE PRECISION stvaln
      EXTERNAL stvaln
C     ..
C     .. External Subroutines ..
      EXTERNAL cumnor
C     ..
C     .. Statement Functions ..
      DOUBLE PRECISION dennor,x

      dennor(x) = r2pi*exp(nhalf*x*x)
C     ..
C     .. Executable Statements ..
C
C     FIND MINIMUM OF P AND Q
C
      qporq = p .LE. q
      IF (.NOT. (qporq)) THEN
        pp = q
      ELSE
        pp = p
      ENDIF
c
c DIGITEO - M. Baudin - 2010
c Patched for bug #8032.
c Avoid to enter in the zero-finder algorithm in trivial case.
c
      IF ( pp .EQ. 0.5d0 ) THEN
        dinvnr = 0.d0
        RETURN
      ENDIF
C
C     INITIALIZATION STEP
C
      strtx = stvaln(pp)
      xcur = strtx
C
C     NEWTON INTERATIONS
C
      DO 30,i = 1,maxit
          CALL cumnor(xcur,cum,ccum)
          dx = (cum-pp)/dennor(xcur)
          xcur = xcur - dx
          IF (abs(dx/xcur).LT.eps) GO TO 40
   30 CONTINUE
      dinvnr = strtx
C
C     IF WE GET HERE, NEWTON HAS FAILED
C
      IF (.NOT.qporq) dinvnr = -dinvnr
      RETURN
C
C     IF WE GET HERE, NEWTON HAS SUCCEDED
C
   40 dinvnr = xcur
      IF (.NOT.qporq) dinvnr = -dinvnr
      RETURN

      END


PROGRAM MAIN
    USE wrtmat_mod
    USE cgm_mod
    IMPLICIT NONE
    INTEGER(8)::m,n,i
    CHARACTER(80):: words
    REAL(8),ALLOCATABLE::A(:,:)
    REAL(8),ALLOCATABLE::b(:,:),x(:,:)
    !----------------------------------------
    ! read the input file and make the matrix
    OPEN(99,FILE='input')
    m=0
    n=0
    DO
        READ(99,'(A80)',END=100) words
        IF(words=='m =') READ(99,*) m
        IF(words=='n =') READ(99,*) n
        IF(m<20) THEN
            IF(words=='A =') then
                ALLOCATE(A(m,n))
                DO i=1,m
                    READ(99,*) A(i,1:n)
                END DO
            END IF
            IF(words=='bt=') then
                ALLOCATE(b(m,1))
                READ(99,*) b(1:m,1)
            END IF
        ELSE
    !------------------------------------------
    !define A and b according to the  P113-3.2
            ALLOCATE(A(m,m))
            A=0
            ALLOCATE(b(m,1))
            b=0

            A(1,1)  =-2
            A(1,2)  = 1
            A(m,m)  =-2
            A(m,m-1)= 1
            b(1,1)  =-1
            b(m,1)  =-1

            DO i=2,m-1
                A(i,i)=-2
                A(i,i+1)=1
                A(i,i-1)=1
            END DO
            EXIT
        END IF
    END DO
100 CLOSE(99)
    !----------------------------------------
    !----------------------------------------
    !do CGM,and write A,b,x in the output file
    OPEN(100,file='output')
    WRITE(*,*)'A='
    WRITE(100,*)'A='
    CALL wrtmat(A)
    WRITE(*,*)'b='
    WRITE(100,*)'b='
    CALL wrtmat(b)
    ALLOCATE(x(m,1))
    x=0
    CALL CGM(A,b,x)

    WRITE(*,*)'x='
    WRITE(100,*)'x='
    CALL wrtmat(x)
    CLOSE(100)
    !---------------------------------------
    DEALLOCATE(b)
    DEALLOCATE(A)
    DEALLOCATE(x)
END PROGRAM


C-----------------------------------------------------------------------
      SUBROUTINE GAUSSLAT(JMAX,SLAT,WLAT)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  GAUSSLAT   COMPUTE GAUSSIAN LATITUDES
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 92-04-16
C
C ABSTRACT: COMPUTES COSINES OF COLATITUDE AND GAUSSIAN WEIGHTS
C   ON THE GAUSSIAN LATITUDES.  THE GAUSSIAN LATITUDES ARE AT
C   THE ZEROES OF THE LEGENDRE POLYNOMIAL OF THE GIVEN ORDER.
C
C PROGRAM HISTORY LOG:
C   92-04-16  IREDELL
C   97-10-20  IREDELL  INCREASED PRECISION
C 1999-08-18  IREDELL  CALLED SPLAT
C
C USAGE:    CALL GAUSSLAT(JMAX,SLAT,WLAT)
C
C   INPUT ARGUMENT LIST:
C     JMAX     - INPUT NUMBER OF LATITUDES.
C
C   OUTPUT ARGUMENT LIST:
C     SLAT     - REAL (K) COSINES OF COLATITUDE.
C     WLAT     - REAL (K) GAUSSIAN WEIGHTS.
C
C SUBPROGRAMS CALLED:
C   SPLAT        COMPUTE LATITUDE FUNCTIONS
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C
C$$$
      IMPLICIT NONE
C
      INTEGER,           INTENT(IN   ) :: JMAX
      REAL,              INTENT(OUT  ) :: SLAT(JMAX),WLAT(JMAX)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      CALL SPLAT(4,JMAX,SLAT,WLAT)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      RETURN
      END


module mp_int
  use sll_m_constants
  use sll_m_boundary_condition_descriptors
  use sll_m_interpolators_2d_base
  use sll_m_cubic_spline_interpolator_2d
  use sll_m_cubic_splines
  use sll_m_poisson_2d_periodic
  use sll_m_poisson_2d_base, only: &
    sll_c_poisson_2d_base

  implicit none

contains

  subroutine interpolate_2d(N1, N2, data_in, &
       char_x1, char_x2, &
       data_exit, eta1_slopes, eta2_slopes)
    INTEGER(KIND=4), intent(in) :: N1, N2
    REAL(KIND=8), intent(in), dimension(:, :) :: char_x1
    REAL(KIND=8), intent(in), dimension(:, :) :: char_x2
    REAL(KIND=8), intent(in), dimension(:, :) :: data_in
    REAL(KIND=8) :: zero_var = 0.0
    REAL(KIND=8) :: one_var = 1.0
    REAL(KIND=8), dimension(2,N2) :: eta1_slopes
    REAL(KIND=8), dimension(2,N1) :: eta2_slopes
    REAL(KIND=8), intent(out), dimension(N1,N2) :: data_exit
    class(sll_c_interpolator_2d), pointer :: cs2d
    type(sll_t_cubic_spline_interpolator_2d), target    :: spline

    !-------------------------------------------------------
    !f2py INTEGER(KIND=4), intent(in,hide)  :: N1, N2
    !f2py REAL(KIND=8), intent(in), dimension(N1, N2) :: data_in
    !--------------------------------------------------------

    call spline%init(N1,N2, &
         zero_var, one_var, zero_var, one_var,&
         sll_p_hermite, sll_p_hermite, &
         eta1_min_slopes=eta1_slopes(1, :), &
         eta1_max_slopes=eta1_slopes(2, :), &
         eta2_min_slopes=eta2_slopes(1, :), &
         eta2_max_slopes=eta2_slopes(2, :))

    cs2d =>  spline

    call cs2d % interpolate_array(N1, N2, data_in, char_x1, char_x2, data_exit)

  end subroutine interpolate_2d

  subroutine alt_interpolate_2d(N1, N2, data_in, &
       char_x1, char_x2, &
       data_out, eta1_slopes, eta2_slopes)
    INTEGER(KIND=4), intent(in) :: N1, N2
    REAL(KIND=8), intent(in), dimension(:, :) :: char_x1
    REAL(KIND=8), intent(in), dimension(:, :) :: char_x2
    REAL(KIND=8), intent(in), dimension(:, :) :: data_in
    REAL(KIND=8), dimension(2,N2) :: eta1_slopes
    REAL(KIND=8), dimension(2,N1) :: eta2_slopes
    REAL(KIND=8), intent(out), dimension(N1,N2) :: data_out
    class(sll_c_interpolator_2d), pointer :: cs2d
    type(sll_t_cubic_spline_interpolator_2d), target    :: spline
    INTEGER(KIND=4) :: i, j
    REAL(KIND=8)    :: eta1
    REAL(KIND=8)    :: eta2
    REAL(KIND=8), dimension((N1+2)*(N2+2)) :: coeffs

    !-------------------------------------------------------
    !f2py INTEGER(KIND=4), intent(in,hide)  :: N1, N2
    !f2py REAL(KIND=8), intent(in), dimension(N1, N2) :: data_in
    !--------------------------------------------------------

    data_out(:,:) = 0.
    call spline%init(N1,N2, &
         0.0_8, 1.0_8, 0.0_8, 1.0_8,&
         sll_p_hermite, sll_p_hermite, &
         eta1_min_slopes=eta1_slopes(1, :), &
         eta1_max_slopes=eta1_slopes(2, :), &
         eta2_min_slopes=eta2_slopes(1, :), &
         eta2_max_slopes=eta2_slopes(2, :))

    cs2d =>  spline

    call cs2d%compute_interpolants(data_in)
    coeffs(:) = 0.d+0
    call sll_s_cubic_spline_2d_get_coeff(spline%spline, coeffs)

    do j=1,N2
       do i=1,N1
          eta1 = char_x1(i,j)
          eta2 = char_x2(i,j)
          data_out(i,j) = cs2d%interpolate_from_interpolant_value(eta1,eta2)
          if ((abs(data_out(i,j)).le.0.000000000001d+0)&
               .and.(abs(data_out(i,j)).gt. 0d+0)) then
             print *, "i, j, res =", i, j, data_out(i,j)
             print *, "x1, x2 =", eta1, eta2
             print *, "coefs ", coeffs
             print *, "slopes1 =", eta1_slopes
             print *, "slopes2 =", eta2_slopes
             STOP
          else
             print *, "i, j, res =", i, j, data_out(i,j), &
                  abs(data_out(i,j)).le.0.000000000001d+0, &
                  abs(data_out(i,j)).gt.0.d+0
          end if
       end do
    end do

  end subroutine alt_interpolate_2d

  subroutine interpolate_value(NPTS1, NPTS2, &
       xi1, xi2, data, eta1_slopes, eta2_slopes, res)
    INTEGER(KIND=4), intent(in) :: NPTS1, NPTS2
    REAL(KIND=8), dimension(2,NPTS1), optional :: eta1_slopes
    REAL(KIND=8), dimension(2,NPTS2), optional :: eta2_slopes
    REAL(KIND=8), intent(in), dimension(NPTS1,NPTS2) :: data
    REAL(KIND=8), intent(in)    :: xi1
    REAL(KIND=8), intent(in)    :: xi2
    REAL(KIND=8), intent(out)   :: res
    class(sll_c_interpolator_2d), pointer :: cs2d

    !-------------------------------------------------------
    !f2py INTEGER(KIND=4), intent(in,hide)  :: NPTS1, NPTS2
    !f2py REAL(KIND=8), intent(in), dimension(2, NPTS2), optional :: eta1_slopes
    !f2py REAL(KIND=8), intent(in), dimension(2, NPTS1), optional :: eta2_slopes
    !--------------------------------------------------------

    if ((present(eta1_slopes)).and.(present(eta2_slopes))) then
       cs2d => sll_f_new_cubic_spline_interpolator_2d( &
            NPTS1, &
            NPTS2, &
            0.0_8, &
            1.0_8, &
            0.0_8, &
            1.0_8, &
            eta1_bc_type = sll_p_hermite, &
            eta2_bc_type = sll_p_hermite, &
            eta1_min_slopes=eta1_slopes(1, :), &
            eta1_max_slopes=eta1_slopes(2, :), &
            eta2_min_slopes=eta2_slopes(1, :), &
            eta2_max_slopes=eta2_slopes(2, :))
    else
       cs2d => sll_f_new_cubic_spline_interpolator_2d( &
            NPTS1, &
            NPTS2, &
            0.0_8, &
            1.0_8, &
            0.0_8, &
            1.0_8, &
            eta1_bc_type = sll_p_hermite, &
            eta2_bc_type = sll_p_hermite)
    endif

    call cs2d%compute_interpolants(data)

    res = cs2d % interpolate_from_interpolant_value(xi1,xi2)

  end subroutine interpolate_value

  subroutine poisson_solver_periodic(N1, N2, rho, phi)
    INTEGER(KIND=4), intent(in) :: N1
    INTEGER(KIND=4), intent(in) :: N2
    REAL(KIND=8),    intent(in),  dimension(:, :)   :: rho
    REAL(KIND=8),    intent(out), dimension(N1, N2) :: phi
    class(sll_c_poisson_2d_base), pointer     :: poisson
    type(sll_t_poisson_2d_periodic), target   :: poisson_tg

    poisson => sll_f_new_poisson_2d_periodic( &
         0.0_8, &
         1.0_8, &
         N1,   &
         0.0_8, &
         1.0_8, &
         N2)
    call poisson%compute_phi_from_rho(phi, rho)
  end subroutine poisson_solver_periodic

end module mp_int