StateSpecification.F90 Source File

#include "MAPL_Exceptions.h"
#include "MAPL_ErrLog.h"
module mapl_StateSpecification
   use ESMF
   use pFlogger
   use mapl_Constants
   use mapl_ErrorHandlingMod
   use mapl_VarSpecVector
   use mapl_VarSpecMiscMod
   use MAPL_VarSpecTypeMod
   implicit none

   private

   public :: StateSpecification
   public MAPL_VarSpecCreateInListNew
   public :: MAPL_VarSpecAddRefToList

   type :: StateSpecification
      type(VarSpecVector) :: var_specs
      type(MAPL_VarSpec), pointer :: old_var_specs(:) => null()
   contains
      procedure :: update_vector
      procedure :: update_legacy
   end type StateSpecification

interface MAPL_VarSpecAddRefToList
   module procedure MAPL_VarSpecAddRefFromItemNew
end interface

contains

   ! Possible memory leak.  Eliminate after refactoring
   subroutine update_vector(this)
      class(StateSpecification), target, intent(inout) :: this

      integer :: i, n

      call this%var_specs%clear()
      
      n = size(this%old_var_specs)
      do i = 1, n
         call this%var_specs%push_back(this%old_var_specs(i))
      end do
         
   end subroutine update_vector

   subroutine update_legacy(this)
      class(StateSpecification), target, intent(inout) :: this
      
      integer :: i, n

      if (associated(this%old_var_specs)) then
         do i = 1, size(this%old_var_specs)
            nullify(this%old_var_specs(i)%specPtr)
         end do
         deallocate(this%old_var_specs)
      endif
      n = this%var_specs%size()
      allocate(this%old_var_specs(n))
      do i = 1, n
         this%old_var_specs(i) = this%var_specs%of(i)
      end do
      
   end subroutine update_legacy

   function to_VarSpecPtr(var_spec_vector) result(spec_arr_ptr)
      type(MAPL_VarSpec), pointer :: spec_arr_ptr(:)
      type(VarSpecVector), target, intent(in) :: var_spec_vector

      integer :: i, n


      n = var_spec_vector%size()
      allocate(spec_arr_ptr(n))

      do i = 1, n
         spec_arr_ptr(i) = var_spec_vector%of(i)
      end do

   end function to_VarSpecPtr


  subroutine MAPL_VarSpecCreateInListNew(SPEC, SHORT_NAME, LONG_NAME,     &
                             UNITS,  Dims, VLocation, FIELD, BUNDLE, STATE, &
                             NUM_SUBTILES, &
                             STAT, ACCMLT_INTERVAL, COUPLE_INTERVAL, OFFSET, &
                             DEFAULT, FRIENDLYTO, &
                             HALOWIDTH, PRECISION, &
                             RESTART, &
                             ATTR_RNAMES, ATTR_INAMES, &
                             ATTR_RVALUES, ATTR_IVALUES, &
                             UNGRIDDED_DIMS, &
                             UNGRIDDED_UNIT, &
                             UNGRIDDED_NAME, &
                             UNGRIDDED_COORDS, &
                             FIELD_TYPE, &
                             STAGGERING, &
                             ROTATION,   & 
                             GRID, &
                             DEPENDS_ON, DEPENDS_ON_CHILDREN, &
                             POSITIVE, &
                                                                   RC  )

    type (StateSpecification), intent(inout):: SPEC
    character (len=*)               , intent(IN)      :: SHORT_NAME
    character (len=*)  , optional   , intent(IN)      :: LONG_NAME
    character (len=*)  , optional   , intent(IN)      :: UNITS
    character (len=*)  , optional   , intent(IN)      :: FRIENDLYTO
    integer            , optional   , intent(IN)      :: DIMS
    integer            , optional   , intent(IN)      :: VLOCATION
    integer            , optional   , intent(IN)      :: NUM_SUBTILES
    integer            , optional   , intent(IN)      :: ACCMLT_INTERVAL
    integer            , optional   , intent(IN)      :: COUPLE_INTERVAL
    integer            , optional   , intent(IN)      :: OFFSET
    integer            , optional   , intent(IN)      :: STAT
    real               , optional   , intent(IN)      :: DEFAULT
    type(ESMF_Field)   , optional   , intent(IN), target :: FIELD
    type(ESMF_FieldBundle)  , optional   , intent(IN), target :: BUNDLE
    type(ESMF_State)   , optional   , intent(IN), target :: STATE
    integer            , optional   , intent(IN)      :: HALOWIDTH
    integer            , optional   , intent(IN)      :: PRECISION
    integer            , optional   , intent(IN)      :: RESTART
    character (len=*)  , optional   , intent(IN)      :: ATTR_INAMES(:)
    character (len=*)  , optional   , intent(IN)      :: ATTR_RNAMES(:)
    integer            , optional   , intent(IN)      :: ATTR_IVALUES(:)
    real               , optional   , intent(IN)      :: ATTR_RVALUES(:)
    integer            , optional   , intent(IN)      :: UNGRIDDED_DIMS(:)
    character (len=*)  , optional   , intent(IN)      :: UNGRIDDED_UNIT
    character (len=*)  , optional   , intent(IN)      :: UNGRIDDED_NAME
    real               , optional   , intent(IN)      :: UNGRIDDED_COORDS(:)
    integer            , optional   , intent(IN)      :: FIELD_TYPE
    integer            , optional   , intent(IN)      :: STAGGERING
    integer            , optional   , intent(IN)      :: ROTATION
    type(ESMF_Grid)    , optional   , intent(IN)      :: GRID
    logical            , optional   , intent(IN)      :: DEPENDS_ON_CHILDREN
    character (len=*)  , optional   , intent(IN)      :: DEPENDS_ON(:)
    character(len=*)   , optional   , intent(IN)      :: positive
    integer            , optional   , intent(OUT)     :: RC



    integer                               :: STATUS

    type (MAPL_VarSpec)         :: TMP

    integer                    :: usableDIMS
    integer                    :: usableVLOC
    integer                    :: usableACCMLT
    integer                    :: usableCOUPLE
    integer                    :: usableOFFSET
    integer                    :: usableSTAT
    integer                    :: usableNUM_SUBTILES
    integer                    :: usableHALOWIDTH
    integer                    :: usablePRECISION
    integer                    :: usableFIELD_TYPE
    integer                    :: usableSTAGGERING
    integer                    :: usableROTATION
    integer                    :: usableRESTART
    character(len=ESMF_MAXSTR) :: usableLONG
    character(len=ESMF_MAXSTR) :: usableUNIT
    character(len=ESMF_MAXSTR) :: usableFRIENDLYTO
    character(len=ESMF_MAXSTR), pointer :: usableATTR_INAMES(:) => NULL()
    character(len=ESMF_MAXSTR), pointer :: usableATTR_RNAMES(:) => NULL()
    integer                   , pointer :: usableATTR_IVALUES(:) => NULL()
    real                      , pointer :: usableATTR_RVALUES(:) => NULL()
    integer                   , pointer :: usableUNGRIDDED_DIMS(:) => null()
    real                       :: usableDEFAULT
    type(ESMF_Grid)            :: usableGRID
    type(ESMF_Field), pointer  :: usableFIELD => null()
    type(ESMF_FieldBundle), pointer :: usableBUNDLE => null()
    type(ESMF_State), pointer  :: usableSTATE => null()
    character(len=ESMF_MAXSTR) :: useableUngrd_Unit
    character(len=ESMF_MAXSTR) :: useableUngrd_Name
    real                      , pointer :: usableUNGRIDDED_COORDS(:) => NULL()
    logical                    :: usableDEPENDS_ON_CHILDREN
    character(len=positive_length) :: usablePositive
