! $Id$
!
! Earth System Modeling Framework
! Copyright (c) 2002-2025, University Corporation for Atmospheric Research,
! Massachusetts Institute of Technology, Geophysical Fluid Dynamics
! Laboratory, University of Michigan, National Centers for Environmental
! Prediction, Los Alamos National Laboratory, Argonne National Laboratory,
! NASA Goddard Space Flight Center.
! Licensed under the University of Illinois-NCSA License.
!
!==============================================================================
!
#define ESMF_FILENAME "ESMF_Regrid.F90"
!
!     ESMF  Regrid Module
      module ESMF_RegridMod
!
!==============================================================================
!
!------------------------------------------------------------------------------
! INCLUDES
#include "ESMF.h"
!==============================================================================
!BOPI
! !MODULE: ESMF_RegridMod - Regridding and interpolation
!
! !DESCRIPTION:
!
! The code in this file interfaces most of the Regrid class methods.  Regrid 
! is responsible for any regridding and interpolation required for ESMF 
! applications.
! Regridding includes any process that transforms a field from one ESMF
! igrid to another, including:
! \begin{itemize}
! \item bilinear or patch-recovery interpolation
! \end{itemize}
!
!------------------------------------------------------------------------------
! !USES:
      use ESMF_GridMod
      use ESMF_StaggerLocMod
      use ESMF_RHandleMod
      use ESMF_UtilTypesMod
      use ESMF_BaseMod          ! ESMF base class
      use ESMF_LogErrMod
      use ESMF_ArrayMod
      use ESMF_F90InterfaceMod
      use ESMF_MeshMod
      use ESMF_PointListMod

       implicit none

!------------------------------------------------------------------------------
! !PRIVATE TYPES:
      private

      ! temporarily store the weights while F90 arrays are alloc'ed
      type ESMF_TempWeights 
#ifndef ESMF_NO_SEQUENCE
        sequence
#endif
        type(ESMF_Pointer) :: this
      end type

      type ESMF_TempUDL 
#ifndef ESMF_NO_SEQUENCE
        sequence
#endif
        type(ESMF_Pointer) :: this
      end type

!------------------------------------------------------------------------------
! !PUBLIC TYPES:
!
!------------------------------------------------------------------------------


!
! !PUBLIC MEMBER FUNCTIONS:
!

    ! These are wrapper routines which call RegridStore to do the
    !  actual work.  Since all our routines are data centric methods
    !  and we are not exposing an externally visible "regrid" object, 
    !  these routines must exist to be consistent with the other interfaces.  
    ! 
    public ESMF_RegridStore
    public ESMF_RegridGetIwts
    public ESMF_RegridGetArea
    public ESMF_RegridGetFrac


! -------------------------- ESMF-public method -------------------------------
!BOPI


!
!EOPI
!------------------------------------------------------------------------------
! The following line turns the CVS identifier string into a printable variable.
      character(*), parameter, private :: version = &
          '$Id$'

!==============================================================================
!
! INTERFACE BLOCKS
!
!==============================================================================


!==============================================================================

      contains

function my_xor(a, b)
    logical                                       :: my_xor
    logical,                intent(in)         :: a
    logical,                intent(in)         :: b

    if (a .and. b) then
      my_xor = .false.
      return
    endif

    if (.not.(a .or. b)) then
      my_xor = .false.
      return
    endif

    my_xor = .true.

end function my_xor


!==============================================================================
!
! This section includes the Regrid Create, Run, and Destroy methods.
! 
!------------------------------------------------------------------------------

!------------------------------------------------------------------------------
#undef  ESMF_METHOD
#define ESMF_METHOD "ESMF_RegridStore"
!BOPI
! !IROUTINE: ESMF_RegridStore - Precomputes Regrid data

! !INTERFACE:
      subroutine ESMF_RegridStore(srcMesh, srcArray, srcPointList, src_pl_used, &
                 dstMesh, dstArray, dstPointList, dst_pl_used, &
                 regridmethod, &
                 lineType, &
                 normType, &
                 vectorRegrid, &
                 polemethod, regridPoleNPnts, &
                 hasStatusArray, &
                 statusArray, &
                 extrapMethod, &
                 extrapNumSrcPnts, &
                 extrapDistExponent, &
                 extrapNumLevels, &
                 extrapNumInputLevels, &
                 unmappedaction, &
                 ignoreDegenerate, &
                 srcTermProcessing, &
                 pipelineDepth, &
                 routehandle, &
                 indices, weights, &
                 transposeRoutehandle, &
                 unmappedDstList, &
                 checkFlag, &
                 rc)
