!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!> @brief A Fortran 2003 module implementing mesh transfer methods.
!>
!>  This package defines a base mesh transfer algorithm and a cartesian and
!>  cylindrical transfer in 1D.  There are multiple options available for mesh
!>  transfer including: point-to-point, point-to-volume, point-to-continuous,
!>  volume-to-point, volume-to-volume, volume-to-continuous, continuous-to-point
!>  continuous-to-volume, and continuous-to-continuous.  All routines implemented
!>  here only handle mesh transfers in serial.  The base class does not prevent
!>  an extension for parallel maps if someone wishes to do so in the future.
!>
!>  The point-to-point transfer can be done using linear interpolation on the
!>  incoming mesh or through a projection to an user-defined order polynomial.
!>  For the linear interpolation method, data points outside the input data range
!>  will return the boundary value.
!>
!>  The point-to-volume transfer can be done by integrating the linear function
!>  between the points or by integrating an user-defined order polynomial.
!>
!>  The point-to-continuous transfer projects the points to a defined order
!>  polynomial.
!>
!>  The volume-to-point transfer returns the values for the volume in which the
!>  points fall into or can use a user-defined order polynomial which minimizes
!>  the error that preserves the volume average quantities.
!>
!>  The volume-to-volume transfer returns the integral values for flat
!>  volume-averaged input data or a user-defined order polynomial fit which
!>  minimizes the error in the volume average input data.
!>
!>  The volume-to-continuous transfer returns the defined polynomial fit which
!>  minimizes the error in the volume average input data.
!>
!>  The continuous-to-point transfer returns point values on the continuous
!>  input polynomial.
!>
!>  The continuous-to-volume transfer returns volume average values from the
!>  continuous input polynomial.
!>
!>  The continuous-to-continuous will return updated coefficients based on the
!>  outgoing moments requested.
!>
!>  In all cases, the user specifies the input mesh or moments and output mesh
!>  or moments and to use the native implementations or a polynomial projection
!>  transfer during initialization.  A mesh transfer matrix or linear system
!>  will be used to transfer input data onto the output mesh.  The call to
!>  transfer will transform the input data onto the output mesh using the transfer
!>  matrix and/or linear system which was defined during init.  As long as the
!>  incoming and outgoing mesh/moments are the same, transfer can be called
!>  an arbitrary number of times very efficiently.  If the mesh is different,
!>  a new transfer object will be needed.
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
MODULE MeshTransfer
#include "Futility_DBC.h"
USE Futility_DBC
USE IntrType
USE Constants_Conversion
USE Strings
USE ParameterLists
USE ExceptionHandler
USE ParallelEnv
USE BLAS
USE ArrayUtils
USE VectorTypes
USE MatrixTypes
USE LinearSolverTypes
IMPLICIT NONE
PRIVATE

PUBLIC :: eMeshTransfer
PUBLIC :: LPPointVal
PUBLIC :: LPIntegral
PUBLIC :: ZPPointVal
PUBLIC :: ZPIntegral
PUBLIC :: MeshTransfer_base
PUBLIC :: MeshTransfer_1Dbase
PUBLIC :: MeshTransfer_1DCart
PUBLIC :: MeshTransfer_1DCyl
! Test Interfaces
PUBLIC :: testsetupP2P
PUBLIC :: testsetupV2P
PUBLIC :: testsetupC2C
PUBLIC :: testsetupP2V_cart
PUBLIC :: testsetupP2C_cart
PUBLIC :: testsetupV2V_cart
PUBLIC :: testsetupV2C_cart
PUBLIC :: testsetupC2P_cart
PUBLIC :: testsetupC2V_cart
PUBLIC :: testsetupP2V_cyl
PUBLIC :: testsetupP2C_cyl
PUBLIC :: testsetupV2V_cyl
PUBLIC :: testsetupV2C_cyl
PUBLIC :: testsetupC2P_cyl
PUBLIC :: testsetupC2V_cyl

INTEGER(SIK),PARAMETER :: MapType_CONTINUOUS=1
INTEGER(SIK),PARAMETER :: MapType_POINT=2
INTEGER(SIK),PARAMETER :: MapType_VOLUME=3

TYPE,ABSTRACT :: MeshTransfer_base
  !> Indicates whether or not this object has been initialized.
  LOGICAL(SBK) :: isInit=.FALSE.
!
!List of type-bound procedures
  CONTAINS
    !> Defines interface for deferred initialization method
    PROCEDURE(mt_init_absintfc),DEFERRED,PASS :: init
    !> Defines interface for deferred clear method
    PROCEDURE(mt_clear_absintfc),DEFERRED,PASS :: clear
    !> Defines interface for deferred setup method
    PROCEDURE(mt_trnsfr_absintfc),DEFERRED,PASS :: transfer
ENDTYPE MeshTransfer_base

!> Defines the interface for procedures for initializing
ABSTRACT INTERFACE
  SUBROUTINE mt_init_absintfc(this,pList)
    IMPORT :: MeshTransfer_base,ParamType
    CLASS(MeshTransfer_base),INTENT(INOUT) :: this
    CLASS(ParamType),INTENT(IN) :: pList
  ENDSUBROUTINE mt_init_absintfc
ENDINTERFACE

!> Defines the interface for procedures for clearing
ABSTRACT INTERFACE
  SUBROUTINE mt_clear_absintfc(this)
    IMPORT :: MeshTransfer_base
    CLASS(MeshTransfer_base),INTENT(INOUT) :: this
  ENDSUBROUTINE mt_clear_absintfc
ENDINTERFACE

!> Defines the interface for procedures for transfering data
ABSTRACT INTERFACE
  SUBROUTINE mt_trnsfr_absintfc(this,data_in,data_out)
    IMPORT :: MeshTransfer_base,SRK
    CLASS(MeshTransfer_base),INTENT(INOUT) :: this
    REAL(SRK),INTENT(IN) :: data_in(:)
    REAL(SRK),INTENT(INOUT),ALLOCATABLE :: data_out(:)
  ENDSUBROUTINE mt_trnsfr_absintfc
ENDINTERFACE

TYPE,ABSTRACT,EXTENDS(MeshTransfer_base) :: MeshTransfer_1Dbase
  !> Enumeration for incoming map type
  INTEGER(SIK) :: MapType_in=0
  !> Enumeration for outgoing map type
  INTEGER(SIK) :: MapType_out=0
  !> The number of incoming mesh elements (or moments for continuous)
  INTEGER(SIK) :: nmesh_in=0
  !> The number of outcoming mesh elements (or moments for continuous)
  INTEGER(SIK) :: nmesh_out=0
  !> Integer indicating the order of polynomial transfer (-1 means no polynomial transfer)
  INTEGER(SIK) :: poly_transfer=-1
  !> The incoming mesh, different meetings depending on the MapType_in
  REAL(SRK),ALLOCATABLE :: mesh_in(:)
  !> The outgoing mesh, different meetings depending on the MapType_out
  REAL(SRK),ALLOCATABLE :: mesh_out(:)
  !> The matrix to transfer the data from incoming to outgoing:  outgoing = transferMatrix * incoming
  REAL(SRK),ALLOCATABLE :: transferMatrix(:,:)
  !> The linear system to transfer the data from incoming to outgoing: transferLS%A * outgoing = incoming
  TYPE(LinearSolverType_Direct) :: transferLS
!
!List of type-bound procedures
  CONTAINS
    !> @copybrief MeshTransfer::init_1Dbase
    !> @copydetails MeshTransfer::init_1Dbase
    PROCEDURE,PASS :: init_base => init_1Dbase
    !> @copybrief MeshTransfer::clear_1Dbase
    !> @copydetails MeshTransfer::clear_1Dbase
    PROCEDURE,PASS :: clear => clear_1Dbase
    !> @copybrief MeshTransfer::clear_1Dbase
    !> @copydetails MeshTransfer::clear_1Dbase
    PROCEDURE,PASS :: transfer => transfer_1Dbase
ENDTYPE MeshTransfer_1Dbase

TYPE,EXTENDS(MeshTransfer_1Dbase) :: MeshTransfer_1DCart
!
!List of type-bound procedures
  CONTAINS
    !> @copybrief MeshTransfer::init_1DCart
    !> @copydetails MeshTransfer::init_1DCart
    PROCEDURE,PASS :: init => init_1DCart
ENDTYPE MeshTransfer_1DCart

TYPE,EXTENDS(MeshTransfer_1Dbase) :: MeshTransfer_1DCyl
!
!List of type-bound procedures
  CONTAINS
    !> @copybrief MeshTransfer::init_1DCyl
    !> @copydetails MeshTransfer::init_1DCyl
    PROCEDURE,PASS :: init => init_1DCyl
ENDTYPE MeshTransfer_1DCyl

!> Name of module
CHARACTER(LEN=*),PARAMETER :: modName='MESHTRANSFER'

!> Exception Handler for use in MeshTransfer
TYPE(ExceptionHandlerType),SAVE :: eMeshTransfer

!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
!> @brief  initialization for the base class
!> @param this  The mesh transfer object
!> @param pList The parameter list which defines the input
!>
!> This routine processes the parameter list and sets data into the base class.
!> Required and optional parameters include:
!>   - Required:
!>     * map_in - type of incoming map (POINT,VOLUME,CONTINUOUS)
!>     * map_out - type of outgoing map (POINT,VOLUME,CONTINUOUS)
!>     * moments_in - number of polynomial coefficients (only for map_in=CONTINUOUS)
!>     * pointmesh_in - 1D array of point locations (only for map_in=POINT)
!>     * volumemesh_in - 1D array of edges of volumes (only for map_in=VOLUME)
!>     * moments_out - number of polynomial coefficients (only for map_out=CONTINUOUS)
!>     * pointmesh_out - 1D array of point locations (only for map_out=POINT)
!>     * volumemesh_out - 1D array of edges of volumes (only for map_out=VOLUME)
!>   - Optional:
!>     * poly_transfer - if present, defines the order of polynomial transfer that is used
!>
SUBROUTINE init_1Dbase(this,pList)
  CHARACTER(LEN=*),PARAMETER :: myName="init_1Dbase"
  CLASS(MeshTransfer_1Dbase),INTENT(INOUT) :: this
  CLASS(ParamType),INTENT(IN) :: pList

  INTEGER(SIK) :: i
  TYPE(StringType) :: tmpstr

  REQUIRE(pList%has('map_in'))
  REQUIRE(pList%has('map_out'))

  CALL pList%get('map_in',tmpstr)
  SELECTCASE(CHAR(tmpstr))
  CASE('CONTINUOUS')
    this%MapType_in=MapType_CONTINUOUS
  CASE('POINT')
    this%MapType_in=MapType_POINT
  CASE('VOLUME')
    this%MapType_in=MapType_VOLUME
  CASE DEFAULT
    CALL eMeshTransfer%raiseError(modName//"::"//myName//" - "// &
        "invalid incoming map type")
  ENDSELECT
  IF(this%MapType_in == MapType_CONTINUOUS) THEN
    CALL pList%get('moments_in',this%nmesh_in)
  ELSEIF(this%MapType_in == MapType_POINT) THEN
    CALL pList%get('pointmesh_in',this%mesh_in)
    this%nmesh_in=SIZE(this%mesh_in)
  ELSEIF(this%MapType_in == MapType_VOLUME) THEN
    CALL pList%get('volumemesh_in',this%mesh_in)
    this%nmesh_in=SIZE(this%mesh_in)-1
  ENDIF

  CALL pList%get('map_out',tmpstr)
  SELECTCASE(CHAR(tmpstr))
  CASE('CONTINUOUS')
    this%MapType_out=MapType_CONTINUOUS
  CASE('POINT')
    this%MapType_out=MapType_POINT
  CASE('VOLUME')
    this%MapType_out=MapType_VOLUME
  CASE DEFAULT
    CALL eMeshTransfer%raiseError(modName//"::"//myName//" - "// &
        "invalid outgoing map type")
  ENDSELECT
  IF(this%MapType_out == MapType_CONTINUOUS) THEN
    CALL pList%get('moments_out',this%nmesh_out)
  ELSEIF(this%MapType_out == MapType_POINT) THEN
    CALL pList%get('pointmesh_out',this%mesh_out)
    this%nmesh_out=SIZE(this%mesh_out)
  ELSEIF(this%MapType_out == MapType_VOLUME) THEN
    CALL pList%get('volumemesh_out',this%mesh_out)
    this%nmesh_out=SIZE(this%mesh_out)-1
  ENDIF

  IF(pList%has('poly_transfer')) THEN
    CALL pList%get('poly_transfer',this%poly_transfer)
  ENDIF

  IF(this%MapType_in /= MapType_CONTINUOUS) THEN
    DO i=2,SIZE(this%mesh_in)
      ENSURE(this%mesh_in(i)>this%mesh_in(i-1))
    ENDDO
  ENDIF
  IF(this%MapType_out /= MapType_CONTINUOUS) THEN
    DO i=2,SIZE(this%mesh_out)
      ENSURE(this%mesh_out(i)>this%mesh_out(i-1))
    ENDDO
  ENDIF

ENDSUBROUTINE init_1Dbase
!
!-------------------------------------------------------------------------------
!> @brief clears the mesh transfer type
!> @param this  The mesh transfer object
!>
!> This routine restores the object to its initial state
!>
SUBROUTINE clear_1Dbase(this)
  CLASS(MeshTransfer_1Dbase),INTENT(INOUT) :: this

  this%MapType_in=0
  this%MapType_out=0
  this%nmesh_in=0
  this%nmesh_out=0
  this%poly_transfer=-1
  IF(ALLOCATED(this%mesh_in)) DEALLOCATE(this%mesh_in)
  IF(ALLOCATED(this%mesh_out)) DEALLOCATE(this%mesh_out)
  IF(ALLOCATED(this%transferMatrix)) DEALLOCATE(this%transferMatrix)
  IF(this%transferLS%isInit) CALL this%transferLS%clear()

  this%isInit=.FALSE.
ENDSUBROUTINE clear_1Dbase
!
!-------------------------------------------------------------------------------
!> @brief Transforms the input data to the output mesh
!> @param this     The mesh transfer object
!> @param data_in  The 1D array contining data on the incoming mesh
!> @param data_out The transformed output data as a 1D array
!>
!> This routine applies the linear system if present, then applies the the
!> transfer matrix if present.  data_out will first be deallocated and reallocated
!> to the correct size.  The 1D arrays contain the point values for a POINT
!> transfer, a volume average values for a VOLUME transfer, and the coefficients
!> of the polynomial fit if the transfer is CONTINUOUS.
!>
SUBROUTINE transfer_1Dbase(this,data_in,data_out)
  CLASS(MeshTransfer_1Dbase),INTENT(INOUT) :: this
  REAL(SRK),INTENT(IN) :: data_in(:)
  REAL(SRK),INTENT(INOUT),ALLOCATABLE :: data_out(:)

  INTEGER(SIK) :: i,nmom
  REAL(SRK),ALLOCATABLE :: tmp(:)

  IF(ALLOCATED(data_out)) DEALLOCATE(data_out)
  ALLOCATE(data_out(this%nmesh_out))
  data_out=ZERO

  IF(this%transferLS%isInit) THEN
    IF(ALLOCATED(this%transferMatrix)) THEN
      nmom=this%poly_transfer
    ELSE
      nmom=this%nmesh_out
    ENDIF
    ALLOCATE(tmp(nmom))
    SELECTTYPE(b => this%transferLS%b); TYPE IS(RealVectorType)
      DO i=1,this%nmesh_in
        CALL b%set(i,data_in(i))
      ENDDO
    ENDSELECT
    CALL this%transferLS%solve()

    SELECTTYPE(x => this%transferLS%x); TYPE IS(RealVectorType)
      DO i=1,nmom
        IF(i<=x%n) THEN
          CALL x%get(i,tmp(i))
        ELSE
          tmp(i)=ZERO
        ENDIF
      ENDDO
    ENDSELECT
  ELSE
    ALLOCATE(tmp(this%nmesh_in))
    tmp(:)=data_in(:)
  ENDIF

  IF(ALLOCATED(this%transferMatrix)) THEN
    CALL BLAS_MATVEC(this%transferMatrix,tmp,data_out)
  ELSE
    data_out(:)=tmp(:)
  ENDIF

  DEALLOCATE(tmp)