!    character (len=:), allocatable :: usableDEPENDS_ON(:)

    INTEGER :: I
    integer :: szINAMES, szRNAMES, szIVALUES, szRVALUES
    integer :: szUNGRD
    logical :: defaultProvided


      if(present(STAT)) then
       usableSTAT=STAT
      else
       usableSTAT=MAPL_FieldItem !ALT: not sure if needs special attn for bundles
      endif
    
      if(present(ACCMLT_INTERVAL)) then
       usableACCMLT=ACCMLT_INTERVAL
      else
       usableACCMLT=0
      endif
    
      if(present(COUPLE_INTERVAL)) then
       usableCOUPLE=COUPLE_INTERVAL
      else
       usableCOUPLE=0
      endif
    
      if(present(OFFSET)) then
       usableOFFSET=OFFSET
      else
       usableOFFSET=0
      endif
    
      if(present(LONG_NAME)) then
       usableLONG=LONG_NAME
      else
       usableLONG=SHORT_NAME
      endif

      if(present(UNITS)) then
       usableUNIT=UNITS
      else
       usableUNIT=""
      endif

      if(present(FRIENDLYTO)) then
       usableFRIENDLYTO=FRIENDLYTO
       if (LEN(TRIM(FRIENDLYTO)) /= 0) then 
          usableSTAT = ior(usableSTAT,MAPL_FriendlyVariable)
       end if
      else
       usableFRIENDLYTO=""
      endif

      if(present(DIMS)) then
       usableDIMS=DIMS
      else
       usableDIMS=MAPL_DimsUnknown
      endif

      if(present(VLOCATION)) then
       usableVLOC=VLOCATION
      else
       usableVLOC=MAPL_VLocationNone
      endif

      if(present(NUM_SUBTILES)) then
       usableNUM_SUBTILES=NUM_SUBTILES
      else
       usableNUM_SUBTILES=0
      endif

      if(present(DEFAULT)) then
         defaultProvided=.true.
         usableDEFAULT=DEFAULT
      else
         defaultProvided=.false.
         usableDEFAULT=0.0 ! ALT: this could be NaN
