subroutine read_regridding_grid(lfilename, ngrids, src_grid, dst_grid, &
testfunction, rc)
!-----------------------------------------------------------------------------
! routine to read the grid specifier file for a regridding test. The routine
! reads a pair (source and destination) of grid specification needed for the
! regridding test.
!
! The grid specification takes the form of a table with row entries
! (0) grid rank
! and (5 * grid rank) remaining entries consisting of cycles of
! (1) grid type
! (2) grid size
! (3) grid minimum range
! (4) grid maximum range
! (5) grid units
! Acceptable values for the units are: DEGREE(S), DEGREE(S)_EAST,
! DEGREE(S)_NORTH, DEG, DEG_E, DEG_N, RADIANS, RAD, METERS, M, KILOMETERS, KM.
! (6) test function
!
! NOTES:
! Both the grid type and units should be enclosed by either single or double
! quotes to insure proper parsing by the ESMF_Config calls.
!
!-----------------------------------------------------------------------------
! arguments
character(THARN_MAXSTR), intent(in ) :: lfilename
type(grid_specification_record), pointer :: src_grid(:), dst_grid(:)
type(test_function_record), pointer :: testfunction(:)
integer, intent( out) :: ngrids
integer, intent(inout) :: rc
! local parameters
character(THARN_MAXSTR), parameter :: descriptor_label = "map_regrid::"
! local esmf types
type(ESMF_Config) :: localcf
! local character strings
character(THARN_MAXSTR) :: ltmp, lchar, lnumb
! character(THARN_MAXSTR) :: lchartmp
character(THARN_MAXSTR) :: gtype, gunits, gtag
type(character_array) :: wchar(10)
logical :: flag
! local integer variables
integer :: ntmp, grank, gsize
integer :: irow, krow, nrows, igrid, ngrid, irank, kelements
integer :: iTFun, k, out_counter
integer, allocatable :: ncolumns(:), new_row(:)
integer :: localrc ! local error status
integer :: allocRcToTest
! local real variables
real(ESMF_KIND_R8) :: gmin, gmax, tmp
! real(ESMF_KIND_R8) :: tmpchar
! initialize return flag
localrc = ESMF_RC_NOT_IMPL
rc = ESMF_RC_NOT_IMPL
!-----------------------------------------------------------------------------
! open the grid file
!-----------------------------------------------------------------------------
localcf = ESMF_ConfigCreate(rc=localrc)
if( ESMF_LogFoundError(localrc, msg="cannot create config object", &
rcToReturn=rc) ) return
call ESMF_ConfigLoadFile(localcf, trim( lfilename ), rc=localrc )
if( ESMF_LogFoundError(localrc, &
msg="cannot load config file " // trim( lfilename ), &
rcToReturn=rc) ) return
!-----------------------------------------------------------------------------
! extract the grid type specifier as sanity check
!-----------------------------------------------------------------------------
call ESMF_ConfigFindLabel(localcf, 'map_type:', rc=localrc )
if( ESMF_LogFoundError(localrc, &
msg="cannot find config label map_type", rcToReturn=rc) ) return
call ESMF_ConfigGetAttribute(localcf, ltmp, rc=localrc)
if( ESMF_LogFoundError(localrc, &
msg="cannot find config label map_type:", &
rcToReturn=rc) ) return
if( trim(adjustL( ltmp )) /= 'REGRID' ) then
call ESMF_LogSetError( &
ESMF_FAILURE, msg="Wrong grid type for regrid test in file " // &
trim( lfilename ), rcToReturn=rc)
return
endif
!-----------------------------------------------------------------------------
! search for the grid specifier table
!-----------------------------------------------------------------------------
call ESMF_ConfigFindLabel(localcf, trim(descriptor_label), rc=localrc )
if( ESMF_LogFoundError(localrc, &
msg="cannot find config label " // trim(descriptor_label), &
rcToReturn=rc) ) return
!-----------------------------------------------------------------------------
! determine the total number of table rows, continue only if not empty
! NOTE: the number of table rows >= number of grid entries due to the
! possibility of continued lines.
!-----------------------------------------------------------------------------
call ESMF_ConfigGetDim(localcf, nrows, ntmp, label=trim(descriptor_label), &
rc=localrc)
if( ESMF_LogFoundError(localrc, &
msg="cannot get descriptor table size in file " // trim(lfilename), &
rcToReturn=rc) ) return
if( nrows .le. 0 ) then
call ESMF_LogSetError( ESMF_FAILURE, &
msg="grid specifier table is empty in file " //trim(lfilename), &
rcToReturn=rc)
return
endif
!-----------------------------------------------------------------------------
! extract the table column lengths of this file
!-----------------------------------------------------------------------------
call ESMF_ConfigFindLabel(localcf, trim(descriptor_label), rc=localrc )
if( ESMF_LogFoundError(localrc, &
msg="cannot find config label " // trim(descriptor_label), &
rcToReturn=rc) ) return
allocate( ncolumns(nrows), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer array ncolumns"// &
" in read_regridding_grid", 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(descriptor_label) // " in file " // trim(lfilename), &
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(lfilename), rcToReturn=rc)
return
endif
enddo ! end krow
!-----------------------------------------------------------------------------
! determine the actual number of grids specified in the file by counting
! lines not starting with the continuation symbol '&'. The number of actual
! grid 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(descriptor_label), rc=localrc )
if( ESMF_LogFoundError(localrc, &
msg="cannot find config label " // trim(descriptor_label), &
rcToReturn=rc) ) return
allocate( new_row(nrows), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer array new_row"// &
" in read_regridding_grid", rcToReturn=rc)) then
endif
!-----------------------------------------------------------------------------
! count the number of actual grids (less than or equal to number of table rows)
!-----------------------------------------------------------------------------
ngrid = 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
ngrid = ngrid + 1
new_row(krow) = ngrid
endif
enddo ! end krow
ngrids = ngrid
!-----------------------------------------------------------------------------
! allocate storage for the grid information based on the calculated number of
! separate grid entries
!-----------------------------------------------------------------------------
allocate( src_grid(ngrid), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="grid type src_grid"// &
" in read_regridding_grid", rcToReturn=rc)) then
endif
allocate( dst_grid(ngrid), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="grid type dst_grid "// &
" in read_regridding_grid", rcToReturn=rc)) then
endif
allocate( testfunction(ngrid), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="test type"// &
" in read_regridding_grid", rcToReturn=rc)) then
endif
!-----------------------------------------------------------------------------
! Read the grid 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(descriptor_label), rc=localrc )
if( ESMF_LogFoundError(localrc, &
msg="cannot find config label " // trim(descriptor_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
igrid = 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
!--------------------------------------------------------------------------
! new grid specification - not continuation symbol and not end of row
!--------------------------------------------------------------------------
if( ncolumns(irow) > 0 ) then
call ESMF_ConfigNextLine(localcf, tableEnd=flag , rc=localrc)
kelements = 0 ! no elements of the row have been read
igrid = igrid +1 ! new grid description
!-----------------------------------------------------------------------
! extract rank of current grid
!-----------------------------------------------------------------------
call ESMF_ConfigGetAttribute(localcf, grank)
!-----------------------------------------------------------------------
! check that grid rank should be between 1 and 7
!-----------------------------------------------------------------------
if( grank < 1 .or. grank >7 ) then
write(lchar,"(i5)") irow
write(lnumb,"(i5)") grank
call ESMF_LogSetError(ESMF_FAILURE,msg="unacceptable rank, should" &
// " be " // "> 1 and <= 7. Rank is " // trim(lnumb) // &
". On line " // &
trim(lchar) // " of table " // trim(descriptor_label) // &
" in file " // trim(lfilename), rcToReturn=rc)
return
endif
!-----------------------------------------------------------------------
! allocate workspace
!-----------------------------------------------------------------------
src_grid(igrid)%grank = grank
allocate( src_grid(igrid)%gtype(grank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="char array "// &
" gtype in read_regridding_grid", rcToReturn=rc)) then
endif
allocate( src_grid(igrid)%gunits(grank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="char array "// &
" gunits in read_regridding_grid", rcToReturn=rc)) then
endif
allocate( src_grid(igrid)%gsize(grank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer array "// &
" gsize in read_regridding_grid", rcToReturn=rc)) then
endif
allocate( src_grid(igrid)%grange(grank,2), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="real array "// &
" grange in read_regridding_grid", rcToReturn=rc)) then
endif
dst_grid(igrid)%grank = grank
allocate( dst_grid(igrid)%gtype(grank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="char array "// &
" gtype in read_regridding_grid", rcToReturn=rc)) then
endif
allocate( dst_grid(igrid)%gunits(grank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="char array "// &
" grank in read_regridding_grid", rcToReturn=rc)) then
endif
allocate( dst_grid(igrid)%gsize(grank), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer array "// &
" gsize in read_regridding_grid", rcToReturn=rc)) then
endif
allocate( dst_grid(igrid)%grange(grank,2), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="real array "// &
" grange in read_regridding_grid", rcToReturn=rc)) then
endif
!-----------------------------------------------------------------------
! Source Grid
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
! read source grid tag
!-----------------------------------------------------------------------
kelements = 1
! print*,'before tag',kelements, irow, nrows, ncolumns(irow), new_row(irow)
call read_table_string(gtag, &
kelements, irow, nrows, ncolumns, new_row, &
lfilename, descriptor_label, localcf, localrc)
! print*,'after tag',kelements, irow, nrows, ncolumns(irow), new_row(irow)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
! if tag not equal SRC post error
if( trim(adjustL(gtag)) /= 'SRC' ) then
call ESMF_LogSetError( ESMF_FAILURE, &
msg="Source flag expected but not found in regridding" // &
" grid specifier file" // trim(lfilename), rcToReturn=rc)
return
endif
!-----------------------------------------------------------------------
! read row elements until grid rank is reached
!-----------------------------------------------------------------------
do irank=1, grank
!--------------------------------------------------------------------
! if haven't reached end of line, read source grid type
!--------------------------------------------------------------------
call read_table_string(gtype, &
kelements, irow, nrows, ncolumns, new_row, &
lfilename, descriptor_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
src_grid(igrid)%gtype(irank)%string = gtype
!--------------------------------------------------------------------
! read source grid size
!--------------------------------------------------------------------
call read_table_integer(gsize, &
kelements, irow, nrows, ncolumns, new_row, &
lfilename, descriptor_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
src_grid(igrid)%gsize(irank) = gsize
!--------------------------------------------------------------------
! read source minimum grid range
!--------------------------------------------------------------------
call read_table_real(gmin, &
kelements, irow, nrows, ncolumns, new_row, &
lfilename, descriptor_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
src_grid(igrid)%grange(irank,1) = gmin
!--------------------------------------------------------------------
! read source maximum grid range
!--------------------------------------------------------------------
call read_table_real(gmax, &
kelements, irow, nrows, ncolumns, new_row, &
lfilename, descriptor_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
src_grid(igrid)%grange(irank,2) = gmax
!--------------------------------------------------------------------
! read source grid units
!--------------------------------------------------------------------
call read_table_string(gunits, &
kelements, irow, nrows, ncolumns, new_row, &
lfilename, descriptor_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
src_grid(igrid)%gunits(irank)%string = gunits
end do !
!-----------------------------------------------------------------------
! Destination Grid
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
! read destination grid tag
!-----------------------------------------------------------------------
call read_table_string(gtag, &
kelements, irow, nrows, ncolumns, new_row, &
lfilename, descriptor_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
! if tag not equal DST post error
if( trim(adjustL(gtag)) /= 'DST' ) then
call ESMF_LogSetError( ESMF_FAILURE, &
msg="Destination flag expected but not found in regridding" // &
" grid specifier file " // trim(lfilename), rcToReturn=rc)
return
endif
!-----------------------------------------------------------------------
! read row elements until grid rank is reached
!-----------------------------------------------------------------------
do irank=1, grank
!--------------------------------------------------------------------
! if haven't reached end of line, read destination grid type
!--------------------------------------------------------------------
call read_table_string(gtype, &
kelements, irow, nrows, ncolumns, new_row, &
lfilename, descriptor_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
dst_grid(igrid)%gtype(irank)%string = gtype
!--------------------------------------------------------------------
! read destination grid size
!--------------------------------------------------------------------
call read_table_integer(gsize, &
kelements, irow, nrows, ncolumns, new_row, &
lfilename, descriptor_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
dst_grid(igrid)%gsize(irank) = gsize
!--------------------------------------------------------------------
! read destination minimum grid range
!--------------------------------------------------------------------
call read_table_real(gmin, &
kelements, irow, nrows, ncolumns, new_row, &
lfilename, descriptor_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
dst_grid(igrid)%grange(irank,1) = gmin
!--------------------------------------------------------------------
! read destination maximum grid range
!--------------------------------------------------------------------
call read_table_real(gmax, &
kelements, irow, nrows, ncolumns, new_row, &
lfilename, descriptor_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
dst_grid(igrid)%grange(irank,2) = gmax
!--------------------------------------------------------------------
! read destination grid units
!--------------------------------------------------------------------
call read_table_string(gunits, &
kelements, irow, nrows, ncolumns, new_row, &
lfilename, descriptor_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
dst_grid(igrid)%gunits(irank)%string = gunits
end do !
!-----------------------------------------------------------------------
! Test Function
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
! read destination grid tag
!-----------------------------------------------------------------------
call read_table_string(gtag, &
kelements, irow, nrows, ncolumns, new_row, &
lfilename, descriptor_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
! if tag not equal FUNCTION post error
if( trim(adjustL(gtag)) /= 'FUNCTION' ) then
call ESMF_LogSetError( ESMF_FAILURE, &
msg="Test Function flag expected but not found in regridding" // &
" grid specifier file " // trim(lfilename), rcToReturn=rc)
return
endif
!-----------------------------------------------------------------------
! extract test function and parameters
!-----------------------------------------------------------------------
iTFun = 0 ! initialize test function counter
!-----------------------------------------------------------------------
! read first function types
!-----------------------------------------------------------------------
call read_table_string(gtag, &
kelements, irow, nrows, ncolumns, new_row, &
lfilename, descriptor_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
do while ( trim(adjustL(gtag)) /= 'END' )
!--------------------------------------------------------------------
! read function types
!--------------------------------------------------------------------
iTFun = iTFun + 1 ! count number of specified test functions
wchar(iTFun)%string = gtag
! read next paramter
call read_table_string(gtag, &
kelements, irow, nrows, ncolumns, new_row, &
lfilename, descriptor_label, localcf, localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
rcToReturn=rc)) return
end do ! while
!-----------------------------------------------------------------------
! allocate character array for test functions & copy values from work array
!-----------------------------------------------------------------------
if(iTFun > 0) then
allocate( testfunction(igrid)%param(iTFun-1), stat=allocRcToTest )
if (ESMF_LogFoundAllocError(allocRcToTest, msg="type in "// &
" read_regridding_grid", rcToReturn=rc)) then
endif
endif
testfunction(igrid)%prank = iTFun-1
testfunction(igrid)%string = wchar(1)%string
do k=2,iTFun
lchar = trim( wchar(k)%string )
read(lchar,*) tmp
testfunction(igrid)%param(k-1) = tmp
enddo
endif !
!---------------------------------------------------------------------------
! 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(descriptor_label) // " should be a new entry, but " // &
"instead a continuation symbol was found. Line " // &
trim(lchar) // " of table " // trim(descriptor_label) // &
" in file " //trim(lfilename) // " had a continuation" &
// " symbol." , rcToReturn=rc)
return
endif
elseif(irow+1 > nrows .and. trim(gtag) /= "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(descriptor_label) // " but no end tag" // &
" found. File " // trim(lfilename) , rcToReturn=rc)
return
else
! we are at the end of the table so finish up.
irow = irow+1
endif
end do ! while
!-----------------------------------------------------------------------------
! deallocate workspace
!-----------------------------------------------------------------------------
deallocate( ncolumns )
!-----------------------------------------------------------------------------
! clean up CF
!-----------------------------------------------------------------------------
call ESMF_ConfigDestroy(localcf, rc=localrc)
if( ESMF_LogFoundError(localrc, msg="cannot destroy config object", &
rcToReturn=rc) ) return
!-----------------------------------------------------------------------------
! set error code to SUCCESS
!-----------------------------------------------------------------------------
rc = ESMF_SUCCESS
!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------
end subroutine read_regridding_grid