ENDSUBROUTINE transfer_1Dbase
!
!-------------------------------------------------------------------------------
!> @brief  initialization for the 1D cartesian transfer class
!> @param this  The mesh transfer object
!> @param pList The parameter list which defines the input
!>
!> This routine processes the parameter list and then sets up the linear system
!> transfer and transfer matrix by calling the appropriate setup methods.
!> Required and optional parameters include:
!>   - Required:
!>     * Only what is required in init_base
!>   - Optional:
!>     * minRange - The minimum extent of a transfer polynomial
!>     * maxRange - The maximum extent of a transfer polynomial
!>
SUBROUTINE init_1DCart(this,pList)
  CLASS(MeshTransfer_1DCart),INTENT(INOUT) :: this
  CLASS(ParamType),INTENT(IN) :: pList

  REAL(SRK) :: minX, maxX
  CALL this%init_base(pList)
  IF(ALLOCATED(this%mesh_in)) THEN
    minX=MINVAL(this%mesh_in)
    maxX=MAXVAL(this%mesh_in)
  ELSE
    minX=-1.0_SRK
    maxX=1.0_SRK
  ENDIF
  IF(pList%has('minRange')) CALL pList%get('minRange',minX)
  IF(pList%has('maxRange')) CALL pList%get('maxRange',maxX)

  IF(this%MapType_in == MapType_POINT .AND. this%MapType_out == MapType_POINT) THEN
    IF(this%poly_transfer>=0) THEN
      CALL setupP2C_cart(this%transferLS,this%mesh_in,minX,maxX)
      CALL setupC2P_cart(this%transferMatrix,this%poly_transfer,this%mesh_out,minX,maxX)
    ELSE
      CALL setupP2P(this%transferMatrix,this%mesh_in,this%mesh_out)
    ENDIF
  ELSEIF(this%MapType_in == MapType_POINT .AND. this%MapType_out == MapType_VOLUME) THEN
    IF(this%poly_transfer>=0) THEN
      CALL setupP2C_cart(this%transferLS,this%mesh_in,minX,maxX)
      CALL setupC2V_cart(this%transferMatrix,this%poly_transfer,this%mesh_out,minX,maxX)
    ELSE
      CALL setupP2V_cart(this%transferMatrix,this%mesh_in,this%mesh_out)
    ENDIF
  ELSEIF(this%MapType_in == MapType_POINT .AND. this%MapType_out == MapType_CONTINUOUS) THEN
      CALL setupP2C_cart(this%transferLS,this%mesh_in,minX,maxX)
  ELSEIF(this%MapType_in == MapType_VOLUME .AND. this%MapType_out == MapType_POINT) THEN
    IF(this%poly_transfer>=0) THEN
      CALL setupV2C_cart(this%transferLS,this%mesh_in,minX,maxX)
      CALL setupC2P_cart(this%transferMatrix,this%poly_transfer,this%mesh_out,minX,maxX)
    ELSE
      CALL setupV2P(this%transferMatrix,this%mesh_in,this%mesh_out)
    ENDIF
  ELSEIF(this%MapType_in == MapType_VOLUME .AND. this%MapType_out == MapType_VOLUME) THEN
    IF(this%poly_transfer>=0) THEN
      CALL setupV2C_cart(this%transferLS,this%mesh_in,minX,maxX)
      CALL setupC2V_cart(this%transferMatrix,this%poly_transfer,this%mesh_out,minX,maxX)
    ELSE
      CALL setupV2V_cart(this%transferMatrix,this%mesh_in,this%mesh_out)
    ENDIF
  ELSEIF(this%MapType_in == MapType_VOLUME .AND. this%MapType_out == MapType_CONTINUOUS) THEN
    CALL setupV2C_cart(this%transferLS,this%mesh_in,minX,maxX)
  ELSEIF(this%MapType_in == MapType_CONTINUOUS .AND. this%MapType_out == MapType_POINT) THEN
    CALL setupC2P_cart(this%transferMatrix,this%nmesh_in,this%mesh_out,minX,maxX)
  ELSEIF(this%MapType_in == MapType_CONTINUOUS .AND. this%MapType_out == MapType_VOLUME) THEN
    CALL setupC2V_cart(this%transferMatrix,this%nmesh_in,this%mesh_out,minX,maxX)
  ELSEIF(this%MapType_in == MapType_CONTINUOUS .AND. this%MapType_out == MapType_CONTINUOUS) THEN
    CALL setupC2C(this%transferMatrix,this%nmesh_in,this%nmesh_out)
  ENDIF

  this%isInit=.TRUE.
ENDSUBROUTINE init_1DCart
!
!-------------------------------------------------------------------------------
!> @brief  initialization for the 1D cylindrical transfer class
!> @param this  The mesh transfer object
!> @param pList The parameter list which defines the input
!>
!> This routine processes the parameter list and then sets up the linear system
!> transfer and transfer matrix by calling the appropriate setup methods.
!> Required and optional parameters include:
!>   - Required:
!>     * Only what is required in init_base
!>   - Optional:
!>     * maxRange - The maximum extent of a transfer polynomial
!>
SUBROUTINE init_1DCyl(this,pList)
  CLASS(MeshTransfer_1DCyl),INTENT(INOUT) :: this
  CLASS(ParamType),INTENT(IN) :: pList

  REAL(SRK) :: maxR

  CALL this%init_base(pList)

  IF(ALLOCATED(this%mesh_in)) THEN
    maxR=MAXVAL(this%mesh_in)
  ELSE
    maxR=1.0_SRK
  ENDIF
  IF(pList%has('maxRange')) CALL pList%get('maxRange',maxR)

  IF(this%MapType_in == MapType_POINT .AND. this%MapType_out == MapType_POINT) THEN
    IF(this%poly_transfer>=0) THEN
      CALL setupP2C_cyl(this%transferLS,this%mesh_in,maxR)
      CALL setupC2P_cyl(this%transferMatrix,this%poly_transfer,this%mesh_out,maxR)
    ELSE
      CALL setupP2P(this%transferMatrix,this%mesh_in,this%mesh_out)
    ENDIF
  ELSEIF(this%MapType_in == MapType_POINT .AND. this%MapType_out == MapType_VOLUME) THEN
    IF(this%poly_transfer>=0) THEN
      CALL setupP2C_cyl(this%transferLS,this%mesh_in,maxR)
      CALL setupC2V_cyl(this%transferMatrix,this%poly_transfer,this%mesh_out,maxR)
    ELSE
      CALL setupP2V_cyl(this%transferMatrix,this%mesh_in,this%mesh_out)
    ENDIF
  ELSEIF(this%MapType_in == MapType_POINT .AND. this%MapType_out == MapType_CONTINUOUS) THEN
      CALL setupP2C_cyl(this%transferLS,this%mesh_in,maxR)
  ELSEIF(this%MapType_in == MapType_VOLUME .AND. this%MapType_out == MapType_POINT) THEN
    IF(this%poly_transfer>=0) THEN
      CALL setupV2C_cyl(this%transferLS,this%mesh_in,maxR)
      CALL setupC2P_cyl(this%transferMatrix,this%poly_transfer,this%mesh_out,maxR)
    ELSE
      CALL setupV2P(this%transferMatrix,this%mesh_in,this%mesh_out)
    ENDIF
  ELSEIF(this%MapType_in == MapType_VOLUME .AND. this%MapType_out == MapType_VOLUME) THEN
    IF(this%poly_transfer>=0) THEN
      CALL setupV2C_cyl(this%transferLS,this%mesh_in,maxR)
      CALL setupC2V_cyl(this%transferMatrix,this%poly_transfer,this%mesh_out,maxR)
    ELSE
      CALL setupV2V_cyl(this%transferMatrix,this%mesh_in,this%mesh_out)
    ENDIF
  ELSEIF(this%MapType_in == MapType_VOLUME .AND. this%MapType_out == MapType_CONTINUOUS) THEN
    CALL setupV2C_cyl(this%transferLS,this%mesh_in,maxR)
  ELSEIF(this%MapType_in == MapType_CONTINUOUS .AND. this%MapType_out == MapType_POINT) THEN
    CALL setupC2P_cyl(this%transferMatrix,this%nmesh_in,this%mesh_out,maxR)
  ELSEIF(this%MapType_in == MapType_CONTINUOUS .AND. this%MapType_out == MapType_VOLUME) THEN
    CALL setupC2V_cyl(this%transferMatrix,this%nmesh_in,this%mesh_out,maxR)
  ELSEIF(this%MapType_in == MapType_CONTINUOUS .AND. this%MapType_out == MapType_CONTINUOUS) THEN
    CALL setupC2C(this%transferMatrix,this%nmesh_in,this%nmesh_out)
  ENDIF

  this%isInit=.TRUE.
ENDSUBROUTINE init_1DCyl
!
!-------------------------------------------------------------------------------
!  General interfaces for Cartesian and Cylindrical
!-------------------------------------------------------------------------------
!> @brief  setup point to point transfer (not type bound)
!> @param TM       The 2D array transfer matrix
!> @param mesh_in  The incoming point mesh
!> @param mesh_out The outcoming point mesh
!>
!> This routine allocates the transfer matrix for point to point
!>
SUBROUTINE setupP2P(TM,mesh_in,mesh_out)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: mesh_out(:)

  INTEGER(SIK) :: i,j
  REAL(SRK) :: dx
  REQUIRE(SIZE(mesh_in)>0)
  REQUIRE(SIZE(mesh_out)>0)

  IF(ALLOCATED(TM)) DEALLOCATE(TM)
  ALLOCATE(TM(SIZE(mesh_out),SIZE(mesh_in)))
  TM(:,:)=ZERO

  DO i=1,SIZE(mesh_out)
    j=findIndex(mesh_in,mesh_out(i),.FALSE.,incl=1)
    IF(j>0) THEN
      dx=mesh_in(j+1)-mesh_in(j)
      TM(i,j)=(mesh_in(j+1)-mesh_out(i))/dx
      TM(i,j+1)=(mesh_out(i)-mesh_in(j))/dx
    ELSEIF(j == -1) THEN
      TM(i,1)=ONE
    ELSEIF(j == -2) THEN
      TM(i,SIZE(mesh_in))=ONE
    ENDIF
  ENDDO

  ENSURE(ALLOCATED(TM))
ENDSUBROUTINE setupP2P
!
!-------------------------------------------------------------------------------
!> @brief  setup volume to point transfer (not type bound)
!> @param TM       The 2D array transfer matrix
!> @param mesh_in  The incoming volume mesh
!> @param mesh_out The outcoming point mesh
!>
!> This routine allocates the transfer matrix for volume to point
!>
SUBROUTINE setupV2P(TM,mesh_in,mesh_out)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: mesh_out(:)

  INTEGER(SIK) :: i,j
  REQUIRE(SIZE(mesh_in)>0)
  REQUIRE(SIZE(mesh_out)>0)

  IF(ALLOCATED(TM)) DEALLOCATE(TM)
  ALLOCATE(TM(SIZE(mesh_out),SIZE(mesh_in)-1))
  TM(:,:)=ZERO

  DO i=1,SIZE(mesh_out)
    j=findIndex(mesh_in,mesh_out(i),.FALSE.)
    IF(j>0) THEN
      TM(i,j)=ONE
    ELSEIF(j == -1) THEN
      TM(i,1)=ONE
    ELSEIF(j == -2) THEN
      TM(i,SIZE(mesh_in)-1)=ONE
    ELSEIF(j == -3) THEN
      j=findIndex(mesh_in,mesh_out(i),.FALSE.,incl=1)
      IF(j == -1) THEN
        TM(i,1)=ONE
      ELSEIF(j == SIZE(mesh_in)-1) THEN
        TM(i,j)=ONE
      ELSE
        TM(i,j)=HALF
        TM(i,j+1)=HALF
      ENDIF
    ENDIF
  ENDDO

  ENSURE(ALLOCATED(TM))
ENDSUBROUTINE setupV2P
!
!-------------------------------------------------------------------------------
!> @brief  setup continuous to continuous transfer (not type bound)
!> @param TM        The 2D array transfer matrix
!> @param nmesh_in  The incoming number of moments
!> @param nmesh_out The outcoming number of moments
!>
!> This routine allocates the transfer matrix for continuous to continuous
!>
SUBROUTINE setupC2C(TM,nmesh_in,nmesh_out)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  INTEGER(SIK),INTENT(IN) :: nmesh_in
  INTEGER(SIK),INTENT(IN) :: nmesh_out

  INTEGER(SIK) :: i

  REQUIRE(nmesh_in>0)
  REQUIRE(nmesh_out>0)

  IF(ALLOCATED(TM)) DEALLOCATE(TM)
  ALLOCATE(TM(nmesh_out,nmesh_in))
  TM(:,:)=ZERO

  DO i=1,MIN(nmesh_in,nmesh_out)
    TM(i,i)=ONE
  ENDDO

  ENSURE(ALLOCATED(TM))
ENDSUBROUTINE setupC2C
!
!-------------------------------------------------------------------------------
!  Cartesian interfaces
!-------------------------------------------------------------------------------
!> @brief  setup point to volume transfer for cartesian mesh (not type bound)
!> @param TM       The 2D array transfer matrix
!> @param mesh_in  The incoming point mesh
!> @param mesh_out The outcoming volume mesh
!>
!> This routine allocates the transfer matrix for point to volume
!>
SUBROUTINE setupP2V_cart(TM,mesh_in,mesh_out)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: mesh_out(:)

  INTEGER(SIK) :: iin,iout,iun
  REAL(SRK) :: dx,vsum
  REAL(SRK),ALLOCATABLE :: union(:)
  ! Volume requires at least 2 mesh points
  REQUIRE(SIZE(mesh_in)>1)
  REQUIRE(SIZE(mesh_out)>1)

  IF(ALLOCATED(TM)) DEALLOCATE(TM)
  ALLOCATE(TM(SIZE(mesh_out)-1,SIZE(mesh_in)))
  TM(:,:)=ZERO

  CALL getUnion(mesh_in,mesh_out,union)

  iout=0
  iin=0
  IF(mesh_in(1) .APPROXEQ. union(1)) iin=1
  IF(mesh_out(1) .APPROXEQ. union(1)) iout=1

  vsum=ZERO
  DO iun=2,SIZE(union)
    dx=(union(iun)-union(iun-1))
    IF(iout>0) THEN
      IF(iin == 0) THEN
        TM(iout,1)=TM(iout,1)+dx
      ELSEIF(iin == SIZE(mesh_in)) THEN
        TM(iout,SIZE(mesh_in))=TM(iout,SIZE(mesh_in))+dx
      ELSE
        TM(iout,iin)=TM(iout,iin)+ &
            HALF*dx*(TWO*mesh_in(iin+1)-union(iun)-union(iun-1))/ &
            (mesh_in(iin+1)-mesh_in(iin))
        TM(iout,iin+1)=TM(iout,iin+1)+ &
            HALF*dx*(union(iun)+union(iun-1)-TWO*mesh_in(iin))/   &
            (mesh_in(iin+1)-mesh_in(iin))
      ENDIF
      vsum=vsum+dx
    ENDIF
    IF(iin < SIZE(mesh_in)) THEN
      IF(union(iun) .APPROXEQ. mesh_in(iin+1)) iin=iin+1
    ENDIF
    IF(union(iun) .APPROXEQ. mesh_out(iout+1)) THEN
      IF(iout>0 .AND. vsum>ZERO) TM(iout,:)=TM(iout,:)/vsum
      vsum=ZERO
      iout=iout+1
      IF(iout>=SIZE(mesh_out)) EXIT
    ENDIF
  ENDDO

  DEALLOCATE(union)

  ENSURE(ALLOCATED(TM))
