subroutine interpret_descriptor_string(lstring, nstring, &
grid_rank, grid_order, grid_type, &
HaloL, HaloR, StaggerLoc, &
dist_rank, dist_order, dist_type, &
localrc)
!-----------------------------------------------------------------------------
! This routine parses a part ( either source or destination) of a problem
! descriptor string for for descriptions of the memory topology and rank,
! the grid rank, order, halo and stagger, and the distribution type, rank,
! and order. The routine assumes the string has beeen partitioned so that
! each memory slot is stored in an element of a character array.
!-----------------------------------------------------------------------------
! arguments
type(character_array), intent(in ) :: lstring(:)
integer, intent(in ) :: nstring
integer, intent( out) :: grid_rank, grid_order(:)
integer, intent( out) :: dist_rank, dist_order(:)
type(character_array), intent( out) :: grid_type(:), dist_type(:)
integer, intent( out) :: HaloL(:), HaloR(:)
integer, intent( out) :: StaggerLoc(:)
integer, intent( out) :: localrc
! local variables
character(THARN_MAXSTR) :: ltmp, lstagger, intstr
integer :: k, n, kstring, rank, halo, ndelim
integer :: iloc(1), mloc(1)
integer :: hbeg, hmid, hend, sbeg, send, slen
integer :: itmp, itmp_beg, itmp_end
integer, allocatable :: sdelim(:)
integer, allocatable :: assoc_grid(:)
integer :: allocRcToTest
!-----------------------------------------------------------------------------
! initialize return variable
!-----------------------------------------------------------------------------
localrc = ESMF_RC_NOT_IMPL
!-----------------------------------------------------------------------------
! work array
!-----------------------------------------------------------------------------
allocate( assoc_grid(nstring), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg=" type "// &
" assoc_grid in interpret descriptor string", rcToReturn=localrc)) then
endif
assoc_grid = 0
!-----------------------------------------------------------------------------
! Determine grid layout (rank and order)
!-----------------------------------------------------------------------------
grid_rank = 0
do kstring=1, nstring
rank = set_query(lstring(kstring)%string, 'GU')
if( rank == 0 ) then
! no associated grid
grid_type(kstring)%string = ' '
grid_order(kstring) = 0
elseif( rank == 1 ) then
! associated grid
grid_rank = grid_rank + rank
call set_locate(lstring(kstring)%string, 'GU', rank , mloc)
grid_type(kstring)%string = lstring(kstring)%string(mloc(1):mloc(1))
read( lstring(kstring)%string(mloc(1)+1:mloc(1)+1), *) grid_order(kstring)
! keep track of associated dimensions
assoc_grid( grid_order(kstring) ) = -1
halo = set_query(lstring(kstring)%string, 'H')
if( halo == 1 ) then
!-----------------------------------------------------------------------
! halo is specified, now check that the syntax is correct
!-----------------------------------------------------------------------
halo = set_query(lstring(kstring)%string, '{:}')
if( halo == 3 ) then
itmp = 1
call pattern_locate(lstring(kstring)%string, 'H{', itmp, iloc)
hbeg = iloc(1)
if( itmp /= 1) then
!syntax error in halo specification
call ESMF_LogSetError( ESMF_FAILURE, &
msg="halo specification missing prefix", &
rcToReturn=localrc)
return
endif
call set_locate(lstring(kstring)%string, ':', itmp, iloc)
hmid = iloc(1)
if( itmp /= 1) then
!syntax error in halo specification
call ESMF_LogSetError( ESMF_FAILURE, &
msg="halo specification missing separator", &
rcToReturn=localrc)
return
endif
call set_locate(lstring(kstring)%string, '}', itmp, iloc)
hend = iloc(1)
if( itmp /= 1) then
!syntax error in halo specification
call ESMF_LogSetError( ESMF_FAILURE, &
msg="halo specification missing suffix", &
rcToReturn=localrc)
return
endif
!-----------------------------------------------------------------
! halo syntax is correct, now read in the halo values as characters
! and convert then to integer values.
!-----------------------------------------------------------------
intstr = adjustL( lstring(kstring)%string(hmid-1:hbeg+2) )
read (intstr, *) HaloL(kstring)
intstr = adjustL( lstring(kstring)%string(hend-1:hmid+1) )
read (intstr, *) HaloR(kstring)
! drs begug
! currently halo must be symmetric and non-negative
if( HaloR(kstring) < 0 .or. HaloL(kstring) < 0 .or. &
HaloL(kstring) /= HaloR(kstring) ) &
call ESMF_LogSetError( ESMF_FAILURE, &
msg="halo specification "//trim(lstring(kstring)%string) // &
" is not symmetric and/or is negative ", &
rcToReturn=localrc)
return
else
! syntax error for halo specification
call ESMF_LogSetError( ESMF_FAILURE, &
msg="halo specification "//trim(lstring(kstring)%string), &
rcToReturn=localrc)
return
endif ! halo
elseif( halo == 0 ) then
! no halo
HaloL(kstring) = 0
HaloR(kstring) = 0
else
! syntax error for halo specification
HaloL(kstring) = 0
HaloR(kstring) = 0
call ESMF_LogSetError( ESMF_FAILURE, &
msg="halo specification wrong "//trim(lstring(kstring)%string), &
rcToReturn=localrc)
return
endif ! halo
else
! error multiple grid specifications for single memory location
call ESMF_LogSetError( ESMF_FAILURE, &
msg="multiple grid specifications for single memory location " // &
trim(lstring(kstring)%string), rcToReturn=localrc)
return
endif
enddo ! kstring
!-----------------------------------------------------------------------------
! fill in the sizes for the tensor dimensions
!-----------------------------------------------------------------------------
if( nstring > grid_rank ) then
n = nstring
do k=grid_rank+1, nstring
do while( assoc_grid(n) == -1 )
n = n-1
enddo ! while
grid_order(k) = n
enddo
endif
!-----------------------------------------------------------------------------
! initialize stagger location
!-----------------------------------------------------------------------------
do k=1,grid_rank
staggerloc(k) = 0
enddo
!-----------------------------------------------------------------------------
! determine if the stagger location is specified by the problem descriptor
! string. Look for trailing tag of the form "@{#,#,#}" following the
! closing "]". If it exists it will be placed in the memory_rank+1 element
! of the character array.
!-----------------------------------------------------------------------------
itmp_beg = pattern_query(lstring(nstring+1)%string, ']@{')
if( itmp_beg == 1 ) then
call pattern_locate( lstring(nstring+1)%string, ']@{', itmp_beg, iloc)
sbeg = iloc(1)
slen = len( trim( lstring(nstring+1)%string ) )
! extract the stagger substring for further parsing
ltmp = trim( adjustL( lstring(nstring+1)%string(sbeg+2:slen) ))
itmp_end = pattern_query(ltmp, '}')
if( itmp_end == 1 ) then
call pattern_locate( ltmp, '}', itmp_end, iloc )
send = iloc(1)
lstagger = trim( adjustL( ltmp(2:send) ))
! determine the number of entries
ndelim = pattern_query( lstagger, ',')
if( ndelim >= 1 .and. ndelim <= grid_rank-1 ) then
! identify the separate entries, check that they are not empty,
! and read the values
allocate( sdelim(ndelim), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg=" integer "// &
"variable sdelim in interpret descriptor string", &
rcToReturn=localrc)) then
endif
call pattern_locate( lstagger, ',', ndelim, sdelim)
if( sdelim(1)-1 >= 1) then
intstr = adjustL( lstagger( 1:sdelim(1)-1 ) )
read(intstr, *) staggerloc(1)
else
! specification empty
call ESMF_LogSetError( ESMF_FAILURE, &
msg="stagger location specification empty ", &
rcToReturn=localrc)
return
endif
do k=2,ndelim
if( sdelim(k)-1 > sdelim(k-1) ) then
intstr = adjustL( lstagger( sdelim(k-1)+1:sdelim(k)-1) )
read(intstr, *) staggerloc(k)
else
! specification empty
call ESMF_LogSetError( ESMF_FAILURE, &
msg="stagger location specification empty ", &
rcToReturn=localrc)
return
endif
enddo ! ndelim
send = len( trim( adjustL( lstagger ) ) )
if( send-1 >= sdelim(ndelim) ) then
intstr = adjustL( lstagger( send-1:sdelim(ndelim)+1 ) )
read(intstr, *) staggerloc(ndelim+1)
else
! specification empty
call ESMF_LogSetError( ESMF_FAILURE, &
msg="stagger location specification empty ", &
rcToReturn=localrc)
return
endif
! clean up workspace
deallocate( sdelim )
else
! wrong number of delimiters for grid rank
call ESMF_LogSetError( ESMF_FAILURE, &
msg="wrong number of delimiters for grid rank", &
rcToReturn=localrc)
return
endif ! number of delimiters
else
! error missing ending delimiter
call ESMF_LogSetError( ESMF_FAILURE, &
msg="missing stagger location ending delimitor from string", &
rcToReturn=localrc)
return
endif ! proper ending syntax
elseif( itmp_beg == 0 ) then
! no stagger assumption, assume cell center location
do k=1,grid_rank
staggerloc(k) = 0
enddo
else
! syntax error
call ESMF_LogSetError( ESMF_FAILURE, &
msg="problem descriptor string syntax error, strings ends with " // &
trim(lstring(nstring+1)%string), rcToReturn=localrc)
return
endif ! proper starting syntax
!-----------------------------------------------------------------------------
! check stagger location for acceptable values
!-----------------------------------------------------------------------------
do k=1,grid_rank
if( staggerloc(k) /= 0 .and. staggerloc(k) /= 1 ) then
! error invalid staggerlocs
call ESMF_LogSetError( ESMF_FAILURE, &
msg="invalid stagger locations from problem descriptor string", &
rcToReturn=localrc)
return
endif
enddo
!-----------------------------------------------------------------------------
! Determine Distribution layout (rank and order)
!-----------------------------------------------------------------------------
dist_rank = 0
do kstring=1, nstring
rank = set_query(lstring(kstring)%string, 'BCA')
if( rank == 0 ) then
! no associated distribution
dist_type(kstring)%string = ' '
dist_order(kstring) = 0
elseif( rank == 1 ) then
! associated grid
dist_rank = dist_rank + rank
call set_locate(lstring(kstring)%string, 'BCA', rank , mloc)
dist_type(kstring)%string = lstring(kstring)%string(mloc(1):mloc(1))
read( lstring(kstring)%string(mloc(1)+1:mloc(1)+1), *) dist_order(kstring)
else
! error multiple distribution specifications for single memory location
call ESMF_LogSetError( ESMF_FAILURE, &
msg="multiple distribution specifications in single memory" // &
"location", rcToReturn=localrc)
return
endif
enddo ! kstring
!-----------------------------------------------------------------------------
! clean up
!-----------------------------------------------------------------------------
deallocate( assoc_grid )
!-----------------------------------------------------------------------------
! if I've gotten this far without an error, then the routine has succeeded.
!-----------------------------------------------------------------------------
localrc = ESMF_SUCCESS
!-----------------------------------------------------------------------------
end subroutine interpret_descriptor_string