!
! !ARGUMENTS:
      type(ESMF_Mesh), intent(inout)                         :: srcMesh
      type(ESMF_Array), intent(inout)                        :: srcArray
      type(ESMF_PointList), intent(inout)                    :: srcPointList
      logical, intent(in)                                    :: src_pl_used
      type(ESMF_Mesh), intent(inout)                         :: dstMesh
      type(ESMF_Array), intent(inout)                        :: dstArray
      type(ESMF_PointList), intent(inout)                    :: dstPointList
      logical, intent(in)                                    :: dst_pl_used
      type(ESMF_RegridMethod_Flag), intent(in)               :: regridmethod
      type(ESMF_LineType_Flag), intent(in)                   :: lineType
      type(ESMF_NormType_Flag), intent(in)                   :: normType
      logical, intent(in)                                    :: vectorRegrid
      type(ESMF_PoleMethod_Flag), intent(in)                 :: polemethod
      integer, intent(in)                                    :: regridPoleNPnts
      type(ESMF_ExtrapMethod_Flag),   intent(in)             :: extrapMethod
      integer, intent(in)                                    :: extrapNumSrcPnts
      real(ESMF_KIND_R8)                                     :: extrapDistExponent
      integer, intent(in)                                    :: extrapNumLevels
      integer, intent(in)                                    :: extrapNumInputLevels
      type(ESMF_UnmappedAction_Flag), intent(in), optional   :: unmappedaction
      logical, intent(in)                                    :: ignoreDegenerate
      integer,                       intent(inout), optional :: srcTermProcessing
      integer,                       intent(inout), optional :: pipelineDepth
      type(ESMF_RouteHandle),  intent(inout), optional       :: routehandle
      type(ESMF_RouteHandle),  intent(inout), optional       :: transposeRoutehandle
      integer(ESMF_KIND_I4), pointer, optional               :: indices(:,:)
      real(ESMF_KIND_R8), pointer, optional                  :: weights(:)
      integer(ESMF_KIND_I4),       pointer, optional         :: unmappedDstList(:)
      logical                                                :: hasStatusArray
      type(ESMF_Array)                                       :: statusArray
      logical                                                :: checkFlag
      integer,                  intent(  out), optional      :: rc
!
! !DESCRIPTION:
 !     The arguments are:
!     \begin{description}
 !     \item[srcGrid]
 !          The source grid.
!     \item[srcArray]
!          The source grid array.
!     \item[dstGrid]
!          The destination grid.
!     \item[dstArray]
!          The destination array.
!     \item[regridmethod]
!          The interpolation method to use.