ENDSUBROUTINE setupP2V_cart
!
!-------------------------------------------------------------------------------
!> @brief  setup point to continuous transfer for cartesian mesh (not type bound)
!> @param TLS     The direct linear solver object to be set up
!> @param mesh_in The incoming point mesh
!> @param minX    The minimum x value for polynomial renormalization
!> @param maxX    The maximum x value for polynomial renormalization
!>
!> This routine initializes a direct linear solver using LU decomposition.  This
!> routine sets up the linear system to solve the full number of moments.  The
!> transfer routine will drop moments that aren't needed.  This is inconsequential
!> because the polynomials are orthogonal.
!>
SUBROUTINE setupP2C_cart(TLS,mesh_in,minX,maxX)
  TYPE(LinearSolverType_Direct),INTENT(INOUT) :: TLS
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: minX
  REAL(SRK),INTENT(IN) :: maxX

  INTEGER(SIK) :: i,j,nin
  REAL(SRK) :: h,cent
  REAL(SRK),ALLOCATABLE :: x(:)
  TYPE(ParamType) :: myPL

  REQUIRE(.NOT. TLS%isInit)
  REQUIRE(SIZE(mesh_in)>0)

  nin=SIZE(mesh_in)
  h=maxX-minX
  cent=0.5_SRK*(maxX+minX)

  CALL myPL%add('LinearSolverType->TPLType',LINSYS_NATIVE)
  CALL myPL%add('LinearSolverType->solverMethod',LU)
  CALL myPL%add('LinearSolverType->MPI_Comm_ID',PE_COMM_SELF)
  CALL myPL%add('LinearSolverType->numberOMP',1_SNK)
  CALL myPL%add('LinearSolverType->timerName','testTimer')
  CALL myPL%add('LinearSolverType->matType',DENSESQUARE)
  CALL myPL%add('LinearSolverType->A->MatrixType->isSym',.FALSE.)
  CALL myPL%add('LinearSolverType->A->MatrixType->n',nin)
  CALL myPL%add('LinearSolverType->x->VectorType->n',nin)
  CALL myPL%add('LinearSolverType->b->VectorType->n',nin)
  CALL TLS%init(myPL)
  CALL myPL%clear()

  ALLOCATE(x(nin))

  SELECTTYPE(A => TLS%A); TYPE IS(DenseSquareMatrixType)
    DO i=1,nin
      DO j=1,nin
        x(:)=0.0_SRK
        x(j)=ONE
        CALL A%set(i,j,LPPointVal(x,mesh_in(i),h,cent))
      ENDDO
    ENDDO
  ENDSELECT

  DEALLOCATE(x)

  ENSURE(TLS%isInit)
ENDSUBROUTINE setupP2C_cart
!
!-------------------------------------------------------------------------------
!> @brief  setup volume to volume transfer for cartesian mesh (not type bound)
!> @param TM       The 2D array transfer matrix
!> @param mesh_in  The incoming volume mesh
!> @param mesh_out The outcoming volume mesh
!>
!> This routine allocates the transfer matrix for volume to volume
!>
SUBROUTINE setupV2V_cart(TM,mesh_in,mesh_out)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: mesh_out(:)

  INTEGER(SIK) :: iin,iout,iun
  REAL(SRK) :: dx,vsum
  REAL(SRK),ALLOCATABLE :: union(:)
  ! Volume requires at least 2 mesh points
  REQUIRE(SIZE(mesh_in)>1)
  REQUIRE(SIZE(mesh_out)>1)

  IF(ALLOCATED(TM)) DEALLOCATE(TM)
  ALLOCATE(TM(SIZE(mesh_out)-1,SIZE(mesh_in)-1))
  TM(:,:)=ZERO

  CALL getUnion(mesh_in,mesh_out,union)

  iout=0
  iin=0
  IF(mesh_in(1) .APPROXEQ. union(1)) iin=1
  IF(mesh_out(1) .APPROXEQ. union(1)) iout=1

  vsum=ZERO
  DO iun=2,SIZE(union)
    dx=union(iun)-union(iun-1)
    IF(iout>0) THEN
      IF(iin == 0) THEN
        TM(iout,1)=TM(iout,1)+dx
      ELSEIF(iin == SIZE(mesh_in)) THEN
        TM(iout,SIZE(mesh_in)-1)=TM(iout,SIZE(mesh_in)-1)+dx
      ELSE
        TM(iout,iin)=TM(iout,iin)+dx
      ENDIF
      vsum=vsum+dx
    ENDIF
    IF(iin < SIZE(mesh_in)) THEN
      IF(union(iun) .APPROXEQ. mesh_in(iin+1)) iin=iin+1
    ENDIF
    IF(union(iun) .APPROXEQ. mesh_out(iout+1)) THEN
      IF(iout>0 .AND. vsum>ZERO) TM(iout,:)=TM(iout,:)/vsum
      vsum=ZERO
      iout=iout+1
      IF(iout>=SIZE(mesh_out)) EXIT
    ENDIF
  ENDDO

  DEALLOCATE(union)

  ENSURE(ALLOCATED(TM))
ENDSUBROUTINE setupV2V_cart
!
!-------------------------------------------------------------------------------
!> @brief  setup volume to continuous transfer for cartesian mesh (not type bound)
!> @param TLS     The direct linear solver object to be set up
!> @param mesh_in The incoming volume mesh
!> @param minX    The minimum x value for polynomial renormalization
!> @param maxX    The maximum x value for polynomial renormalization
!>
!> This routine initializes a direct linear solver using LU decomposition.  This
!> routine sets up the linear system to solve the full number of moments.  The
!> transfer routine will drop moments that aren't needed.  This is inconsequential
!> because the polynomials are orthogonal.
!>
SUBROUTINE setupV2C_cart(TLS,mesh_in,minX,maxX)
  TYPE(LinearSolverType_Direct),INTENT(INOUT) :: TLS
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: minX
  REAL(SRK),INTENT(IN) :: maxX

  INTEGER(SIK) :: i,j,nin
  REAL(SRK) :: h,cent
  REAL(SRK),ALLOCATABLE :: x(:)
  TYPE(ParamType) :: myPL

  REQUIRE(.NOT. TLS%isInit)
  ! Volume mesh requires at least 2 mesh points
  REQUIRE(SIZE(mesh_in)>1)

  nin=SIZE(mesh_in)-1
  h=(maxX-minX)
  cent=0.5_SRK*(maxX+minX)

  CALL myPL%add('LinearSolverType->TPLType',LINSYS_NATIVE)
  CALL myPL%add('LinearSolverType->solverMethod',LU)
  CALL myPL%add('LinearSolverType->MPI_Comm_ID',PE_COMM_SELF)
  CALL myPL%add('LinearSolverType->numberOMP',1_SNK)
  CALL myPL%add('LinearSolverType->timerName','testTimer')
  CALL myPL%add('LinearSolverType->matType',DENSESQUARE)
  CALL myPL%add('LinearSolverType->A->MatrixType->isSym',.FALSE.)
  CALL myPL%add('LinearSolverType->A->MatrixType->n',nin)
  CALL myPL%add('LinearSolverType->x->VectorType->n',nin)
  CALL myPL%add('LinearSolverType->b->VectorType->n',nin)
  CALL TLS%init(myPL)
  CALL myPL%clear()

  ALLOCATE(x(nin))

  SELECTTYPE(A => TLS%A); TYPE IS(DenseSquareMatrixType)
    DO i=1,nin
      DO j=1,nin
        x(:)=0.0_SRK
        x(j)=ONE
        CALL A%set(i,j,LPIntegral(x,mesh_in(i),mesh_in(i+1),h,cent))
      ENDDO
    ENDDO
  ENDSELECT

  DEALLOCATE(x)

  ENSURE(TLS%isInit)
ENDSUBROUTINE setupV2C_cart
!
!-------------------------------------------------------------------------------
!> @brief  setup continuous to point transfer for cartesian mesh (not type bound)
!> @param TM       The 2D array transfer matrix
!> @param nmesh_in The incoming moments
!> @param mesh_out The outcoming point mesh
!> @param minX     The minimum x value for polynomial renormalization
!> @param maxX     The maximum x value for polynomial renormalization
!>
!> This routine allocates the transfer matrix for continuous to point
!>
SUBROUTINE setupC2P_cart(TM,nmesh_in,mesh_out,minX,maxX)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  INTEGER(SIK),INTENT(IN) :: nmesh_in
  REAL(SRK),INTENT(IN) :: mesh_out(:)
  REAL(SRK),INTENT(IN) :: minX
  REAL(SRK),INTENT(IN) :: maxX

  INTEGER(SIK) :: i,j,nin,nout
  REAL(SRK) :: h,cent
  REAL(SRK),ALLOCATABLE :: x(:)

  REQUIRE(nmesh_in>0)
  REQUIRE(SIZE(mesh_out)>0)

  nin=nmesh_in
  nout=SIZE(mesh_out)
  h=(maxX-minX)
  cent=0.5_SRK*(maxX+minX)
  ALLOCATE(x(nin))
  IF(ALLOCATED(TM)) DEALLOCATE(TM)
  ALLOCATE(TM(nout,nin))
  TM(:,:)=ZERO

  DO i=1,nout
    DO j=1,nin
      x(:)=ZERO
      x(j)=ONE
      TM(i,j)=LPPointVal(x,mesh_out(i),h,cent)
    ENDDO
  ENDDO

  DEALLOCATE(x)

  ENSURE(ALLOCATED(TM))
ENDSUBROUTINE setupC2P_cart
!
!-------------------------------------------------------------------------------
!> @brief  setup continuous to volume transfer for cartesian mesh (not type bound)
!> @param TM       The 2D array transfer matrix
!> @param nmesh_in The incoming moments
!> @param mesh_out The outcoming volume mesh
!> @param minX     The minimum x value for polynomial renormalization
!> @param maxX     The maximum x value for polynomial renormalization
!>
!> This routine allocates the transfer matrix for continuous to volume
!>
SUBROUTINE setupC2V_cart(TM,nmesh_in,mesh_out,minX,maxX)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  INTEGER(SIK),INTENT(IN) :: nmesh_in
  REAL(SRK),INTENT(IN) :: mesh_out(:)
  REAL(SRK),INTENT(IN) :: minX
  REAL(SRK),INTENT(IN) :: maxX

  INTEGER(SIK) :: i,j,nin,nout
  REAL(SRK) :: h,cent
  REAL(SRK),ALLOCATABLE :: x(:)

  REQUIRE(nmesh_in>0)
  ! Volume mesh requires at least 2 points
  REQUIRE(SIZE(mesh_out)>1)

  nin=nmesh_in
  nout=SIZE(mesh_out)-1
  h=(maxX-minX)
  cent=0.5_SRK*(maxX+minX)
  ALLOCATE(x(nin))
  IF(ALLOCATED(TM)) DEALLOCATE(TM)
  ALLOCATE(TM(nout,nin))
  TM(:,:)=ZERO

  DO i=1,nout
    DO j=1,nin
      x(:)=ZERO
      x(j)=ONE
      TM(i,j)=LPIntegral(x,mesh_out(i),mesh_out(i+1),h,cent)
    ENDDO
  ENDDO

  DEALLOCATE(x)

  ENSURE(ALLOCATED(TM))
ENDSUBROUTINE setupC2V_cart
!
!-------------------------------------------------------------------------------
! Cylindrical Interfaces
!-------------------------------------------------------------------------------
!> @brief  setup point to volume transfer for cylindrical mesh (not type bound)
!> @param TM       The 2D array transfer matrix
!> @param mesh_in  The incoming point mesh
!> @param mesh_out The outcoming volume mesh
!>
!> This routine allocates the transfer matrix for point to volume
!>
SUBROUTINE setupP2V_cyl(TM,mesh_in,mesh_out)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: mesh_out(:)

  INTEGER(SIK) :: iin,iout,iun
  REAL(SRK) :: dx,vsum,a,b,x1,x2
  REAL(SRK),ALLOCATABLE :: union(:)
  ! Volume requires at least 2 mesh points
  REQUIRE(SIZE(mesh_in)>1)
  REQUIRE(SIZE(mesh_out)>1)
  REQUIRE(ALL(mesh_in >= ZERO))
  REQUIRE(ALL(mesh_out >= ZERO))

  IF(ALLOCATED(TM)) DEALLOCATE(TM)
  ALLOCATE(TM(SIZE(mesh_out)-1,SIZE(mesh_in)))
  TM(:,:)=ZERO

  CALL getUnion(mesh_in,mesh_out,union)

  iout=0
  iin=0
  IF(mesh_in(1) .APPROXEQ. union(1)) iin=1
  IF(mesh_out(1) .APPROXEQ. union(1)) iout=1

  vsum=ZERO
  DO iun=2,SIZE(union)
    dx=union(iun)*union(iun)-union(iun-1)*union(iun-1)
    IF(iout>0) THEN
      IF(iin == 0) THEN
        TM(iout,1)=TM(iout,1)+dx
      ELSEIF(iin == SIZE(mesh_in)) THEN
        TM(iout,SIZE(mesh_in))=TM(iout,SIZE(mesh_in))+dx
      ELSE
        a=union(iun-1)
        b=union(iun)
        x1=mesh_in(iin)
        x2=mesh_in(iin+1)
        TM(iout,iin)=TM(iout,iin)+ &
            (TWO*a**3-3.0_SRK*a**2*x2-b**2*(TWO*b-3.0_SRK*x2))/(3.0_SRK*(x2-x1))
        TM(iout,iin+1)=TM(iout,iin+1)+ &
            (b**2*(TWO*b-3.0_SRK*x1)+3.0_SRK*a**2*x1-TWO*a**3)/(3.0_SRK*(x2-x1))
      ENDIF
      vsum=vsum+dx
    ENDIF
    IF(iin < SIZE(mesh_in)) THEN
      IF(union(iun) .APPROXEQ. mesh_in(iin+1)) iin=iin+1
    ENDIF
    IF(union(iun) .APPROXEQ. mesh_out(iout+1)) THEN
      IF(iout>0 .AND. vsum>ZERO) TM(iout,:)=TM(iout,:)/vsum
      vsum=ZERO
      iout=iout+1
      IF(iout>=SIZE(mesh_out)) EXIT
    ENDIF
  ENDDO

  DEALLOCATE(union)

  ENSURE(ALLOCATED(TM))