!         usableDEFAULT=Z'7F800001' ! DSK: set to NaN, dies in FV Init
!         usableDEFAULT=-999. ! DSK
      endif

      if (present(FIELD_TYPE)) then
         usableFIELD_TYPE=FIELD_TYPE
      else
         usableFIELD_TYPE=MAPL_ScalarField 
      endif

      if (present(STAGGERING)) then
         usableSTAGGERING=STAGGERING
      else
         usableSTAGGERING=MAPL_AGrid
      endif

      if (present(ROTATION)) then
         usableROTATION=ROTATION
      else
         usableROTATION=MAPL_RotateLL
      endif

      if(present(GRID)) then
         usableGRID=GRID
      else
!         usableGRID = ESMF_GridEmptyCreate(RC=STATUS)
!         _VERIFY(STATUS)
!         call ESMF_GridDestroy(usableGRID) !ALT we do not need RC

         ! Initialize this grid object as invalid
         usableGrid%this = ESMF_NULL_POINTER
      endif

      if(present(FIELD)) then
         usableFIELD=>FIELD
      else
         allocate(usableFIELD, STAT=STATUS)
         _VERIFY(STATUS)
!         usableFIELD = ESMF_FieldEmptyCreate(NAME=SHORT_NAME,RC=STATUS)
!         _VERIFY(STATUS)
!         call ESMF_FieldDestroy(usableFIELD) !ALT we do not need RC

         ! Initialize this field object as invalid
         usableField%ftypep => NULL()
      endif

      if(present(BUNDLE)) then
         usableBUNDLE=>BUNDLE
      else
         allocate(usableBUNDLE, STAT=STATUS)
         _VERIFY(STATUS)
!         usableBUNDLE = ESMF_FieldBundleCreate(NAME=SHORT_NAME,RC=STATUS)
!         _VERIFY(STATUS)
!         call ESMF_FieldBundleDestroy(usableBUNDLE) !ALT we do not need RC

         ! Initialize this fieldBundle object as invalid
         usableBundle%this => NULL()
      endif

      if(present(STATE)) then
         usableSTATE=>STATE
      else
         allocate(usableSTATE, STAT=STATUS)
         _VERIFY(STATUS)
!         usableSTATE = ESMF_StateCreate(NAME=SHORT_NAME,RC=STATUS)
!         _VERIFY(STATUS)
!         call ESMF_StateDestroy(usableSTATE) !ALT we do not need RC

         ! Initialize this state object as invalid
         usableState%statep => NULL()
      endif

      if(present(HALOWIDTH)) then
       usableHALOWIDTH=HALOWIDTH
      else
       usableHALOWIDTH=0
      endif

      if(present(RESTART)) then
       usableRESTART=RESTART
      else
       usableRESTART=MAPL_RestartOptional ! default
      endif

      if(present(PRECISION)) then
       usablePRECISION=PRECISION
      else
       usablePRECISION=kind(0.0) ! default "real" kind
      endif

      usableDEPENDS_ON_CHILDREN = .false.
      if(present(DEPENDS_ON_CHILDREN)) then
         usableDEPENDS_ON_CHILDREN = DEPENDS_ON_CHILDREN
      end if