!     \item [{[regridConserve]}]
!           Specifies whether to implement the mass conservation 
!           correction or not.  Options are 
!           {\tt ESMF\_REGRID_CONSERVE\_OFF} or 
!           {\tt ESMF\_REGRID_CONSERVE\_ON}. If not specified, defaults 
!           to {\tt ESMF\_REGRID_CONSERVE\_OFF}. 
!     \item [{[unmappedaction]}]
!           Specifies what should happen if there are destination points that
!           can't be mapped to a source cell. Options are 
!           {\tt ESMF\_UNMAPPEDACTION\_ERROR} or 
!           {\tt ESMF\_UNMAPPEDACTION\_IGNORE}. If not specified, defaults 
!           to {\tt ESMF\_UNMAPPEDACTION\_ERROR}. 
!     \item[routeHandle]
!          Handle to store the resulting sparseMatrix
!     \item [{[unmappedDstList]}] 
!           The list of the sequence indices for locations in {\tt dstField} which couldn't be mapped the {\tt srcField}. 
!           The list on each PET only contains the unmapped locations for the piece of the {\tt dstField} on that PET. 
!           If a destination point is masked, it won't be put in this list. 
!     \item[{rc}]
!          Return code.
!     \end{description}
!EOPI
       integer :: localrc
       integer :: has_rh, has_trh, has_iw, nentries
       type(ESMF_TempWeights) :: tweights
       integer :: has_udl, num_udl
       type(ESMF_TempUDL) :: tudl
       type(ESMF_RegridConserve) :: localregridConserve
       type(ESMF_UnmappedAction_Flag) :: localunmappedaction
       logical :: isMemFreed
       integer :: localIgnoreDegenerate
       integer :: src_pl_used_int, dst_pl_used_int
       integer ::  has_statusArrayInt
       integer :: checkFlagInt, vectorRegridInt


       ! Logic to determine if valid optional args are passed.  

        ! First thing to check is that indices <=> weights
        if (my_xor(present(indices), present(weights))) then
         localrc = ESMF_RC_ARG_BAD
         if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
           ESMF_CONTEXT, rcToReturn=rc)) return
       endif

       ! Next, we require that the user request at least something
       if (.not.(present(routehandle) .or. &
                 present(transposeRoutehandle) .or. &
                 present(indices))) then
         localrc = ESMF_RC_ARG_BAD
         if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
           ESMF_CONTEXT, rcToReturn=rc)) return
       endif

       ! **************************************************
        ! Tests passed, so proceed

       ! Initialize return code; assume failure until success is certain
       localrc = ESMF_RC_NOT_IMPL
       if (present(rc)) rc = ESMF_RC_NOT_IMPL

       has_rh = 0
        has_iw = 0
       has_udl=0
       if (present(routehandle)) has_rh = 1
       if (present(indices)) has_iw = 1
       if (present(unmappedDstList)) has_udl = 1

       ! Record if transpose routehandle is present
       has_trh = 0
       if (present(transposeRoutehandle)) has_trh = 1
       
       if (present(unmappedaction)) then
          localunmappedaction=unmappedaction
       else
          localunmappedaction=ESMF_UNMAPPEDACTION_ERROR
       endif

       if (ignoreDegenerate) then
          localIgnoreDegenerate=1
       else
          localIgnoreDegenerate=0
       endif

       if (.not. src_pl_used) then
         ! Make sure the srcMesh has its internal bits in place
         call ESMF_MeshGet(srcMesh, isMemFreed=isMemFreed, rc=localrc)
          if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
           ESMF_CONTEXT, rcToReturn=rc)) return

          if (isMemFreed)  then
             call ESMF_LogSetError(rcToCheck=ESMF_RC_OBJ_WRONG, & 
                   msg="- source Mesh has had its coordinate and connectivity info freed", & 
                   ESMF_CONTEXT, rcToReturn=rc) 
             return 
         endif
       endif


       if (.not. dst_pl_used) then
         ! Make sure the dstMesh has its internal bits in place
         call ESMF_MeshGet(dstMesh, isMemFreed=isMemFreed, rc=localrc)
         if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
           ESMF_CONTEXT, rcToReturn=rc)) return

          if (isMemFreed)  then
              call ESMF_LogSetError(rcToCheck=ESMF_RC_OBJ_WRONG, & 
                   msg="- dest Mesh has had its coordinate and connectivity info freed", & 
                   ESMF_CONTEXT, rcToReturn=rc) 
             return 
         endif
       endif

       ! Make used ints
       src_pl_used_int=0
       if (src_pl_used) then
          src_pl_used_int=1
       endif

       dst_pl_used_int=0
       if (dst_pl_used) then
          dst_pl_used_int=1
       endif

       ! Get statusArray if present and set appropriate flag
       has_statusArrayInt=0
       if (hasStatusArray) then
          has_statusArrayInt=1
       endif

       ! Covert checkFlag to int
       checkFlagInt=0
       if (checkFlag) checkFlagInt=1

       ! Covert vectorRegrid to int
       vectorRegridInt=0
       if (vectorRegrid) vectorRegridInt=1

        ! Call through to the C++ object that does the work
        call c_ESMC_regrid_create(srcMesh%this, srcArray, srcPointList, src_pl_used_int, &
                   dstMesh%this, dstArray, dstPointList, dst_pl_used_int, &
                   regridmethod,  &
                   lineType, &
                   normType, &
                   vectorRegridInt, & 
                   polemethod, regridPoleNPnts, &    
                   extrapMethod, &
                   extrapNumSrcPnts, &
                   extrapDistExponent, &
                   extrapNumLevels, &
                   extrapNumInputLevels, &
                   localunmappedaction%unmappedaction, &
                   localIgnoreDegenerate, &
                   srcTermProcessing, pipelineDepth, &
                   routehandle, has_rh, has_iw, &
                   nentries, tweights, &
                   transposeRoutehandle, has_trh, &
                   has_udl, num_udl, tudl, &
                   has_statusArrayInt, statusArray, &
                   checkFlagInt, &
                   localrc)

       if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
         ESMF_CONTEXT, rcToReturn=rc)) return
         
