subroutine MAPL_StateCreateFromSpecNew(STATE,SPEC,DEFER,range, RC)
type(ESMF_State), intent(INOUT) :: STATE
type(StateSpecification), target, intent(inout) :: spec
logical, optional, intent(IN ) :: DEFER
integer, optional, intent(in) :: range(2)
integer, optional, intent( OUT) :: RC
character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_StateCreateFromSpecNew"
integer :: status
integer :: L
type (ESMF_Grid) :: GRID
type (ESMF_Array) :: Array
type (ESMF_Field) :: FIELD
type (ESMF_FieldBundle) :: BUNDLE
type (ESMF_Field) :: SPEC_FIELD
type (ESMF_FieldBundle) :: SPEC_BUNDLE
real(kind=ESMF_KIND_R4), pointer :: VAR_1D(:), VAR_2D(:,:), VAR_3D(:,:,:), VAR_4d(:,:,:,:)
real(kind=ESMF_KIND_R8), pointer :: VR8_1D(:), VR8_2D(:,:), VR8_3D(:,:,:), VR8_4D(:,:,:,:)
logical :: usableDEFER
logical :: deferAlloc
integer :: DIMS
integer :: STAT
integer :: KND
integer :: LOCATION
character(ESMF_MAXSTR):: SHORT_NAME
character(ESMF_MAXSTR):: LONG_NAME
character(ESMF_MAXSTR):: UNITS
character(ESMF_MAXSTR):: FRIENDLYTO
integer :: REFRESH
integer :: AVGINT
real :: DEFAULT_VALUE
integer :: I
logical :: done
integer :: N, N1, N2, NE
integer :: HW
integer :: RESTART
character(len=ESMF_MAXSTR), pointer :: ATTR_INAMES(:)
character(len=ESMF_MAXSTR), pointer :: ATTR_RNAMES(:)
integer, pointer :: ATTR_IVALUES(:)
real, pointer :: ATTR_RVALUES(:)
integer, pointer :: UNGRD(:)
integer :: attr
integer :: initStatus
logical :: defaultProvided
integer :: fieldRank
real(kind=ESMF_KIND_R8) :: def_val_8
type(ESMF_TypeKind_Flag) :: typekind
logical :: has_ungrd
logical :: doNotAllocate
logical :: alwaysAllocate
integer :: field_type
integer :: staggering
integer :: rotation
type(ESMF_State) :: SPEC_STATE
type(ESMF_State) :: nestSTATE
character(ESMF_MAXSTR) :: ungridded_unit
character(ESMF_MAXSTR) :: ungridded_name
real, pointer :: ungridded_coords(:)
integer :: szUngrd
integer :: rstReq
logical :: isPresent
logical :: isCreated
integer :: range_(2)
type(MAPL_VarSpec), pointer :: varspec
if (present(range)) then
range_ = range
else
range_(1) = 1
range_(2) = spec%var_specs%size()
end if
if (present(DEFER)) then
usableDEFER = DEFER
else
usableDEFER = .false.
end if
attr = 0
rstReq = 0
do L = range_(1), range_(2)
call MAPL_VarSpecGet(SPEC%var_specs%of(L),DIMS=DIMS,VLOCATION=LOCATION, &
SHORT_NAME=SHORT_NAME, LONG_NAME=LONG_NAME, UNITS=UNITS,&
FIELD=SPEC_FIELD, &
BUNDLE=SPEC_BUNDLE, &
STATE=SPEC_STATE, &
STAT=STAT, DEFAULT = DEFAULT_VALUE, &
defaultProvided = defaultProvided, &
FRIENDLYTO=FRIENDLYTO, &
COUPLE_INTERVAL=REFRESH, &
ACCMLT_INTERVAL=AVGINT, &
HALOWIDTH=HW, &
RESTART=RESTART, &
PRECISION=KND, &
ATTR_RNAMES=ATTR_RNAMES, &
ATTR_INAMES=ATTR_INAMES, &
ATTR_RVALUES=ATTR_RVALUES, &
ATTR_IVALUES=ATTR_IVALUES, &
UNGRIDDED_DIMS=UNGRD, &
UNGRIDDED_UNIT=UNGRIDDED_UNIT, &
UNGRIDDED_NAME=UNGRIDDED_NAME, &
UNGRIDDED_COORDS=UNGRIDDED_COORDS, &
GRID=GRID, &
doNotAllocate=doNotAllocate, &
alwaysAllocate=alwaysAllocate, &
FIELD_TYPE=FIELD_TYPE, &
STAGGERING=STAGGERING, &
ROTATION=ROTATION, &
RC=status )
_VERIFY(status)
I=MAPL_VarSpecGetIndex(SPEC%old_var_specs(range_(1):range_(2)), SHORT_NAME, RC=status)
if (I + (range_(1)-1) /= L) then
CALL WRITE_PARALLEL("===================>")
CALL WRITE_PARALLEL(trim(Iam) //": var "// trim(SHORT_NAME) // " already exists. Skipping ...")
cycle
endif
if (RESTART == MAPL_RestartRequired) then
rstReq = 1
end if
if (IAND(STAT, MAPL_StateItem) /= 0) then
isCreated = ESMF_StateIsCreated(SPEC_STATE, rc=status)
_VERIFY(status)
if (.not. isCreated) then
! Create an empty state
! ---------------------
nestState = ESMF_StateCreate(NAME=SHORT_NAME, RC=status)
_VERIFY(status)
else
nestState = SPEC_STATE
end if
varspec => spec%var_specs%of(L)
call MAPL_VarSpecSet(varspec,STATE=nestState,RC=status)
_VERIFY(status)
call ESMF_AttributeSet(nestState, NAME='RESTART', VALUE=RESTART, RC=status)
_VERIFY(status)
! Put the BUNDLE in the state
! --------------------------
call ESMF_StateAdd(STATE, (/nestState/), rc=status)
_VERIFY(status)
GOTO 10
endif
if (IAND(STAT, MAPL_BundleItem) /= 0) then
!ALT: logic needed for putting bundleptr (like bundle validate)
isCreated = ESMF_FieldBundleIsCreated(SPEC_BUNDLE, rc=status)
_VERIFY(status)
if (.not. isCreated) then
! Create an empty BUNDLE
! ----------------------
bundle = ESMF_FieldBundleCreate(NAME=SHORT_NAME, RC=status)
_VERIFY(status)
call ESMF_FieldBundleSet(bundle, GRID=GRID, RC=status)
_VERIFY(status)
else
BUNDLE = SPEC_BUNDLE
end if
varspec => SPEC%var_specs%of(L)
call MAPL_VarSpecSet(varspec,BUNDLE=BUNDLE,RC=status)
_VERIFY(status)
call ESMF_AttributeSet(BUNDLE, NAME='RESTART', VALUE=RESTART, RC=status)
_VERIFY(status)
! Put the BUNDLE in the state
! --------------------------
call MAPL_StateAdd(STATE, bundle, rc=status)
_VERIFY(status)
GOTO 10
! cycle
endif
if (DIMS == MAPL_DimsTileOnly .OR. DIMS == MAPL_DimsTileTile) then
ATTR = IOR(ATTR, MAPL_AttrTile)
else
ATTR = IOR(ATTR, MAPL_AttrGrid)
end if
deferAlloc = usableDefer
if (usableDefer) deferAlloc = .not. alwaysAllocate
!ALTcheck this call ESMF_FieldGet(SPEC_FIELD, Array=array, rc=status)
isCreated = ESMF_FieldIsCreated(SPEC_FIELD, rc=status)
_VERIFY(status)
if (isCreated) then
call MAPL_AllocateCoupling( SPEC_FIELD, RC=status ) ! if 'DEFER' this allocates the data
_VERIFY(status)
!ALT we are creating new field so that we can optionally change the name of the field;
! the important thing is that the data (ESMF_Array) is the SAME as the one in SPEC_Field
FIELD = MAPL_FieldCreate(SPEC_FIELD, name=SHORT_NAME, RC=status )
_VERIFY(status)
call ESMF_FieldGet(field, Array=array, rc=status)
_VERIFY(status)
call ESMF_AttributeGet(field, NAME="MAPL_InitStatus", isPresent=isPresent, RC=status)
_VERIFY(status)
if (isPresent) then
call ESMF_AttributeGet(field, NAME="MAPL_InitStatus", VALUE=initStatus, RC=status)
_VERIFY(status)
else
initStatus = MAPL_UnInitialized
end if
if (defaultProvided) then
! if the "original" field was initialized by reading a restart file do not overwrite
if (initStatus /= MAPL_InitialRestart) then
call ESMF_FieldGet(FIELD, typeKind=typeKind, dimCount=fieldRank, RC=status)
_VERIFY(status)
if (typeKind == ESMF_TYPEKIND_R4) then
if (fieldRank == 1) then
call ESMF_FieldGet(field, farrayPtr=var_1d, rc=status)
_VERIFY(status)
if (initStatus == MAPL_InitialDefault) then
if (any(var_1d /= default_value)) then
_RETURN(ESMF_FAILURE)
endif
end if
var_1d = default_value
initStatus = MAPL_InitialDefault
else if (fieldRank == 2) then
call ESMF_FieldGet(field, farrayPtr=var_2d, rc=status)
_VERIFY(status)
if (initStatus == MAPL_InitialDefault) then
if (any(var_2d /= default_value)) then
_RETURN(ESMF_FAILURE)
endif
end if
var_2d = default_value
initStatus = MAPL_InitialDefault
else if (fieldRank == 3) then
call ESMF_FieldGet(field, farrayPtr=var_3d, rc=status)
_VERIFY(status)
if (initStatus == MAPL_InitialDefault) then
if (any(var_3d /= default_value)) then
_RETURN(ESMF_FAILURE)
endif
end if
var_3d = default_value
initStatus = MAPL_InitialDefault
else if (fieldRank == 4) then
call ESMF_FieldGet(field, farrayPtr=var_4d, rc=status)
_VERIFY(status)
if (initStatus == MAPL_InitialDefault) then
if (any(var_4d /= default_value)) then
_RETURN(ESMF_FAILURE)
endif
end if
var_4d = default_value
initStatus = MAPL_InitialDefault
end if
else if (typeKind == ESMF_TYPEKIND_R8) then
def_val_8 = real(default_value,kind=ESMF_KIND_R8)
if (fieldRank == 1) then
call ESMF_FieldGet(field, farrayPtr=vr8_1d, rc=status)
_VERIFY(status)
if (initStatus == MAPL_InitialDefault) then
if (any(vr8_1d /= def_val_8)) then
_RETURN(ESMF_FAILURE)
endif
end if
vr8_1d = def_val_8
initStatus = MAPL_InitialDefault
else if (fieldRank == 2) then
call ESMF_FieldGet(field, farrayPtr=vr8_2d, rc=status)
_VERIFY(status)
if (initStatus == MAPL_InitialDefault) then
if (any(vr8_2d /= def_val_8)) then
_RETURN(ESMF_FAILURE)
endif
end if
vr8_2d = def_val_8
initStatus = MAPL_InitialDefault
else if (fieldRank == 3) then
call ESMF_FieldGet(field, farrayPtr=vr8_3d, rc=status)
_VERIFY(status)
if (initStatus == MAPL_InitialDefault) then
if (any(vr8_3d /= def_val_8)) then
_RETURN(ESMF_FAILURE)
endif
end if
vr8_3d = def_val_8
initStatus = MAPL_InitialDefault
else if (fieldRank == 4) then
call ESMF_FieldGet(field, farrayPtr=vr8_4d, rc=status)
_VERIFY(status)
if (initStatus == MAPL_InitialDefault) then
if (any(vr8_4d /= default_value)) then
_RETURN(ESMF_FAILURE)
endif
end if
vr8_4d = default_value
initStatus = MAPL_InitialDefault
end if
end if
call MAPL_AttributeSet(field, NAME="MAPL_InitStatus", &
VALUE=initStatus, RC=status)
_VERIFY(status)
end if
end if
else
! Create the appropriate ESMF FIELD
! ---------------------------------
field = MAPL_FieldCreateEmpty(name=SHORT_NAME, grid=grid, rc=status)
_VERIFY(status)
has_ungrd = associated(UNGRD)
if (.not. deferAlloc) then
!ALT we check if doNotAllocate is set only for fields that are not deferred
if (.not. doNotAllocate) then
if (has_ungrd) then
if (defaultProvided) then
call MAPL_FieldAllocCommit(field, dims=dims, location=location, typekind=knd, &
hw=hw, ungrid=ungrd, default_value=default_value, rc=status)
_VERIFY(status)
else
call MAPL_FieldAllocCommit(field, dims=dims, location=location, typekind=knd, &
hw=hw, ungrid=ungrd, rc=status)
_VERIFY(status)
endif
else
if (defaultProvided) then
call MAPL_FieldAllocCommit(field, dims=dims, location=location, typekind=knd, &
hw=hw, default_value=default_value, rc=status)
_VERIFY(status)
else
call MAPL_FieldAllocCommit(field, dims=dims, location=location, typekind=knd, &
hw=hw, rc=status)
_VERIFY(status)
end if
end if
else
call ESMF_AttributeSet(FIELD, NAME='doNotAllocate', VALUE=1, RC=status)
_VERIFY(status)
end if
else
call ESMF_AttributeSet(FIELD, NAME='PRECISION', VALUE=KND, RC=status)
_VERIFY(status)
call ESMF_AttributeSet(FIELD, NAME='DEFAULT_PROVIDED', &
value=defaultProvided, RC=status)
_VERIFY(status)
if (defaultProvided) then
call ESMF_AttributeSet(FIELD, NAME='DEFAULT_VALUE', &
value=default_value, RC=status)
_VERIFY(status)
end if
end if
! Put the FIELD in the MAPL FIELD (VAR SPEC)
! --------------------------------
! call MAPL_VarSpecSet(SPEC(L),FIELD=FIELD,RC=status)
! _VERIFY(status)
endif
varspec => SPEC%var_specs%of(L)
call MAPL_VarSpecSet(varspec,FIELD=FIELD,RC=status)
_VERIFY(status)
! and in the FIELD in the state
! --------------------------
call MAPL_StateAdd(STATE, field, rc=status)
_VERIFY(status)
if (deferAlloc) then
initStatus = MAPL_Uninitialized
else
if (defaultProvided) initStatus = MAPL_InitialDefault
end if
! Add SPECs to the FIELD
call ESMF_AttributeSet(FIELD, NAME='STAT', VALUE=STAT, RC=status)
_VERIFY(status)
call ESMF_AttributeSet(FIELD, NAME='DIMS', VALUE=DIMS, RC=status)
_VERIFY(status)
call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=LOCATION, RC=status)
_VERIFY(status)
call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE=LONG_NAME, RC=status)
_VERIFY(status)
call ESMF_AttributeSet(FIELD, NAME='UNITS', VALUE=UNITS, RC=status)
_VERIFY(status)
call ESMF_AttributeSet(FIELD, NAME='REFRESH_INTERVAL', VALUE=REFRESH, RC=status)
_VERIFY(status)
call ESMF_AttributeSet(FIELD, NAME='AVERAGING_INTERVAL', VALUE=AVGINT, RC=status)
_VERIFY(status)
call ESMF_AttributeSet(FIELD, NAME='HALOWIDTH', VALUE=HW, RC=status)
_VERIFY(status)
call ESMF_AttributeSet(FIELD, NAME='RESTART', VALUE=RESTART, RC=status)
_VERIFY(status)
call ESMF_AttributeSet(FIELD, NAME='FIELD_TYPE', VALUE=FIELD_TYPE, RC=status)
_VERIFY(status)
call ESMF_AttributeSet(FIELD, NAME='STAGGERING', VALUE=STAGGERING, RC=status)
_VERIFY(status)
call ESMF_AttributeSet(FIELD, NAME='ROTATION', VALUE=ROTATION, RC=status)
_VERIFY(status)
if (associated(UNGRD)) Then
call ESMF_AttributeSet(FIELD, NAME='UNGRIDDED_DIMS', valueList=UNGRD, RC=status)
_VERIFY(status)
call ESMF_AttributeSet(FIELD, NAME='UNGRIDDED_NAME', VALUE=UNGRIDDED_NAME, RC=status)
_VERIFY(status)
call ESMF_AttributeSet(FIELD, NAME='UNGRIDDED_UNIT', VALUE=UNGRIDDED_UNIT, RC=status)
_VERIFY(status)
if (associated(UNGRIDDED_COORDS)) then
szUngrd = size(ungridded_coords)
call ESMF_AttributeSet(FIELD, NAME='UNGRIDDED_COORDS', itemCount=szUngrd, &
valuelist=ungridded_coords, rc=status)
_VERIFY(status)
end if
end if
if (associated(ATTR_RNAMES)) then
DO N = 1, size(ATTR_RNAMES)
call ESMF_AttributeSet(FIELD, NAME=trim(ATTR_RNAMES(N)), &
VALUE=ATTR_RVALUES(N), RC=status)
_VERIFY(status)
END DO
end if
if (associated(ATTR_INAMES)) then
DO N = 1, size(ATTR_INAMES)
call ESMF_AttributeSet(FIELD, NAME=trim(ATTR_INAMES(N)), &
VALUE=ATTR_IVALUES(N), RC=status)
_VERIFY(status)
END DO
end if
10 if (FRIENDLYTO /= "") then
! parse the string for ":" word delimiters
done = .false.
n1 = 1
NE = len(FRIENDLYTO)
DO WHILE(.not. DONE)
N = INDEX(FRIENDLYTO(N1:NE), ':')
IF (N == 0) then
DONE = .TRUE.
N2 = NE
ELSE
N2 = N1 + N - 2
END IF
if (N1 <= N2 .and. N2 > 0) then
if (IAND(STAT, MAPL_BundleItem) /= 0) then
call ESMF_AttributeSet(BUNDLE, &
NAME='FriendlyTo'//trim(FRIENDLYTO(N1:N2)), &
VALUE=.TRUE., RC=status)
_VERIFY(status)
else
!print *,"DEBUG: setting FieldAttr:FriendlyTo"//trim(FRIENDLYTO(N1:N2))
call ESMF_AttributeSet(FIELD, &
NAME='FriendlyTo'//trim(FRIENDLYTO(N1:N2)), &
VALUE=.TRUE., RC=status)
_VERIFY(status)
end if
end if
N1 = N1 + N
END DO
end if
enddo
call ESMF_AttributeSet(STATE, NAME="MAPL_GridTypeBits", VALUE=ATTR, RC=status)
_VERIFY(status)
call ESMF_AttributeSet(STATE, NAME="MAPL_RestartRequired", VALUE=rstReq, RC=status)
_VERIFY(status)
_RETURN(ESMF_SUCCESS)
end subroutine MAPL_StateCreateFromSpecNew