! Sanity checks
      if (usablePRECISION /= ESMF_KIND_R4 .AND. usablePRECISION /= ESMF_KIND_R8) then
         ! only those 2 values are allowed
         _RETURN(ESMF_FAILURE) 
      end if

      szRNAMES = 0
      if (present(ATTR_RNAMES)) then
         szRNAMES = size(ATTR_RNAMES)
         allocate(usableATTR_RNAMES(szRNAMES), stat=status)
         _VERIFY(STATUS)
         usableATTR_RNAMES = ATTR_RNAMES
      end if

      szINAMES = 0
      if (present(ATTR_INAMES)) then
         szINAMES = size(ATTR_INAMES)
         allocate(usableATTR_INAMES(szINAMES), stat=status)
         _VERIFY(STATUS)
         usableATTR_INAMES = ATTR_INAMES
      end if

      szRVALUES = 0
      if (present(ATTR_RVALUES)) then
         szRVALUES = size(ATTR_RVALUES)
         allocate(usableATTR_RVALUES(szRVALUES), stat=status)
         _VERIFY(STATUS)
         usableATTR_RVALUES = ATTR_RVALUES
      end if

      szIVALUES = 0
      if (present(ATTR_IVALUES)) then
         szIVALUES = size(ATTR_INAMES)
         allocate(usableATTR_IVALUES(szIVALUES), stat=status)
         _VERIFY(STATUS)
         usableATTR_IVALUES = ATTR_IVALUES
      end if
      _ASSERT(szIVALUES == szINAMES,'needs informative message')
      _ASSERT(szRVALUES == szRNAMES,'needs informative message')

      szUNGRD = 0
      if (present(UNGRIDDED_DIMS)) then
         szUNGRD = size(UNGRIDDED_DIMS)
         allocate(usableUNGRIDDED_DIMS(szUNGRD), stat=status)
         _VERIFY(STATUS)
         usableUNGRIDDED_DIMS = UNGRIDDED_DIMS
      else
         NULLIFY(usableUNGRIDDED_DIMS)
      end if

      if (present(UNGRIDDED_UNIT)) then
         useableUngrd_Unit = UNGRIDDED_UNIT
      else
         useableUngrd_Unit = "level" ! ALT: we are changing the default from "N/A" to "level" to make GrADS happy
      end if
      if (present(UNGRIDDED_NAME)) then
         useableUngrd_NAME = UNGRIDDED_NAME
      else
         useableUngrd_NAME = "N/A"
      end if

      szUNGRD = 0
      if (present(UNGRIDDED_COORDS)) then
         szUNGRD = size(UNGRIDDED_COORDS)
         allocate(usableUNGRIDDED_COORDS(szUNGRD), stat=status)
         _VERIFY(STATUS)
         usableUNGRIDDED_COORDS = UNGRIDDED_COORDS
      end if

      if (present(POSITIVE)) then
         usablePositive = positive
      else
         usablePositive = 'down'
      end if

      I = spec%var_specs%size()
      allocate(tmp%specptr)
      
      TMP%SPECPTR%SHORT_NAME =  SHORT_NAME
      TMP%SPECPTR%LONG_NAME  =  usableLONG
      TMP%SPECPTR%UNITS      =  usableUNIT
      TMP%SPECPTR%DIMS       =  usableDIMS
      TMP%SPECPTR%LOCATION   =  usableVLOC
      TMP%SPECPTR%NUM_SUBTILES = usableNUM_SUBTILES
      TMP%SPECPTR%STAT       =  usableSTAT
      TMP%SPECPTR%ACCMLT_INTERVAL  =  usableACCMLT
      TMP%SPECPTR%COUPLE_INTERVAL  =  usableCOUPLE
      TMP%SPECPTR%OFFSET     =  usableOFFSET
      TMP%SPECPTR%LABEL      =  0
      TMP%SPECPTR%DEFAULT    =  usableDEFAULT
      TMP%SPECPTR%defaultProvided = defaultProvided
      TMP%SPECPTR%FIELD      => usableFIELD
      TMP%SPECPTR%BUNDLE     => usableBUNDLE
      TMP%SPECPTR%STATE      => usableSTATE
      TMP%SPECPTR%GRID       =  usableGRID
      TMP%SPECPTR%FRIENDLYTO =  usableFRIENDLYTO
      TMP%SPECPTR%HALOWIDTH  =  usableHALOWIDTH
      TMP%SPECPTR%RESTART    =  usableRESTART
      TMP%SPECPTR%PRECISION  =  usablePRECISION
      TMP%SPECPTR%FIELD_TYPE =  usableFIELD_TYPE
      TMP%SPECPTR%UNGRIDDED_UNIT =  useableUngrd_Unit
      TMP%SPECPTR%UNGRIDDED_NAME =  useableUngrd_Name
      TMP%SPECPTR%STAGGERING =  usableSTAGGERING
      TMP%SPECPTR%ROTATION =  usableROTATION
      TMP%SPECPTR%doNotAllocate    =  .false.
      TMP%SPECPTR%alwaysAllocate   =  .false.
      TMP%SPECPTR%positive = usablePositive
      if(associated(usableATTR_IVALUES)) then
         TMP%SPECPTR%ATTR_IVALUES  =>  usableATTR_IVALUES
      else
         NULLIFY(TMP%SPECPTR%ATTR_IVALUES)
      endif
      if(associated(usableATTR_RVALUES)) then
         TMP%SPECPTR%ATTR_RVALUES  =>  usableATTR_RVALUES
      else
         NULLIFY(TMP%SPECPTR%ATTR_RVALUES)
      endif
      if(associated(usableUNGRIDDED_DIMS)) then
         TMP%SPECPTR%UNGRIDDED_DIMS  =>  usableUNGRIDDED_DIMS
      else
         NULLIFY(TMP%SPECPTR%UNGRIDDED_DIMS)
      endif
      if(associated(usableUNGRIDDED_COORDS)) then
         TMP%SPECPTR%UNGRIDDED_COORDS  =>  usableUNGRIDDED_COORDS
      else
         NULLIFY(TMP%SPECPTR%UNGRIDDED_COORDS)
      endif
      if(associated(usableATTR_RNAMES)) then
         TMP%SPECPTR%ATTR_RNAMES=>  usableATTR_RNAMES
      else
         NULLIFY(TMP%SPECPTR%ATTR_RNAMES)
      endif
      if(associated(usableATTR_INAMES)) then
         TMP%SPECPTR%ATTR_INAMES=>  usableATTR_INAMES
      else
         NULLIFY(TMP%SPECPTR%ATTR_INAMES)
      endif

      if(present(DEPENDS_ON)) then
         TMP%SPECPTR%DEPENDS_ON = DEPENDS_ON
      end if

      TMP%SPECPTR%DEPENDS_ON_CHILDREN    =  usableDEPENDS_ON_CHILDREN

      call spec%var_specs%push_back(tmp)
      call spec%update_legacy()

      _RETURN(ESMF_SUCCESS)

   end subroutine MAPL_VarSpecCreateInListNew

  subroutine MAPL_VarSpecAddRefFromItemNew(SPEC, ITEM, ALLOW_DUPLICATES, RC)

    type (StateSpecification)        :: SPEC
    type (MAPL_VarSpec ), intent(IN )     :: ITEM
    logical, optional   , intent(IN)      :: ALLOW_DUPLICATES
    integer, optional   , intent(OUT)     :: RC



    integer                               :: STATUS

    integer                               :: I
    logical                               :: usableALLOW_DUPLICATES
    class(Logger), pointer :: lgr
     

    if(present(ALLOW_DUPLICATES)) then
       usableALLOW_DUPLICATES=ALLOW_DUPLICATES
    else
       usableALLOW_DUPLICATES=.FALSE.
    endif


    if(.not.associated(ITEM%SPECPtr)) then
       _RETURN(ESMF_FAILURE)
    endif
    if (spec%var_specs%size() > 0) then
       if (.not. usableALLOW_DUPLICATES) then
          I = MAPL_VarSpecGetIndex(SPEC%old_var_specs, ITEM, RC=STATUS)
          _VERIFY(STATUS)
          if(I /= -1) then
             if (SPEC%old_var_specs(I) == ITEM) THEN
                if(present(RC)) then
                   RC=MAPL_DuplicateEntry
                end if
                return
             else
                lgr => logging%get_logger('MAPL.GENERIC')
                call lgr%error("Duplicate SHORT_NAME %a with different attributes.", trim(ITEM%SPECPtr%short_name))
                call MAPL_VarSpecPrint(ITEM)
                call MAPL_VarSpecPrint(SPEC%old_var_specs(I))
                _RETURN(ESMF_FAILURE)
             end if
          endif
       end if
    end if
      call spec%var_specs%push_back(item)
      call spec%update_legacy()

      _RETURN(ESMF_SUCCESS)


   end subroutine MAPL_VarSpecAddRefFromItemNew


end module mapl_StateSpecification