#ifdef C_SIDE_REGRID_FREE_MESH
! enabling this freature currently breaks several tests
       ! Mark Meshes as CMemFreed
       call C_ESMC_MeshSetIsFree(srcMesh)
       call C_ESMC_MeshSetIsFree(dstMesh)
#endif
       ! Now we must allocate the F90 pointers and copy weights
       if (present(indices)) then
         allocate(indices(2,nentries))
         allocate(weights(nentries))

         ! Copy weights if any exist
         if (nentries > 0)  then
            call c_ESMC_Copy_TempWeights(tweights, indices(1,1), weights(1))
         endif
       endif

       ! If unmappedDstList is present then we must allocate the F90 pointers and copy 
       if (present(unmappedDstList)) then
         allocate(unmappedDstList(num_udl))
         
         ! Copy unmapped dst locations if any exist
         if (num_udl > 0)  then
            call c_ESMC_Copy_TempUDL(num_udl, tudl, unmappedDstList(1))
         endif
       endif

       ! Mark routeHandle created
      if (present(routeHandle)) then 
        call ESMF_RouteHandleSetInitCreated(routeHandle, localrc)
        if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
         ESMF_CONTEXT, rcToReturn=rc)) return
      endif

      ! Mark transpose routeHandle created
      if (present(transposeRoutehandle)) then 
         call ESMF_RouteHandleSetInitCreated(transposeRoutehandle, localrc)
         if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
              ESMF_CONTEXT, rcToReturn=rc)) return
      endif
      
      rc = ESMF_SUCCESS
       end subroutine ESMF_RegridStore

!------------------------------------------------------------------------------
#undef  ESMF_METHOD
#define ESMF_METHOD "ESMF_RegridGetIwts"
!BOPI
! !IROUTINE: ESMF_RegridGetIwts - Gets the integration weights

! !INTERFACE:
      subroutine ESMF_RegridGetIwts(Grid, Mesh, Array, staggerLoc, &
           rc)
!
! !ARGUMENTS:
      type(ESMF_Grid), intent(inout)         :: Grid
      type(ESMF_Mesh), intent(inout)         :: Mesh
      type(ESMF_Array), intent(inout)        :: Array
      type(ESMF_StaggerLoc), intent(in)      :: staggerLoc
      integer, intent(out), optional         :: rc
!
! !DESCRIPTION:
!     The arguments are:
!     \begin{description}
!     \item[Mesh]
!          The mesh.
!     \item[Array]
!          The grid array.
!     \item[{rc}]
!          Return code.
!     \end{description}
!EOPI
       integer :: localrc
       logical :: isMemFreed

       ! Logic to determine if valid optional args are passed.  

       ! Initialize return code; assume failure until success is certain
       localrc = ESMF_RC_NOT_IMPL
       if (present(rc)) rc = ESMF_RC_NOT_IMPL

       ! Make sure the srcMesh has its internal bits in place
       call ESMF_MeshGet(Mesh, isMemFreed=isMemFreed, rc=localrc)
       if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
         ESMF_CONTEXT, rcToReturn=rc)) return

       if (isMemFreed)  then
           call ESMF_LogSetError(rcToCheck=ESMF_RC_OBJ_WRONG, & 
                 msg="- Mesh has had its coordinate and connectivity info freed", & 
                 ESMF_CONTEXT, rcToReturn=rc) 
          return 
       endif

       ! Call through to the C++ object that does the work
       call c_ESMC_regrid_getiwts(Grid, Mesh, Array, staggerLoc, &
                                   localrc)
       if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
         ESMF_CONTEXT, rcToReturn=rc)) return

      rc = ESMF_SUCCESS

      end subroutine ESMF_RegridGetIwts



