! $Id$ ! ! Earth System Modeling Framework ! Copyright (c) 2002-2023, University Corporation for Atmospheric Research, ! Massachusetts Institute of Technology, Geophysical Fluid Dynamics ! Laboratory, University of Michigan, National Centers for Environmental ! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, ! NASA Goddard Space Flight Center. ! Licensed under the University of Illinois-NCSA License. ! !=============================================================================== #define ESMF_FILENAME "ESMF_TestHarnessUtilMod" ! ! ESMF Test Harness Types Module module ESMF_TestHarnessUtilMod ! !=============================================================================== ! ! This file contains parameters, global data types, and parser ! functions/subroutines for the Testing Harness. ! These methods are used by the test harness driver ESMF_TestHarnessUTest.F90 ! and all the other test harness modules. ! !------------------------------------------------------------------------------- ! INCLUDES #include "ESMF.h" !=============================================================================== !BOPI ! !MODULE: ESMF_TestHarnessUtilMod ! ! !DESCRIPTION: ! ! The code in this file contains basic utilities for string manipulation and ! inputting configuration table entries and misc utility functions ! !------------------------------------------------------------------------------- ! !USES: use ESMF_TestHarnessTypesMod implicit none !=============================================================================== ! minimum error neighborhood for regrid interpolation real(ESMF_KIND_R8), parameter :: RegridMinNeighborhood = 1.0D-14 ! global storage of test specification type (harness_descriptor), save :: har integer :: localPet integer :: petCount integer :: rootPet = Harness_rootPet contains !=============================================================================== !------------------------------------------------------------------------------ ! Routines to search strings !------------------------------------------------------------------------------ !------------------------------------------------------------------------------ !--------------------------------------------------------------------------- integer function calc_grid_rank(lstring, MemBeg, MemEnd, localrc) !--------------------------------------------------------------------------- ! This function returns the grid rank as specified by the descriptor ! string. !--------------------------------------------------------------------------- ! arguments character(len=THARN_MAXSTR), intent(in ) :: lstring integer, intent(in ) :: MemBeg, MemEnd integer, intent( out) :: localrc ! local variables character(len=3) :: pattern3 integer :: nGrid ! initialize variables localrc = ESMF_RC_NOT_IMPL !--------------------------------------------------------------------------- ! Check each memory chunk to see if any of the dimensions are associated ! with a grid. !--------------------------------------------------------------------------- pattern3 = 'GU' nGrid = set_query(lstring(MemBeg:MemEnd), pattern3) if ( nGrid == 0 ) then ! syntax error, no grid layout specified print*,'Syntax error, no grid layout' call ESMF_LogSetError( ESMF_FAILURE, msg="syntax error, no grid " // & "layout specified", rcToReturn=localrc) return endif calc_grid_rank = nGrid !--------------------------------------------------------------------------- ! if I've gotten this far without an error, then the routine has succeeded. !--------------------------------------------------------------------------- localrc = ESMF_SUCCESS !--------------------------------------------------------------------------- end function calc_grid_rank !--------------------------------------------------------------------------- !------------------------------------------------------------------------------ !--------------------------------------------------------------------------- integer function char2int( lstring, strloc, localrc ) !--------------------------------------------------------------------------- ! This function converts a character representation of an integer digit ! between 0-9 into its integer equivalent. Optional argument of character ! address allows selection of individual characters in a string. Default ! assumes conversion of the first character of the string. !--------------------------------------------------------------------------- ! arguments character(len=*), intent(in ) :: lstring integer, intent(in ), optional :: strloc integer, intent(inout) :: localrc ! local variables integer :: ntemp, sloc ! initialize variables localrc = ESMF_RC_NOT_IMPL if(present(strloc) ) then sloc = strloc else sloc = 1 endif !------------------------------------------------------------------------------ !--------------------------------------------------------------------------- ! Convert string to integer !--------------------------------------------------------------------------- ntemp = iachar( lstring(sloc:sloc) )-iachar('0') ! check to see that values is within the acceptable range if ( ntemp < 0 .and. ntemp > 9 ) then call ESMF_LogSetError( ESMF_FAILURE, & msg="character is not a digit between 0 and 9", & rcToReturn=localrc) return char2int = 0 else char2int = ntemp endif !--------------------------------------------------------------------------- ! if I've gotten this far without an error, then the routine has succeeded. !--------------------------------------------------------------------------- localrc = ESMF_SUCCESS return !--------------------------------------------------------------------------- end function char2int !--------------------------------------------------------------------------- !------------------------------------------------------------------------------ !--------------------------------------------------------------------------- integer function findblank( lstring, strloc, increment ) !--------------------------------------------------------------------------- ! This function searches for the address of the closest blank space to a ! specified address in the string. The parameter increment determines if ! the search proceedes foward (+1) or backward (-1). !--------------------------------------------------------------------------- ! arguments character(len=*), intent(in) :: lstring integer, intent(in) :: strloc integer, intent(in) :: increment ! local variables integer :: k, len_string ! initialize variables findblank = 0 len_string = len( trim(adjustL(lstring)) ) !--------------------------------------------------------------------------- k = strloc do while( ( k + increment >= 1 ).and.( k + increment <= len_string) ) k = k + increment if(lstring(k:k) == ' ') then findblank = k return endif end do ! while return !--------------------------------------------------------------------------- end function findblank !--------------------------------------------------------------------------- !------------------------------------------------------------------------------ !--------------------------------------------------------------------------- integer function dist_rank(lstring, MemBeg, MemEnd, localrc) !--------------------------------------------------------------------------- ! This function returns the distribution rank as specified by the ! descriptor string. !--------------------------------------------------------------------------- ! arguments character(len=THARN_MAXSTR), intent(in ) :: lstring integer, intent(in ) :: MemBeg, MemEnd integer, intent( out) :: localrc ! local variables character(len=3) :: pattern3 integer :: nDist ! initialize variables localrc = ESMF_RC_NOT_IMPL !--------------------------------------------------------------------------- ! Check each memory chunk to see if any of the dimensions are distributed. !--------------------------------------------------------------------------- pattern3 = 'BCA' nDist = set_query(lstring(MemBeg:MemEnd), pattern3) if ( nDist == 0 ) then call ESMF_LogSetError( ESMF_FAILURE, & msg="Syntax Error - no distribution indicated", & rcToReturn=localrc) return endif dist_rank = nDist !--------------------------------------------------------------------------- ! if I've gotten this far without an error, then the routine has succeeded. !--------------------------------------------------------------------------- localrc = ESMF_SUCCESS !--------------------------------------------------------------------------- end function dist_rank !--------------------------------------------------------------------------- !------------------------------------------------------------------------------ !--------------------------------------------------------------------------- subroutine memory_separate(lstring, iRank, lmem, localrc) !--------------------------------------------------------------------------- ! For a structured block of memory, return the memory rank (iRank) as ! specified by the descriptor string, and separate each the string ! corresponding to each memory dimension into a separate element of a ! character array ( lmem(1:iRank) ). Finely separate any specification of ! stagger into the last (iRank+1) element of the character array lmem. !--------------------------------------------------------------------------- ! arguments character(*), intent(in ) :: lstring integer, intent(in ) :: iRank type(character_array), intent( out) :: lmem(:) integer, intent( out) :: localrc ! local variables character(len=1) :: pattern integer :: k, nMem, nEnd, iBeg, iEnd integer :: EndPos(1) integer, allocatable :: MemPos(:) integer :: allocRcToTest ! initialize variables localrc = ESMF_RC_NOT_IMPL ! initialize variables !--------------------------------------------------------------------------- ! The structured memory is delineated by square brackets. To determine ! how this memory is specified, it is first necessary to determne ! the existence of two matching pairs of square brackets. !--------------------------------------------------------------------------- pattern = ';' nMem = pattern_query(lstring, pattern) nEnd = pattern_query(lstring, ']') if( nMem+1 /= iRank .and. nEnd /= 1 ) then call ESMF_LogSetError(ESMF_FAILURE, msg="asserted memory rank does not" & // " agree with actual memory rank", rcToReturn=localrc) return else !------------------------------------------------------------------------ !------------------------------------------------------------------------ allocate( MemPos(nMem), stat=allocRcToTest ) if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer array "// & "MemPos in memory_separate", rcToReturn=localrc)) then endif call pattern_locate(lstring, pattern, nMem, MemPos) call pattern_locate(lstring, ']', nEnd, EndPos) !------------------------------------------------------------------------ ! extract first memory location - not enclosed by ";" on front side !------------------------------------------------------------------------ iBeg = 2 iEnd = MemPos(1)-1 lmem(1)%string = lstring(iBeg:iEnd) !------------------------------------------------------------------------ ! extract remaining memory locations !------------------------------------------------------------------------ do k=2,nMem iBeg = MemPos(k-1) +1 iEnd = MemPos(k) -1 lmem(k)%string = lstring(iBeg:iEnd) enddo !------------------------------------------------------------------------ ! extract last memory location - not enclosed by ";" on back side !------------------------------------------------------------------------ iBeg = MemPos(nMeM) +1 iEnd = EndPos(1) -1 lmem(nMem+1)%string = lstring(iBeg:iEnd) !------------------------------------------------------------------------ ! extract stagger location if included !------------------------------------------------------------------------ iBeg = EndPos(1) iEnd = len(trim(lstring)) if( iEnd > iBeg ) then lmem(nMem+2)%string = lstring(iBeg:iEnd) else lmem(nMem+2)%string = ' ' endif deallocate( MemPos ) endif !--------------------------------------------------------------------------- ! if I've gotten this far without an error, then the routine has succeeded. !--------------------------------------------------------------------------- localrc = ESMF_SUCCESS !--------------------------------------------------------------------------- end subroutine memory_separate !--------------------------------------------------------------------------- !------------------------------------------------------------------------------ !--------------------------------------------------------------------------- subroutine memory_topology(lstring, location, srcMulti, srcBlock, & dstMulti,dstBlock, localrc) !--------------------------------------------------------------------------- ! routine checks the whole input string to determine if the memory topology ! consists of a single structured Logically Rectangular block of memory, or ! multiple structured blocks. It also conducts syntax checking on the ! string. Output is through two sets (source and destination) of two ! variables; *Block the number of single contigous blocks of memory, and ! *Multi the number of multiple memory blocks. !--------------------------------------------------------------------------- ! arguments character(THARN_MAXSTR), intent(in ) :: lstring integer, intent(in ) :: location(2) integer, intent( out) :: srcMulti, dstMulti integer, intent( out) :: srcBlock,dstBlock integer, intent( out) :: localrc ! local variables integer :: nsingle, nmult, strlen ! initialize variables localrc = ESMF_RC_NOT_IMPL strlen = len(lstring) srcBlock = 0 srcMulti = 0 dstBlock = 0 dstMulti = 0 !--------------------------------------------------------------------------- ! Memory Layout !--------------------------------------------------------------------------- nmult = set_query(lstring,'()' ) nsingle = set_query(lstring,'[]' ) !--------------------------------------------------------------------------- ! check if memory is structured with multiple blocks !--------------------------------------------------------------------------- if( (nmult >= 4).and.(nsingle >= 4) ) then !------------------------------------------------------------------------ ! check to see if symbols are properly paired on each half of the string !------------------------------------------------------------------------ if( pattern_match(lstring(1:location(1)), '(', ')') .and. & pattern_match(lstring(location(2):strlen), '(', ')') .and. & pattern_match(lstring(1:location(1)), '[', ']') .and. & pattern_match(lstring(location(2):strlen), '[', ']') ) then srcBlock = set_query(lstring(1:location(1)),'[' ) srcMulti = set_query(lstring(1:location(1)),'(' ) dstBlock = set_query(lstring(location(2):strlen),'[' ) dstMulti = set_query(lstring(location(2):strlen),'(' ) else call ESMF_LogSetError(ESMF_FAILURE,msg="symbols not properly paired", & rcToReturn=localrc) return endif !--------------------------------------------------------------------------- ! if memory is single block !--------------------------------------------------------------------------- elseif( (nmult == 0).and.(nsingle == 4) ) then !------------------------------------------------------------------------ ! check to see if symbols are properly paired on each half of the string !------------------------------------------------------------------------ if( pattern_match(lstring(1:location(1)), '[', ']') .and. & pattern_match(lstring(location(1):strlen), '[', ']') ) then srcBlock = set_query(lstring(1:location(1)),'[' ) dstBlock = set_query(lstring(location(2):strlen),'[' ) else call ESMF_LogSetError(ESMF_FAILURE,msg="symbols not properly paired", & rcToReturn=localrc) return endif else ! syntax error call ESMF_LogSetError( ESMF_FAILURE, msg="symbols not paired properly", & rcToReturn=localrc) return endif !--------------------------------------------------------------------------- ! if I've gotten this far without an error, then the routine has succeeded. !--------------------------------------------------------------------------- localrc = ESMF_SUCCESS !--------------------------------------------------------------------------- end subroutine memory_topology !--------------------------------------------------------------------------- !------------------------------------------------------------------------------ !--------------------------------------------------------------------------- subroutine process_query(lstring, lname, tag, symbol_loc, localrc) !--------------------------------------------------------------------------- ! routine checks the input test string for a method specifier. Acceptable ! methods include: ! REDIST (-->), BILINEAR REMAP (=B=>), CONSERVATIVE REMAP (=C=>), ! SECOND ORDER CONSERVATIVE REMAP (=S=>), NEAREST NEIGHBOR REMAP (=N=>), ! EXCHANGE GRID CONSERVATIVE REMAPPING (=E=>), and a USER SPECIFIED REMAP ! METHOD (=U=>). ! !--------------------------------------------------------------------------- ! arguments character(len=*), intent(in ) :: lstring character(len=*), intent(inout) :: lname integer, intent( out) :: tag integer, intent( out) :: symbol_loc(2) integer, intent( out) :: localrc ! local variables character(THARN_MAXSTR) :: pattern integer :: iredist, iregrid, direction, ib ! initialize variables localrc = ESMF_RC_NOT_IMPL !--------------------------------------------------------------------------- ! Determine the Process type (REDISTRIBUTION or REMAPPING) ! Search for the two signifiers and determine which, if any applies. !--------------------------------------------------------------------------- iredist = index(lstring,'-->') iregrid = index(lstring,'=>') if( (iredist /= 0).and.(iregrid == 0) ) then ! redistribution lname = 'REDISTRIBUTION' tag = Harness_Redist symbol_loc(1) = iredist -1 symbol_loc(2) = iredist +3 elseif( (iredist == 0).and.(iregrid /= 0) ) then ! regrid, now determine what type direction = -1 ! find beginning of process symbol ib = findblank( lstring, iregrid, direction ) pattern = lstring(ib:iregrid+1) select case ( trim(adjustL(pattern)) ) case('=B=>') ! remap method Bilinear lname = 'Bilinear REGRID' tag = Harness_BilinearRegrid symbol_loc(1) = ib symbol_loc(2) = iregrid +2 case('=P=>') ! remap method Bilinear lname = 'patch REGRID' tag = Harness_PatchRegrid symbol_loc(1) = ib symbol_loc(2) = iregrid +2 case('=C=>') ! remap method first order conservative lname = 'Conservative REGRID' tag = Harness_ConservRegrid symbol_loc(1) = ib symbol_loc(2) = iregrid +2 case('=S=>') ! remap method second order conservative lname = '2nd Order Conservative REGRID' tag = Harness_2ndConservRegrid symbol_loc(1) = ib symbol_loc(2) = iregrid +2 case('=E=>') ! remap method exchange grid lname = 'Exchange Grid REGRID' tag = Harness_ExchangeRegrid symbol_loc(1) = ib symbol_loc(2) = iregrid +2 case('=N=>') ! remap method nearest neighbor lname = 'Nearest Neighbor REGRID' tag = Harness_NearNeighRegrid symbol_loc(1) = ib symbol_loc(2) = iregrid +2 case('=U=>') ! remap method undefined/user provided lname = 'User Provided REGRID' tag = Harness_UserProvRegrid symbol_loc(1) = ib symbol_loc(2) = iregrid +2 case default ! syntax error - no recognized method specified call ESMF_LogSetError( ESMF_FAILURE, & msg="process symbol not recognized", & rcToReturn=localrc) lname = 'ERROR' tag = Harness_Error symbol_loc(1) = 0 symbol_loc(2) = 0 return end select ! remap type elseif( (iredist == 0).and.(iregrid == 0) ) then ! syntax error - no action call ESMF_LogSetError( ESMF_FAILURE, & msg="no process symbol found", & rcToReturn=localrc) lname = 'ERROR' tag = Harness_Error return elseif( (iredist /= 0).and.(iregrid /= 0) ) then ! syntax error - multiple actions call ESMF_LogSetError( ESMF_FAILURE, & msg="more than one process symbol found", & rcToReturn=localrc) lname = 'ERROR' tag = Harness_Error return endif ! process test !--------------------------------------------------------------------------- ! if I've gotten this far without an error, then the routine has succeeded. !--------------------------------------------------------------------------- localrc = ESMF_SUCCESS !--------------------------------------------------------------------------- end subroutine process_query !--------------------------------------------------------------------------- !------------------------------------------------------------------------------- !--------------------------------------------------------------------------- subroutine set_locate(lstring, lset, number_hits, hit_loc) !--------------------------------------------------------------------------- ! Locates in STRING, any elements of SET and places their location ! in hit_loc. !--------------------------------------------------------------------------- ! arguments character(len=*), intent(in ) :: lstring character(len=*), intent(in ) :: lset integer, intent(inout) :: number_hits integer, dimension(:),intent(inout) :: hit_loc ! of size number_hits ! local variables integer :: k, klast, ncount integer :: len_string, len_set ! initialize variables ncount = 0 klast = 0 len_string = len(lstring) len_set = len( trim(adjustL(lset) )) !--------------------------------------------------------------------------- ! error check - conduct the scan only if the set and string are not empty. !--------------------------------------------------------------------------- if( (len_set > 0) .and. (len_string > 0) ) then !------------------------------------------------------------------------ ! examine the string to find the find the FIRST instance of an ! element in the set. !------------------------------------------------------------------------ k = scan(lstring(klast+1:len_string), trim(adjustL(lset) )) do while( k > 0 ) ncount = ncount + 1 ! count match. hit_loc(ncount) = k+klast ! save location of set match. klast = k + klast ! slide forward in string looking for next match. k = scan(lstring(klast+1:len_string), trim(adjustL(lset) )) enddo ! while endif ! sanity check - if these do not agree something has failed. if (number_hits /= ncount) ncount = 0 ! return value number_hits = ncount !--------------------------------------------------------------------------- end subroutine set_locate !--------------------------------------------------------------------------- !------------------------------------------------------------------------------ !--------------------------------------------------------------------------- integer function set_query(lstring,lset) !--------------------------------------------------------------------------- ! Scans a string for any character from a SET of characters. Returns zero ! if none of the elements of the set occur in the string or if the set or ! string is empty. !--------------------------------------------------------------------------- ! arguments character(len=*), intent(in) :: lstring character(len=*), intent(in) :: lset ! local variables integer :: k, klast, ncount integer :: len_string, len_set ! initialize variables ncount = 0 klast = 0 len_string = len(lstring) len_set = len( trim(adjustL(lset) )) !--------------------------------------------------------------------------- ! error check - conduct the scan only if the set and string are not empty !--------------------------------------------------------------------------- if( (len_set > 0) .and. (len_string > 0) ) then !------------------------------------------------------------------------ ! examine the string to find the find the FIRST instance of an ! element in the set. !------------------------------------------------------------------------ k = scan(lstring(klast+1:len_string), trim(adjustL(lset) )) do while( k > 0 ) !--------------------------------------------------------------------- ! if scan is nonzero, there is at least one match, increment ! through the string checking for additional matches. !--------------------------------------------------------------------- ncount = ncount + 1 ! count match klast = k + klast ! slide forward in string looking for next match k = scan(lstring(klast+1:len_string), trim(adjustL(lset) )) enddo ! while endif set_query = ncount !--------------------------------------------------------------------------- end function set_query !--------------------------------------------------------------------------- !------------------------------------------------------------------------------ !--------------------------------------------------------------------------- logical function pattern_match(lstring, lcharL, lcharR, rc) !--------------------------------------------------------------------------- ! function checks the input string and determines if there are matching ! pairs of the enclosing symbols ( lcharL, lcharR) and that they are in the ! proper order. !--------------------------------------------------------------------------- ! arguments character(len=*), intent(in ) :: lstring character(len=*), intent(in ) :: lcharL, lcharR integer, optional :: rc ! local variables integer, allocatable :: locL(:), locR(:) integer :: k, ntestL, ntestR integer :: allocRcToTest logical :: flag ! initialize variables flag = .true. !--------------------------------------------------------------------------- ! check that the patterns mach up !--------------------------------------------------------------------------- ntestL = pattern_query(lstring,trim(adjustL(lcharL)) ) ntestR = pattern_query(lstring,trim(adjustL(lcharR)) ) if( ntestL == ntestR ) then !------------------------------------------------------------------------ ! the numbers match, so now check that the order is left to right !------------------------------------------------------------------------ allocate( locL(ntestL), stat=allocRcToTest ) if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer array "// & "locL in pattern_match", rcToReturn=rc)) then endif allocate( locR(ntestR), stat=allocRcToTest ) if (ESMF_LogFoundAllocError(allocRcToTest, msg="integer array "// & "locR in pattern_match", rcToReturn=rc)) then endif call pattern_locate(lstring,trim(adjustL(lcharL)), ntestL, locL ) call pattern_locate(lstring,trim(adjustL(lcharR)), ntestR, locR ) !------------------------------------------------------------------------ ! are any of the symbols out of order !------------------------------------------------------------------------ do k=1, ntestL if( locL(k) > locR(k) ) flag = .false. enddo if( flag ) then ! order correct pattern_match = .true. else ! order wrong pattern_match = .false. endif ! flag deallocate( locL, locR ) else ! numbers of symbols don't pair pattern_match = .false. endif !--------------------------------------------------------------------------- end function pattern_match !--------------------------------------------------------------------------- !------------------------------------------------------------------------------- !--------------------------------------------------------------------------- subroutine pattern_locate(lstring, lpattern, number_hits, hit_loc) !--------------------------------------------------------------------------- ! Locates all instances of a PATTERN in STRING, placing the location of ! the beginning of the pattern in hit_loc. !--------------------------------------------------------------------------- ! arguments character(len=*), intent(in ) :: lstring character(len=*), intent(in ) :: lpattern integer, intent(inout) :: number_hits integer, intent(inout) :: hit_loc(:) ! local variables integer :: k, klast, ncount integer :: len_string, len_pattern ! initialize variables ncount = 0 len_string = len(lstring) len_pattern = len( trim(adjustL(lpattern) )) !--------------------------------------------------------------------------- ! error check - conduct the search only if the pattern & string are not empty !--------------------------------------------------------------------------- if( (len_pattern > 0) .and. (len_string > 0) ) then klast = 0 !------------------------------------------------------------------------ ! examine the string to find the find the FIRST instance of the pattern !------------------------------------------------------------------------ k = index(lstring(klast+1:len_string), trim(adjustL(lpattern) )) do while( k > 0 ) !--------------------------------------------------------------------- ! if index is nonzero, there is at least one match, increment ! through the string checking for additional matches. !--------------------------------------------------------------------- ncount = ncount + 1 ! count match klast = k + klast ! slide forward in string looking for next match hit_loc(ncount) = klast ! save location of the pattern match k = index(lstring(klast+1:len_string), trim(adjustL(lpattern) )) enddo ! while endif ! if they do not agree something has failed. if (number_hits /= ncount) ncount = 0 ! return value number_hits = ncount !--------------------------------------------------------------------------- end subroutine pattern_locate !--------------------------------------------------------------------------- !------------------------------------------------------------------------------ !--------------------------------------------------------------------------- integer function pattern_query(lstring,lpattern) !--------------------------------------------------------------------------- ! Searches a string for a PATTERN of characters. Returns zero if the pattern ! is not found, or if the pattern or string is empty. !--------------------------------------------------------------------------- ! arguments character(len=*), intent(in) :: lstring character(len=*), intent(in) :: lpattern ! local variables integer :: k, klast, ncount integer :: len_string, len_pattern ! initialize variables ncount = 0 klast = 0 len_string = len(lstring) len_pattern = len( trim(adjustL(lpattern)) ) !--------------------------------------------------------------------------- ! error check - conduct the search only if the pattern & string are not empty !--------------------------------------------------------------------------- if( (len_pattern > 0) .and. (len_string > 0) ) then !------------------------------------------------------------------------ ! examine the string to find the find the FIRST instance of the pattern !------------------------------------------------------------------------ k = index(lstring(klast+1:len_string), trim(adjustL(lpattern) )) do while( k > 0 ) !--------------------------------------------------------------------- ! if index is nonzero, there is at least one match, increment ! through the string checking for additional matches. !--------------------------------------------------------------------- ncount = ncount + 1 ! count match klast = k + klast ! slide forward in string looking for next match k = index(lstring(klast+1:len_string), trim(adjustL(lpattern) )) enddo ! while endif pattern_query = ncount !--------------------------------------------------------------------------- end function pattern_query !--------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! methods to query config tables !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- subroutine read_table_integer(int_value, & kelements, irow, nrows, ncolumns, new_row, & lfilename, descriptor_label, localcf, rc) !----------------------------------------------------------------------------- ! helper routine to read a single integer entry of a config file table. The ! tables are designed to have multiple lines for a single entry by using "&" ! continuation symbols to indicate a line continuation. It internally tests ! for the end of the table line and looks for a continuation symbol on the ! next line. If found it advances to the next entry. ! ! This separate routine was created to avoid significant duplication of code ! necessary for parsing the tables. !----------------------------------------------------------------------------- character(THARN_MAXSTR), intent(in ) :: lfilename, descriptor_label integer, intent( out) :: int_value integer, intent(in ) :: ncolumns(:), new_row(:) integer, intent(inout) :: irow ! current row of table integer, intent(in ) :: nrows ! total rows in table integer, intent(inout) :: kelements ! current element of row irow of table type(ESMF_Config), intent(inout) :: localcf integer, intent(inout) :: rc ! local parameters integer :: localrc ! local error status ! local character strings character(THARN_MAXSTR) :: lchar, ltmp integer :: int_tmp logical :: flag ! initialize return flag localrc = ESMF_RC_NOT_IMPL rc = ESMF_RC_NOT_IMPL !----------------------------------------------------------------------------- ! if kelements < ncolumns then not at end of the row and can safely read ! another element. !----------------------------------------------------------------------------- if( kelements < ncolumns(irow) ) then if( debug_flag) print*,' get attribute integer ' call ESMF_ConfigGetAttribute(localcf, int_tmp, rc=localrc) !-------------------------------------------------------------------------- ! if error !-------------------------------------------------------------------------- write(lchar,"(i5)") irow if( ESMF_LogFoundError(localrc, & msg="cannot read row " // trim(adjustL(lchar)) // & " of table " //trim(descriptor_label) // "in file " // & trim(lfilename), rcToReturn=rc) ) return kelements = kelements + 1 int_value = int_tmp elseif( kelements >= ncolumns(irow) .and. irow+1 <= nrows ) then !-------------------------------------------------------------------------- ! reached end of the row, check if another line exists !-------------------------------------------------------------------------- if( new_row(irow+1) == 0 .and. ncolumns(irow+1) >= 2 ) then !----------------------------------------------------------------------- ! if new line starts with a continuation and there are at least two ! columns, advance and read !----------------------------------------------------------------------- irow = irow + 1 kelements = 1 ! if error if( debug_flag) print*,' get next line ' call ESMF_ConfigNextLine(localcf, tableEnd=flag, rc=localrc) write(lchar,"(i5)") irow if( ESMF_LogFoundError(localrc, & msg="cannot read row " // trim(adjustL(lchar)) // & " of table " //trim(descriptor_label) // "in file " // & trim(lfilename), rcToReturn=rc) ) return !----------------------------------------------------------------------- ! read and discard continuation symbol !----------------------------------------------------------------------- if( debug_flag) print*,' get attribute integer - contin symbol ' call ESMF_ConfigGetAttribute(localcf, ltmp, rc=localrc) if( ESMF_LogFoundError(localrc, & msg="cannot read row " // trim(adjustL(lchar)) // & " of table " //trim(descriptor_label) // "in file " // & trim(lfilename), rcToReturn=rc) ) return !----------------------------------------------------------------------- ! read string from table !----------------------------------------------------------------------- if( debug_flag) print*,' get attribute integer - after contin symbol ' call ESMF_ConfigGetAttribute(localcf, int_tmp, rc=localrc) if( ESMF_LogFoundError(localrc, & msg="cannot read row " // trim(adjustL(lchar)) // & " of table " //trim(descriptor_label) // "in file " // & trim(lfilename), rcToReturn=rc) ) return kelements = kelements + 1 int_value = int_tmp else !----------------------------------------------------------------------- ! error continuation line missing, but grid not finished !----------------------------------------------------------------------- write(lchar,"(i5)") irow call ESMF_LogSetError( ESMF_FAILURE, & msg="cannot read row " // trim(adjustL(lchar)) // & " of table " //trim(descriptor_label) // "in file " // & trim(lfilename), rcToReturn=rc) return endif ! new line endif ! !----------------------------------------------------------------------------- rc = ESMF_SUCCESS !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- end subroutine read_table_integer !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- subroutine read_table_real(flt_value, & kelements, irow, nrows, ncolumns, new_row, & lfilename, descriptor_label, localcf, rc) !----------------------------------------------------------------------------- ! helper routine to read a single real entry of a config file table. The ! tables are designed to have multiple lines for a single entry by using "&" ! continuation symbols to indicate a line continuation. It internally tests ! for the end of the table line and looks for a continuation symbol on the ! next line. If found it advances to the next entry. ! ! This separate routine was created to avoid significant duplication of code ! necessary for parsing the tables. !----------------------------------------------------------------------------- character(THARN_MAXSTR), intent(in ) :: lfilename, descriptor_label real(ESMF_KIND_R8), intent( out) :: flt_value integer, intent(in ) :: ncolumns(:), new_row(:) integer, intent(inout) :: irow ! current row of table integer, intent(in ) :: nrows ! total rows in table integer, intent(inout) :: kelements ! current element of row irow of table type(ESMF_Config), intent(inout) :: localcf integer, intent(inout) :: rc ! local parameters integer :: localrc ! local error status ! local character strings character(THARN_MAXSTR) :: lchar, ltmp real(ESMF_KIND_R8) :: flt_tmp logical :: flag ! initialize return flag localrc = ESMF_RC_NOT_IMPL rc = ESMF_RC_NOT_IMPL !----------------------------------------------------------------------------- ! if kelements < ncolumns then not at end of the row and can safely read ! another element. !----------------------------------------------------------------------------- if( kelements < ncolumns(irow) ) then if( debug_flag) print*,' get attribute - real ' call ESMF_ConfigGetAttribute(localcf, flt_tmp, rc=localrc) !-------------------------------------------------------------------------- ! if error !-------------------------------------------------------------------------- write(lchar,"(i5)") irow if( ESMF_LogFoundError(localrc, & msg="cannot read row " // trim(adjustL(lchar)) // & " of table " //trim(descriptor_label) // "in file " // & trim(lfilename), rcToReturn=rc) ) return kelements = kelements + 1 flt_value = flt_tmp elseif( kelements >= ncolumns(irow) .and. irow+1 <= nrows ) then !-------------------------------------------------------------------------- ! reached end of the row, check if another line exists !-------------------------------------------------------------------------- if( new_row(irow+1) == 0 .and. ncolumns(irow+1) >= 2 ) then !----------------------------------------------------------------------- ! if new line starts with a continuation and there are at least two ! columns, advance and read !----------------------------------------------------------------------- irow = irow + 1 kelements = 1 ! if error if( debug_flag) print*,' get next line in real' call ESMF_ConfigNextLine(localcf, tableEnd=flag, rc=localrc) write(lchar,"(i5)") irow if( ESMF_LogFoundError(localrc, & msg="cannot read row " // trim(adjustL(lchar)) // & " of table " //trim(descriptor_label) // "in file " // & trim(lfilename), rcToReturn=rc) ) return !----------------------------------------------------------------------- ! read and discard continuation symbol !----------------------------------------------------------------------- if( debug_flag) print*,' get attribute - contin symbol ' call ESMF_ConfigGetAttribute(localcf, ltmp, rc=localrc) if( ESMF_LogFoundError(localrc, & msg="cannot read row " // trim(adjustL(lchar)) // & " of table " //trim(descriptor_label) // "in file " // & trim(lfilename), rcToReturn=rc) ) return !----------------------------------------------------------------------- ! read string from table !----------------------------------------------------------------------- if( debug_flag) print*,' get attribute - real after continuation ' call ESMF_ConfigGetAttribute(localcf, flt_tmp, rc=localrc) if( ESMF_LogFoundError(localrc, & msg="cannot read row " // trim(adjustL(lchar)) // & " of table " //trim(descriptor_label) // "in file " // & trim(lfilename), rcToReturn=rc) ) return kelements = kelements + 1 flt_value = flt_tmp else !----------------------------------------------------------------------- ! error continuation line missing, but grid not finished !----------------------------------------------------------------------- write(lchar,"(i5)") irow call ESMF_LogSetError( ESMF_FAILURE,msg=" continuation missing " // & "cannot read row " // trim(adjustL(lchar)) // & " of table " //trim(descriptor_label) // "in file " // & trim(lfilename), rcToReturn=rc) return endif ! new line endif ! !----------------------------------------------------------------------------- rc = ESMF_SUCCESS !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- end subroutine read_table_real !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- subroutine read_table_string(string, & kelements, irow, nrows, ncolumns, new_row, & lfilename, descriptor_label, localcf, rc) !----------------------------------------------------------------------------- ! helper routine to read character string entry of a config file table. The ! tables are designed to have multiple lines for a single entry by using "&" ! continuation symbols to indicate a line continuation. It internally tests ! for the end of the table line and looks for a continuation symbol on the ! next line. If found it advances to the next entry. ! ! This separate routine was created to avoid significant duplication of code ! necessary for parsing the tables. !----------------------------------------------------------------------------- ! arguments character(THARN_MAXSTR), intent(in ) :: lfilename, descriptor_label character(THARN_MAXSTR), intent( out) :: string integer, intent(in ) :: ncolumns(:), new_row(:) integer, intent(inout) :: irow ! current row of table integer, intent(in ) :: nrows ! total rows in table integer, intent(inout) :: kelements ! current element of row irow of table type(ESMF_Config), intent(inout) :: localcf integer, intent(inout) :: rc ! local parameters integer :: localrc ! local error status ! local character strings character(THARN_MAXSTR) :: ltmp, lchar logical :: flag ! initialize return flag localrc = ESMF_RC_NOT_IMPL rc = ESMF_RC_NOT_IMPL !----------------------------------------------------------------------------- ! if kelements < ncolumns then not at end of the row and can safely read ! another element. !----------------------------------------------------------------------------- if( kelements < ncolumns(irow) ) then if( debug_flag) print*,' get attribute string ' call ESMF_ConfigGetAttribute(localcf, ltmp, rc=localrc) !-------------------------------------------------------------------------- ! if error !-------------------------------------------------------------------------- write(lchar,"(i5)") irow if( ESMF_LogFoundError(localrc, & msg="cannot read row " // trim(adjustL(lchar)) // & " of table " //trim(descriptor_label) // "in file " // & trim(lfilename), rcToReturn=rc) ) return kelements = kelements + 1 string = ltmp elseif( kelements >= ncolumns(irow) .and. irow+1 <= nrows ) then !-------------------------------------------------------------------------- ! reached end of the row, check if another line exists !-------------------------------------------------------------------------- if( new_row(irow+1) == 0 .and. ncolumns(irow+1) >= 2 ) then !----------------------------------------------------------------------- ! if new line starts with a continuation and there are at least two ! columns, advance and read !----------------------------------------------------------------------- irow = irow + 1 kelements = 1 ! if error if( debug_flag) print*,' next line string ' call ESMF_ConfigNextLine(localcf, tableEnd=flag, rc=localrc) write(lchar,"(i5)") irow if( ESMF_LogFoundError(localrc, & msg="cannot read row " // trim(adjustL(lchar)) // & " of table " //trim(descriptor_label) // "in file " // & trim(lfilename), rcToReturn=rc) ) return !----------------------------------------------------------------------- ! read and discard continuation symbol !----------------------------------------------------------------------- if( debug_flag) print*,' get attribute - read continuation symbol ' call ESMF_ConfigGetAttribute(localcf, ltmp, rc=localrc) if( ESMF_LogFoundError(localrc, & msg="cannot read row " // trim(adjustL(lchar)) // & " of table " //trim(descriptor_label) // "in file " // & trim(lfilename), rcToReturn=rc) ) return !----------------------------------------------------------------------- ! read string from table !----------------------------------------------------------------------- if( debug_flag) print*,' get attribute string after continuation ' call ESMF_ConfigGetAttribute(localcf, ltmp, rc=localrc) if( ESMF_LogFoundError(localrc, & msg="cannot read row " // trim(adjustL(lchar)) // & " of table " //trim(descriptor_label) // "in file " // & trim(lfilename), rcToReturn=rc) ) return kelements = kelements + 1 string = ltmp else !----------------------------------------------------------------------- ! error continuation line missing, but grid not finished !----------------------------------------------------------------------- write(lchar,"(i5)") irow call ESMF_LogSetError( ESMF_FAILURE,msg=" continuation missing " // & "cannot read row " // trim(adjustL(lchar)) // & " of table " //trim(descriptor_label) // "in file " // & trim(lfilename), rcToReturn=rc) return endif ! new line endif ! !----------------------------------------------------------------------------- rc = ESMF_SUCCESS !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- end subroutine read_table_string !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! ! check an actual value against and expected value within a (relative) tolerance ! logical function check_value (exp_val, act_val, tol) real(ESMF_KIND_R8), intent(in) :: exp_val real(ESMF_KIND_R8), intent(in) :: act_val real(ESMF_KIND_R8), intent(in) :: tol real(ESMF_KIND_R8) :: abs_err real(ESMF_KIND_R8) :: tol_band abs_err = abs(act_val - exp_val) tol_band = abs(tol * exp_val) + RegridMinNeighborhood check_value = abs_err .LT. tol_band #if 1 ! print error message if value rejected because its outside of the minimum tolerance band if (.NOT. check_value) then if (abs_err .GE. RegridMinNeighborhood) then call ESMF_LogSetError (ESMF_FAILURE, msg="regrid error - value outside of minimum tolerance band", & line=__LINE__, file=__FILE__) end if end if #endif ! debug #if 0 if (.NOT. check_value) then print *, "check_value - value out of tolerance(debug)", exp_val, act_val, abs_err, tol_band endif #endif return !----------------------------------------------------------------------------- end function check_value !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! ! check an ESMF return code, display file/line no of error location ! logical function CheckError (checkpoint, line, file, rcValue, msg, rcToReturn) logical, intent(in) :: checkpoint integer, intent(in) :: line character(len=*), intent(in) :: file character(len=*), intent(in) :: msg integer, intent(in) :: rcValue integer, intent(out) :: rcToReturn if (checkpoint) then print '("checkpoint at line ", I5, " in file ", A)', line, file end if rcToReturn = ESMF_SUCCESS CheckError = ESMF_LogFoundError (rcValue, msg=msg, rcToReturn=rcToReturn) if (CheckError) then print '("error detected at line ", I5, " in file ", A, " - return code = ", I8)', & line, file, rcToReturn print '(" ", A)', msg end if return !----------------------------------------------------------------------------- end function CheckError !----------------------------------------------------------------------------- !----------------------------------------------------------------------- !=============================================================================== end module ESMF_TestHarnessUtilMod !===============================================================================