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