subroutine read_dist_specification( nPEs, Dfile, DstMem, SrcMem, rc)
!-----------------------------------------------------------------------------
! routine to read the dist specifier files and populate the Dfile type
!
! each dist specifier entry contains:
! (0) discriptive string
! then for each dist rank
! (1) a divider tag (SRC, DST, END)
! (2) a series of size specifiers for each dimension (==, =+, =*)
! (3) a termination tag (END)
!-----------------------------------------------------------------------------
! arguments
integer, intent(in ) :: nPEs
type(dist_record), intent(inout) :: Dfile
type(memory_config), intent(in ) :: DstMem ! destination memory configuration
type(memory_config), intent(in ) :: SrcMem ! source memory configuration
integer, intent(inout) :: rc
! local esmf types
type(ESMF_Config) :: localcf
! local parameters
integer :: localrc ! local error status
type(character_array) :: pattern(7)
! local character strings
character(THARN_MAXSTR) :: ltmp, lchar, lnumb, ltag
character(THARN_MAXSTR) :: dtag
character(THARN_MAXSTR) :: distribution_label
type(character_array) :: lop(56) ! work space dimensioned 8*7 = max number
! of operators * maximum rank of distribution
type(character_array) :: loper(7,8) ! dimensioned 7x8 = rank of dist by # oper
! local reals
real(ESMF_KIND_R8) :: opv(56) ! work space dimensioned 8*7 = maximum number
! of operators * maximum rank of distribution
real(ESMF_KIND_R8) :: op_val(7,8) ! dimensioned 7x8 = rank of dist by # oper
real(ESMF_KIND_R8) :: tvalue
! local logical
logical :: flag
! local integer variables
integer :: ntmp, src_rank, dst_rank
integer :: irow, krow, nrows, idist, ndist, irank, erank
integer :: n, k, kelements
integer :: counter, sanity_counter, out_counter
integer, allocatable :: ncolumns(:), new_row(:)
integer :: numOp(8) ! dimensioned 8 = allowable number of operators
integer :: allocRcToTest
! initialize return flag
localrc = ESMF_RC_NOT_IMPL
rc = ESMF_RC_NOT_IMPL
! matching patterns
pattern(1)%string = "D1"
pattern(2)%string = "D2"
pattern(3)%string = "D3"
pattern(4)%string = "D4"
pattern(5)%string = "D5"
pattern(6)%string = "D6"
pattern(7)%string = "D7"
!-----------------------------------------------------------------------------
! open the distribution file
!-----------------------------------------------------------------------------
localcf = ESMF_ConfigCreate(rc=localrc)
if( ESMF_LogFoundError(localrc, msg="cannot create config object", &
rcToReturn=localrc) ) return
print*,'Opening Dist specifier file ',trim( Dfile%filename )
call ESMF_ConfigLoadFile(localcf, trim( Dfile%filename ), rc=localrc )
if( ESMF_LogFoundError(localrc, &
msg="cannot load config file " // trim( Dfile%filename ), &
rcToReturn=localrc) ) return
!----------------------------------------------------------------------------
! find the appropriate DistGrid specifier table for the SRC and DST DistRanks
!----------------------------------------------------------------------------
! create label "distgrid_block_ndmd" using DstMem%DistRank SrcMem%DistRank
10 format(i1,'d',i1,'d::')
write(ltmp,10) SrcMem%DistRank,DstMem%DistRank
distribution_label = "distgrid_block_" // trim(adjustL(ltmp))
if( debug_flag ) print*,' Dist Ranks ',DstMem%DistRank,SrcMem%DistRank, &
trim(distribution_label)
call ESMF_ConfigFindLabel(localcf, trim(distribution_label), rc=localrc )
if (localrc .ne. ESMF_SUCCESS) print*,' could not find distribution label'
if( ESMF_LogFoundError(localrc,msg="could not find distribution label " // &
trim(distribution_label), rcToReturn=rc) ) return
!-----------------------------------------------------------------------------
! determine the total number of table rows, continue only if not empty
! NOTE: the number of table rows >= number of dist entries due to the
! possibility of continued lines.
!-----------------------------------------------------------------------------
call ESMF_ConfigGetDim(localcf, nrows, ntmp, label=trim(distribution_label), &
rc=localrc)
if( ESMF_LogFoundError(localrc, &
msg="cannot get descriptor table size in file " // trim(Dfile%filename), &
rcToReturn=rc) ) return
if( nrows .le. 0 ) then
call ESMF_LogSetError(ESMF_FAILURE,msg="table "//trim(distribution_label) &
// " empty in file " //trim(Dfile%filename), rcToReturn=rc)
return
endif
!-----------------------------------------------------------------------------
! extract the table column lengths of this file
!-----------------------------------------------------------------------------
call ESMF_ConfigFindLabel(localcf, trim(distribution_label), rc=localrc )
if( ESMF_LogFoundError(localrc, &
msg="cannot find config label " // trim(distribution_label), &
rcToReturn=rc) ) return
allocate( ncolumns(nrows), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer array ncolumns in "// &
" read_dist_specification", rcToReturn=rc)) then
endif
do krow=1,nrows
call ESMF_ConfigNextLine(localcf, tableEnd=flag , rc=localrc)
if( ESMF_LogFoundError(localrc, &
msg="cannot advance to next line of table " // &
trim(distribution_label) // " in file " // trim(Dfile%filename), &
rcToReturn=rc) ) return
ncolumns(krow) = ESMF_ConfigGetLen(localcf, rc=localrc)
if (localrc .ne. ESMF_SUCCESS .or. ncolumns(krow) .lt. 1 ) then
write(lchar,"(i5)") krow
call ESMF_LogSetError( ESMF_FAILURE, &
msg="problem reading line " // trim(adjustl(lchar)) // &
" of table in file " // trim(Dfile%filename), rcToReturn=rc)
return
endif
enddo ! end krow
!-----------------------------------------------------------------------------
! determine the actual number of dist specifications in the file by counting
! lines not starting with the continuation symbol '&'. The number of actual
! specifications in the table is less than or equal to 'nrows', the number
! of rows in the table. A new grid entry in a particular row is indicated by
! a non-zero value in 'new_row'. A value of zero in the array indicates that
! that that row starts with a continiued line. The non-zero value indicates
! the number of the current grid being read.
!-----------------------------------------------------------------------------
call ESMF_ConfigFindLabel(localcf, trim(distribution_label), rc=localrc )
if( ESMF_LogFoundError(localrc,msg="cannot find config label " // &
trim(distribution_label),rcToReturn=rc) ) return
allocate( new_row(nrows), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer array new_row "// &
" in read_dist_specification", rcToReturn=rc)) then
endif
!-----------------------------------------------------------------------------
! count the number of actual grids (less than or equal to number of table rows)
!-----------------------------------------------------------------------------
ndist = 0
do krow=1,nrows
call ESMF_ConfigNextLine(localcf, tableEnd=flag , rc=localrc)
call ESMF_ConfigGetAttribute(localcf, ltmp, rc=localrc)
if( trim(adjustL(ltmp)) == "&" ) then
! continuation line
new_row(krow) = 0
else
ndist = ndist + 1
new_row(krow) = ndist
endif
enddo ! end krow
Dfile%nDspecs = ndist
!-----------------------------------------------------------------------------
! allocate storage for the dist information based on the calculated number of
! separate grid entries
!-----------------------------------------------------------------------------
allocate( Dfile%src_dist(Dfile%nDspecs), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer array src_dist "// &
" in read_dist_specification", rcToReturn=rc)) then
endif
allocate( Dfile%dst_dist(Dfile%nDspecs), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer array dst_dist "// &
" in read_dist_specification", rcToReturn=rc)) then
endif
!-----------------------------------------------------------------------------
! Read the specifications from the table:
! (1) start at the top of the table.
! (2) read the row elements until the end of the row is reached.
! (3) determine if all the elements are read;
! (a) if not advance to the next line and continue to read elements until
! the end of the line is reached - repeat (3)
! (b) if all the elements read, skip to next row and repeat (2)
!-----------------------------------------------------------------------------
call ESMF_ConfigFindLabel(localcf, trim(distribution_label), rc=localrc )
if( ESMF_LogFoundError(localrc,msg="cannot find config label " // &
trim(distribution_label),rcToReturn=rc) ) return
!-----------------------------------------------------------------------------
! move to the next line in the table and confirm that (1) the line doesn't
! start with a continuation symbol, and (2) that the line isn't empty.
!-----------------------------------------------------------------------------
irow = 1 ! start with first row
idist = 0
!-----------------------------------------------------------------------------
! as long as the current row is within the bounds of the table process entry
!-----------------------------------------------------------------------------
out_counter = 0
do while(irow <= nrows)
if (new_row(irow) == 0 ) exit
!---------------------------------------------------------------------------
! start at the top of the table and read new specification. check that it is
! not a continuation symbol and not end of row
!---------------------------------------------------------------------------
if( ncolumns(irow) > 0 ) then
call ESMF_ConfigNextLine(localcf, tableEnd=flag , rc=localrc)
kelements = 0 ! first element on the row
idist = idist + 1 ! index to count distributions in the table
call read_table_string(dtag, kelements, irow, nrows, ncolumns, new_row, &
Dfile%filename, distribution_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
endif
if( debug_flag ) print*,' distribution ',dtag
!---------------------------------------------------------------------------
! read the SRC distribution tag, first time through it should be SRC
!---------------------------------------------------------------------------
call read_table_string(ltag, kelements, irow, nrows, ncolumns, new_row, &
Dfile%filename, distribution_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU,rcToReturn=rc)) return
if( trim(adjustL(ltag)) /= "SRC") then
! wrong tag, SRC expected - return error
write(lchar,"(i5)") irow
call ESMF_LogSetError(ESMF_FAILURE,msg="wrong tag, SRC expected on line "&
// trim(lchar) // " of table "// trim(distribution_label) // &
" in file " // trim(Dfile%filename), rcToReturn=rc)
return
endif
!---------------------------------------------------------------------------
! read the SRC rank, should be between 1 and 7
!---------------------------------------------------------------------------
call read_table_integer(src_rank, kelements, irow, nrows, ncolumns, &
new_row, Dfile%filename, distribution_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
if( src_rank < 1 .or. src_rank > 7 ) then
! error - unacceptable rank
write(lchar,"(i5)") irow
write(lnumb,"(i5)") src_rank
call ESMF_LogSetError(ESMF_FAILURE,msg="unacceptable rank, should be " &
// "> 1 and <= 7. Rank is " // trim(lnumb) // ". On line " // &
trim(lchar) // " of table " // trim(distribution_label) // &
" in file " // trim(Dfile%filename), rcToReturn=rc)
return
endif
allocate( Dfile%src_dist(idist)%dsize(SrcMem%memRank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer array dsize "// &
" in read_dist_specification", rcToReturn=rc)) then
endif
Dfile%src_dist(idist)%drank = src_rank
!---------------------------------------------------------------------------
! initialize counters
!---------------------------------------------------------------------------
sanity_counter = 0
counter = 0
do while( trim(adjustL(ltag)) /= "DST" .and. trim(adjustL(ltag)) /= "END" )
! read distribution syntax operator
call read_table_string(ltag, kelements, irow, nrows, ncolumns, &
new_row, Dfile%filename, distribution_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
if( pattern_query(trim(ltag), "==") /= 0 .or. &
pattern_query(trim(ltag), "=+") /= 0 .or. &
pattern_query(trim(ltag), "=*") /= 0 ) then
! valid operator so now read value
call read_table_real(tvalue, kelements, irow, nrows, ncolumns, &
new_row, Dfile%filename, distribution_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
if( debug_flag ) print*,' operator/value ',trim(ltag),tvalue
! save pair of values
counter = counter + 1
lop(counter)%string = ltag
opv(counter) = tvalue
endif
! test to avoid an infinite loop - drop out if too many iterations
sanity_counter = sanity_counter + 1
if( sanity_counter > 8*src_rank ) then
! infinite loop - post error and return
write(lchar,"(i5)") irow
call ESMF_LogSetError(ESMF_FAILURE,msg="SRC while loop not " // &
"completing. Line " // trim(lchar) // " of table " // &
trim(distribution_label) // " in file " // &
trim(Dfile%filename), rcToReturn=rc)
return
endif
enddo ! while
!-----------------------------------------------------------------------------
! process operator and values
! - sort operators by rank dimension
! - search for case of equivalence operator "=="
!-----------------------------------------------------------------------------
do irank=1, src_rank
n = 0
numOp(irank) = 0
do k=1, counter
if( pattern_query(lop(k)%string,pattern(irank)%string) /= 0 ) then
n = n + 1
loper(irank,n)%string = lop(k)%string
op_val(irank,n) = opv(k)
numOp(irank) = n
if( debug_flag ) print*,' operator ',trim(loper(irank,n)%string), &
op_val(irank,n)
endif
enddo ! k
enddo ! irank
!-----------------------------------------------------------------------------
! search for equivalence operators to know how to partition the total PE
! amoung the distribution axes. The base value = (nPE)**(1/erank), where
! erank is the effective rank = source rank - number of equivalences
!-----------------------------------------------------------------------------
erank = src_rank
do irank=1, src_rank
if( numOp(irank) > 0 .and. numOp(irank) < 9 ) then
do n=1, numOp(irank)
if( pattern_query(loper(irank,n)%string, "==") /= 0 ) then
if( n > 1 ) then
! error can't have both equivalence and multiple operators
write(lchar,"(i5)") irow
call ESMF_LogSetError(ESMF_FAILURE,msg="only single operator"&
// " allowed when equivalence operator used. Line "// &
trim(lchar) // " of table "//trim(distribution_label) &
// " in file " //trim(Dfile%filename), rcToReturn=rc)
return
endif
erank = erank - 1
endif
enddo ! k
else
! error operator missing for rank
write(lchar,"(i5)") irow
write(lnumb,"(i5)") irank
call ESMF_LogSetError(ESMF_FAILURE,msg="operator missing from SRC" // &
" specification, rank " // trim(lnumb) // " Line " // &
trim(lchar) // " of table " // trim(distribution_label) // &
" in file " //trim(Dfile%filename), rcToReturn=rc)
return
endif
enddo ! irank
!---------------------------------------------------------------------------
! compute the distribution dimension size.
!---------------------------------------------------------------------------
call dist_size(nPEs, erank, numOp, loper, op_val, Dfile%src_dist(idist), &
SrcMem%memRank, rc)
!-----------------------------------------------------------------------------
! DST Phase
!-----------------------------------------------------------------------------
if( debug_flag ) print*,' entering DST ', irow
!---------------------------------------------------------------------------
! read the DST distribution tag, first time through it should be DST
!---------------------------------------------------------------------------
if( debug_flag ) print*,'ltag ',ltag
if( trim(adjustL(ltag)) /= "DST") then
! wrong tag, DST expected - return error
write(lchar,"(i5)") irow
call ESMF_LogSetError(ESMF_FAILURE,msg="wrong tag, DST expected on line" &
// trim(lchar) // " of table "// trim(distribution_label) // &
" in file " // trim(Dfile%filename), rcToReturn=rc)
return
endif
!---------------------------------------------------------------------------
! read the DST rank, should be between 1 and 7
!---------------------------------------------------------------------------
call read_table_integer(dst_rank, kelements, irow, nrows, ncolumns, &
new_row, Dfile%filename, distribution_label, localcf, localrc)
if( debug_flag ) print*,' dst_rank', dst_rank, kelements
if (ESMF_LogFoundError(localrc,ESMF_ERR_PASSTHRU,rcToReturn=rc)) return
if( dst_rank < 1 .or. dst_rank > 7 ) then
! error - unacceptable rank
write(lchar,"(i5)") irow
write(lnumb,"(i5)") dst_rank
call ESMF_LogSetError(ESMF_FAILURE,msg="unacceptable rank, should be > " &
// "1 and <= 7. Rank is " // trim(lnumb) // ". On line " // &
trim(lchar) // " of table " // trim(distribution_label) // &
" in file " // trim(Dfile%filename), rcToReturn=rc)
return
endif
allocate( Dfile%dst_dist(idist)%dsize(DstMem%memRank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer array dsize "// &
" in read_dist_specification", rcToReturn=rc)) then
endif
Dfile%dst_dist(idist)%drank = dst_rank
!---------------------------------------------------------------------------
! initialize counters
!---------------------------------------------------------------------------
sanity_counter = 0
counter = 0
do while( trim(adjustL(ltag)) /= "END" .and. irow <= nrows )
! read distribution syntax operator
call read_table_string(ltag, kelements, irow, nrows, ncolumns, &
new_row, Dfile%filename, distribution_label, localcf, localrc)
if (ESMF_LogFoundError(localrc,ESMF_ERR_PASSTHRU,rcToReturn=rc)) return
if( pattern_query(trim(ltag), "==") /= 0 .or. &
pattern_query(trim(ltag), "=+") /= 0 .or. &
pattern_query(trim(ltag), "=*") /= 0 ) then
! valid operator so now read value
call read_table_real(tvalue, kelements, irow, nrows, ncolumns, &
new_row, Dfile%filename, distribution_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
if( debug_flag ) print*,' operator/value ',trim(ltag),tvalue
! save pair of values
counter = counter + 1
lop(counter)%string = ltag
opv(counter) = tvalue
endif
! test to avoid an infinite loop - drop out if too many iterations
sanity_counter = sanity_counter + 1
if( sanity_counter > 8*dst_rank ) then
! infinite loop - post error and return
write(lchar,"(i5)") irow
call ESMF_LogSetError(ESMF_FAILURE,msg="DST while loop not completing"&
// " Line " // trim(lchar) // " of table " // &
trim(distribution_label) // " in file " // &
trim(Dfile%filename), rcToReturn=rc)
return
endif
enddo ! while
!---------------------------------------------------------------------------
! process operator and values
! - sort operators by rank dimension
! - search for case of equivalence operator "=="
!---------------------------------------------------------------------------
do irank=1, dst_rank
n = 0
numOp(irank) = 0
do k=1, counter
if( pattern_query(lop(k)%string,pattern(irank)%string) /= 0 ) then
n = n + 1
loper(irank,n)%string = lop(k)%string
op_val(irank,n) = opv(k)
numOp(irank) = n
if( debug_flag ) print*,' operator ',trim(loper(irank,n)%string), &
op_val(irank,n)
endif
enddo ! k
enddo ! irank
!---------------------------------------------------------------------------
! search for equivalence operators to know how to partition the total PE
! amoung the distribution axes. The base value = (nPE)**(1/erank), where
! erank is the effective rank = source rank - number of equivalences
!-----------------------------------------------------------------------------
erank = dst_rank
do irank=1, dst_rank
if( numOp(irank) > 0 .and. numOp(irank) < 9 ) then
do n=1, numOp(irank)
if( pattern_query(loper(irank,n)%string, "==") /= 0 ) then
if( n > 1 ) then
! error can't have both equivalence and multiple operators
write(lchar,"(i5)") irow
call ESMF_LogSetError(ESMF_FAILURE,msg="only single operator"&
// " allowed when equivalence operator used. Line " // &
trim(lchar) // " of table " // trim(distribution_label) // &
" in file " //trim(Dfile%filename), rcToReturn=rc)
return
endif
erank = erank - 1
endif
enddo ! k
else
! error no operator for rank
write(lchar,"(i5)") irow
write(lnumb,"(i5)") irank
call ESMF_LogSetError(ESMF_FAILURE,msg="operator missing from DST" // &
" specification, rank " // trim(lnumb) // " Line " // &
trim(lchar) // " of table " // trim(distribution_label) // &
" in file " //trim(Dfile%filename), rcToReturn=rc)
return
endif
enddo ! irank
!---------------------------------------------------------------------------
! compute the distribution dimension size.
!---------------------------------------------------------------------------
call dist_size(nPEs, erank, numOp, loper, op_val, Dfile%dst_dist(idist), &
DstMem%memRank, rc)
!---------------------------------------------------------------------------
! both source and destination specifications have been read, move to next
! entry - check new row to make certain it is a new entry and not a
! continuation.
!---------------------------------------------------------------------------
if( irow+1 <= nrows ) then
if( new_row(irow+1) /= 0) then
! if there is a next row and it doesn't have a continuation symbol
irow = irow + 1
else
! error next line should be a new entry but instead a continuation
! symbol was found
write(lchar,"(i5)") irow+1
write(lnumb,"(i5)") irank
call ESMF_LogSetError(ESMF_FAILURE,msg="next line in table " // &
trim(distribution_label) // " should be a new entry, but " // &
"instead a continuation symbol was found. Line " // &
trim(lchar) // " of table " // trim(distribution_label) // &
" in file " //trim(Dfile%filename) // " had a continuation" &
// " symbol." , rcToReturn=rc)
return
endif
elseif(irow+1 > nrows .and. trim(ltag) /= "END") then
! we should be done and can drop out, but there is no end tag
call ESMF_LogSetError(ESMF_FAILURE,msg="should be at end of " // &
"table " // trim(distribution_label) // " but no end tag" // &
" found. File " // trim(Dfile%filename) , rcToReturn=rc)
return
else
! we are at the end of the table so finish up.
irow = irow+1
endif
! sanity check to catch infinite loops
out_counter = out_counter + 1
if(out_counter > 1000 ) then
call ESMF_LogSetError(ESMF_FAILURE,msg="we seem to have gotten into" &
// " an infinite loop reading table " // &
trim(distribution_label) // " in file " // &
trim(Dfile%filename), rcToReturn=rc)
return
endif
enddo ! while
!-----------------------------------------------------------------------------
! clean up CF
!-----------------------------------------------------------------------------
call ESMF_ConfigDestroy(localcf, rc=localrc)
if( ESMF_LogFoundError(localrc, msg="cannot destroy config object", &
rcToReturn=rc) ) return
!-----------------------------------------------------------------------------
rc = ESMF_SUCCESS
!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------
end subroutine read_dist_specification