f_esmf_dynmaskcallbackr4r8r4 Subroutine

recursive subroutine f_esmf_dynmaskcallbackr4r8r4(routehandle, count, elementVector, countVector, totalCount, factorsVector, valuesVector, vectorL, rc)

Arguments

Type IntentOptional Attributes Name
type(ESMF_RouteHandle) :: routehandle
integer :: count
type(C_PTR) :: elementVector(count)
integer :: countVector(count)
integer :: totalCount
real(kind=ESMF_KIND_R8) :: factorsVector(totalCount)
type(C_PTR) :: valuesVector(totalCount)
integer :: vectorL
integer :: rc

Source Code

recursive subroutine f_esmf_dynmaskcallbackr4r8r4(routehandle, count, &
  elementVector, countVector, totalCount, factorsVector, valuesVector, &
  vectorL, rc)
  use ESMF_UtilTypesMod      ! ESMF utility types
  use ESMF_BaseMod           ! ESMF base class
  use ESMF_LogErrMod
  use ESMF_RHandleMod
  use ISO_C_BINDING
  implicit none
  ! dummy arguments
  type(ESMF_RouteHandle)        :: routehandle
  integer                       :: count
  type(C_PTR)                   :: elementVector(count)
  real(ESMF_KIND_R4), pointer   :: elementV(:)
  integer                       :: countVector(count)
  integer                       :: totalCount
  real(ESMF_KIND_R8)            :: factorsVector(totalCount)
  type(C_PTR)                   :: valuesVector(totalCount)
  real(ESMF_KIND_R4), pointer   :: value
  real(ESMF_KIND_R4), pointer   :: valueV(:)
  integer                       :: vectorL
  integer                       :: rc
  ! local variables
  integer                       :: localrc, i, ii, j, k, k_in, v
  type(ESMF_DynamicMaskStateWrpR4R8R4)   :: dynamicMaskState
  type(ESMF_DynamicMaskElementR4R8R4), pointer  :: dynamicMaskList(:)
  type(ESMF_DynamicMaskStateWrpR4R8R4V)  :: dynamicMaskStateV
  type(ESMF_DynamicMaskElementR4R8R4V), pointer :: dynamicMaskListV(:)

  ! Initialize return code; assume routine not implemented
  rc = ESMF_RC_NOT_IMPL

#if 0
  print *, "*** made it into f_esmf_dynmaskcallbackr4r8r4(), with count=", count