ENDSUBROUTINE setupP2V_cyl
!
!-------------------------------------------------------------------------------
!> @brief  setup point to continuous transfer for cylindrical mesh (not type bound)
!> @param TLS     The direct linear solver object to be set up
!> @param mesh_in The incoming point mesh
!> @param maxR    The maximum radius for polynomial renormalization
!>
!> This routine initializes a direct linear solver using LU decomposition.  This
!> routine sets up the linear system to solve the full number of moments.  The
!> transfer routine will drop moments that aren't needed.  This is inconsequential
!> because the polynomials are orthogonal.
!>
SUBROUTINE setupP2C_cyl(TLS,mesh_in,maxR)
  TYPE(LinearSolverType_Direct),INTENT(INOUT) :: TLS
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: maxR

  INTEGER(SIK) :: i,j,nin
  REAL(SRK),ALLOCATABLE :: x(:)
  TYPE(ParamType) :: myPL

  REQUIRE(.NOT. TLS%isInit)
  REQUIRE(SIZE(mesh_in)>0)
  REQUIRE(ALL(mesh_in >= ZERO))

  nin=SIZE(mesh_in)

  CALL myPL%add('LinearSolverType->TPLType',LINSYS_NATIVE)
  CALL myPL%add('LinearSolverType->solverMethod',LU)
  CALL myPL%add('LinearSolverType->MPI_Comm_ID',PE_COMM_SELF)
  CALL myPL%add('LinearSolverType->numberOMP',1_SNK)
  CALL myPL%add('LinearSolverType->timerName','testTimer')
  CALL myPL%add('LinearSolverType->matType',DENSESQUARE)
  CALL myPL%add('LinearSolverType->A->MatrixType->isSym',.FALSE.)
  CALL myPL%add('LinearSolverType->A->MatrixType->n',nin)
  CALL myPL%add('LinearSolverType->x->VectorType->n',nin)
  CALL myPL%add('LinearSolverType->b->VectorType->n',nin)
  CALL TLS%init(myPL)
  CALL myPL%clear()

  ALLOCATE(x(nin))

  SELECTTYPE(A => TLS%A); TYPE IS(DenseSquareMatrixType)
    DO i=1,nin
      DO j=1,nin
        x(:)=0.0_SRK
        x(j)=ONE
        CALL A%set(i,j,ZPPointVal(x,mesh_in(i),maxR))
      ENDDO
    ENDDO
  ENDSELECT

  DEALLOCATE(x)

  ENSURE(TLS%isInit)
ENDSUBROUTINE setupP2C_cyl
!
!-------------------------------------------------------------------------------
!> @brief  setup volume to volume transfer for cylindrical mesh (not type bound)
!> @param TM       The 2D array transfer matrix
!> @param mesh_in  The incoming volume mesh
!> @param mesh_out The outcoming volume mesh
!>
!> This routine allocates the transfer matrix for volume to volume
!>
SUBROUTINE setupV2V_cyl(TM,mesh_in,mesh_out)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: mesh_out(:)

  INTEGER(SIK) :: iin,iout,iun
  REAL(SRK) :: dx,vsum
  REAL(SRK),ALLOCATABLE :: union(:)
  ! Volume requires at least 2 mesh points
  REQUIRE(SIZE(mesh_in)>1)
  REQUIRE(SIZE(mesh_out)>1)
  REQUIRE(ALL(mesh_in >= ZERO))
  REQUIRE(ALL(mesh_out >= ZERO))

  IF(ALLOCATED(TM)) DEALLOCATE(TM)
  ALLOCATE(TM(SIZE(mesh_out)-1,SIZE(mesh_in)-1))
  TM(:,:)=ZERO

  CALL getUnion(mesh_in,mesh_out,union)

  iout=0
  iin=0
  IF(mesh_in(1) .APPROXEQ. union(1)) iin=1
  IF(mesh_out(1) .APPROXEQ. union(1)) iout=1

  vsum=ZERO
  DO iun=2,SIZE(union)
    dx=union(iun)*union(iun)-union(iun-1)*union(iun-1)
    IF(iout>0) THEN
      IF(iin == 0) THEN
        TM(iout,1)=TM(iout,1)+dx
      ELSEIF(iin == SIZE(mesh_in)) THEN
        TM(iout,SIZE(mesh_in)-1)=TM(iout,SIZE(mesh_in)-1)+dx
      ELSE
        TM(iout,iin)=TM(iout,iin)+dx
      ENDIF
      vsum=vsum+dx
    ENDIF
    IF(iin < SIZE(mesh_in)) THEN
      IF(union(iun) .APPROXEQ. mesh_in(iin+1)) iin=iin+1
    ENDIF
    IF(union(iun) .APPROXEQ. mesh_out(iout+1)) THEN
      IF(iout>0 .AND. vsum>ZERO) TM(iout,:)=TM(iout,:)/vsum
      vsum=ZERO
      iout=iout+1
      IF(iout>=SIZE(mesh_out)) EXIT
    ENDIF
  ENDDO

  DEALLOCATE(union)

  ENSURE(ALLOCATED(TM))
ENDSUBROUTINE setupV2V_cyl
!
!-------------------------------------------------------------------------------
!> @brief  setup point to continuous transfer for cylindrical mesh (not type bound)
!> @param TLS     The direct linear solver object to be set up
!> @param mesh_in The incoming point mesh
!> @param maxR    The maximum radius for polynomial renormalization
!>
!> This routine initializes a direct linear solver using LU decomposition.  This
!> routine sets up the linear system to solve the full number of moments.  The
!> transfer routine will drop moments that aren't needed.  This is inconsequential
!> because the polynomials are orthogonal.
!>
SUBROUTINE setupV2C_cyl(TLS,mesh_in,maxR)
  TYPE(LinearSolverType_Direct),INTENT(INOUT) :: TLS
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: maxR

  INTEGER(SIK) :: i,j,nin
  REAL(SRK),ALLOCATABLE :: x(:)
  TYPE(ParamType) :: myPL

  REQUIRE(.NOT. TLS%isInit)
  ! Volume mesh requires at least 2 mesh points
  REQUIRE(SIZE(mesh_in)>1)
  REQUIRE(ALL(mesh_in >= ZERO))

  nin=SIZE(mesh_in)-1

  CALL myPL%add('LinearSolverType->TPLType',LINSYS_NATIVE)
  CALL myPL%add('LinearSolverType->solverMethod',LU)
  CALL myPL%add('LinearSolverType->MPI_Comm_ID',PE_COMM_SELF)
  CALL myPL%add('LinearSolverType->numberOMP',1_SNK)
  CALL myPL%add('LinearSolverType->timerName','testTimer')
  CALL myPL%add('LinearSolverType->matType',DENSESQUARE)
  CALL myPL%add('LinearSolverType->A->MatrixType->isSym',.FALSE.)
  CALL myPL%add('LinearSolverType->A->MatrixType->n',nin)
  CALL myPL%add('LinearSolverType->x->VectorType->n',nin)
  CALL myPL%add('LinearSolverType->b->VectorType->n',nin)
  CALL TLS%init(myPL)
  CALL myPL%clear()

  ALLOCATE(x(nin))

  SELECTTYPE(A => TLS%A); TYPE IS(DenseSquareMatrixType)
    DO i=1,nin
      DO j=1,nin
        x(:)=ZERO
        x(j)=ONE
        CALL A%set(i,j,ZPIntegral(x,mesh_in(i),mesh_in(i+1),maxR))
      ENDDO
    ENDDO
  ENDSELECT

  DEALLOCATE(x)

  ENSURE(TLS%isInit)
ENDSUBROUTINE setupV2C_cyl
!
!-------------------------------------------------------------------------------
!> @brief  setup continuous to point transfer for cylindrical mesh (not type bound)
!> @param TM       The 2D array transfer matrix
!> @param nmesh_in The incoming moments
!> @param mesh_out The outcoming point mesh
!> @param maxR     The maximum radius for polynomial renormalization
!>
!> This routine allocates the transfer matrix for continuous to point
!>
SUBROUTINE setupC2P_cyl(TM,nmesh_in,mesh_out,maxR)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  INTEGER(SIK),INTENT(IN) :: nmesh_in
  REAL(SRK),INTENT(IN) :: mesh_out(:)
  REAL(SRK),INTENT(IN) :: maxR

  INTEGER(SIK) :: i,j,nin,nout
  REAL(SRK),ALLOCATABLE :: x(:)

  REQUIRE(nmesh_in>0)
  REQUIRE(SIZE(mesh_out)>0)
  REQUIRE(ALL(mesh_out >= ZERO))

  nin=nmesh_in
  nout=SIZE(mesh_out)
  ALLOCATE(x(nin))
  IF(ALLOCATED(TM)) DEALLOCATE(TM)
  ALLOCATE(TM(nout,nin))
  TM(:,:)=ZERO

  DO i=1,nout
    DO j=1,nin
      x(:)=ZERO
      x(j)=ONE
      TM(i,j)=ZPPointVal(x,mesh_out(i),maxR)
    ENDDO
  ENDDO

  DEALLOCATE(X)

  ENSURE(ALLOCATED(TM))
ENDSUBROUTINE setupC2P_cyl
!
!-------------------------------------------------------------------------------
!> @brief  setup continuous to volume transfer for cylindrical mesh (not type bound)
!> @param TM       The 2D array transfer matrix
!> @param nmesh_in The incoming moments
!> @param mesh_out The outcoming volume mesh
!> @param maxR     The maximum radius for polynomial renormalization
!>
!> This routine allocates the transfer matrix for continuous to volume
!>
SUBROUTINE setupC2V_cyl(TM,nmesh_in,mesh_out,maxR)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  INTEGER(SIK),INTENT(IN) :: nmesh_in
  REAL(SRK),INTENT(IN) :: mesh_out(:)
  REAL(SRK),INTENT(IN) :: maxR

  INTEGER(SIK) :: i,j,nin,nout
  REAL(SRK),ALLOCATABLE :: x(:)

  REQUIRE(nmesh_in>0)
  ! Volume mesh requires at least 2 points
  REQUIRE(SIZE(mesh_out)>1)
  REQUIRE(ALL(mesh_out >= ZERO))

  nin=nmesh_in
  nout=SIZE(mesh_out)-1
  ALLOCATE(x(nin))
  IF(ALLOCATED(TM)) DEALLOCATE(TM)
  ALLOCATE(TM(nout,nin))
  TM(:,:)=ZERO

  DO i=1,nout
    DO j=1,nin
      x(:)=ZERO
      x(j)=ONE
      TM(i,j)=ZPIntegral(x,mesh_out(i),mesh_out(i+1),maxR)
    ENDDO
  ENDDO

  DEALLOCATE(x)

  ENSURE(ALLOCATED(TM))
ENDSUBROUTINE setupC2V_cyl
!
!-------------------------------------------------------------------------------
!> @brief Returns value of an arbitrary order Legendre Polynomial with coefficients coef
!> @param coef  The coefficients of the Legendre expansion
!> @param globX The value of x in the global coordinate
!> @param h     The height of the node, OPTIONAL (if not provided a height of 2 is assumed)
!> @param nodeX The center of the node, OPTIONAL (if not provided a position of 0 is assumed)
!>
!> This routine returns the value of an arbitrary order Legendre expansion at a
!> specific point for NEM and SANM nodal methods.
!>
FUNCTION LPPointVal(coef,globX,h,nodeX) RESULT(y)
  REAL(SRK),INTENT(IN) :: coef(0:)
  REAL(SRK),INTENT(IN) :: globX
  REAL(SRK),INTENT(IN),OPTIONAL :: h
  REAL(SRK),INTENT(IN),OPTIONAL :: nodeX
  REAL(SRK) :: y
  ! Local variables
  INTEGER(SIK) :: N,i
  REAL(SRK) :: w, x, Pn, Pnm1, Pnm2

  REQUIRE(SIZE(coef) > 0)

  w=TWO
  x=globX

  IF(PRESENT(h)) w=h
  IF(PRESENT(nodeX)) x=globX-nodeX

  N=SIZE(coef)

  !project into local coordinate system
  x=TWO*x/w
  y=coef(0)
  Pnm2=ONE
  IF(N > 1) THEN
    y=y+coef(1)*x
    Pnm1=x
    DO i=2,N-1
      Pn=(TWO*REAL(i,SRK)-ONE)/REAL(i,SRK)*x*Pnm1-(REAL(i,SRK)-ONE)/REAL(i,SRK)*Pnm2
      y=y+coef(i)*Pn
      Pnm2=Pnm1
      Pnm1=Pn
    ENDDO
  ENDIF
ENDFUNCTION LPPointVal
!
!-------------------------------------------------------------------------------
!> @brief Returns value of the integral of an arbitrary order Legendre Polynomial with coefficients coef
!> @param coef  The coefficients of the Legendre expansion
!> @param a     The beginning of the integral range
!> @param b     The end of the integral range
!> @param h     The height of the node, OPTIONAL (if not provided a height of 2 is assumed)
!> @param nodeX The center of the node, OPTIONAL (if not provided a position of 0 is assumed)
!>
!> This routine returns the value of the integral of an arbitrary order Legendre expansion on a
!> specific range a to b for NEM and SANM nodal methods.
!>
FUNCTION LPIntegral(coef,a,b,h,nodeX) RESULT(y)
  REAL(SRK),INTENT(IN) :: coef(0:)
  REAL(SRK),INTENT(IN) :: a
  REAL(SRK),INTENT(IN) :: b
  REAL(SRK),INTENT(IN),OPTIONAL :: h
  REAL(SRK),INTENT(IN),OPTIONAL :: nodeX
  REAL(SRK) :: y
  ! Local variables
  INTEGER(SIK) :: N,m
  REAL(SRK) :: w, xa, xb, Pna, Pnm1a, Pnm2a, Pnb, Pnm1b, Pnm2b

  REQUIRE(SIZE(coef) > 0)

  w=TWO
  xa=a
  xb=b

  IF(PRESENT(h)) w=h
  IF(PRESENT(nodeX)) xa=a-nodeX
  IF(PRESENT(nodeX)) xb=b-nodeX

  REQUIRE(ABS(xb-xa) <= w)

  N=SIZE(coef)

  !project into local coordinate system
  xa=TWO*xa/w
  xb=TWO*xb/w

  Pnm1a=xa
  Pnm1b=xb
  Pnm2a=ONE
  Pnm2b=ONE
  !this is m=1
  y=coef(0)*(xb-xa)
  DO m=2,N
    Pna=(TWO*REAL(m,SRK)-ONE)/REAL(m,SRK)*xa*Pnm1a-(REAL(m,SRK)-ONE)/REAL(m,SRK)*Pnm2a
    Pnb=(TWO*REAL(m,SRK)-ONE)/REAL(m,SRK)*xb*Pnm1b-(REAL(m,SRK)-ONE)/REAL(m,SRK)*Pnm2b
    y=y+coef(m-1)/(TWO*REAL(m,SRK)-ONE)*(Pnb-Pna-Pnm2b+Pnm2a)
    Pnm2a=Pnm1a
    Pnm2b=Pnm1b
    Pnm1a=Pna
    Pnm1b=Pnb
  ENDDO
  y=y/(xb-xa)

