!> Character string manipulation methods !> These methods work generally on character strings, but also, more particularly !> on lists. A list is a character string that contains substrings separated by !> a delimeter. That delimeter can be set by the user but the default is ":". !> Colon delimeted lists are used in OASIS and MCT mainly to instantiate a list !> of fields, such as "temperature:humidity:zonal_velocity:meridiona_velocity". #define NEW_LGI_METHOD2a !!#define NEW_LGI_METHOD2b !=============================================================================== !BOP =========================================================================== ! ! !MODULE: mod_oasis_string -- string and list methods ! ! !DESCRIPTION: ! General string and specific list method. A list is a single string ! that is delimited by a character forming multiple fields, ie, ! character(len=*) :: mylist = "t:s:u1:v1:u2:v2:taux:tauy" ! The delimiter is called listDel in this module, is default ":", ! but can be set by a call to oasis_string_listSetDel. ! ! ! !INTERFACE: ------------------------------------------------------------------ module mod_oasis_string ! !USES: use mod_oasis_kinds use mod_oasis_parameters use mod_oasis_data use mod_oasis_sys use mod_oasis_timer implicit none private ! !PUBLIC TYPES: ! no public types ! !PUBLIC MEMBER FUNCTIONS: public :: oasis_string_countChar ! Count number of char in string, fn public :: oasis_string_toUpper ! Convert string to upper-case public :: oasis_string_toLower ! Convert string to lower-case public :: oasis_string_getParentDir ! For a pathname get the parent directory name public :: oasis_string_lastIndex ! Index of last substr in str public :: oasis_string_endIndex ! Index of end of substr in str public :: oasis_string_leftAlign ! remove leading white space public :: oasis_string_alphanum ! remove all non alpha-numeric characters public :: oasis_string_betweenTags ! get the substring between the two tags public :: oasis_string_parseCFtunit ! parse CF time units public :: oasis_string_clean ! Set string to all white space public :: oasis_string_listIsValid ! test for a valid "list" public :: oasis_string_listGetNum ! Get number of fields in list, fn public :: oasis_string_listGetIndex ! Get index of field public :: oasis_string_listGetIndexF ! function version of listGetIndex public :: oasis_string_listGetName ! get k-th field name public :: oasis_string_listIntersect ! get intersection of two field lists public :: oasis_string_listUnion ! get union of two field lists public :: oasis_string_listMerge ! merge two lists to form third public :: oasis_string_listAppend ! append list at end of another public :: oasis_string_listPrepend ! prepend list in front of another public :: oasis_string_listSetDel ! Set field delimeter in lists public :: oasis_string_listGetDel ! Get field delimeter in lists public :: oasis_string_setAbort ! set local abort flag public :: oasis_string_setDebug ! set local debug flag ! !PUBLIC DATA MEMBERS: ! no public data members !EOP character(len=1) ,save :: listDel = ":" ! note single exec implications character(len=2) ,save :: listDel2 = "::" ! note single exec implications logical ,save :: doabort = .true. integer(ip_i4_p),save :: debug = 0 !=============================================================================== contains !=============================================================================== !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_countChar -- Count number of occurances of a character ! ! !DESCRIPTION: !> Count number of occurances of a single character in a string ! \newline ! n = shr\_string\_countChar(string,character) ! ! ! !INTERFACE: ------------------------------------------------------------------ integer function oasis_string_countChar(str,char,rc) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*) ,intent(in) :: str !< string to search character(1) ,intent(in) :: char !< char to search for integer(ip_i4_p),intent(out),optional :: rc !< return code !EOP !----- local ----- integer(ip_i4_p) :: count ! counts occurances of char integer(ip_i4_p) :: n ! generic index !----- formats ----- character(*),parameter :: subName = "(oasis_string_countChar) " !------------------------------------------------------------------------------- ! Notes: !------------------------------------------------------------------------------- call oasis_debug_enter(subname) count = 0 do n = 1, len_trim(str) if (str(n:n) == char) count = count + 1 end do oasis_string_countChar = count if (present(rc)) rc = 0 call oasis_debug_exit(subname) end function oasis_string_countChar !=============================================================================== !BOP =========================================================================== ! !IROUTINE: oasis_string_toUpper -- Convert string to upper case ! ! !DESCRIPTION: !> Convert the input string to upper-case. ! Use achar and iachar intrinsics to ensure use of ascii collating sequence. ! ! ! !INTERFACE: ------------------------------------------------------------------ function oasis_string_toUpper(str) implicit none ! !INPUT/OUTPUT PARAMETERS: character(len=*), intent(in) :: str !< input string to convert to upper case character(len=len(str)) :: oasis_string_toUpper !< output converted string !----- local ----- integer(ip_i4_p) :: i ! Index integer(ip_i4_p) :: aseq ! ascii collating sequence integer(ip_i4_p) :: LowerToUpper ! integer to convert case character(len=1) :: ctmp ! Character temporary !----- formats ----- character(*),parameter :: subName = "(oasis_string_toUpper) " !------------------------------------------------------------------------------- ! !------------------------------------------------------------------------------- call oasis_debug_enter(subname) LowerToUpper = iachar("A") - iachar("a") do i = 1, len(str) ctmp = str(i:i) aseq = iachar(ctmp) if ( aseq >= iachar("a") .and. aseq <= iachar("z") ) & ctmp = achar(aseq + LowertoUpper) oasis_string_toUpper(i:i) = ctmp end do call oasis_debug_exit(subname) end function oasis_string_toUpper !=============================================================================== !BOP =========================================================================== ! !IROUTINE: oasis_string_toLower -- Convert string to lower case ! ! !DESCRIPTION: !> Convert the input string to lower-case. ! Use achar and iachar intrinsics to ensure use of ascii collating sequence. ! ! ! !INTERFACE: ------------------------------------------------------------------ function oasis_string_toLower(str) implicit none ! !INPUT/OUTPUT PARAMETERS: character(len=*), intent(in) :: str !< input string to convert to lower case character(len=len(str)) :: oasis_string_toLower !< output converted string !----- local ----- integer(ip_i4_p) :: i ! Index integer(ip_i4_p) :: aseq ! ascii collating sequence integer(ip_i4_p) :: UpperToLower ! integer to convert case character(len=1) :: ctmp ! Character temporary !----- formats ----- character(*),parameter :: subName = "(oasis_string_toLower) " !------------------------------------------------------------------------------- ! !------------------------------------------------------------------------------- call oasis_debug_enter(subname) UpperToLower = iachar("a") - iachar("A") do i = 1, len(str) ctmp = str(i:i) aseq = iachar(ctmp) if ( aseq >= iachar("A") .and. aseq <= iachar("Z") ) & ctmp = achar(aseq + UpperToLower) oasis_string_toLower(i:i) = ctmp end do call oasis_debug_exit(subname) end function oasis_string_toLower !=============================================================================== !BOP =========================================================================== ! !IROUTINE: oasis_string_getParentDir -- For pathname get the parent directory name ! ! !DESCRIPTION: !> Get the parent directory pathname. ! ! ! !INTERFACE: ------------------------------------------------------------------ function oasis_string_getParentDir(str) implicit none ! !INPUT/OUTPUT PARAMETERS: character(len=*), intent(in) :: str !< input string character(len=len(str)) :: oasis_string_getParentDir !< return directory path !----- local ----- integer(ip_i4_p) :: i ! Index integer(ip_i4_p) :: nlen ! Length of string !----- formats ----- character(*),parameter :: subName = "(oasis_string_getParentDir) " !------------------------------------------------------------------------------- ! !------------------------------------------------------------------------------- call oasis_debug_enter(subname) nlen = len_trim(str) if ( str(nlen:nlen) == "/" ) nlen = nlen - 1 i = index( str(1:nlen), "/", back=.true. ) if ( i == 0 )then oasis_string_getParentDir = str else oasis_string_getParentDir = str(1:i-1) end if call oasis_debug_exit(subname) end function oasis_string_getParentDir !=============================================================================== !BOP =========================================================================== ! ! ! !IROUTINE: oasis_string_lastIndex -- Get index of last substr within string ! ! !DESCRIPTION: !> Get the index of the last occurance of a substring within a string ! \newline ! n = shr\_string\_lastIndex(string,substring) ! ! ! !INTERFACE: ------------------------------------------------------------------ integer function oasis_string_lastIndex(string,substr,rc) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*) ,intent(in) :: string !< input string to search character(*) ,intent(in) :: substr !< sub-string to search for integer(ip_i4_p),intent(out),optional :: rc !< return code !EOP !--- local --- !----- formats ----- character(*),parameter :: subName = "(oasis_string_lastIndex) " !------------------------------------------------------------------------------- ! Note: ! - "new" F90 back option to index function makes this home-grown solution obsolete !------------------------------------------------------------------------------- call oasis_debug_enter(subname) oasis_string_lastIndex = index(string,substr,.true.) if (present(rc)) rc = 0 call oasis_debug_exit(subname) end function oasis_string_lastIndex !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_endIndex -- Get the ending index of substr within string ! ! !DESCRIPTION: !> Get the ending index of the first occurance of a substring within string ! \newline ! n = shr\_string\_endIndex(string,substring) ! ! ! !INTERFACE: ------------------------------------------------------------------ integer function oasis_string_endIndex(string,substr,rc) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*) ,intent(in) :: string !< string to search character(*) ,intent(in) :: substr !< sub-string to search for integer(ip_i4_p),intent(out),optional :: rc !< return code !EOP !--- local --- integer(ip_i4_p) :: i ! generic index !----- formats ----- character(*),parameter :: subName = "(oasis_string_endIndex) " !------------------------------------------------------------------------------- ! Notes: ! * returns zero if substring not found, uses len_trim() intrinsic ! * very similar to: i = index(str,substr,back=.true.) ! * do we need this function? !------------------------------------------------------------------------------- call oasis_debug_enter(subname) i = index(trim(string),trim(substr)) if ( i == 0 ) then oasis_string_endIndex = 0 ! substr is not in string else oasis_string_endIndex = i + len_trim(substr) - 1 end if ! ------------------------------------------------------------------- ! i = index(trim(string),trim(substr),back=.true.) ! if (i == len(string)+1) i = 0 ! oasis_string_endIndex = i ! ------------------------------------------------------------------- if (present(rc)) rc = 0 call oasis_debug_exit(subname) end function oasis_string_endIndex !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_leftAlign -- remove leading white space ! ! !DESCRIPTION: !> Remove leading white space ! \newline ! call shr\_string\_leftAlign(string) ! ! ! !INTERFACE: ------------------------------------------------------------------ subroutine oasis_string_leftAlign(str,rc) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*) ,intent(inout) :: str !< input and returned string integer(ip_i4_p),intent(out) ,optional :: rc !< return code !EOP !----- local ---- integer(ip_i4_p) :: rCode ! return code !----- formats ----- character(*),parameter :: subName = "(oasis_string_leftAlign) " !------------------------------------------------------------------------------- ! note: ! * ?? this routine isn't needed, use the intrisic adjustL instead ?? !------------------------------------------------------------------------------- ! ------------------------------------------------------------------- ! --- used this until I discovered the intrinsic function below ! do while (len_trim(str) > 0 ) ! if (str(1:1) /= ' ') exit ! str = str(2:len_trim(str)) ! end do ! rCode = 0 ! !! (len_trim(str) == 0 ) rCode = 1 ! ?? appropriate ?? ! ------------------------------------------------------------------- call oasis_debug_enter(subname) str = adjustL(str) if (present(rc)) rc = 0 call oasis_debug_exit(subname) end subroutine oasis_string_leftAlign !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_alphanum -- remove non alpha numeric characters ! ! !DESCRIPTION: !> Remove all non alpha numeric characters from string ! \newline ! call shr\_string\_alphanum(string) ! ! ! !INTERFACE: ------------------------------------------------------------------ subroutine oasis_string_alphanum(str,rc) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*) ,intent(inout) :: str !< input and output string integer(ip_i4_p),intent(out) ,optional :: rc !< return code !EOP !----- local ---- integer(ip_i4_p) :: rCode ! return code integer(ip_i4_p) :: n,icnt ! counters !----- formats ----- character(*),parameter :: subName = "(oasis_string_alphaNum) " !------------------------------------------------------------------------------- ! !------------------------------------------------------------------------------- call oasis_debug_enter(subname) icnt = 0 do n=1,len_trim(str) if ((str(n:n) >= 'a' .and. str(n:n) <= 'z') .or. & (str(n:n) >= 'A' .and. str(n:n) <= 'Z') .or. & (str(n:n) >= '0' .and. str(n:n) <= '9')) then icnt = icnt + 1 str(icnt:icnt) = str(n:n) endif enddo do n=icnt+1,len(str) str(n:n) = ' ' enddo if (present(rc)) rc = 0 call oasis_debug_exit(subname) end subroutine oasis_string_alphanum !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_betweenTags -- Get the substring between the two tags. ! ! !DESCRIPTION: !> Get the substring found between the start and end strings. ! \newline ! call shr\_string\_betweenTags(string,startTag,endTag,substring,rc) ! ! ! !INTERFACE: ------------------------------------------------------------------ subroutine oasis_string_betweenTags(string,startTag,endTag,substr,rc) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*) ,intent(in) :: string !< input string to search character(*) ,intent(in) :: startTag !< start string character(*) ,intent(in) :: endTag !< end string character(*) ,intent(out) :: substr !< output sub-string between tags integer(ip_i4_p),intent(out),optional :: rc !< return code !EOP !--- local --- integer(ip_i4_p) :: iStart ! substring start index integer(ip_i4_p) :: iEnd ! substring end index integer(ip_i4_p) :: rCode ! return code !----- formats ----- character(*),parameter :: subName = "(oasis_string_betweenTags) " !------------------------------------------------------------------------------- ! Notes: ! * assumes the leading/trailing white space is not part of start & end tags !------------------------------------------------------------------------------- call oasis_debug_enter(subname) iStart = oasis_string_endIndex(string,trim(adjustL(startTag))) ! end of start tag iEnd = index(string,trim(adjustL(endTag ))) ! start of end tag rCode = 0 substr = "" if (iStart < 1) then WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local WRITE(nulprt,*) subname,estr,"can't find start tag in string" WRITE(nulprt,*) subname,estr,"start tag = ",TRIM(startTag) WRITE(nulprt,*) subname,estr,"string = ",TRIM(string) CALL oasis_flush(nulprt) rCode = 1 else if (iEnd < 1) then WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local WRITE(nulprt,*) subname,estr,"can't find end tag in string" WRITE(nulprt,*) subname,estr,"end tag = ",TRIM( endTag) WRITE(nulprt,*) subname,estr,"string = ",TRIM(string) CALL oasis_flush(nulprt) rCode = 2 else if ( iEnd <= iStart) then WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local WRITE(nulprt,*) subname,estr,"start tag not before end tag" WRITE(nulprt,*) subname,estr,"start tag = ",TRIM(startTag) WRITE(nulprt,*) subname,estr,"end tag = ",TRIM( endTag) WRITE(nulprt,*) subname,estr,"string = ",TRIM(string) CALL oasis_flush(nulprt) rCode = 3 else if ( iStart+1 == iEnd ) then substr = "" WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local WRITE(nulprt,*) subname,wstr,"zero-length substring found in ",TRIM(string) CALL oasis_flush(nulprt) else substr = string(iStart+1:iEnd-1) IF (LEN_TRIM(substr) == 0) THEN WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local WRITE(nulprt,*) subname,wstr,"white-space substring found in ",TRIM(string) CALL oasis_flush(nulprt) ENDIF end if if (present(rc)) rc = rCode call oasis_debug_exit(subname) end subroutine oasis_string_betweenTags !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_parseCFtunit -- Parse CF time unit ! ! !DESCRIPTION: !> Parse CF time unit into a delta string name and a base time in yyyymmdd ! and seconds (nearest integer actually). ! \newline ! call shr\_string\_parseCFtunit(string,substring) ! \newline ! Input string is like "days since 0001-06-15 15:20:45.5 -6:00" ! - recognizes "days", "hours", "minutes", "seconds" ! - must have at least yyyy-mm-dd, hh:mm:ss.s is optional ! - expects a "since" in the string ! - ignores time zone part ! ! ! !INTERFACE: ------------------------------------------------------------------ subroutine oasis_string_parseCFtunit(string,unit,bdate,bsec,rc) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*) ,intent(in) :: string !< string to search character(*) ,intent(out) :: unit !< delta time unit integer(ip_i4_p),intent(out) :: bdate !< base date yyyymmdd real(ip_r8_p) ,intent(out) :: bsec !< base seconds integer(ip_i4_p),intent(out),optional :: rc !< return code !EOP !--- local --- integer(ip_i4_p) :: i,i1,i2 ! generic index character(ic_long) :: tbase ! baseline time character(ic_long) :: lstr ! local string integer(ip_i4_p) :: yr,mo,da,hr,min ! time stuff real(ip_r8_p) :: sec ! time stuff !----- formats ----- character(*),parameter :: subName = "(oasis_string_parseCFtunit) " !------------------------------------------------------------------------------- ! Notes: ! o assume length of CF-1.0 time attribute char string < ic_long ! This is a reasonable assumption. !------------------------------------------------------------------------------- call oasis_debug_enter(subname) unit = 'none' bdate = 0 bsec = 0.0_ip_r8_p i = oasis_string_lastIndex(string,'days ') if (i > 0) unit = 'days' i = oasis_string_lastIndex(string,'hours ') if (i > 0) unit = 'hours' i = oasis_string_lastIndex(string,'minutes ') if (i > 0) unit = 'minutes' i = oasis_string_lastIndex(string,'seconds ') if (i > 0) unit = 'seconds' if (trim(unit) == 'none') then WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local WRITE(nulprt,*) subname,estr,'time unit unknown' CALL oasis_flush(nulprt) CALL oasis_string_abort(subName//' time unit unknown') endif i = oasis_string_lastIndex(string,' since ') if (i < 1) then WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local WRITE(nulprt,*) subname,estr,'since does not appear in unit attribute for time ' CALL oasis_flush(nulprt) CALL oasis_string_abort(subName//' no since in attr name') endif tbase = trim(string(i+6:)) call oasis_string_leftAlign(tbase) if (debug > 0 .and. nulprt > 0) then WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local WRITE(nulprt,*) TRIM(subName)//' '//'unit '//TRIM(unit) WRITE(nulprt,*) TRIM(subName)//' '//'tbase '//TRIM(tbase) CALL oasis_flush(nulprt) endif yr=0; mo=0; da=0; hr=0; min=0; sec=0 i1 = 1 i2 = index(tbase,'-') - 1 lstr = tbase(i1:i2) read(lstr,*,ERR=200,END=200) yr tbase = tbase(i2+2:) call oasis_string_leftAlign(tbase) i2 = index(tbase,'-') - 1 lstr = tbase(i1:i2) read(lstr,*,ERR=200,END=200) mo tbase = tbase(i2+2:) call oasis_string_leftAlign(tbase) i2 = index(tbase,' ') - 1 lstr = tbase(i1:i2) read(lstr,*,ERR=200,END=200) da tbase = tbase(i2+2:) call oasis_string_leftAlign(tbase) i2 = index(tbase,':') - 1 lstr = tbase(i1:i2) read(lstr,*,ERR=200,END=100) hr tbase = tbase(i2+2:) call oasis_string_leftAlign(tbase) i2 = index(tbase,':') - 1 lstr = tbase(i1:i2) read(lstr,*,ERR=200,END=100) min tbase = tbase(i2+2:) call oasis_string_leftAlign(tbase) i2 = index(tbase,' ') - 1 lstr = tbase(i1:i2) read(lstr,*,ERR=200,END=100) sec 100 continue IF (debug > 0 ) THEN WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local WRITE(nulprt,*) TRIM(subName),'ymdhms:',yr,mo,da,hr,min,sec CALL oasis_flush(nulprt) ENDIF bdate = abs(yr)*10000 + mo*100 + da if (yr < 0) bdate = -bdate bsec = real(hr*3600 + min*60,ip_r8_p) + sec if (present(rc)) rc = 0 call oasis_debug_exit(subname) return 200 continue WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local write(nulprt,*) subname,estr,'200 on char num read ' CALL oasis_flush(nulprt) call oasis_string_abort(subName//estr//'on char num read') call oasis_debug_exit(subname) end subroutine oasis_string_parseCFtunit !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_clean -- Clean a string, set it to "blank" ! ! !DESCRIPTION: !> Clean a string, set it to blank ! \newline ! call shr\_string\_clean(string,rc) ! ! ! !INTERFACE: ------------------------------------------------------------------ subroutine oasis_string_clean(string,rc) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*) ,intent(inout) :: string !< char string integer(ip_i4_p),optional,intent(out) :: rc !< return code !EOP !----- local ----- integer(ip_i4_p) :: n ! counter integer(ip_i4_p) :: rCode ! return code !----- formats ----- character(*),parameter :: subName = "(oasis_string_clean) " !------------------------------------------------------------------------------- ! Notes: !------------------------------------------------------------------------------- call oasis_debug_enter(subname) rCode = 0 string = ' ' if (present(rc)) rc = rCode call oasis_debug_exit(subname) end subroutine oasis_string_clean !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_listIsValid -- determine whether string is a valid list ! ! !DESCRIPTION: !> Determine whether string is a valid list ! \newline ! logical_var = shr\_string\_listIsValid(list,rc) ! ! ! !INTERFACE: ------------------------------------------------------------------ logical function oasis_string_listIsValid(list,rc) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*) ,intent(in) :: list !< list/string integer(ip_i4_p),optional,intent(out) :: rc !< return code !EOP !----- local ----- integer (ip_i4_p) :: nChar ! lenth of list integer (ip_i4_p) :: rCode ! return code !----- formats ----- character(*),parameter :: subName = "(oasis_string_listIsValid) " !------------------------------------------------------------------------------- ! check that the list conforms to the list format !------------------------------------------------------------------------------- call oasis_debug_enter(subname) rCode = 0 oasis_string_listIsValid = .true. nChar = len_trim(list) if (nChar < 1) then ! list is an empty string rCode = 1 else if ( list(1:1) == listDel ) then ! first char is delimiter rCode = 2 else if (list(nChar:nChar) == listDel ) then ! last char is delimiter rCode = 3 else if (index(trim(list)," " ) > 0) then ! white-space in a field name rCode = 4 else if (index(trim(list),listDel2) > 0) then ! found zero length field rCode = 5 end if if (rCode /= 0) then oasis_string_listIsValid = .false. WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local write(nulprt,*) subname,wstr,"invalid list = ",trim(list) CALL oasis_flush(nulprt) endif if (present(rc)) rc = rCode call oasis_debug_exit(subname) end function oasis_string_listIsValid !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_listGetName -- Get name of k-th field in list ! ! !DESCRIPTION: !> Get name of k-th field in list ! \newline ! call shr\_string\_listGetName(list,k,name,rc) ! ! ! !INTERFACE: ------------------------------------------------------------------ subroutine oasis_string_listGetName(list,k,name,rc) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*) ,intent(in) :: list !< input list integer(ip_i4_p) ,intent(in) :: k !< index of field character(*) ,intent(out) :: name !< k-th name in list integer(ip_i4_p),optional,intent(out) :: rc !< return code !EOP !----- local ----- integer(ip_i4_p) :: i,j,n ! generic indecies integer(ip_i4_p) :: kFlds ! number of fields in list integer(ip_i4_p) :: i0,i1 ! name = list(i0:i1) integer(ip_i4_p) :: rCode ! return code !----- formats ----- character(*),parameter :: subName = "(oasis_string_listGetName) " !------------------------------------------------------------------------------- ! Notes: !------------------------------------------------------------------------------- call oasis_debug_enter(subname) rCode = 0 !--- check that this is a valid list --- if (.not. oasis_string_listIsValid(list,rCode) ) then WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local write(nulprt,*) subname,estr,"invalid list = ",trim(list) CALL oasis_flush(nulprt) call oasis_string_abort(subName//estr//"invalid list = "//trim(list)) end if !--- check that this is a valid index --- kFlds = oasis_string_listGetNum(list) if (k<1 .or. kFlds Get intersection of two fields lists, write into third list ! \newline ! call shr\_string\_listIntersect(list1,list2,listout) ! ! ! !INTERFACE: ------------------------------------------------------------------ subroutine oasis_string_listIntersect(list1,list2,listout,rc) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*) ,intent(in) :: list1 !< input list 1 character(*) ,intent(in) :: list2 !< input list 2 character(*) ,intent(out) :: listout !< output list integer(ip_i4_p),optional,intent(out) :: rc !< return code !EOP !----- local ----- integer(ip_i4_p) :: nf,n1,n2 ! counters character(ic_med) :: name ! field name integer(ip_i4_p) :: rCode ! return code !----- formats ----- character(*),parameter :: subName = "(oasis_string_listIntersect) " !------------------------------------------------------------------------------- ! Notes: !------------------------------------------------------------------------------- call oasis_debug_enter(subname) rCode = 0 nf = oasis_string_listGetNum(list1) call oasis_string_clean(listout) do n1 = 1,nf call oasis_string_listGetName(list1,n1,name,rCode) n2 = oasis_string_listGetIndexF(list2,name) if (n2 > 0) then call oasis_string_listAppend(listout,name) endif enddo if (present(rc)) rc = rCode call oasis_debug_exit(subname) end subroutine oasis_string_listIntersect !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_listUnion -- Get union of two field lists ! ! !DESCRIPTION: !> Get union of two fields lists, write into third list ! \newline ! call shr\_string\_listUnion(list1,list2,listout) ! ! ! !INTERFACE: ------------------------------------------------------------------ subroutine oasis_string_listUnion(list1,list2,listout,rc) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*) ,intent(in) :: list1 !< input list 1 character(*) ,intent(in) :: list2 !< input list 2 character(*) ,intent(out) :: listout !< output list 3 integer(ip_i4_p),optional,intent(out) :: rc !< return code !EOP !----- local ----- integer(ip_i4_p) :: nf,n1,n2 ! counters character(ic_med) :: name ! field name integer(ip_i4_p) :: rCode ! return code !----- formats ----- character(*),parameter :: subName = "(oasis_string_listUnion) " !------------------------------------------------------------------------------- ! Notes: !------------------------------------------------------------------------------- call oasis_debug_enter(subname) rCode = 0 call oasis_string_clean(listout) nf = oasis_string_listGetNum(list1) do n1 = 1,nf call oasis_string_listGetName(list1,n1,name,rCode) n2 = oasis_string_listGetIndexF(listout,name) if (n2 < 1) then call oasis_string_listAppend(listout,name) endif enddo nf = oasis_string_listGetNum(list2) do n1 = 1,nf call oasis_string_listGetName(list2,n1,name,rCode) n2 = oasis_string_listGetIndexF(listout,name) if (n2 < 1) then call oasis_string_listAppend(listout,name) endif enddo if (present(rc)) rc = rCode call oasis_debug_exit(subname) end subroutine oasis_string_listUnion !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_listMerge -- Merge lists two list to third ! ! !DESCRIPTION: !> Merge two lists into a third list ! \newline ! call shr\_string\_listMerge(list1,list2,listout) ! call shr\_string\_listMerge(list1,list2,list1) ! ! ! !INTERFACE: ------------------------------------------------------------------ subroutine oasis_string_listMerge(list1,list2,listout,rc) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*) ,intent(in) :: list1 !< input list 1 character(*) ,intent(in) :: list2 !< input list 2 character(*) ,intent(out) :: listout !< output list integer(ip_i4_p),optional,intent(out) :: rc !< return code !EOP !----- local ----- character(ic_xxl):: l1,l2 ! local char strings integer(ip_i4_p) :: rCode ! return code !----- formats ----- character(*),parameter :: subName = "(oasis_string_listMerge) " !------------------------------------------------------------------------------- ! Notes: ! - no input or output string should be longer than ic_xxl !------------------------------------------------------------------------------- call oasis_debug_enter(subname) rCode = 0 !--- make sure temp strings are large enough --- if ( (len(l1) < len_trim(list1)) .or. (len(l2) < len_trim(list2))) then call oasis_string_abort(subName//estr//"temp string not large enough") end if call oasis_string_clean(l1) call oasis_string_clean(l2) call oasis_string_clean(listout) l1 = trim(list1) l2 = trim(list2) call oasis_string_leftAlign(l1,rCode) call oasis_string_leftAlign(l2,rCode) if (len_trim(l1)+len_trim(l2)+1 > len(listout)) & call oasis_string_abort(subName//estr//"output list string not large enough") if (len_trim(l1) == 0) then listout = trim(l2) else listout = trim(l1)//":"//trim(l2) endif if (present(rc)) rc = rCode call oasis_debug_exit(subname) end subroutine oasis_string_listMerge !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_listAppend -- Append one list to another ! ! !DESCRIPTION: !> Append one list to another ! \newline ! call shr\_string\_listAppend(list,listadd) ! ! ! !INTERFACE: ------------------------------------------------------------------ subroutine oasis_string_listAppend(list,listadd,rc) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*) ,intent(inout) :: list !< input and output list character(*) ,intent(in) :: listadd !< list to append integer(ip_i4_p),optional,intent(out) :: rc !< return code !EOP !----- local ----- character(ic_xxl) :: l1 ! local string integer(ip_i4_p) :: rCode ! return code !----- formats ----- character(*),parameter :: subName = "(oasis_string_listAppend) " !------------------------------------------------------------------------------- ! Notes: ! - no input or output string should be longer than ic_xxl !------------------------------------------------------------------------------- call oasis_debug_enter(subname) rCode = 0 !--- make sure temp string is large enough --- if (len(l1) < len_trim(listAdd)) then call oasis_string_abort(subName//estr//'temp string not large enough') end if call oasis_string_clean(l1) l1 = trim(listadd) call oasis_string_leftAlign(l1,rCode) if (len_trim(list)+len_trim(l1)+1 > len(list)) & call oasis_string_abort(subName//estr//'output list string not large enough') if (len_trim(list) == 0) then list = trim(l1) else list = trim(list)//":"//trim(l1) endif if (present(rc)) rc = rCode call oasis_debug_exit(subname) end subroutine oasis_string_listAppend !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_listPrepend -- Prepend one list to another ! ! !DESCRIPTION: !> Prepend one list to another ! \newline ! call shr\_string\_listPrepend(listadd,list) ! \newline ! results in listadd:list ! ! ! !INTERFACE: ------------------------------------------------------------------ subroutine oasis_string_listPrepend(listadd,list,rc) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*) ,intent(in) :: listadd ! input and output list character(*) ,intent(inout) :: list ! list to prepend integer(ip_i4_p),optional,intent(out) :: rc ! return code !EOP !----- local ----- character(ic_xxl) :: l1 ! local string integer(ip_i4_p) :: rCode ! return code !----- formats ----- character(*),parameter :: subName = "(oasis_string_listPrepend) " !------------------------------------------------------------------------------- ! Notes: ! - no input or output string should be longer than ic_xxl !------------------------------------------------------------------------------- call oasis_debug_enter(subname) rCode = 0 !--- make sure temp string is large enough --- if (len(l1) < len_trim(listAdd)) then call oasis_string_abort(subName//estr//'temp string not large enough') end if call oasis_string_clean(l1) l1 = trim(listadd) call oasis_string_leftAlign(l1,rCode) call oasis_string_leftAlign(list,rCode) if (len_trim(list)+len_trim(l1)+1 > len(list)) & call oasis_string_abort(subName//estr//"output list string not large enough") if (len_trim(l1) == 0) then list = trim(list) else list = trim(l1)//":"//trim(list) endif if (present(rc)) rc = rCode call oasis_debug_exit(subname) end subroutine oasis_string_listPrepend !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_listGetIndexF -- Get index of field in string ! ! !DESCRIPTION: !> Get the index of a field in a list ! \newline ! k = shr\_string\_listGetIndex(str,"taux") ! ! ! !INTERFACE: ------------------------------------------------------------------ integer function oasis_string_listGetIndexF(string,fldStr) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*),intent(in) :: string !< input string character(*),intent(in) :: fldStr !< name of field !EOP !----- local ----- integer(ip_i4_p) :: k ! local index variable integer(ip_i4_p) :: rc ! error code !----- formats ----- character(*),parameter :: subName = "(oasis_string_listGetIndexF) " !------------------------------------------------------------------------------- call oasis_debug_enter(subname) call oasis_string_listGetIndex(string,fldStr,k,print=.false.,rc=rc) oasis_string_listGetIndexF = k call oasis_debug_exit(subname) end function oasis_string_listGetIndexF #if (defined NEW_LGI_METHOD2a || defined NEW_LGI_METHOD2b) !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_listGetIndex -- Get index of field in string ! ! !DESCRIPTION: !> Get the index of a field in a string ! \newline ! call shr\_string\_listGetIndex(str,"taux",k,rc) ! ! ! !INTERFACE: ------------------------------------------------------------------ subroutine oasis_string_listGetIndex(string,fldStr,kFld,print,rc) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*) ,intent(in) :: string !< input list character(*) ,intent(in) :: fldStr !< name of field integer(ip_i4_p),intent(out) :: kFld !< index of field in list logical ,intent(in) ,optional :: print !< print switch integer(ip_i4_p),intent(out),optional :: rc !< return code !EOP !----- local ----- integer(ip_i4_p) :: n,n1,n2 ! index for colon position integer(ip_i4_p) :: lens ! length of string logical :: found ! T => field found in fieldNames logical :: lprint ! local print flag !----- formats ----- character(*),parameter :: subName = "(oasis_string_listGetIndex) " !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- call oasis_debug_enter(subname) ! call oasis_timer_start('tcx_slgi0') ! call oasis_timer_start('tcx_slgia') if (present(rc)) rc = 0 kfld = 0 found = .false. lprint = .false. if (present(print)) lprint = print !--- confirm proper size of input data --- if (len_trim(fldStr) < 1) then IF (lprint) THEN WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local WRITE(nulprt,*) subname,estr,"input field name has 0 length" CALL oasis_flush(nulprt) ENDIF CALL oasis_string_abort(subName//"invalid field name") end if ! call oasis_timer_stop('tcx_slgia') ! call oasis_timer_start('tcx_slgib') lens = len_trim(string) ! write(nulprt,*) subname,' tcx1 ',string ! write(nulprt,*) subname,' tcx2 ',fldStr n = index(string,listDel,back=.false.) ! write(nulprt,*) subname,' tcx3 ',n ! call oasis_timer_start('tcx_slgib') ! call oasis_timer_start('tcx_slgic') if (n <= 0) then ! single field only ! call oasis_timer_start('tcx_slgic1') if (trim(fldStr) == string(1:lens)) then found = .true. kFld = 1 endif ! call oasis_timer_stop('tcx_slgic1') ! write(nulprt,*) subname,' tcx4a ',found,kfld elseif (n > 0) then !--- check first string --- ! call oasis_timer_start('tcx_slgic2') if (trim(fldStr) == string(1:n-1)) then found = .true. kFld = 1 endif ! write(nulprt,*) subname,' tcx4b ',found,kfld ! call oasis_timer_stop('tcx_slgic2') !--- check last string --- if (.not.found) then ! call oasis_timer_start('tcx_slgic3') n = index(string,listDel,back=.true.) if (trim(fldStr) == string(n+1:lens)) then found = .true. kFld = oasis_string_listGetNum(string) endif ! call oasis_timer_stop('tcx_slgic3') ! write(nulprt,*) subname,' tcx4c ',found,kfld endif !--- check other strings --- if (.not.found) then ! call oasis_timer_start('tcx_slgic4') n = index(string,':'//trim(fldStr)//':',back=.false.) ! write(nulprt,*) subname,' tcx5a ',n if (n > 0) then found = .true. #if defined NEW_LGI_METHOD2a if (n <= lens) then #endif #if defined NEW_LGI_METHOD2b if (n <= lens/2) then #endif ! call oasis_timer_start('tcx_slgic4a') n1 = 0 kFld = 1 do while (n1 < n) kFld = kFld + 1 n2 = index(string(n1+1:lens),listDel,back=.false.) n1 = n1 + n2 ! write(nulprt,*) subname,' tcx5b ',kfld,n2,n1,n enddo ! call oasis_timer_stop('tcx_slgic4a') else ! call oasis_timer_start('tcx_slgic4b') n1 = lens+1 kFld = oasis_string_listGetNum(string) + 1 ! call oasis_timer_stop('tcx_slgic4b') ! call oasis_timer_start('tcx_slgic4c') do while (n1 > n) kFld = kFld - 1 n2 = index(string(1:n1-1),listDel,back=.true.) n1 = n2 ! write(nulprt,*) subname,' tcx5c ',kfld,n2,n1,n enddo ! call oasis_timer_stop('tcx_slgic4c') endif endif ! write(nulprt,*) subname,' tcx4d ',found,kfld ! call oasis_timer_stop('tcx_slgic4') endif endif ! call oasis_timer_stop('tcx_slgic') ! call oasis_timer_start('tcx_slgid') !--- not finding a field is not a fatal error --- if (.not. found) then IF (lprint) THEN WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local WRITE(nulprt,*) subname,"FYI: field ",TRIM(fldStr)," not found in list ",TRIM(string) CALL oasis_flush(nulprt) ENDIF if (present(rc)) rc = 1 end if ! call oasis_timer_stop('tcx_slgid') ! call oasis_timer_stop('tcx_slgi0') call oasis_debug_exit(subname) end subroutine oasis_string_listGetIndex #endif !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_listGetNum -- get number of fields in a string list ! ! !DESCRIPTION: !> return number of fields in string list ! ! ! !INTERFACE: ------------------------------------------------------------------ integer function oasis_string_listGetNum(str) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*),intent(in) :: str !< input list !EOP !----- local ----- integer(ip_i4_p) :: count ! counts occurances of char !----- formats ----- character(*),parameter :: subName = "(oasis_string_listGetNum) " !------------------------------------------------------------------------------- ! Notes: !------------------------------------------------------------------------------- call oasis_debug_enter(subname) oasis_string_listGetNum = 0 if (len_trim(str) > 0) then count = oasis_string_countChar(str,listDel) oasis_string_listGetNum = count + 1 endif call oasis_debug_exit(subname) end function oasis_string_listGetNum !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_listSetDel -- Set list delimeter character ! ! !DESCRIPTION: !> Set field delimeter character in lists ! \newline ! call shr\_string\_listSetDel(":") ! ! ! !INTERFACE: ------------------------------------------------------------------ subroutine oasis_string_listSetDel(cflag) implicit none ! !INPUT/OUTPUT PARAMETERS: character(len=1),intent(in) :: cflag !< field delimeter !EOP !--- formats --- character(*),parameter :: subName = "(oasis_string_listSetDel) " !------------------------------------------------------------------------------- call oasis_debug_enter(subname) IF (debug > 0) THEN WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local WRITE(nulprt,*) subname,' changing listDel from '//TRIM(listDel)//' to '//TRIM(cflag) CALL oasis_flush(nulprt) ENDIF listDel = trim(cflag) listDel2 = listDel//listDel call oasis_debug_exit(subname) end subroutine oasis_string_listSetDel !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_listGetDel -- Get list delimeter character ! ! !DESCRIPTION: !> Get field delimeter character in lists ! \newline ! call shr\_string\_listGetDel(del) ! ! ! !INTERFACE: ------------------------------------------------------------------ subroutine oasis_string_listGetDel(del) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*),intent(out) :: del !< field delimeter !EOP !--- formats --- character(*),parameter :: subName = "(oasis_string_listGetDel) " !------------------------------------------------------------------------------- call oasis_debug_enter(subname) del = trim(listDel) call oasis_debug_exit(subname) end subroutine oasis_string_listGetDel !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_setAbort -- Set local oasis_string abort flag ! ! !DESCRIPTION: !> Set local oasis_string abort flag, true = abort, false = print and continue ! \newline ! call shr\_string\_setAbort(.false.) ! ! ! !INTERFACE: ------------------------------------------------------------------ subroutine oasis_string_setAbort(flag) implicit none ! !INPUT/OUTPUT PARAMETERS: logical,intent(in) :: flag !< abort flag !EOP !--- formats --- character(*),parameter :: subName = "(oasis_string_setAbort) " !------------------------------------------------------------------------------- call oasis_debug_enter(subname) if (debug > 0) then if (flag) then WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local WRITE(nulprt,*) subname,' setting abort to true' CALL oasis_flush(nulprt) else WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local WRITE(nulprt,*) subname,' setting abort to false' CALL oasis_flush(nulprt) endif endif doabort = flag call oasis_debug_exit(subname) end subroutine oasis_string_setAbort !=============================================================================== !BOP =========================================================================== ! ! !IROUTINE: oasis_string_setDebug -- Set local oasis_string debug level ! ! !DESCRIPTION: !> Set local oasis_string debug level, 0 = production ! \newline ! call shr\_string\_setDebug(2) ! ! ! !INTERFACE: ------------------------------------------------------------------ subroutine oasis_string_setDebug(iFlag) implicit none ! !INPUT/OUTPUT PARAMETERS: integer(ip_i4_p),intent(in) :: iFlag !< requested debug level !EOP !--- local --- !--- formats --- character(*),parameter :: subName = "(oasis_string_setDebug) " !------------------------------------------------------------------------------- ! NTOE: write statement can be expensive if called many times. !------------------------------------------------------------------------------- call oasis_debug_enter(subname) ! if (OASIS_debug > 0) write(nulprt,*) subname,' changing debug level from ',debug,' to ',iflag debug = iFlag call oasis_debug_exit(subname) end subroutine oasis_string_setDebug !=============================================================================== !=============================================================================== !> Supports aborts in the string module subroutine oasis_string_abort(string) implicit none ! !INPUT/OUTPUT PARAMETERS: character(*),optional,intent(in) :: string !< error string !EOP !--- local --- character(ic_xxl) :: lstring character(*),parameter :: subName = "(oasis_string_abort)" !------------------------------------------------------------------------------- ! NOTE: ! - no input or output string should be longer than ic_xxl !------------------------------------------------------------------------------- call oasis_debug_enter(subname) lstring = '' if (present(string)) lstring = string if (doabort) then WRITE(nulprt,*) subname,estr,'abort for ',TRIM(lstring) call oasis_abort(file=__FILE__,line=__LINE__) else write(nulprt,*) subname,wstr,'no abort for '//trim(lstring) CALL oasis_flush(nulprt) endif call oasis_debug_exit(subname) end subroutine oasis_string_abort !=============================================================================== !=============================================================================== end module mod_oasis_string