#endif

  ! access the dynamicMaskState that is stored inside the Routehandle
  nullify(dynamicMaskState%wrap)
  call c_ESMC_RouteHandleGetASR4R8R4(routehandle, dynamicMaskState, localrc)
  if (ESMF_LogFoundError(localrc, msg="Must provide dynamicMaskRoutine!", &
    ESMF_CONTEXT, rcToReturn=rc)) return

  ! look at typeKey to see what needs to be done
  if (dynamicMaskState%wrap%typeKey == "R4R8R4") then
    ! non-vector version
    ! prepare the dynamicMaskList
    if (vectorL==1) then
      ! no vectorization
      allocate(dynamicMaskList(count))
      k=1
      do i=1, count
        call C_F_POINTER(elementVector(i), dynamicMaskList(i)%dstElement)
        allocate(dynamicMaskList(i)%factor(countVector(i)))
        allocate(dynamicMaskList(i)%srcElement(countVector(i)))
        do j=1, countVector(i)
          dynamicMaskList(i)%factor(j) = factorsVector(k)
          call C_F_POINTER(valuesVector(k), value)
          dynamicMaskList(i)%srcElement(j) = value
          k = k+1
        enddo
      enddo
    else
      ! unroll the vector dimension
      allocate(dynamicMaskList(count*vectorL))
      k=1
      ii=1
      do i=1, count
        call C_F_POINTER(elementVector(i), elementV, (/vectorL/))
        k_in=k  ! need to come back to this k value several times
        do v=1, vectorL ! unrolling
          dynamicMaskList(ii)%dstElement => elementV(v)
          allocate(dynamicMaskList(ii)%factor(countVector(i)))
          allocate(dynamicMaskList(ii)%srcElement(countVector(i)))
          k=k_in  ! reset to the entrance value
          do j=1, countVector(i)
            dynamicMaskList(ii)%factor(j) = factorsVector(k)
            call C_F_POINTER(valuesVector(k), valueV, (/vectorL/))
            dynamicMaskList(ii)%srcElement(j) = valueV(v)
            k = k+1
          enddo
          ii = ii+1
        enddo
      enddo
    endif
    ! call into user provided routine to handle dynamically masked elements
    if (dynamicMaskState%wrap%dynamicSrcMaskIsPresent &
      .and. dynamicMaskState%wrap%dynamicDstMaskIsPresent) then
      call dynamicMaskState%wrap%routine(dynMaskList=dynamicMaskList, &
        dynamicSrcMaskValue=dynamicMaskState%wrap%dynamicSrcMaskValue, &
        dynamicDstMaskValue=dynamicMaskState%wrap%dynamicDstMaskValue, &
        rc=localrc)
    else if (dynamicMaskState%wrap%dynamicSrcMaskIsPresent) then
      call dynamicMaskState%wrap%routine(dynMaskList=dynamicMaskList, &
        dynamicSrcMaskValue=dynamicMaskState%wrap%dynamicSrcMaskValue, &
        rc=localrc)
    else if (dynamicMaskState%wrap%dynamicDstMaskIsPresent) then
      call dynamicMaskState%wrap%routine(dynMaskList=dynamicMaskList, &
        dynamicDstMaskValue=dynamicMaskState%wrap%dynamicDstMaskValue, &
        rc=localrc)
    else
      call dynamicMaskState%wrap%routine(dynMaskList=dynamicMaskList, &
        rc=localrc)
    endif
    ! local garbage collection before error handling to prevent memory leaks
    do i=1, size(dynamicMaskList)
      deallocate(dynamicMaskList(i)%factor)
      deallocate(dynamicMaskList(i)%srcElement)
    enddo
    deallocate(dynamicMaskList)
    ! error handling of call back into user routine
    if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
      ESMF_CONTEXT, rcToReturn=rc)) return
  else if (dynamicMaskState%wrap%typeKey == "R4R8R4V") then
    ! vector version -> use correct variables
    nullify(dynamicMaskStateV%wrap)
    call c_ESMC_RouteHandleGetASR4R8R4V(routehandle, dynamicMaskStateV, localrc)
    if (ESMF_LogFoundError(localrc, msg="Must provide dynamicMaskRoutine!", &
      ESMF_CONTEXT, rcToReturn=rc)) return
    ! prepare the dynamicMaskListV
    allocate(dynamicMaskListV(count))
    k=1
    do i=1, count
      call C_F_POINTER(elementVector(i), dynamicMaskListV(i)%dstElement, &
        (/vectorL/))
      allocate(dynamicMaskListV(i)%factor(countVector(i)))
      allocate(dynamicMaskListV(i)%srcElement(countVector(i)))
      do j=1, countVector(i)
        dynamicMaskListV(i)%factor(j) = factorsVector(k)
        call C_F_POINTER(valuesVector(k), &
          dynamicMaskListV(i)%srcElement(j)%ptr, (/vectorL/))
        k = k+1
      enddo
    enddo
    ! call into user provided routine to handle dynamically masked elements
    if (dynamicMaskStateV%wrap%dynamicSrcMaskIsPresent &
      .and. dynamicMaskStateV%wrap%dynamicDstMaskIsPresent) then
      call dynamicMaskStateV%wrap%routine(dynMaskList=dynamicMaskListV, &
        dynamicSrcMaskValue=dynamicMaskStateV%wrap%dynamicSrcMaskValue, &
        dynamicDstMaskValue=dynamicMaskStateV%wrap%dynamicDstMaskValue, &
        rc=localrc)
    else if (dynamicMaskStateV%wrap%dynamicSrcMaskIsPresent) then
      call dynamicMaskStateV%wrap%routine(dynMaskList=dynamicMaskListV, &
        dynamicSrcMaskValue=dynamicMaskStateV%wrap%dynamicSrcMaskValue, &
        rc=localrc)
    else if (dynamicMaskStateV%wrap%dynamicDstMaskIsPresent) then
      call dynamicMaskStateV%wrap%routine(dynMaskList=dynamicMaskListV, &
        dynamicDstMaskValue=dynamicMaskStateV%wrap%dynamicDstMaskValue, &
        rc=localrc)
    else
      call dynamicMaskStateV%wrap%routine(dynMaskList=dynamicMaskListV, &
        rc=localrc)
    endif
    ! local garbage collection before error handling to prevent memory leaks
    do i=1, count
      deallocate(dynamicMaskListV(i)%factor)
      deallocate(dynamicMaskListV(i)%srcElement)
    enddo
    deallocate(dynamicMaskListV)
    ! error handling of call back into user routine
    if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
      ESMF_CONTEXT, rcToReturn=rc)) return
  else
    call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_INCOMP, &
      msg="Inconsistency between the provided 'dynamicMaskRoutine' and "// &
      "actual data types.", &
      ESMF_CONTEXT, rcToReturn=rc)
    return
  endif

  ! return successfully
  rc = ESMF_SUCCESS

end subroutine f_esmf_dynmaskcallbackr4r8r4