!------------------------------------------------------------------------------
#undef  ESMF_METHOD
#define ESMF_METHOD "ESMF_RegridGetArea"
!BOPI
! !IROUTINE: ESMF_RegridGetArea - Gets the area of grid cells

! !INTERFACE:
      subroutine ESMF_RegridGetArea(Grid, Mesh, Array, staggerLoc, &
                  rc)
!
! !ARGUMENTS:
      type(ESMF_Grid), intent(inout)         :: Grid
      type(ESMF_Mesh), intent(inout)         :: Mesh
      type(ESMF_Array), intent(inout)        :: Array
      type(ESMF_StaggerLoc), intent(in)      :: staggerLoc
      integer, intent(out), optional         :: rc
!
! !DESCRIPTION:
!     The arguments are:
!     \begin{description}
!     \item[Mesh]
!          The mesh.
!     \item[Array]
!          The grid array.
!     \item[{rc}]
!          Return code.
!     \end{description}
!EOPI
       integer :: localrc
       logical :: isMemFreed

       ! Logic to determine if valid optional args are passed.  

       ! Initialize return code; assume failure until success is certain
       localrc = ESMF_RC_NOT_IMPL
       if (present(rc)) rc = ESMF_RC_NOT_IMPL

       ! Make sure the srcMesh has its internal bits in place
       call ESMF_MeshGet(Mesh, isMemFreed=isMemFreed, rc=localrc)
       if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
         ESMF_CONTEXT, rcToReturn=rc)) return

       if (isMemFreed)  then
           call ESMF_LogSetError(rcToCheck=ESMF_RC_OBJ_WRONG, & 
                 msg="- Mesh has had its coordinate and connectivity info freed", & 
                 ESMF_CONTEXT, rcToReturn=rc) 
          return 
       endif


       ! Call through to the C++ object that does the work
       call c_ESMC_regrid_getarea(Grid, Mesh, Array, staggerLoc, &
                                  localrc)
       if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
         ESMF_CONTEXT, rcToReturn=rc)) return


      rc = ESMF_SUCCESS

      end subroutine ESMF_RegridGetArea


!------------------------------------------------------------------------------
#undef  ESMF_METHOD
#define ESMF_METHOD "ESMF_RegridGetFrac"
!BOPI
! !IROUTINE: ESMF_RegridGetArea - Gets the frac of grid cells after a regrid from a Mesh

! !INTERFACE:
      subroutine ESMF_RegridGetFrac(Grid, Mesh, Array, staggerLoc, &
                 rc)
!
! !ARGUMENTS:
      type(ESMF_Grid), intent(inout)         :: Grid
      type(ESMF_Mesh), intent(inout)         :: Mesh
      type(ESMF_Array), intent(inout)        :: Array
      type(ESMF_StaggerLoc), intent(in)      :: staggerLoc
      integer, intent(out), optional         :: rc
!
! !DESCRIPTION:
!     The arguments are:
!     \begin{description}
!     \item[Mesh]
!          The mesh.
!     \item[Array]
!          The grid array.
!     \item[{rc}]
!          Return code.
!     \end{description}
!EOPI
       integer :: localrc
       logical :: isMemFreed

       ! Logic to determine if valid optional args are passed.  

       ! Initialize return code; assume failure until success is certain
       localrc = ESMF_RC_NOT_IMPL
       if (present(rc)) rc = ESMF_RC_NOT_IMPL

       ! Make sure the srcMesh has its internal bits in place
       call ESMF_MeshGet(Mesh, isMemFreed=isMemFreed, rc=localrc)
       if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
         ESMF_CONTEXT, rcToReturn=rc)) return

       if (isMemFreed)  then
           call ESMF_LogSetError(rcToCheck=ESMF_RC_OBJ_WRONG, & 
                 msg="- Mesh has had its coordinate and connectivity info freed", & 
                 ESMF_CONTEXT, rcToReturn=rc) 
          return 
       endif

       ! Call through to the C++ object that does the work
       call c_ESMC_regrid_getfrac(Grid, Mesh, Array, staggerLoc, &
                                  localrc)
       if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
         ESMF_CONTEXT, rcToReturn=rc)) return

      rc = ESMF_SUCCESS

      end subroutine ESMF_RegridGetFrac




   end module ESMF_RegridMod