ENDFUNCTION LPIntegral
!
!-------------------------------------------------------------------------------
!> @brief Returns value of an arbitrary order Zernike Polynomial with coefficients coef
!> @param coef  The coefficients of the Zernike expansion
!> @param r     The value of r in the global coordinate
!> @param h     The height of the node, OPTIONAL (if not provided a height of 1 is assumed)
!>
!> This routine returns the value of an arbitrary order Zernike expansion at a
!> specific point.
!>
FUNCTION ZPPointVal(coef,r,h) RESULT(y)
  REAL(SRK),INTENT(IN) :: coef(:)
  REAL(SRK),INTENT(IN) :: r
  REAL(SRK),INTENT(IN),OPTIONAL :: h
  REAL(SRK) :: y
  ! Local variables
  REAL(SRK) :: w

  w=ONE

  IF(PRESENT(h)) w=h

  y=LPPointVal(coef,TWO*(r/w)*(r/w)-ONE)
ENDFUNCTION ZPPointVal
!
!-------------------------------------------------------------------------------
!> @brief Returns value of an arbitrary order Zernike Polynomial with coefficients coef
!> @param coef  The coefficients of the Zernike expansion
!> @param a     The beginning of the integral range
!> @param b     The end of the integral range
!> @param h     The height of the node, OPTIONAL (if not provided a height of 1 is assumed)
!>
!> This routine returns the value of an arbitrary order Zernike expansion at a
!> specific point.
!>
FUNCTION ZPIntegral(coef,a,b,h) RESULT(y)
  REAL(SRK),INTENT(IN) :: coef(:)
  REAL(SRK),INTENT(IN) :: a
  REAL(SRK),INTENT(IN) :: b
  REAL(SRK),INTENT(IN),OPTIONAL :: h
  REAL(SRK) :: y
  ! Local variables
  REAL(SRK) :: w

  w=ONE

  IF(PRESENT(h)) w=h
  REQUIRE(ABS(b-a) <= w)

  y=LPIntegral(coef,TWO*(a/w)*(a/w)-ONE,TWO*(b/w)*(b/w)-ONE)
ENDFUNCTION ZPIntegral
!
!-------------------------------------------------------------------------------
!  Test Interfaces
!-------------------------------------------------------------------------------
SUBROUTINE testsetupP2P(TM,mesh_in,mesh_out)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: mesh_out(:)

  CALL setupP2P(TM,mesh_in,mesh_out)
ENDSUBROUTINE testsetupP2P
!
SUBROUTINE testsetupV2P(TM,mesh_in,mesh_out)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: mesh_out(:)

  CALL setupV2P(TM,mesh_in,mesh_out)
ENDSUBROUTINE testsetupV2P
!
SUBROUTINE testsetupC2C(TM,nmesh_in,nmesh_out)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  INTEGER(SIK),INTENT(IN) :: nmesh_in
  INTEGER(SIK),INTENT(IN) :: nmesh_out

  CALL setupC2C(TM,nmesh_in,nmesh_out)
ENDSUBROUTINE testsetupC2C
!
SUBROUTINE testsetupP2V_cart(TM,mesh_in,mesh_out)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: mesh_out(:)

  CALL setupP2V_cart(TM,mesh_in,mesh_out)
ENDSUBROUTINE testsetupP2V_cart
!
SUBROUTINE testsetupP2C_cart(TLS,mesh_in,minX,maxX)
  TYPE(LinearSolverType_Direct),INTENT(INOUT) :: TLS
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: minX
  REAL(SRK),INTENT(IN) :: maxX

  CALL setupP2C_cart(TLS,mesh_in,minX,maxX)
ENDSUBROUTINE testsetupP2C_cart
!
SUBROUTINE testsetupV2V_cart(TM,mesh_in,mesh_out)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: mesh_out(:)

  CALL setupV2V_cart(TM,mesh_in,mesh_out)
ENDSUBROUTINE testsetupV2V_cart
!
SUBROUTINE testsetupV2C_cart(TLS,mesh_in,minX,maxX)
  TYPE(LinearSolverType_Direct),INTENT(INOUT) :: TLS
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: minX
  REAL(SRK),INTENT(IN) :: maxX

  CALL setupV2C_cart(TLS,mesh_in,minX,maxX)
ENDSUBROUTINE testsetupV2C_cart
!
SUBROUTINE testsetupC2P_cart(TM,nmesh_in,mesh_out,minX,maxX)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  INTEGER(SIK),INTENT(IN) :: nmesh_in
  REAL(SRK),INTENT(IN) :: mesh_out(:)
  REAL(SRK),INTENT(IN) :: minX
  REAL(SRK),INTENT(IN) :: maxX

  CALL setupC2P_cart(TM,nmesh_in,mesh_out,minX,maxX)
ENDSUBROUTINE testsetupC2P_cart
!
SUBROUTINE testsetupC2V_cart(TM,nmesh_in,mesh_out,minX,maxX)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  INTEGER(SIK),INTENT(IN) :: nmesh_in
  REAL(SRK),INTENT(IN) :: mesh_out(:)
  REAL(SRK),INTENT(IN) :: minX
  REAL(SRK),INTENT(IN) :: maxX

  CALL setupC2V_cart(TM,nmesh_in,mesh_out,minX,maxX)
ENDSUBROUTINE testsetupC2V_cart
!
SUBROUTINE testsetupP2V_cyl(TM,mesh_in,mesh_out)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: mesh_out(:)

  CALL setupP2V_cyl(TM,mesh_in,mesh_out)
ENDSUBROUTINE testsetupP2V_cyl
!
SUBROUTINE testsetupP2C_cyl(TLS,mesh_in,maxR)
  TYPE(LinearSolverType_Direct),INTENT(INOUT) :: TLS
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: maxR

  CALL setupP2C_cyl(TLS,mesh_in,maxR)
ENDSUBROUTINE testsetupP2C_cyl
!
SUBROUTINE testsetupV2V_cyl(TM,mesh_in,mesh_out)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: mesh_out(:)

  CALL setupV2V_cyl(TM,mesh_in,mesh_out)
ENDSUBROUTINE testsetupV2V_cyl
!
SUBROUTINE testsetupV2C_cyl(TLS,mesh_in,maxR)
  TYPE(LinearSolverType_Direct),INTENT(INOUT) :: TLS
  REAL(SRK),INTENT(IN) :: mesh_in(:)
  REAL(SRK),INTENT(IN) :: maxR

  CALL setupV2C_cyl(TLS,mesh_in,maxR)
ENDSUBROUTINE testsetupV2C_cyl
!
SUBROUTINE testsetupC2P_cyl(TM,nmesh_in,mesh_out,maxR)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  INTEGER(SIK),INTENT(IN) :: nmesh_in
  REAL(SRK),INTENT(IN) :: mesh_out(:)
  REAL(SRK),INTENT(IN) :: maxR

  CALL setupC2P_cyl(TM,nmesh_in,mesh_out,maxR)
ENDSUBROUTINE testsetupC2P_cyl
!
SUBROUTINE testsetupC2V_cyl(TM,nmesh_in,mesh_out,maxR)
  REAL(SRK),ALLOCATABLE,INTENT(INOUT) :: TM(:,:)
  INTEGER(SIK),INTENT(IN) :: nmesh_in
  REAL(SRK),INTENT(IN) :: mesh_out(:)
  REAL(SRK),INTENT(IN) :: maxR

  CALL setupC2V_cyl(TM,nmesh_in,mesh_out,maxR)
ENDSUBROUTINE testsetupC2V_cyl
!
ENDMODULE MeshTransfer


SUBROUTINE leafno(daynum,gdde,lnarray,lncntr,lnpout,pchron,rowcntr,todayln,     &
                & yestln)
!
! the leafno subroutine is taken from phenologymms.  it calculates the
! number of leaves per day.
!
! debe rowcntr, todayln, yestln are used to print leaf number when the
! integer value has incremented.
!
IMPLICIT NONE
!
! Subroutine arguments
!
INTEGER :: daynum,lncntr,rowcntr
REAL :: gdde,pchron,todayln,yestln
REAL,DIMENSION(400,2) :: lnarray
REAL,DIMENSION(100,2) :: lnpout
!
! Local variables
!
INTEGER :: col,nextcol
INTEGER :: int
REAL :: ln
!
! debe changed dimensions of lnpout to (100,2) from (60,2)
! local variables

!     + + + argument definitions + + +
!     daynum - the integer version of day of year
!     gdde - the accumulated growing degree-days since emergence
!     lnarray - an array to hold the leaf number calculated for each day
!     lncntr - counter for the leafno subroutine
!     lnpout - an array to hold the leaf number when it changes to the
!              next whole number, i.e. the interger version of the real leaf
!              number
!     pchron - the number of growing degree-days required to produce another
!              leaf
!     rowcntr - a counter for the rows in an array
!     todayln - the value of the current day's leaf number
!     yestln - the value of yesterday's leaf number

!     + + + local variable definitions + + +
!     col - column number 1 in the arrays
!     ln - leaf number
!     nextcol - column number 2 in the arrays
!
! initialize variables
ln = 0.0           ! leaf number
col = 1            ! column number one
nextcol = 2        ! column number two

! fill arrays
ln = gdde/pchron          ! calculate leaf number for current day
lncntr = lncntr + 1         ! increment counter
lnarray(lncntr,col) = daynum          ! fill leaf number array
lnarray(lncntr,nextcol) = ln

 !set todayln to the value in the lnarray for today.
todayln = lnarray(lncntr,nextcol)

 ! fill leaf output array when the integer version of yesterday's leaf
 ! number is less than the integer version of today's leaf number

IF ((int(yestln)).LT.(int(todayln))) THEN
  IF (rowcntr.LT.101) THEN
     lnpout(rowcntr,col) = daynum
     lnpout(rowcntr,nextcol) = ln
  END IF
  rowcntr = rowcntr + 1
END IF
!
yestln = lnarray(lncntr,nextcol)
!
  !  print *, 'daynum = ', daynum, 'array counter = ', lncntr
END SUBROUTINE leafno

