subroutine parse_descriptor_string(nstrings, pds, rc)
!-----------------------------------------------------------------------------
! Routine parses a problem descriptor string and extracts:
! operation - redistribution or regrid plus method
! rank of memory
! rank of distribution
! rank of grid association
! order of dist and grid
! type of dist or grid
!
! Upon completion, the routine returns the values to the harness record
! Harness%Record(*)%string(*)% for
!
! process%string character string of process
! process%tag numerical tag for process
!
! SrcMem%memRank rank of source memory block
! SrcMem%GridRank rank of source grid
! SrcMem%DistRank rank of source distribution
! SrcMem%GridType type of grid
! SrcMem%DistType type of distribution
! SrcMem%GridOrder order of grid elements with dimensions
! SrcMem%DistOrder order of distribution elements with dimensions
! SrcMem%HaloL Left halo size for each dimension
! SrcMem%HaloR Right halo size for each dimension
! SrcMem%StagLoc Stagger location for each dimension
! and the equivalent DstMem records.
!
!-----------------------------------------------------------------------------
! arguments
integer, intent(in ) :: nstrings
type(problem_descriptor_strings), intent(inout) :: pds
integer, intent( out) :: rc
! local character strings
character(THARN_MAXSTR) :: lstring, lname
character(THARN_MAXSTR) :: src_string, dst_string
type(character_array), allocatable :: lsrc(:), ldst(:)
type(character_array), allocatable :: grid_type(:), dist_type(:)
! logical :: flag = .true.
! local integer variables
integer :: k
integer :: tag, location(2)
integer :: dst_beg, dst_end, src_beg, src_end
integer :: srcMulti, dstMulti
integer :: srcBlock,dstBlock
integer :: src_mem_rank, dst_mem_rank
integer :: dist_rank, grid_rank
integer :: localrc
integer :: allocRcToTest
integer, allocatable :: grid_order(:), dist_order(:)
integer, allocatable :: grid_HaloL(:), grid_HaloR(:)
integer, allocatable :: grid_StagLoc(:)
! local logical variable
! logical :: endflag = .false.
! initialize return flag
rc = ESMF_RC_NOT_IMPL
localrc = ESMF_RC_NOT_IMPL
!-----------------------------------------------------------------------------
! parse the problem descriptor string
!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------
! search for the test operation
! 1. search for "->" or "=>" - tip of symbol provides ending address
! 2. back up until reach white space - provides begining address
! 3. src_beg = 1, src_end = operation_beg-1
! dst_beg = operation_end+1, dst_end = length(trim(string))
! 4. LOCATION provides a reference for later splitting the string into
! source and destination parts
!-----------------------------------------------------------------------------
lstring = trim(adjustL( pds%pds ) )
call process_query(lstring, lname, tag, location, localrc)
if( CheckError(checkpoint, __LINE__, __FILE__, localrc,"syntax error in problem descriptor" // &
" string " // trim(adjustL(lstring)), &
rcToReturn=rc) ) return
! store name (string) of operation and numerical code
pds%process%string = lname
pds%process%tag = tag
!-----------------------------------------------------------------------------
! separate the problem descriptor string into source and destination
! chunks to ease with parsing, but first determine if the problem
! descriptor string describes a multiple block memory structure
!-----------------------------------------------------------------------------
call memory_topology(lstring, location, srcMulti, srcBlock, &
dstMulti, dstBlock, localrc)
if( CheckError(checkpoint, __LINE__, __FILE__, localrc,"syntax error in problem descriptor" // &
" string " // trim(adjustL(lstring)), &
rcToReturn=rc) ) return
! a multiple block memory structure contains (), these are counted in
! srcMulti and dstMulti
if( (srcMulti >= 1).or.(dstMulti >= 1) ) then
! TODO break into multiple single block strings
! and parse each string separately
elseif( (srcMulti == 0).and.(dstMulti == 0) ) then
! single block memory structure
if( (srcBlock==1).and.(dstBlock==1) ) then
src_beg = 1
src_end = location(1)
dst_beg = location(2)
dst_end = len( trim(lstring) )
!-----------------------------------------------------------------------
! separate string into source and destination strings
!-----------------------------------------------------------------------
src_string = adjustL( lstring(src_beg:src_end) )
dst_string = adjustL( lstring(dst_beg:dst_end) )
!-----------------------------------------------------------------------
! check that the source and destination memory ranks are not empty
! and that the sizes agree
!-----------------------------------------------------------------------
src_mem_rank = pattern_query(src_string,';') + 1
pds%SrcMem%memRank = src_mem_rank
dst_mem_rank = pattern_query(dst_string,';') + 1
pds%DstMem%memRank = dst_mem_rank
if( (src_mem_rank == 0).or.(dst_mem_rank == 0).or. &
(src_mem_rank /= dst_mem_rank) ) then
localrc = ESMF_FAILURE
call ESMF_LogSetError(ESMF_FAILURE,msg="rank of memory block " &
// "symbols not properly paired", rcToReturn=rc)
return
endif
! test for common mistake of using commas instead of semicolons
if( pattern_query(dst_string,',') > 0 ) then
localrc = ESMF_FAILURE
call ESMF_LogSetError(ESMF_FAILURE,msg="syntax error - commas" &
// " are not valid deliminators", rcToReturn=rc)
return
endif
!-----------------------------------------------------------------------
! create work space for parsing the source descriptor string
!-----------------------------------------------------------------------
allocate( lsrc(src_mem_rank+1), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="type "// &
" lsrc in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( grid_order(src_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" grid_order in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( grid_type(src_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="char variable "// &
" grid_type in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( grid_HaloL(src_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" grid_HaloL in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( grid_HaloR(src_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" grid_HaloR in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( grid_StagLoc(src_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" grid_StagLoc in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( dist_order(src_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" dist_order in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( dist_type(src_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="char variable "// &
" dist_type in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( pds%SrcMem%GridType(src_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="char variable "// &
" GridType in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( pds%SrcMem%DistType(src_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="char variable "// &
" DistType in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( pds%SrcMem%GridOrder(src_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" GridOrder in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( pds%SrcMem%DistOrder(src_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" DistOrder in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( pds%SrcMem%HaloL(src_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" HaloL in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( pds%SrcMem%HaloR(src_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" HaloR in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( pds%SrcMem%StagLoc(src_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" StagLoc in parse_descriptor_string", rcToReturn=rc)) then
endif
!-----------------------------------------------------------------------
! partition the source descriptor string into separate parts which
! correspond to memory locations and parse the substrings for
! grid and distribution descriptions.
!-----------------------------------------------------------------------
call memory_separate( src_string, src_mem_rank, lsrc, localrc)
if( CheckError(checkpoint, __LINE__, __FILE__, localrc,"syntax error in SRC portion " // &
"of problem descriptor string - memory separate " // &
trim(adjustL(lstring)), rcToReturn=rc) ) return
call interpret_descriptor_string( lsrc, src_mem_rank, &
grid_rank, grid_order, grid_type, grid_HaloL, grid_HaloR, &
grid_StagLoc, dist_rank, dist_order, dist_type, localrc)
if( CheckError(checkpoint, __LINE__, __FILE__, localrc,"syntax error in SRC portion " // &
"of problem descriptor string - interpret string " // &
trim(adjustL(lstring)), rcToReturn=rc) ) return
pds%SrcMem%GridRank = grid_rank
pds%SrcMem%DistRank = dist_rank
do k=1,pds%SrcMem%memRank
pds%SrcMem%GridType(k)%string = grid_type(k)%string
pds%SrcMem%DistType(k)%string = dist_type(k)%string
pds%SrcMem%GridOrder(k) = grid_order(k)
! These are getting corrupted when tensor dimensions are specified
pds%SrcMem%DistOrder(k) = dist_order(k)
pds%SrcMem%HaloL(k) = grid_HaloL(k)
pds%SrcMem%HaloR(k) = grid_HaloR(k)
pds%SrcMem%StagLoc(k) = grid_StagLoc(k)
enddo
deallocate( lsrc )
deallocate( grid_order, grid_type, grid_HaloL, grid_HaloR )
deallocate( grid_StagLoc )
deallocate( dist_order, dist_type )
!-----------------------------------------------------------------------
! create work space for parsing the destination descriptor string
!-----------------------------------------------------------------------
allocate( ldst(dst_mem_rank+1), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="type "// &
" ldst in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( grid_order(dst_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" grid_order in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( grid_type(dst_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="char variable "// &
" grid_type in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( grid_HaloL(dst_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" grid_HaloL in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( grid_HaloR(dst_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" grid_HaloR in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( grid_StagLoc(dst_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" grid_StagLoc in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( dist_order(dst_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" dist_order in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( dist_type(dst_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="char variable "// &
" dist_type in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( pds%DstMem%GridOrder(dst_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" GridOrder in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( pds%DstMem%DistOrder(dst_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" DistOrder in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( pds%DstMem%GridType(dst_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="char variable "// &
" GridType in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( pds%DstMem%DistType(dst_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="char variable "// &
" DistType in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( pds%DstMem%HaloL(dst_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" HaloL in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( pds%DstMem%HaloR(dst_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" HaloR in parse_descriptor_string", rcToReturn=rc)) then
endif
allocate( pds%DstMem%StagLoc(dst_mem_rank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer variable "// &
" StagLoc in parse_descriptor_string", rcToReturn=rc)) then
endif
!-----------------------------------------------------------------------
! partition the destination descriptor string into separate parts
! which correspond to memory locations and parse the substrings
! for grid and distribution descriptions.
!-----------------------------------------------------------------------
call memory_separate( dst_string, dst_mem_rank, ldst, localrc)
if( CheckError(checkpoint, __LINE__, __FILE__, localrc,"syntax error in SRC portion " // &
"of problem descriptor string - memory separate " // &
trim(adjustL(lstring)), rcToReturn=rc) ) return
call interpret_descriptor_string( ldst, dst_mem_rank, &
grid_rank, grid_order, grid_type, grid_HaloL, grid_HaloR, &
grid_StagLoc, dist_rank, dist_order, dist_type, localrc)
if( CheckError(checkpoint, __LINE__, __FILE__, localrc,"syntax error in SRC portion " // &
"of problem descriptor string - interpret string " // &
trim(adjustL(lstring)), rcToReturn=rc) ) return
pds%DstMem%GridRank = grid_rank
pds%DstMem%DistRank = dist_rank
do k=1,pds%DstMem%memRank
pds%DstMem%GridType(k)%string = grid_type(k)%string
pds%DstMem%DistType(k)%string = dist_type(k)%string
pds%DstMem%GridOrder(k) = grid_order(k)
pds%DstMem%DistOrder(k) = dist_order(k)
pds%DstMem%HaloL(k) = grid_HaloL(k)
pds%DstMem%HaloR(k) = grid_HaloR(k)
pds%DstMem%StagLoc(k) = grid_StagLoc(k)
enddo
deallocate( ldst )
deallocate( grid_order, grid_type, grid_HaloL, grid_HaloR )
deallocate( grid_StagLoc )
deallocate( dist_order, dist_type )
else ! error does not conform to either single block or multiblock
localrc = ESMF_FAILURE
call ESMF_LogSetError(ESMF_FAILURE,msg="syntax error - problem " &
// " descriptor string does not conform to either " // &
"single block syntax or to multiblock syntax", &
rcToReturn=rc)
return
endif
else ! error does not conform to either single block or multiblock
localrc = ESMF_FAILURE
call ESMF_LogSetError(ESMF_FAILURE,msg="syntax error - problem " &
// " descriptor string does not conform to either " // &
"single block syntax or to multiblock syntax", &
rcToReturn=rc)
return
endif
!-----------------------------------------------------------------------------
! if I've gotten this far without an error, then the routine has succeeded.
!-----------------------------------------------------------------------------
rc = ESMF_SUCCESS
!-----------------------------------------------------------------------------
end subroutine parse_descriptor_string