Project Documents/Source Code Original/Leafno.f90


    module mod_vectors
    use, intrinsic :: iso_fortran_env, only : sp=>real32, wp => real64, li => int64
    implicit none ( type, external )

    integer, parameter :: dims = 3

    enum, bind(c)
        enumerator :: x_axis
        enumerator :: y_axis
        enumerator :: z_axis
    end enum

    type vector
        real(wp) :: data(dims)
    contains
        procedure :: mag => v_mag
        procedure, pass :: write => v_write
        procedure, pass :: read => v_read
        generic, public :: write(formatted) => write
        generic, public :: read(formatted)  => read
    end type

    real(wp), parameter :: nan64 =  transfer(-2251799813685248_li, 1._wp)
    real(wp), parameter :: pi = 4d0*atan(1d0), deg = pi/180d0
    real(wp), parameter :: eye3(3,3) = reshape( &
        [1.0_wp, 0.0_wp, 0.0_wp, &
        0.0_wp, 1.0_wp, 0.0_wp, &
        0.0_wp, 0.0_wp, 1.0_wp],[3,3])
    type(vector), parameter :: o_ = vector([0.0_wp, 0.0_wp, 0.0_wp])
    type(vector), parameter :: i_ = vector([1.0_wp, 0.0_wp, 0.0_wp])
    type(vector), parameter :: j_ = vector([0.0_wp, 1.0_wp, 0.0_wp])
    type(vector), parameter :: k_ = vector([0.0_wp, 0.0_wp, 1.0_wp])

    interface eye
    procedure m_identity, m_elemental, a_elemental
    end interface
    interface null
    procedure m_null
    end interface

    interface norm2
    procedure v_mag
    end interface

    interface dot_product
    procedure v_dot
    end interface

    interface dot
    procedure v_dot
    end interface

    interface cross
    procedure a_cross_op, a_cross, v_cross_op, v_cross
    end interface
    interface operator (.x.)
    procedure a_cross_op, a_cross, v_cross_op, v_cross
    end interface

    interface matmul
    procedure :: v_mul_matrix_left !, v_mul_matrix_right
    end interface

    interface diag
    procedure a_diag, D_diag
    end interface
    interface inv
    procedure m_inv_3
    end interface
    interface solve
    procedure a_solve, a_solve2
    end interface

    interface vector
    procedure xyz_to_vector, axis_to_vector
    end interface

    interface assignment (=)
    procedure asgn_vector_from_array, asgn_array_from_vector
    end interface

    interface operator (+)
    procedure :: v_add
    end interface
    interface operator (-)
    procedure :: v_neg, v_sub
    end interface
    interface operator (*)
    procedure :: v_scale_left, v_scale_right
    end interface
    interface operator (/)
    procedure :: v_div
    end interface

    interface show
        procedure :: v_show
    end interface

    contains

    pure function i_null(n, index) result(non)
    integer, intent(in) :: n, index(:)
    integer, allocatable :: non(:)
    integer i, k, nk
    nk = size(index)
    k = 0
    allocate(non(n-nk))
    do i=1, n
        if ( any(index==i) ) then
        else
            k = k + 1
            non(k) = i
        end if
    end do
    end function

    pure function m_identity(n) result(A)
    integer, intent(in) :: n
    real(wp) :: A(n,n)
    integer :: i
    A = 0d0
    forall(i=1:n)
        A(i,i) = 1d0
    end forall
    end function

    pure function a_elemental(n,i) result(v)
    integer, intent(in) :: n, i
    real(wp) :: v(n)
    v = 0d0
    v(i) = 1d0
    end function

    pure function m_elemental(n,index) result(A)
    integer, intent(in) :: n, index(:)
    real(wp), allocatable :: A(:,:)
    integer :: i, nk
    nk = size(index)
    allocate(A(n, nk), source=0d0)
    do i=1, nk
        A(index(i),i) = 1d0
    end do
    end function

    pure function m_null(n, index) result(A)
    integer, intent(in) :: n, index(:)
    real(wp), allocatable:: A(:,:)
    integer, allocatable :: non(:)
    integer :: i, nk
    nk = size(index)
    non = i_null(n, index)
    allocate(A(n,n-nk), source=0d0)
    do i=1,n-nk
        A(non(i),i) = 1d0
    end do
    end function

    pure function a_cross(v_1, v_2) result(v_3)
    real(wp), intent(in) :: v_1(3), v_2(3)
    real(wp) :: v_3(3)
    v_3 = [ v_1(2)*v_2(3)-v_1(3)*v_2(2), &
        v_1(3)*v_2(1)-v_1(1)*v_2(3), &
        v_1(1)*v_2(2)-v_1(2)*v_2(1) ]
    end function

    pure function a_cross_op(v) result(vx)
    real(wp), intent(in) :: v(3)
    real(wp) :: vx(3,3)
    vx(1,:) = [0d0, -v(3), v(2)]
    vx(2,:) = [v(3), 0d0, -v(1)]
    vx(3,:) = [-v(2), v(1), 0d0]
    end function

    pure function a_mmoi(v) result(mm)
    real(wp), intent(in) :: v(3)
    real(wp) :: mm(3,3)
    mm(1,:) = [v(2)**2+v(3)**2, -v(1)*v(2), -v(1)*v(3)]
    mm(2,:) = [-v(1)*v(2), v(1)**2+v(3)**2, -v(2)*v(3)]
    mm(3,:) = [-v(1)*v(3), -v(2)*v(3), v(1)**2+v(2)**2]
    end function

    pure function a_mag(v) result(m)
    real(wp), intent(in) :: v(:)
    real(wp) :: m
    m = sqrt( sum( v**2 ))
    end function

    pure function a_dot(v, w) result(m)
    real(wp), intent(in) :: v(:), w(:)
    real(wp) :: m
    m = sum(v*w)
    end function

    pure function a_diag(v) result(D)
    real(wp), intent(in) :: v(:)
    real(wp),allocatable :: D(:,:)
    integer :: n, i
    n = size(v)
    allocate(D(n,n))
    D = 0d0
    forall(i=1:n)
        D(i,i) = v(i)
    end forall
    end function

    pure function D_diag(D) result(v)
    real(wp), intent(in) :: D(:,:)
    real(wp), allocatable :: v(:)
    integer :: n,i
    n = min(size(D,1),size(D,2))
    allocate(v(n))
    do i=1,n
        v(i) = D(i,i)
    end do
    end function

    pure function a_matmul(A, v) result(w)
    ! evaluate w = A*v
    real(wp), intent(in) :: A(:,:), v(:)
    real(wp) :: w(size(A,1))
    integer :: i
    do i=1,size(A,1)
        w(i) = sum(A(i,:)*v(:))
    end do
    end function

    pure function a_matmul2(v, A) result(w)
    ! evaluate w = v*A
    real(wp), intent(in) :: A(:,:), v(:)
    real(wp) :: w(size(A,2))
    integer :: i
    do i=1,size(A,2)
        w(i) = sum(v(:)*A(:,i))
    end do
    end function

    pure function m_inv_3(A) result(B)
    ! invert 3x3 matrix
    real(wp), intent(in) :: A(3,3)
    real(wp) :: B(3,3), d, t2, t3, t4, t7, t8, t9, t6
    t2 = A(1,1)*A(2,2)*A(3,3)
    t3 = A(1,2)*A(2,3)*A(3,1)
    t4 = A(1,3)*A(2,1)*A(3,2)
    t7 = A(1,1)*A(2,3)*A(3,2)
    t8 = A(1,2)*A(2,1)*A(3,3)
    t9 = A(1,3)*A(2,2)*A(3,1)
    d = t2+t3+t4-t7-t8-t9
    t6 = 1.0D0/d
    B(1,1) = t6*(A(2,2)*A(3,3)-A(2,3)*A(3,2))
    B(1,2) = -t6*(A(1,2)*A(3,3)-A(1,3)*A(3,2))
    B(1,3) = t6*(A(1,2)*A(2,3)-A(1,3)*A(2,2))
    B(2,1) = -t6*(A(2,1)*A(3,3)-A(2,3)*A(3,1))
    B(2,2) = t6*(A(1,1)*A(3,3)-A(1,3)*A(3,1))
    B(2,3) = -t6*(A(1,1)*A(2,3)-A(1,3)*A(2,1))
    B(3,1) = t6*(A(2,1)*A(3,2)-A(2,2)*A(3,1))
    B(3,2) = -t6*(A(1,1)*A(3,2)-A(1,2)*A(3,1))
    B(3,3) = t6*(A(1,1)*A(2,2)-A(1,2)*A(2,1))
    end function

    pure function a_solve(A, b) result(x)
    ! solve b = A*x for x
    real(wp), intent(in) :: A(3,3), b(3)
    real(wp) :: x(3), d, w(3)

    d = A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))+A(1,2)*(A(2,3)*A(3,1)-A(2,1)*A(3,3))+A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1))
    w = b/d
    x = [ &
        w(1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))+w(2)*(A(1,3)*A(3,2)-A(1,2)*A(3,3))+w(3)*(A(1,2)*A(2,3)-A(1,3)*A(2,2)), &
        w(1)*(A(2,3)*A(3,1)-A(2,1)*A(3,3))+w(2)*(A(1,1)*A(3,3)-A(1,3)*A(3,1))+w(3)*(A(1,3)*A(2,1)-A(1,1)*A(2,3)), &
        w(1)*(A(2,1)*A(3,2)-A(2,2)*A(3,1))+w(2)*(A(1,2)*A(3,1)-A(1,1)*A(3,2))+w(3)*(A(1,1)*A(2,2)-A(1,2)*A(2,1))]
    end function

    pure function a_solve2(A, B) result(x)
    ! solve b = A*x for x
    real(wp), intent(in) :: A(3,3), B(3,3)
    real(wp) :: x(3,3), d, w(3,3)
    integer :: i

    d = A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))+A(1,2)*(A(2,3)*A(3,1)-A(2,1)*A(3,3))+A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1))

    forall (i=1:3)
        w(:,i) = B(:,i)/d
        x(:,i) = [ &
            w(1,i)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))+w(2,i)*(A(1,3)*A(3,2)-A(1,2)*A(3,3))+w(3,i)*(A(1,2)*A(2,3)-A(1,3)*A(2,2)), &
            w(1,i)*(A(2,3)*A(3,1)-A(2,1)*A(3,3))+w(2,i)*(A(1,1)*A(3,3)-A(1,3)*A(3,1))+w(3,i)*(A(1,3)*A(2,1)-A(1,1)*A(2,3)), &
            w(1,i)*(A(2,1)*A(3,2)-A(2,2)*A(3,1))+w(2,i)*(A(1,2)*A(3,1)-A(1,1)*A(3,2))+w(3,i)*(A(1,1)*A(2,2)-A(1,2)*A(2,1))]
    end forall

    end function

    function a_rotate_x(v,q) result(u)
    real(wp), intent(in) :: v(3), q
    real(wp) :: u(3), cq, sq
    cq = cos(q)
    sq = sin(q)
    u = [ v(1), &
        cq*v(2)-sq*v(3), &
        sq*v(2)+cq*v(3)]
    end function
    function a_rotate_y(v,q) result(u)
    real(wp), intent(in) :: v(3), q
    real(wp) :: u(3), cq, sq
    cq = cos(q)
    sq = sin(q)
    u = [ cq*v(1)+sq*v(3), &
        v(2), &
        -sq*v(1)+cq*v(3)]
    end function
    function a_rotate_z(v,q) result(u)
    real(wp), intent(in) :: v(3), q
    real(wp) :: u(3), cq, sq
    cq = cos(q)
    sq = sin(q)
    u = [ cq*v(1)-sq*v(1), &
        sq*v(1)+cq*v(2), &
        v(3)]
    end function

    function m_mmul(A,x,b) result(y)
    !tex: Matrix vector calculation
    ! $$ y = A\,x + b $$
    ! or
    ! $$ y = A\,x  $$
    real(wp), intent(in) :: A(:,:), x(:)
    real(wp), intent(in), optional :: b(:)
    real(wp), allocatable :: y(:)
    if( present(b) ) then
        y = matmul(A,x)  + b
    else
        y = matmul(A,x)
    end if
    end function

    pure function axis_to_vector(axis) result(v)
    integer, intent(in) :: axis
    type(vector) :: v
    select case(axis)
    case(x_axis)
        v = i_
    case(y_axis)
        v = j_
    case(z_axis)
        v = k_
        case default
        v = o_
    end select
    end function

    pure function xyz_to_vector(x,y,z) result(v)
    real(wp), intent(in) :: x,y,z
    type(vector) :: v
    v%data = [x,y,z]
    end function

    pure subroutine asgn_vector_from_array(v, a)
    type(vector), intent(out) :: v
    real(wp), intent(in) :: a(dims)
    v%data = a
    end subroutine

    pure subroutine asgn_array_from_vector(a, v)
    real(wp), intent(out) :: a(dims)
    type(vector), intent(in) :: v
    a = v%data
    end subroutine

    elemental function v_mag(v) result(m)
    class(vector), intent(in) :: v
    real(wp) :: m
    m = norm2(v%data)
    end function

    elemental function v_dot(u,v) result(m)
    class(vector), intent(in) :: u,v
    real(wp) :: m
    m = dot_product(u%data, v%data)
    end function

    elemental function v_cross(u, v) result(w)
    class(vector), intent(in) :: u, v
    type(vector) :: w
    w%data = [ &
        u%data(2)*v%data(3) - u%data(3)*v%data(2), &
        u%data(3)*v%data(1) - u%data(1)*v%data(2), &
        u%data(1)*v%data(2) - u%data(2)*v%data(1) ]
    end function

    pure function v_cross_op(v) result(w)
    class(vector), intent(in) :: v
    real(wp) :: w(3,3)
    !     |  0 -z  y |
    ! w = |  z  0 -x |
    !     | -y  x  0 |
    w = reshape([ &
        0.0_wp, v%data(3), -v%data(2), &
        -v%data(1), 0.0_wp, v%data(1), &
        v%data(2), -v%data(1), 0.0_wp], [3,3])
    end function

    elemental function v_scale_left(f, v) result(w)
    real(wp), intent(in) :: f
    class(vector), intent(in) :: v
    type(vector) :: w
    w%data = f*v%data
    end function

    elemental function v_scale_right(v, f) result(w)
    class(vector), intent(in) :: v
    real(wp), intent(in) :: f
    type(vector) :: w
    w%data = f*v%data
    end function

    elemental function v_neg(v) result(w)
    class(vector), intent(in) :: v
    type(vector) :: w
    w%data = -v%data
    end function

    elemental function v_add(v, u) result(w)
    class(vector), intent(in) :: v, u
    type(vector) :: w
    w%data = v%data + u%data
    end function

    elemental function v_sub(v, u) result(w)
    class(vector), intent(in) :: v, u
    type(vector) :: w
    w%data = v%data + u%data
    end function

    elemental function v_div(v, f) result(w)
    class(vector), intent(in) :: v
    real(wp), intent(in) :: f
    type(vector) :: w
    w%data = v%data/f
    end function

    pure function v_mul_matrix_left(A, v) result(w)
    real(wp), intent(in) :: A(dims,dims)
    type(vector), intent(in) :: v
    type(vector) :: w
    w%data = matmul(A, v%data)
    end function

    subroutine v_write (v, unit, iotype, v_list, iostat, iomsg)
    class(vector), intent(in) :: v
    integer, intent(in) :: unit
    character(*), intent(in) :: iotype
    integer, intent(in)  :: v_list(:)
    integer, intent(out) :: iostat
    character(*), intent(inout) :: iomsg
    character(len=:), allocatable :: fmt
        if( iotype == 'LISTDIRECTED' ) then
            write (unit, *, iostat=iostat) v%data
        else
            fmt = '(a,' // iotype(3:) // ',a,' // iotype(3:) // ',a,' // iotype(3:) // ',a)'
            write (unit, fmt, iostat=iostat) "(",v%data(1),", ",v%data(2),", ",v%data(3),")"
        end if
    end subroutine

    subroutine v_read (v, unit, iotype, v_list, iostat, iomsg)
    class(vector), intent(inout) :: v
    integer, intent(in) :: unit
    character(*), intent(in) :: iotype
    integer, intent(in)  :: v_list(:)
    integer, intent(out) :: iostat
    character(*), intent(inout) :: iomsg
    character(len=:), allocatable :: fmt
        read (unit, *, iostat=iostat) v%data
    end subroutine

    subroutine v_show(label,vec,fmt)
    character(len=*), intent(in) :: label
    type(vector), intent(in) :: vec
    character(len=*), optional, intent(in) :: fmt
        if(present(fmt)) then
            print '(a,DT "' // fmt // '")', label, vec
        else
            print '(a,DT "g0")', label, vec
        end if
    end subroutine

    end module


Module Md_Constantes

Use Md_Types_Numeriques

Implicit none

! Constantes Mathematiques "simple precision"

Real(4),parameter :: Pi          = 3.141592654_sp, &
                      deux_Pi     = 6.283185307_sp, &
                      Pi_sur_2    = 1.570796327_sp, &
		      Pi_sur_4    = 0.7853981635_sp, &
                      sqrt_Pi     = 1.772453851_sp
Real(4),parameter :: e_ln        = 2.718281828_sp, &
                      ln_2        = .6931471806_sp, &
		      deux_ln_2   = 1.386294361_sp, &
		      sqrt_2_ln_2 = 1.177410022_sp, &
		      sqrt_2_sp   = 1.414213562_sp
Real(4),parameter :: eps = epsilon(1.0_4)
Real(4),parameter :: Infini = huge(1.0_4)

! Constantes Mathematiques "double precision"

Real(8),parameter :: Pi_dp         = 3.14159265358979323846264338328_dp, &
                      deux_Pi_dp    = 6.28318530717958647692528676656_dp, &
                      Pi_sur_2_dp   = 1.57079632679489661923132169164_dp, &
                      Pi_sur_4_dp   = 0.78539816339744830961566084582_dp, &
                      sqrt_Pi_dp    = 1.77245385090551602729816748334_dp
Real(8),parameter :: e_ln_dp       = 2.71828182845904523536028747135_dp, &
                      ln_2_dp       = .693147180559945309417232121458_dp, & ! pi**(3/2)
		      deux_ln_2_dp  = 1.38629436111989061883446424292_dp, &
		      sqrt_2_ln_2_dp = 1.17741002251547469101156932646_dp, &
		      sqrt_2_dp     = 1.41421356237310_dp
Real(8),parameter :: eps_dp        = epsilon(1.0_8)
Real(8),parameter :: Infini_dp     = huge(1.0_8)

! Constantes Physiques dans le systeme SI

Real(4),parameter :: c_lum_si_sp     = 2.997924580e8_sp         ! Vitesse de la lumiere [m*s^(-1)]
Real(8),parameter :: c_lum_si_dp     = 2.997924580e8_dp         ! Vitesse de la lumiere [m*s^(-1)]
Real(4),parameter :: R_mole_si       = 8.3144598_sp             ! Constante des gaz parfaits [J*mol^(-1)*K^(-1)] (NIST)
Real(4),parameter :: V_mol_bar_si    = 22.710981e-3_sp          ! Volume molaire d'un gaz parfait a 273.15 K et 1 bar [m^3 mol^(-1)]
Real(4),parameter :: V_mol_atm_si    = 22.413996e-3_sp          ! Volume molaire d'un gaz parfait a 273.15 K et 1 atm [m^3 mol^(-1)]
Real(4),parameter :: Losch_atm_si    = 2.686777489e25_sp        ! Nombre de Loschmidt pour 273.15 K et 101.325 kPa (=1 atm) [m^(-3)]
Real(4),parameter :: Losch_bar_si    = 2.651643269e25_sp        ! Nombre de Loschmidt pour 273.15 K et 100.000 kPa (=1 bar) [m^(-3)]
Real(4),parameter :: h_Planck_si     = 6.62606876e-34_sp        ! Constante de Planck [J*s]
Real(4),parameter :: k_Boltz_si      = 1.380662e-23_sp!1.3806503e-23_sp         ! Constante de Boltzmann [J*K^(-1)]
Real(4),parameter :: hP_sur_kB_si    = 0.47992746e-10_sp        ! Comme son nom l indique
Real(4),parameter :: G_gravit_si     = 6.67259e-11_sp           ! Constante de gravitation [m^3*kg^(-1)*s^(-2)]
Real(4),parameter :: amu             = 1.6605402e-27_sp         ! Unite de masse atomique [ kg ]

! Constantes Physiques dans le systeme cgs

Real(4),parameter :: c_lum_cgs       = 2.997924580e10_sp        ! Vitesse de la lumiere [cm*s^(-1)]
Real(4),parameter :: R_mole_cgs      = 8.3144598e+07_sp          ! Constante des gaz parfaits [erg.mole^(-1).K^(-1)]
Real(4),parameter :: V_mol_bar_cgs   = 22.710981e3_sp           ! Volume molaire d'un gaz parfait a 273.15 K et 1 bar [cm^3 mol^(-1)]
Real(4),parameter :: V_mol_atm_cgs   = 22.413996e3_sp           ! Volume molaire d'un gaz parfait a 273.15 K et 1 atm [cm^3 mol^(-1)]
Real(4),parameter :: Losch_atm_cgs   = 2.686777489e19_sp        ! Nombre de Loschmidt pour 273.15 K et 101.325 kPa (=1 atm) [cm^(-3)]
Real(4),parameter :: Losch_bar_cgs   = 2.651643269e19_sp        ! Nombre de Loschmidt pour 273.15 K et 100.000 kPa (=1 bar) [cm^(-3)]
Real(4),parameter :: h_Planck_cgs    = 6.62606876e-27_sp        ! Constante de Planck [erg*s]
Real(4),parameter :: k_Boltz_cgs     = 1.3806503e-16_sp         ! Constante de Boltzmann [erg*K^(-1)]
Real(4),parameter :: Masse_C12_cgs   = 1.66053873e-24_sp        ! Masse du Carbone 12
Real(4),parameter :: G_gravit_cgs    = 6.67259e-8_sp            ! Constante de gravitation [cm^3*g^(-1)*s^(-2)]

! Constantes Astronomiques

Real(8),parameter :: UA_m            = 149597870691.0_dp        ! Unite astronomique [km]
Real(4),parameter :: T_sky           = 2.735_sp                 ! Temperature cosmologique [ K ]
Real(4),parameter :: R_soleil_km     = 6.960e5_sp               ! Rayon equatorial solaire [km]
Real(4),parameter :: M_soleil_kg     = 1.9891e30_sp             ! Masse Soleil [kg]
Real(4),parameter :: M_terre_kg      = 5.9742e24_sp             ! Masse Terre [kg]

! Constantes diverses

Real(4),parameter :: Cte_Avogadro       = 6.02214199e23_sp         ! Constante d'Avogadro [mol^(-1)]
Real(4),parameter :: Convert_bar_atm    = 0.9869232863_sp          ! Convertit les bars en atm (par multiplication)
Real(4),parameter :: Convert_atm_bar    = 1.013249980_sp           ! Convertit les atm en bars (par multiplication)
Real(4),parameter :: Convert_mmHg_mbar  = 1.3332_sp                ! Convertit les mmHg en mbars (par multiplication)
Real(8),parameter :: Convert_deg_rad    = Pi_dp/180.0d0            ! Convertit les degrs en radians
Real(8),parameter :: Convert_rad_deg    = 180.0d0/Pi_dp            ! Convertit les radians en degrs
Real(8),parameter :: Convert_rad_arcsec = 648.0d3/Pi_dp            ! Convertit les radians en arcsec
Real(8),parameter :: Convert_arcsec_rad = Pi_dp/648.0d3            ! Convertit les radians en arcsec
Real(8),parameter :: T_std              = 273.15d0  	            ! Temperature standard [K]
Real(8),parameter :: p_std              = 101324.9980_dp 	    ! Pression standard [Pa]

! ---------------------------------------------------------------------------------------------
! Masses molculaires [kg] (Hanbook of Chemistry and Physics, 65eme edition, 1988)
! ---------------------------------------------------------------------------------------------
Real(4),parameter :: M_HD	  =  3.021933e-3_sp
Real(4),parameter :: M_H2O	  = 18.010565e-3_sp
Real(4),parameter :: M_HDO	  = 19.016740e-3_sp
Real(4),parameter :: M_H217O	  = 19.014782e-3_sp
Real(4),parameter :: M_H218O	  = 20.014810e-3_sp
Real(4),parameter :: M_CO	  = 27.994915e-3_sp
Real(4),parameter :: M_13CO	  = 28.998270e-3_sp
Real(4),parameter :: M_C17O	  = 28.999132e-3_sp
Real(4),parameter :: M_C18O	  = 29.999160e-3_sp
Real(4),parameter :: M_H2O2	  = 34.005480e-3_sp
Real(4),parameter :: M_NH3	  = 17.026549e-3_sp
Real(4),parameter :: M_PH3	  = 33.997237e-3_sp
Real(4),parameter :: M_O2	  = 31.989830e-3_sp
Real(4),parameter :: M_O3	  = 47.984745e-3_sp
Real(4),parameter :: M_HCN	  = 27.010899e-3_sp
Real(4),parameter :: M_HC15N	  = 28.007375e-3_sp
Real(4),parameter :: M_CH3OH	  = 32.026100e-3_sp
Real(4),parameter :: M_CS	  = 43.972100e-3_sp
Real(4),parameter :: M_C34S	  = 45.967080e-3_sp
Real(4),parameter :: M_OCS	  = 59.967000e-3_sp
Real(4),parameter :: M_HCO	  = 29.002740e-3_sp
Real(4),parameter :: M_CH4	  = 16.031300e-3_sp
Real(4),parameter :: M_HCl	  = 35.976678e-3_sp
Real(4),parameter :: M_H2S	  = 33.987721e-3_sp
Real(4),parameter :: M_CH3C2H    = 40.031300e-3_sp
Real(4),parameter :: M_H2	  =  2.015650e-3_sp
Real(4),parameter :: M_He	  =  4.002603e-3_sp

! ---------------------------------------------------------------------------------------------
! Elements et masses atomiques [amu] correspondantes
! ---------------------------------------------------------------------------------------------
Integer, parameter :: nmaxelem = 72           ! Maximum number of elements

Character(len=2), parameter :: element(nmaxelem) = (/'H ','He','Li','Be','B ','C ','N ','O ','F ','Ne','Na', &
                                                     'Mg','Al','Si','P ','S ','Cl','Ar','K ','Ca','Sc','Ti', &
						     'V ','Cr','Mn','Fe','Co','Ni','Cu','Zn','Ga','Ge','As', &
						     'Se','Br','Kr','Rb','Sr','Y ','Zr','Nb','Mo','Tc','Ru', &
						     'Rh','Pd','Ag','Cd','In','Sn','Sb','Te','I ','Xe','Cs', &
						     'Ba','Lu','Hf','Ta','W ','Re','Os','Ir','Pt','Au','Hg', &
						     'Tl','Pb','Bi','Po','At','Rn'/)
Real(8), parameter :: atomic_weight(nmaxelem) = (/1.00794d0, &    ! H  Z=1
                                                   4.002602d0, &   ! He Z=2
                                                   6.941d0, &      ! Li Z=3
                                                   9.012182d0, &   ! Be Z=4
                                                  10.811d0, &	   ! B  Z=5
                                                  12.0107d0, &     ! C  Z=6
                                                  14.0067d0, &     ! N  Z=7
                                                  15.9994d0, &     ! O  Z=8
                                                  18.9984032d0, &  ! F  Z=9
                                                  20.1797d0, &     ! Ne Z=10
                                                  22.98976928d0, & ! Na Z=11
                                                  24.3050d0, &     ! Mg Z=12
                                                  26.9815386d0, &  ! Al Z=13
                                                  28.0855d0, &     ! Si Z=14
                                                  30.973762d0, &   ! P  Z=15
                                                  32.065d0, &	   ! S  Z=16
                                                  35.453d0, &	   ! Cl Z=17
                                                  39.948d0, &	   ! Ar Z=18
                                                  39.0983d0, &     ! K  Z=19
                                                  40.078d0, &	   ! Ca Z=20
                                                  44.955912d0, &   ! Sc Z=21
                                                  47.867d0, &	   ! Ti Z=22
                                                  50.9415d0, &     ! V  Z=23
                                                  51.9961d0, &     ! Cr Z=24
                                                  54.938045d0, &   ! Mn Z=25
                                                  55.845d0, &	   ! Fe Z=26
                                                  58.933195d0, &   ! Co Z=27
                                                  58.6934d0, &     ! Ni Z=28
                                                  63.546d0, &	   ! Cu Z=29
                                                  65.38d0, &	   ! Zn Z=30
                                                  69.723d0, &	   ! Ga Z=31
                                                  72.64d0, &	   ! Ge Z=32
                                                  74.92160d0, &    ! As Z=33
                                                  78.96d0, &	   ! Se Z=34
                                                  79.904d0, &	   ! Br Z=35
                                                  83.798d0, &	   ! Kr Z=36
                                                  85.4678d0, &     ! Rb Z=37
                                                  87.62d0, &	   ! Sr Z=38
                                                  88.90585d0, &    ! Y  Z=39
                                                  91.224d0, &	   ! Zr Z=40
                                                  92.90638d0, &    ! Nb Z=41
                                                  95.96d0, &	   ! Mo Z=42
                                                  98.d0, &	   ! Tc Z=43
                                                 101.07d0, &	   ! Ru Z=44
                                                 102.90550d0, &    ! Rh Z=45
                                                 106.42d0, &	   ! Pd Z=46
                                                 107.8682d0, &     ! Ag Z=47
                                                 112.411d0, &	   ! Cd Z=48
                                                 114.818d0, &	   ! In Z=49
                                                 118.710d0, &	   ! Sn Z=50
                                                 121.760d0, &	   ! Sb Z=51
                                                 127.60d0, &	   ! Te Z=52
                                                 126.90447d0, &    ! I  Z=53
                                                 131.293d0, &	   ! Xe Z=54
                                                 132.9054519d0, &  ! Cs Z=55
                                                 137.327d0, &	   ! Ba Z=56
                                                 174.9668d0, &     ! Lu Z=71
                                                 178.49d0, &	   ! Hf Z=72
                                                 180.94788d0, &    ! Ta Z=73
                                                 183.84d0, &	   ! W  Z=74
                                                 186.207d0, &	   ! Re Z=75
                                                 190.23d0, &	   ! Os Z=76
                                                 192.217d0, &	   ! Ir Z=77
                                                 195.084d0, &	   ! Pt Z=78
                                                 196.966569d0, &   ! Au Z=79
                                                 200.59d0, &	   ! Hg Z=80
                                                 204.3833d0, &     ! Tl Z=81
                                                 207.2d0, &	   ! Pb Z=82
                                                 208.98040d0, &    ! Bi Z=83
                                                 209.d0, &	   ! Po Z=84
                                                 210.d0, &	   ! At Z=85
                                                 222.d0/)	   ! At Z=86

! ---------------------------------------------------------------------------------------------
! Abondances solaires (Lodders 2010)
! ---------------------------------------------------------------------------------------------
Real(8), parameter :: H_abund_dex = 12.0d0
Real(8), parameter :: O_abund_Sol_dex = 8.73d0
Real(8), parameter :: C_abund_Sol_dex = 8.39d0

End Module Md_Constantes


module poisson_3d_m

use mesh_fields_m

use, intrinsic :: iso_c_binding

implicit none

include 'fftw3.f03'

type, public :: poisson_3d_t

    type(mesh_t)            :: mesh
    complex(8), allocatable :: rhs(:,:,:)
    complex(8), allocatable :: psi(:,:,:)
    integer(8)              :: fw
    integer(8)              :: bw

end type poisson_3d_t

contains

subroutine init_poisson( poisson, mesh)

  type(poisson_3d_t)  :: poisson
  type(mesh_t)        :: mesh

  integer :: nx, ny, nz

  nx = mesh%nx
  ny = mesh%ny
  nz = mesh%nz

  allocate(poisson%rhs(nx,ny,nz))
  allocate(poisson%psi(nx,ny,nz))

  call dfftw_plan_dft_3d(poisson%fw, nx, ny, nz, poisson%rhs, poisson%psi, &
                         fftw_forward, fftw_estimate)

  call dfftw_plan_dft_3d(poisson%bw, nx, ny, nz, poisson%psi, poisson%rhs, &
                         fftw_backward, fftw_estimate)

end subroutine init_poisson

subroutine solve_poisson(poisson, fields)

  type(poisson_3d_t) :: poisson
  type(fields_3d_t)  :: fields

  integer  :: nx, ny, nz
  integer  :: ind_x, ind_y, ind_z
  real(8)  :: kx, ky, kz
  real(8)  :: dimx, dimy, dimz
  real(8)  :: pi
  integer  :: i, j, k

  pi = 4d0 * atan(1d0)

  nx = fields%mesh%nx
  ny = fields%mesh%ny
  nz = fields%mesh%nz

  dimx = fields%mesh%xmax - fields%mesh%xmin
  dimy = fields%mesh%ymax - fields%mesh%ymin
  dimz = fields%mesh%zmax - fields%mesh%zmin

  poisson%psi = cmplx(fields%rho(1:nx,1:ny,1:nz), 0d0, kind=8)

  call dfftw_execute_dft(poisson%fw, poisson%psi, poisson%rhs)

  do k=1,nz
      if (k<=nz/2) then
          ind_z = k-1
      else
          ind_z = -nz+(k-1)
      end if
      kz = 2d0 * pi * real(ind_z,8) / dimz
      do j=1,ny
          if (j<=ny/2) then
              ind_y = j-1
          else
              ind_y = -ny+(j-1)
          end if
          ky = 2d0 * pi * real(ind_y,8)  / dimy
          do i=1,nx
              if (i<=nx/2) then
                  ind_x = i-1
              else
                  ind_x = - nx+(i-1)
              end if
              kx = 2d0 * pi * real(ind_x,8)  / dimx
              if ( ind_x==0 .and. ind_y==0 .and. ind_z==0 ) then
                  poisson%rhs(i,j,k) = cmplx(0d0,0d0,kind=8)
              else
                  poisson%rhs(i,j,k) = -cmplx(0d0,kx,kind=8) * poisson%rhs(i,j,k) &
                          / cmplx(kx**2+ky**2+kz**2,0d0,kind=8)
              end if
         end do
      end do
  end do

  call dfftw_execute_dft( poisson%bw, poisson%rhs, poisson%psi )

  fields%e(1,1:nx,1:ny,1:nz) = real(poisson%psi)

  poisson%psi = cmplx(fields%rho(1:nx,1:ny,1:nz), 0d0, kind=8)

  call dfftw_execute_dft(poisson%fw, poisson%psi, poisson%rhs)

  do k=1,nz
      if (k<=nz/2) then
          ind_z = k-1
      else
          ind_z = -nz+(k-1)
      end if
      kz = 2d0 * pi * real(ind_z,8) / dimz
      do j=1,ny
          if (j<=ny/2) then
              ind_y = j-1
          else
              ind_y = -ny+(j-1)
          end if
          ky = 2d0 * pi * real(ind_y,8) / dimy
          do i=1,nx
              if (i<=nx/2) then
                  ind_x = i-1
              else
                  ind_x = - nx+(i-1)
              end if
              kx = 2d0 * pi * real(ind_x,8) / dimx
              if ( ind_x==0 .and. ind_y==0 .and. ind_z==0 ) then
                  poisson%rhs(i,j,k) = cmplx(0d0,0d0,kind=8)
              else
                  poisson%rhs(i,j,k) = -cmplx(0d0,ky,kind=8) * poisson%rhs(i,j,k) &
                                / cmplx(kx**2+ky**2+kz**2,0d0,kind=8)
              end if
          end do
    end do
  end do

  call dfftw_execute_dft( poisson%bw, poisson%rhs, poisson%psi )
  fields%e(2,1:nx,1:ny,1:nz) = real(poisson%psi, kind=8)

  poisson%psi = cmplx(fields%rho(1:nx,1:ny,1:nz), 0d0, kind=8)
  call dfftw_execute_dft(poisson%fw, poisson%psi, poisson%rhs)

  do k=1,nz
      if (k<=nz/2) then
          ind_z = k-1
      else
          ind_z = -nz+(k-1)
      endif
      kz = 2d0 * pi * real(ind_z,8) /dimz
      do j=1,ny
          if (j<=ny/2) then
              ind_y = j-1
          else
              ind_y = -ny+(j-1)
          endif
          ky = 2d0 * pi * real(ind_y,8) /dimy
          do i=1,nx
              if (i<=nx/2) then
                 ind_x = i-1
              else
                 ind_x = - nx+(i-1)
              end if
              kx = 2d0 * pi * real(ind_x,8) /dimx
              if ( ind_x==0 .and. ind_y==0 .and. ind_z==0 ) then
                  poisson%rhs(i,j,k) = cmplx(0d0,0d0,kind=8)
              else
                  poisson%rhs(i,j,k) = -cmplx(0d0,kz,kind=8) * poisson%rhs(i,j,k) &
                           / cmplx(kx**2+ky**2+kz**2,0d0,kind=8)
              end if
          end do
      end do
  enddo

  call dfftw_execute_dft( poisson%bw, poisson%rhs, poisson%psi )
  fields%e(3,1:nx,1:ny,1:nz) = real(poisson%psi, kind=8)

  !periodic boundary conditions

  fields%e(:,nx+1,:,:) = fields%e(:,1,:,:)
  fields%e(:,:,ny+1,:) = fields%e(:,:,1,:)
  fields%e(:,:,:,nz+1) = fields%e(:,:,:,1)

  fields%e = fields%e / real(nx*ny*nz,kind=8)

end subroutine solve_poisson

end module poisson_3d_m


SUBROUTINE EnforceCCZ4Constraints(luh)
    IMPLICIT NONE
    ! Argument list
    REAL, INTENT(INOUT)  :: luh(59)              ! numerical solution
    ! Local variables
    INTEGER :: i,j,k,l,iVar,iDim, iter
    REAL    :: Q(59)
    REAL    :: g_cov(3,3), det, g_contr(3,3), Aex(3,3), traceA, phi
    REAL    :: DD(3,3,3), traceDk
#if defined(CCZ4EINSTEIN) || defined(CCZ4GRMHD) || defined(CCZ4GRHD) || defined(CCZ4GRGPR)
    !
            Q = luh(:)
            !
            g_cov(1,1) = Q(1)
            g_cov(1,2) = Q(2)
            g_cov(1,3) = Q(3)
            g_cov(2,1) = Q(2)
            g_cov(2,2) = Q(4)
            g_cov(2,3) = Q(5)
            g_cov(3,1) = Q(3)
            g_cov(3,2) = Q(5)
            g_cov(3,3) = Q(6)
            ! This determinant should be close to unity, since we use the conformal decomposition
            det = (Q(1)*Q(4)*Q(6)-Q(1)*Q(5)**2-Q(2)**2*Q(6)+2*Q(2)*Q(3)*Q(5)-Q(3)**2*Q(4))
            g_contr(1,1) = (Q(4)*Q(6)-Q(5)**2)   / det
            g_contr(1,2) = -(Q(2)*Q(6)-Q(3)*Q(5))/ det
            g_contr(1,3) = (Q(2)*Q(5)-Q(3)*Q(4)) / det
            g_contr(2,1) = -(Q(2)*Q(6)-Q(3)*Q(5))/ det
            g_contr(2,2) = (Q(1)*Q(6)-Q(3)**2)   / det
            g_contr(2,3) = -(Q(1)*Q(5)-Q(2)*Q(3))/ det
            g_contr(3,1) = (Q(2)*Q(5)-Q(3)*Q(4)) / det
            g_contr(3,2) = -(Q(1)*Q(5)-Q(2)*Q(3))/ det
            g_contr(3,3) = (Q(1)*Q(4)-Q(2)**2)   / det
            !
            phi = det**(-1./6.)
            g_cov = phi**2*g_cov
            det = (g_cov(1,1)*g_cov(2,2)*g_cov(3,3)-g_cov(1,1)*g_cov(2,3)*g_cov(3,2)-g_cov(2,1)*g_cov(1,2)*g_cov(3,3)+g_cov(2,1)*g_cov(1,3)*g_cov(3,2)+g_cov(3,1)*g_cov(1,2)*g_cov(2,3)-g_cov(3,1)*g_cov(1,3)*g_cov(2,2))
            g_contr(1,1) =  (g_cov(2,2)*g_cov(3,3)-g_cov(2,3)*g_cov(3,2)) / det
            g_contr(1,2) = -(g_cov(1,2)*g_cov(3,3)-g_cov(1,3)*g_cov(3,2)) / det
            g_contr(1,3) = -(-g_cov(1,2)*g_cov(2,3)+g_cov(1,3)*g_cov(2,2))/ det
            g_contr(2,1) = -(g_cov(2,1)*g_cov(3,3)-g_cov(2,3)*g_cov(3,1)) / det
            g_contr(2,2) = (g_cov(1,1)*g_cov(3,3)-g_cov(1,3)*g_cov(3,1))  / det
            g_contr(2,3) = -(g_cov(1,1)*g_cov(2,3)-g_cov(1,3)*g_cov(2,1)) / det
            g_contr(3,1) = -(-g_cov(2,1)*g_cov(3,2)+g_cov(2,2)*g_cov(3,1))/ det
            g_contr(3,2) = -(g_cov(1,1)*g_cov(3,2)-g_cov(1,2)*g_cov(3,1)) / det
            g_contr(3,3) = (g_cov(1,1)*g_cov(2,2)-g_cov(1,2)*g_cov(2,1))  / det
            !
            Aex(1,1) = Q(7)
            Aex(1,2) = Q(8)
            Aex(1,3) = Q(9)
            Aex(2,1) = Q(8)
            Aex(2,2) = Q(10)
            Aex(2,3) = Q(11)
            Aex(3,1) = Q(9)
            Aex(3,2) = Q(11)
            Aex(3,3) = Q(12)
            !
            traceA = SUM(g_contr*Aex)
            !
            Aex = Aex - 1./3.*g_cov*traceA
            !
            luh( 1) = g_cov(1,1)
            luh( 2) = g_cov(1,2)
            luh( 3) = g_cov(1,3)
            luh( 4) = g_cov(2,2)
            luh( 5) = g_cov(2,3)
            luh( 6) = g_cov(3,3)
            !
            luh( 7) = Aex(1,1)
            luh( 8) = Aex(1,2)
            luh( 9) = Aex(1,3)
            luh(10) = Aex(2,2)
            luh(11) = Aex(2,3)
            luh(12) = Aex(3,3)
            !
            ! As suggested by our PRD referee, we also enforce the algebraic constraint that results from the first spatial derivative of the constraint
            ! det \tilde{\gamma}_ij = 0, which leads to
            !
            ! \tilde{\gamma}^{ij} D_kij = 0
            !
            ! and is thus a condition of trace-freeness on all submatrices D_kij for k=1,2,3.
            !
            DD(1,1,1)=Q(36)
            DD(1,1,2)=Q(37)
            DD(1,1,3)=Q(38)
            DD(1,2,1)=Q(37)
            DD(1,2,2)=Q(39)
            DD(1,2,3)=Q(40)
            DD(1,3,1)=Q(38)
            DD(1,3,2)=Q(40)
            DD(1,3,3)=Q(41)
            !
            DD(2,1,1)=Q(42)
            DD(2,1,2)=Q(43)
            DD(2,1,3)=Q(44)
            DD(2,2,1)=Q(43)
            DD(2,2,2)=Q(45)
            DD(2,2,3)=Q(46)
            DD(2,3,1)=Q(44)
            DD(2,3,2)=Q(46)
            DD(2,3,3)=Q(47)
            !
            DD(3,1,1)=Q(48)
            DD(3,1,2)=Q(49)
            DD(3,1,3)=Q(50)
            DD(3,2,1)=Q(49)
            DD(3,2,2)=Q(51)
            DD(3,2,3)=Q(52)
            DD(3,3,1)=Q(50)
            DD(3,3,2)=Q(52)
            DD(3,3,3)=Q(53)
            !!
            DO l = 1, 3
                traceDk = SUM(g_contr*DD(l,:,:))
                DD(l,:,:) = DD(l,:,:) - 1./3.*g_cov*traceDk
            ENDDO
            !
            luh(36) = DD(1,1,1)
            luh(37) = DD(1,1,2)
            luh(38) = DD(1,1,3)
            luh(39) = DD(1,2,2)
            luh(40) = DD(1,2,3)
            luh(41) = DD(1,3,3)
            !
            luh(42) = DD(2,1,1)
            luh(43) = DD(2,1,2)
            luh(44) = DD(2,1,3)
            luh(45) = DD(2,2,2)
            luh(46) = DD(2,2,3)
            luh(47) = DD(2,3,3)
            !
            luh(48) = DD(3,1,1)
            luh(49) = DD(3,1,2)
            luh(50) = DD(3,1,3)
            luh(51) = DD(3,2,2)
            luh(52) = DD(3,2,3)
            luh(53) = DD(3,3,3)
            !
#ifdef CCZ4GRHD
            !IF( Q(60) < 1e-6) THEN
            !    luh(61:63,i,j,k) = 0.0                  ! in the atmosphere, there is no velocity
            !ENDIF
#endif
            !

#endif
END SUBROUTINE EnforceCCZ4Constraints

program main
  implicit none
  REAL ::  Qwork(59), Qtest(59)
  integer::i,j, seed_size
  integer,allocatable :: seed(:)
  call random_seed() ! initialize with system generated seed
  call random_seed(size=seed_size) ! find out size of seed
  allocate(seed(seed_size))
  call random_seed(get=seed) ! get system generated seed
  seed=314159261
  call random_seed(put=seed) ! set current seed
  call random_seed(get=seed) ! get current seed
  deallocate(seed)           ! safe

  Qwork = (/2.03876392436862219348e+00,1.13327632951146378931e-17,1.13328125850752231240e-17,9.81163922513405450943e-01,7.28991960382758263436e-20,9.81163922513405450943e-01,1.60702820377219834924e-01,-2.51854521837995827255e-14,-2.51859943549822510890e-14,-7.58958825491163335819e-02,-1.66695209611466999131e-16,-7.58958825491163335819e-02,5.73443499779581738335e-04,3.01713236980058585601e-01,-5.73062863551328161271e-12,-5.73061639353499262517e-12,2.85203957292370774423e-02,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,2.33452764998758000026e-01,-4.17807322717328905611e-12,-4.17806121758503744557e-12,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,1.66029261165760388952e-01,3.52110122269561003271e-16,3.52110623323521089469e-16,-7.84114259822868420180e-02,-1.00892874234056400197e-18,-7.84114259822868420180e-02,-2.87874071850877923045e-12,-3.11299149429065573305e-16,4.67768108082361629111e-18,1.35940313205684060638e-12,-2.07569443609550208564e-18,1.35970991086859628736e-12,-2.87874063909529684826e-12,1.43318865709343599115e-18,-3.14548568405474184678e-16,1.35970993559255365097e-12,-2.04322863271445272127e-18,1.35940303232291987362e-12,2.34302828568053289615e-01,-9.50679857641236088217e-03,-7.99171325660463643947e-02,1.44427998332769005893e-12,1.44427998345849223420e-12,0.00000000000000000000e+00/)
  Qtest = (/2.03876392436862219348e+00,1.13327632951146378931e-17,1.13328125850752231240e-17,9.81163922513405450943e-01,7.28991960382758263436e-20,9.81163922513405450943e-01,1.60702820377219834924e-01,-2.51854521837995827255e-14,-2.51859943549822510890e-14,-7.58958825491163335819e-02,-1.66695209611466999131e-16,-7.58958825491163335819e-02,5.73443499779581738335e-04,3.01713236980058585601e-01,-5.73062863551328161271e-12,-5.73061639353499262517e-12,2.85203957292370774423e-02,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,2.33452764998758000026e-01,-4.17807322717328905611e-12,-4.17806121758503744557e-12,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,0.00000000000000000000e+00,1.66029261165760388952e-01,3.52110122269561003271e-16,3.52110623323521089469e-16,-7.84114259822868420180e-02,-1.00892874234056400197e-18,-7.84114259822868420180e-02,-2.87874071850877923045e-12,-3.11299149429065573305e-16,4.67768108082361629111e-18,1.35940313205684060638e-12,-2.07569443609550208564e-18,1.35970991086859628736e-12,-2.87874063909529684826e-12,1.43318865709343599115e-18,-3.14548568405474184678e-16,1.35970993559255365097e-12,-2.04322863271445272127e-18,1.35940303232291987362e-12,2.34302828568053289615e-01,-9.50679857641236088217e-03,-7.99171325660463643947e-02,1.44427998332769005893e-12,1.44427998345849223420e-12,0.00000000000000000000e+00/)

  !do i=1,100
      !call random_number(Qwork)
      !!do j=1,59
      !!Qtest(j) = Qwork(j)
      !!enddo
      !Qtest=Qwork

      CALL EnforceCCZ4Constraints(Qwork)
      do i = 1,59
      print*,i,Qwork(i)-Qtest(i)
      enddo
      print*,sum(Qwork-Qtest)
  !enddo
end program main


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

C=======================================================================
      SUBROUTINE INIGRD (FROM, TO, GRAD, NINT, NPTS, ARRAY)
C=======================================================================

C     INIGRD: Initialize array ARRAY with NPTS values.
C             values are calculated to have a gradient of GRAD
C             ranging from FROM to TO with NINT segments.

C --- FROM - IN - Minimum value of range
C --- TO   - IN - Maximum value of range
C --- GRAD - IN - Gradient
C --- NINT - IN - Number of intervals in range
C --- NPTS - IN - Number of points in range.  Can be less than NINT if
C                 do not need full range, but want gradient spacing
C                 based on full range.  Normally NPTS = NINT + 1
C --- ARRAY- OUT- Range of values

      REAL    ARRAY(NPTS)
      LOGICAL NOGRAD

      IF (FROM .EQ. TO  .OR. NINT .LE. 0) THEN
         CALL PRTERR ('PROGRAM',
     *      'invalid values passed to INIGRD')
         RETURN
      END IF

      NOGRAD = (ABS(GRAD - 1.0)/NINT .LE. 1.0e-7)

      IF (NOGRAD) THEN
         D3 = 1.0 / NINT
         DO 10 I=1, NPTS
            ARRAY(I) = D3 * (I-1)
   10    CONTINUE
      ELSE
         ARRAY(1) = 0.0
         D3 = (1.0 - GRAD) / (1.0 - GRAD**NINT)
         DO 20 I=2,NPTS
            ARRAY(I) = ARRAY(I-1) + D3 * GRAD**(I-2)
   20    CONTINUE
      END IF

      DO 30 I=1, NPTS
         ARRAY(I) = FROM + ARRAY(I) * (TO - FROM)
   30 CONTINUE

      RETURN
      END