!===============================================================================
! SVN $Id: shr_string_mod.F90 18548 2009-09-26 23:55:51Z tcraig $
! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/branch_tags/cesm1_0_rel_tags/cesm1_0_rel01_share3_100616/shr/shr_string_mod.F90 $
!===============================================================================
!===============================================================================
!BOP ===========================================================================
!
! !MODULE: shr_string_mod -- 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 shr_string_listSetDel.
!
! !REVISION HISTORY:
! 2005-Apr-28 - T. Craig - first version
!
! !INTERFACE: ------------------------------------------------------------------
module shr_string_mod 19,6
! !USES:
use shr_kind_mod
! F90 kinds
use shr_sys_mod ! shared system calls
use shr_cal_mod ! shared calendar
use shr_timer_mod, only : shr_timer_get, shr_timer_start, shr_timer_stop
use shr_log_mod, only : s_loglev => shr_log_Level
use shr_log_mod, only : s_logunit => shr_log_Unit
implicit none
private
! !PUBLIC TYPES:
! no public types
! !PUBLIC MEMBER FUNCTIONS:
public :: shr_string_countChar ! Count number of char in string, fn
public :: shr_string_toUpper ! Convert string to upper-case
public :: shr_string_toLower ! Convert string to lower-case
public :: shr_string_getParentDir ! For a pathname get the parent directory name
public :: shr_string_lastIndex ! Index of last substr in str
public :: shr_string_endIndex ! Index of end of substr in str
public :: shr_string_leftAlign ! remove leading white space
public :: shr_string_alphanum ! remove all non alpha-numeric characters
public :: shr_string_betweenTags ! get the substring between the two tags
public :: shr_string_parseCFtunit ! parse CF time units
public :: shr_string_clean ! Set string to all white space
public :: shr_string_listIsValid ! test for a valid "list"
public :: shr_string_listGetNum ! Get number of fields in list, fn
public :: shr_string_listGetIndex ! Get index of field
public :: shr_string_listGetIndexF ! function version of listGetIndex
public :: shr_string_listGetName ! get k-th field name
public :: shr_string_listIntersect ! get intersection of two field lists
public :: shr_string_listUnion ! get union of two field lists
public :: shr_string_listMerge ! merge two lists to form third
public :: shr_string_listAppend ! append list at end of another
public :: shr_string_listPrepend ! prepend list in front of another
public :: shr_string_listSetDel ! Set field delimeter in lists
public :: shr_string_listGetDel ! Get field delimeter in lists
public :: shr_string_setAbort ! set local abort flag
public :: shr_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(SHR_KIND_IN),save :: debug = 0
!===============================================================================
contains
!===============================================================================
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_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)
!
! !REVISION HISTORY:
! 2005-Feb-28 - First version from dshr_bundle
!
! !INTERFACE: ------------------------------------------------------------------
integer function shr_string_countChar(str,char,rc) 1,3
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(in) :: str ! string to search
character(1) ,intent(in) :: char ! char to search for
integer(SHR_KIND_IN),intent(out),optional :: rc ! return code
!EOP
!----- local -----
integer(SHR_KIND_IN) :: count ! counts occurances of char
integer(SHR_KIND_IN) :: n ! generic index
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_countChar) "
character(*),parameter :: F00 = "('(shr_string_countChar) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
count = 0
do n = 1, len_trim(str)
if (str(n:n) == char) count = count + 1
end do
shr_string_countChar = count
if (present(rc)) rc = 0
if (debug>1) call shr_timer_stop (t01)
end function shr_string_countChar
!===============================================================================
!BOP ===========================================================================
! !IROUTINE: shr_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.
!
! !REVISION HISTORY:
! 2005-Dec-20 - Move CAM version over to shared code.
!
! !INTERFACE: ------------------------------------------------------------------
function shr_string_toUpper(str) 6,4
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(len=*), intent(in) :: str ! String to convert to upper case
character(len=len(str)) :: shr_string_toUpper
!----- local -----
integer(SHR_KIND_IN) :: i ! Index
integer(SHR_KIND_IN) :: aseq ! ascii collating sequence
integer(SHR_KIND_IN) :: LowerToUpper ! integer to convert case
character(len=1) :: ctmp ! Character temporary
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_toUpper) "
character(*),parameter :: F00 = "('(shr_string_toUpper) ',4a)"
!-------------------------------------------------------------------------------
!
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
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)
shr_string_toUpper(i:i) = ctmp
end do
if (debug>1) call shr_timer_stop (t01)
end function shr_string_toUpper
!===============================================================================
!BOP ===========================================================================
! !IROUTINE: shr_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.
!
! !REVISION HISTORY:
! 2006-Apr-20 - Creation
!
! !INTERFACE: ------------------------------------------------------------------
function shr_string_toLower(str) 1,4
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(len=*), intent(in) :: str ! String to convert to lower case
character(len=len(str)) :: shr_string_toLower
!----- local -----
integer(SHR_KIND_IN) :: i ! Index
integer(SHR_KIND_IN) :: aseq ! ascii collating sequence
integer(SHR_KIND_IN) :: UpperToLower ! integer to convert case
character(len=1) :: ctmp ! Character temporary
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_toLower) "
character(*),parameter :: F00 = "('(shr_string_toLower) ',4a)"
!-------------------------------------------------------------------------------
!
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
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)
shr_string_toLower(i:i) = ctmp
end do
if (debug>1) call shr_timer_stop (t01)
end function shr_string_toLower
!===============================================================================
!BOP ===========================================================================
! !IROUTINE: shr_string_getParentDir -- For pathname get the parent directory name
!
! !DESCRIPTION:
! Get the parent directory name for a pathname.
!
! !REVISION HISTORY:
! 2006-May-09 - Creation
!
! !INTERFACE: ------------------------------------------------------------------
function shr_string_getParentDir(str),3
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(len=*), intent(in) :: str ! String to convert to lower case
character(len=len(str)) :: shr_string_getParentDir
!----- local -----
integer(SHR_KIND_IN) :: i ! Index
integer(SHR_KIND_IN) :: nlen ! Length of string
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_getParentDir) "
character(*),parameter :: F00 = "('(shr_string_getParentDir) ',4a)"
!-------------------------------------------------------------------------------
!
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
nlen = len_trim(str)
if ( str(nlen:nlen) == "/" ) nlen = nlen - 1
i = index( str(1:nlen), "/", back=.true. )
if ( i == 0 )then
shr_string_getParentDir = str
else
shr_string_getParentDir = str(1:i-1)
end if
if (debug>1) call shr_timer_stop (t01)
end function shr_string_getParentDir
!===============================================================================
!BOP ===========================================================================
!
!
! !IROUTINE: shr_string_lastIndex -- Get index of last substr within string
!
! !DESCRIPTION:
! Get index of last substr within string
! \newline
! n = shr\_string\_lastIndex(string,substring)
!
! !REVISION HISTORY:
! 2005-Feb-28 - First version from dshr_domain
!
! !INTERFACE: ------------------------------------------------------------------
integer function shr_string_lastIndex(string,substr,rc) 7,3
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(in) :: string ! string to search
character(*) ,intent(in) :: substr ! sub-string to search for
integer(SHR_KIND_IN),intent(out),optional :: rc ! return code
!EOP
!--- local ---
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_lastIndex) "
character(*),parameter :: F00 = "('(shr_string_lastIndex) ',4a)"
!-------------------------------------------------------------------------------
! Note:
! - "new" F90 back option to index function makes this home-grown solution obsolete
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
shr_string_lastIndex = index(string,substr,.true.)
if (present(rc)) rc = 0
if (debug>1) call shr_timer_stop (t01)
end function shr_string_lastIndex
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_string_endIndex -- Get the ending index of substr within string
!
! !DESCRIPTION:
! Get the ending index of substr within string
! \newline
! n = shr\_string\_endIndex(string,substring)
!
! !REVISION HISTORY:
! 2005-May-10 - B. Kauffman, first version.
!
! !INTERFACE: ------------------------------------------------------------------
integer function shr_string_endIndex(string,substr,rc) 1,3
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(in) :: string ! string to search
character(*) ,intent(in) :: substr ! sub-string to search for
integer(SHR_KIND_IN),intent(out),optional :: rc ! return code
!EOP
!--- local ---
integer(SHR_KIND_IN) :: i ! generic index
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_endIndex) "
character(*),parameter :: F00 = "('(shr_string_endIndex) ',4a)"
!-------------------------------------------------------------------------------
! 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?
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
i = index(trim(string),trim(substr))
if ( i == 0 ) then
shr_string_endIndex = 0 ! substr is not in string
else
shr_string_endIndex = i + len_trim(substr) - 1
end if
! -------------------------------------------------------------------
! i = index(trim(string),trim(substr),back=.true.)
! if (i == len(string)+1) i = 0
! shr_string_endIndex = i
! -------------------------------------------------------------------
if (present(rc)) rc = 0
if (debug>1) call shr_timer_stop (t01)
end function shr_string_endIndex
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_string_leftAlign -- remove leading white space
!
! !DESCRIPTION:
! Remove leading white space
! \newline
! call shr\_string\_leftAlign(string)
!
! !REVISION HISTORY:
! 2005-Apr-28 - B. Kauffman - First version
!
! !INTERFACE: ------------------------------------------------------------------
subroutine shr_string_leftAlign(str,rc) 22,3
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(inout) :: str
integer(SHR_KIND_IN),intent(out) ,optional :: rc ! return code
!EOP
!----- local ----
integer(SHR_KIND_IN) :: rCode ! return code
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_leftAlign) "
character(*),parameter :: F00 = "('(shr_string_leftAlign) ',4a)"
!-------------------------------------------------------------------------------
! note:
! * ?? this routine isn't needed, use the intrisic adjustL instead ??
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
! -------------------------------------------------------------------
! --- I used this until I discovered the intrinsic function below - BK
! 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 ??
! -------------------------------------------------------------------
str = adjustL(str)
if (present(rc)) rc = 0
if (debug>1) call shr_timer_stop (t01)
end subroutine shr_string_leftAlign
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_string_alphanum -- remove non alpha numeric characters
!
! !DESCRIPTION:
! Remove all non alpha numeric characters from string
! \newline
! call shr\_string\_alphanum(string)
!
! !REVISION HISTORY:
! 2005-Aug-01 - T. Craig - First version
!
! !INTERFACE: ------------------------------------------------------------------
subroutine shr_string_alphanum(str,rc),3
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(inout) :: str
integer(SHR_KIND_IN),intent(out) ,optional :: rc ! return code
!EOP
!----- local ----
integer(SHR_KIND_IN) :: rCode ! return code
integer(SHR_KIND_IN) :: n,icnt ! counters
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_alphaNum) "
character(*),parameter :: F00 = "('(shr_string_alphaNum) ',4a)"
!-------------------------------------------------------------------------------
!
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
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
if (debug>1) call shr_timer_stop (t01)
end subroutine shr_string_alphanum
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_string_betweenTags -- Get the substring between the two tags.
!
! !DESCRIPTION:
! Get the substring found between the start and end tags.
! \newline
! call shr\_string\_betweenTags(string,startTag,endTag,substring,rc)
!
! !REVISION HISTORY:
! 2005-May-11 - B. Kauffman, first version
!
! !INTERFACE: ------------------------------------------------------------------
subroutine shr_string_betweenTags(string,startTag,endTag,substr,rc),4
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(in) :: string ! string to search
character(*) ,intent(in) :: startTag ! start tag
character(*) ,intent(in) :: endTag ! end tag
character(*) ,intent(out) :: substr ! sub-string between tags
integer(SHR_KIND_IN),intent(out),optional :: rc ! retrun code
!EOP
!--- local ---
integer(SHR_KIND_IN) :: iStart ! substring start index
integer(SHR_KIND_IN) :: iEnd ! substring end index
integer(SHR_KIND_IN) :: rCode ! return code
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_betweenTags) "
character(*),parameter :: F00 = "('(shr_string_betweenTags) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
! * assumes the leading/trailing white space is not part of start & end tags
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
iStart = shr_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
if (s_loglev > 0) then
write(s_logunit,F00) "ERROR: can't find start tag in string"
write(s_logunit,F00) "ERROR: start tag = ",trim(startTag)
write(s_logunit,F00) "ERROR: string = ",trim(string)
endif
rCode = 1
else if (iEnd < 1) then
if (s_loglev > 0) then
write(s_logunit,F00) "ERROR: can't find end tag in string"
write(s_logunit,F00) "ERROR: end tag = ",trim( endTag)
write(s_logunit,F00) "ERROR: string = ",trim(string)
endif
rCode = 2
else if ( iEnd <= iStart) then
if (s_loglev > 0) then
write(s_logunit,F00) "ERROR: start tag not before end tag"
write(s_logunit,F00) "ERROR: start tag = ",trim(startTag)
write(s_logunit,F00) "ERROR: end tag = ",trim( endTag)
write(s_logunit,F00) "ERROR: string = ",trim(string)
endif
rCode = 3
else if ( iStart+1 == iEnd ) then
substr = ""
if (s_loglev > 0) write(s_logunit,F00) "WARNING: zero-length substring found in ",trim(string)
else
substr = string(iStart+1:iEnd-1)
if (len_trim(substr) == 0 .and. s_loglev > 0) &
& write(s_logunit,F00) "WARNING: white-space substring found in ",trim(string)
end if
if (present(rc)) rc = rCode
if (debug>1) call shr_timer_stop (t01)
end subroutine shr_string_betweenTags
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_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
!
! !REVISION HISTORY:
! 2005-May-15 - T. Craig - first version
!
! !INTERFACE: ------------------------------------------------------------------
subroutine shr_string_parseCFtunit(string,unit,bdate,bsec,rc) 2,19
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(in) :: string ! string to search
character(*) ,intent(out) :: unit ! delta time unit
integer(SHR_KIND_IN),intent(out) :: bdate ! base date yyyymmdd
real(SHR_KIND_R8) ,intent(out) :: bsec ! base seconds
integer(SHR_KIND_IN),intent(out),optional :: rc ! return code
!EOP
!--- local ---
integer(SHR_KIND_IN) :: i,i1,i2 ! generic index
character(SHR_KIND_CL) :: tbase ! baseline time
character(SHR_KIND_CL) :: lstr ! local string
integer(SHR_KIND_IN) :: yr,mo,da,hr,min ! time stuff
real(SHR_KIND_R8) :: sec ! time stuff
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_parseCFtunit) "
character(*),parameter :: F00 = "('(shr_string_parseCFtunit) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
! o assume length of CF-1.0 time attribute char string < SHR_KIND_CL
! This is a reasonable assumption.
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
unit = 'none'
bdate = 0
bsec = 0.0_SHR_KIND_R8
i = shr_string_lastIndex(string,'days ')
if (i > 0) unit = 'days'
i = shr_string_lastIndex(string,'hours ')
if (i > 0) unit = 'hours'
i = shr_string_lastIndex(string,'minutes ')
if (i > 0) unit = 'minutes'
i = shr_string_lastIndex(string,'seconds ')
if (i > 0) unit = 'seconds'
if (trim(unit) == 'none') then
write(s_logunit,F00) ' ERROR time unit unknown'
call shr_string_abort(subName//' time unit unknown')
endif
i = shr_string_lastIndex(string,' since ')
if (i < 1) then
write(s_logunit,F00) ' ERROR since does not appear in unit attribute for time '
call shr_string_abort(subName//' no since in attr name')
endif
tbase = trim(string(i+6:))
call shr_string_leftAlign(tbase)
if (debug > 0 .and. s_logunit > 0) then
write(s_logunit,*) trim(subName)//' '//'unit '//trim(unit)
write(s_logunit,*) trim(subName)//' '//'tbase '//trim(tbase)
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 shr_string_leftAlign(tbase)
i2 = index(tbase,'-') - 1
lstr = tbase(i1:i2)
read(lstr,*,ERR=200,END=200) mo
tbase = tbase(i2+2:)
call shr_string_leftAlign(tbase)
i2 = index(tbase,' ') - 1
lstr = tbase(i1:i2)
read(lstr,*,ERR=200,END=200) da
tbase = tbase(i2+2:)
call shr_string_leftAlign(tbase)
i2 = index(tbase,':') - 1
lstr = tbase(i1:i2)
read(lstr,*,ERR=200,END=100) hr
tbase = tbase(i2+2:)
call shr_string_leftAlign(tbase)
i2 = index(tbase,':') - 1
lstr = tbase(i1:i2)
read(lstr,*,ERR=200,END=100) min
tbase = tbase(i2+2:)
call shr_string_leftAlign(tbase)
i2 = index(tbase,' ') - 1
lstr = tbase(i1:i2)
read(lstr,*,ERR=200,END=100) sec
100 continue
if (debug > 0 .and. s_loglev > 0) write(s_logunit,*) trim(subName),'ymdhms:',yr,mo,da,hr,min,sec
call shr_cal_ymd2date(yr,mo,da,bdate)
bsec = real(hr*3600 + min*60,SHR_KIND_R8) + sec
if (present(rc)) rc = 0
if (debug>1) call shr_timer_stop (t01)
return
200 continue
write(s_logunit,F00) 'ERROR 200 on char num read '
call shr_string_abort(subName//' ERROR on char num read')
if (debug>1) call shr_timer_stop (t01)
return
end subroutine shr_string_parseCFtunit
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_string_clean -- Clean a string, set it to "blank"
!
! !DESCRIPTION:
! Clean a string, set it to blank
! \newline
! call shr\_string\_clean(string,rc)
!
! !REVISION HISTORY:
! 2005-May-05 - T. Craig
!
! !INTERFACE: ------------------------------------------------------------------
subroutine shr_string_clean(string,rc) 7,3
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(inout) :: string ! list/string
integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code
!EOP
!----- local -----
integer(SHR_KIND_IN) :: n ! counter
integer(SHR_KIND_IN) :: rCode ! return code
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_clean) "
character(*),parameter :: F00 = "('(shr_string_clean) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
rCode = 0
string = ' '
if (present(rc)) rc = rCode
if (debug>1) call shr_timer_stop (t01)
end subroutine shr_string_clean
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_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)
!
! !REVISION HISTORY:
! 2005-May-05 - B. Kauffman
!
! !INTERFACE: ------------------------------------------------------------------
logical function shr_string_listIsValid(list,rc),3
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(in) :: list ! list/string
integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code
!EOP
!----- local -----
integer (SHR_KIND_IN) :: nChar ! lenth of list
integer (SHR_KIND_IN) :: rCode ! return code
integer (SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_listIsValid) "
character(*),parameter :: F00 = "('(shr_string_listIsValid) ',4a)"
!-------------------------------------------------------------------------------
! check that the list conforms to the list format
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
rCode = 0
shr_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
shr_string_listIsValid = .false.
if (s_loglev > 0) write(s_logunit,F00) "WARNING: invalid list = ",trim(list)
endif
if (present(rc)) rc = rCode
if (debug>1) call shr_timer_stop (t01)
end function shr_string_listIsValid
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_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)
!
! !REVISION HISTORY:
! 2005-May-05 - B. Kauffman
!
! !INTERFACE: ------------------------------------------------------------------
subroutine shr_string_listGetName(list,k,name,rc) 15,6
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(in) :: list ! list/string
integer(SHR_KIND_IN) ,intent(in) :: k ! index of field
character(*) ,intent(out) :: name ! k-th name in list
integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code
!EOP
!----- local -----
integer(SHR_KIND_IN) :: i,j,n ! generic indecies
integer(SHR_KIND_IN) :: kFlds ! number of fields in list
integer(SHR_KIND_IN) :: i0,i1 ! name = list(i0:i1)
integer(SHR_KIND_IN) :: rCode ! return code
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_listGetName) "
character(*),parameter :: F00 = "('(shr_string_listGetName) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
rCode = 0
!--- check that this is a valid list ---
if (.not. shr_string_listIsValid(list,rCode) ) then
write(s_logunit,F00) "ERROR: invalid list = ",trim(list)
call shr_string_abort(subName//" ERROR: invalid list = "//trim(list))
end if
!--- check that this is a valid index ---
kFlds = shr_string_listGetNum(list)
if (k<1 .or. kFlds<k) then
write(s_logunit,*) subName,"ERROR: invalid index = ",k
write(s_logunit,*) subName,"ERROR: list = ",trim(list)
call shr_string_abort(subName//" ERROR: invalid index")
end if
!--- start with whole list, then remove fields before and after desired field ---
i0 = 1
i1 = len_trim(list)
!--- remove field names before desired field ---
do n=2,k
i = index(list(i0:i1),listDel)
i0 = i0 + i
end do
!--- remove field names after desired field ---
if ( k < kFlds ) then
i = index(list(i0:i1),listDel)
i1 = i0 + i - 2
end if
!--- copy result into output variable ---
name = list(i0:i1)//" "
if (present(rc)) rc = rCode
if (debug>1) call shr_timer_stop (t01)
end subroutine shr_string_listGetName
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_string_listIntersect -- Get intersection of two field lists
!
! !DESCRIPTION:
! Get intersection of two fields lists, write into third list
! \newline
! call shr\_string\_listIntersect(list1,list2,listout)
!
! !REVISION HISTORY:
! 2005-May-05 - T. Craig
!
! !INTERFACE: ------------------------------------------------------------------
subroutine shr_string_listIntersect(list1,list2,listout,rc) 1,8
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(in) :: list1 ! list/string
character(*) ,intent(in) :: list2 ! list/string
character(*) ,intent(out) :: listout ! list/string
integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code
!EOP
!----- local -----
integer(SHR_KIND_IN) :: nf,n1,n2 ! counters
character(SHR_KIND_CS) :: name ! field name
integer(SHR_KIND_IN) :: rCode ! return code
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_listIntersect) "
character(*),parameter :: F00 = "('(shr_string_listIntersect) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
rCode = 0
nf = shr_string_listGetNum(list1)
call shr_string_clean(listout)
do n1 = 1,nf
call shr_string_listGetName(list1,n1,name,rCode)
n2 = shr_string_listGetIndexF(list2,name)
if (n2 > 0) then
call shr_string_listAppend(listout,name)
endif
enddo
if (present(rc)) rc = rCode
if (debug>1) call shr_timer_stop (t01)
end subroutine shr_string_listIntersect
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_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)
!
! !REVISION HISTORY:
! 2005-May-05 - T. Craig
!
! !INTERFACE: ------------------------------------------------------------------
subroutine shr_string_listUnion(list1,list2,listout,rc),12
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(in) :: list1 ! list/string
character(*) ,intent(in) :: list2 ! list/string
character(*) ,intent(out) :: listout ! list/string
integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code
!EOP
!----- local -----
integer(SHR_KIND_IN) :: nf,n1,n2 ! counters
character(SHR_KIND_CS) :: name ! field name
integer(SHR_KIND_IN) :: rCode ! return code
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_listUnion) "
character(*),parameter :: F00 = "('(shr_string_listUnion) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
rCode = 0
call shr_string_clean(listout)
nf = shr_string_listGetNum(list1)
do n1 = 1,nf
call shr_string_listGetName(list1,n1,name,rCode)
n2 = shr_string_listGetIndexF(listout,name)
if (n2 < 1) then
call shr_string_listAppend(listout,name)
endif
enddo
nf = shr_string_listGetNum(list2)
do n1 = 1,nf
call shr_string_listGetName(list2,n1,name,rCode)
n2 = shr_string_listGetIndexF(listout,name)
if (n2 < 1) then
call shr_string_listAppend(listout,name)
endif
enddo
if (present(rc)) rc = rCode
if (debug>1) call shr_timer_stop (t01)
end subroutine shr_string_listUnion
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_string_listMerge -- Merge lists two list to third
!
! !DESCRIPTION:
! Merge two list to third
! \newline
! call shr\_string\_listMerge(list1,list2,listout)
! call shr\_string\_listMerge(list1,list2,list1)
!
! !REVISION HISTORY:
! 2005-May-05 - T. Craig
!
! !INTERFACE: ------------------------------------------------------------------
subroutine shr_string_listMerge(list1,list2,listout,rc),10
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(in) :: list1 ! list/string
character(*) ,intent(in) :: list2 ! list/string
character(*) ,intent(out) :: listout ! list/string
integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code
!EOP
!----- local -----
character(SHR_KIND_CX) :: l1,l2 ! local char strings
integer(SHR_KIND_IN) :: rCode ! return code
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_listMerge) "
character(*),parameter :: F00 = "('(shr_string_listMerge) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
! - no input or output string should be longer than SHR_KIND_CX
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
rCode = 0
!--- make sure temp strings are large enough ---
if ( (len(l1) < len_trim(list1)) .or. (len(l2) < len_trim(list2))) then
call shr_string_abort(subName//'ERROR: temp string not large enough')
end if
call shr_string_clean(l1)
call shr_string_clean(l2)
call shr_string_clean(listout)
l1 = trim(list1)
l2 = trim(list2)
call shr_string_leftAlign(l1,rCode)
call shr_string_leftAlign(l2,rCode)
if (len_trim(l1)+len_trim(l2)+1 > len(listout)) &
call shr_string_abort(subName//'ERROR: 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
if (debug>1) call shr_timer_stop (t01)
end subroutine shr_string_listMerge
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_string_listAppend -- Append one list to another
!
! !DESCRIPTION:
! Append one list to another
! \newline
! call shr\_string\_listAppend(list,listadd)
!
! !REVISION HISTORY:
! 2005-May-05 - T. Craig
!
! !INTERFACE: ------------------------------------------------------------------
subroutine shr_string_listAppend(list,listadd,rc) 4,7
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(inout) :: list ! list/string
character(*) ,intent(in) :: listadd ! list/string
integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code
!EOP
!----- local -----
character(SHR_KIND_CX) :: l1 ! local string
integer(SHR_KIND_IN) :: rCode ! return code
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_listAppend) "
character(*),parameter :: F00 = "('(shr_string_listAppend) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
! - no input or output string should be longer than SHR_KIND_CX
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
rCode = 0
!--- make sure temp string is large enough ---
if (len(l1) < len_trim(listAdd)) then
call shr_string_abort(subName//'ERROR: temp string not large enough')
end if
call shr_string_clean(l1)
l1 = trim(listadd)
call shr_string_leftAlign(l1,rCode)
if (len_trim(list)+len_trim(l1)+1 > len(list)) &
call shr_string_abort(subName//'ERROR: 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
if (debug>1) call shr_timer_stop (t01)
end subroutine shr_string_listAppend
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_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
!
! !REVISION HISTORY:
! 2005-May-05 - T. Craig
!
! !INTERFACE: ------------------------------------------------------------------
subroutine shr_string_listPrepend(listadd,list,rc),8
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(in) :: listadd ! list/string
character(*) ,intent(inout) :: list ! list/string
integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code
!EOP
!----- local -----
character(SHR_KIND_CX) :: l1 ! local string
integer(SHR_KIND_IN) :: rCode ! return code
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_listPrepend) "
character(*),parameter :: F00 = "('(shr_string_listPrepend) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
! - no input or output string should be longer than SHR_KIND_CX
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
rCode = 0
!--- make sure temp string is large enough ---
if (len(l1) < len_trim(listAdd)) then
call shr_string_abort(subName//'ERROR: temp string not large enough')
end if
call shr_string_clean(l1)
l1 = trim(listadd)
call shr_string_leftAlign(l1,rCode)
call shr_string_leftAlign(list,rCode)
if (len_trim(list)+len_trim(l1)+1 > len(list)) &
call shr_string_abort(subName//'ERROR: 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
if (debug>1) call shr_timer_stop (t01)
end subroutine shr_string_listPrepend
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_string_listGetIndexF -- Get index of field in string
!
! !DESCRIPTION:
! Get index of field in string
! \newline
! k = shr\_string\_listGetIndex(str,"taux")
!
! !REVISION HISTORY:
! 2005-Feb-28 - B. Kauffman and J. Schramm - first version
!
! !INTERFACE: ------------------------------------------------------------------
integer function shr_string_listGetIndexF(string,fldStr) 448,4
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*),intent(in) :: string ! string
character(*),intent(in) :: fldStr ! name of field
!EOP
!----- local -----
integer(SHR_KIND_IN) :: k ! local index variable
integer(SHR_KIND_IN) :: rc ! error code
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_listGetIndexF) "
character(*),parameter :: F00 = "('(shr_string_listGetIndexF) ',4a)"
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
call shr_string_listGetIndex(string,fldStr,k,print=.false.,rc=rc)
shr_string_listGetIndexF = k
if (debug>1) call shr_timer_stop (t01)
end function shr_string_listGetIndexF
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_string_listGetIndex -- Get index of field in string
!
! !DESCRIPTION:
! Get index of field in string
! \newline
! call shr\_string\_listGetIndex(str,"taux",k,rc)
!
! !REVISION HISTORY:
! 2005-Feb-28 - B. Kauffman and J. Schramm - first version
!
! !INTERFACE: ------------------------------------------------------------------
subroutine shr_string_listGetIndex(string,fldStr,kFld,print,rc) 1,5
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(in) :: string ! string
character(*) ,intent(in) :: fldStr ! name of field
integer(SHR_KIND_IN),intent(out) :: kFld ! index of field
logical ,intent(in) ,optional :: print ! print switch
integer(SHR_KIND_IN),intent(out),optional :: rc ! return code
!EOP
!----- local -----
integer(SHR_KIND_IN) :: n ! index for colon position
integer(SHR_KIND_IN) :: k ! index for field name position
integer(SHR_KIND_IN) :: nFields ! number of fields in a string
integer(SHR_KIND_IN) :: i0,i1 ! fldStr == string(i0,i1) ??
integer(SHR_KIND_IN) :: j0,j1 ! fldStr == string(j0,j1) ??
logical :: found ! T => field found in fieldNames
logical :: lprint ! local print flag
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_listGetIndex) "
character(*),parameter :: F00 = "('(shr_string_listGetIndex) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
! - searching from both ends of the list at the same time seems to be 20% faster
! but I'm not sure why (B. Kauffman, Feb 2007)
! - I commented out sanity check to a little gain speed (B. Kauffman, Mar 2007)
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
if (present(rc)) rc = 0
lprint = .false.
if (present(print)) lprint = print
!--- confirm proper size of input data ---
if (len_trim(fldStr) < 1) then
if (lprint) write(s_logunit,F00) "ERROR: input field name has 0 length"
call shr_string_abort(subName//"invalid field name")
end if
!--- search for field name in string's list of fields ---
found = .false.
kFld = 0
i0 = 1 ! ?? fldStr == string(i0:i1) ??
i1 = -1
j0 = -1 ! ?? fldStr == string(j0:j1) ??
j1 = len_trim(string)
nFields = shr_string_listGetNum(string)
do k = 1,nFields
!--------------------------------------------------------
! search from end of list to end of list
!--------------------------------------------------------
!--- get end index of of field number k ---
n = index(string(i0:len_trim(string)),listDel)
if (n > 0) then
i1 = i0 + n - 2 ! *not* the last field name in fieldNames
else
i1 = len_trim(string) ! this is the last field name in fieldNames
endif
!--- sanity check ---
! if ((k <nFields .and. n<1) .or. (k==nFields .and. n>0)) then
! call shr_string_abort(subName//"ERROR: wrong string%nf ?")
! end if
!--- is it a match? ---
if (trim(fldStr) == string(i0:i1)) then
found = .true.
kFld = k
exit
endif
i0 = i1 + 2 ! start index for next iteration
!--------------------------------------------------------
! search from end of list to start of list
!--------------------------------------------------------
!--- get start index of field number (nFields + 1 - k ) ---
n = index(string(1:j1),listDel,back=.true.)
j0 = n + 1 ! n==0 => the first field name in fieldNames
!--- sanity check ---
! if ((k <nFields .and. n<1) .or. (k==nFields .and. n>0)) then
! call shr_string_abort(subName//"ERROR: wrong string%nf ?")
! end if
!--- is it a match? ---
if (trim(fldStr) == string(j0:j1)) then
found = .true.
kFld = nFields + 1 - k
exit
endif
j1 = j0 - 2 ! end index for next iteration
!--------------------------------------------------------
! exit if all field names have been checked
!--------------------------------------------------------
if (2*k >= nFields) exit
end do
!--- not finding a field is not a fatal error ---
if (.not. found) then
kFld = 0
if (lprint .and. s_loglev > 0) write(s_logunit,F00) "FYI: field ",trim(fldStr)," not found in list ",trim(string)
if (present(rc)) rc = 1
end if
if (debug>1) call shr_timer_stop (t01)
end subroutine shr_string_listGetIndex
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_string_listGetNum -- get number of fields in a string list
!
! !DESCRIPTION:
! return number of fields in string list
!
! !REVISION HISTORY:
! 2005-Apr-28 - T. Craig - First version
!
! !INTERFACE: ------------------------------------------------------------------
integer function shr_string_listGetNum(str) 23,4
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*),intent(in) :: str ! string to search
!EOP
!----- local -----
integer(SHR_KIND_IN) :: count ! counts occurances of char
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!----- formats -----
character(*),parameter :: subName = "(shr_string_listGetNum) "
character(*),parameter :: F00 = "('(shr_string_listGetNum) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
shr_string_listGetNum = 0
if (len_trim(str) > 0) then
count = shr_string_countChar(str,listDel)
shr_string_listGetNum = count + 1
endif
if (debug>1) call shr_timer_stop (t01)
end function shr_string_listGetNum
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_string_listSetDel -- Set list delimeter character
!
! !DESCRIPTION:
! Set field delimeter character in lists
! \newline
! call shr\_string\_listSetDel(":")
!
! !REVISION HISTORY:
! 2005-Apr-30 - T. Craig - first prototype
!
! !INTERFACE: ------------------------------------------------------------------
subroutine shr_string_listSetDel(cflag),3
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(len=1),intent(in) :: cflag
!EOP
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!--- formats ---
character(*),parameter :: subName = "(shr_string_listSetDel) "
character(*),parameter :: F00 = "('(shr_string_listSetDel) ',a) "
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
if (debug > 0 .and. s_loglev > 0) write(s_logunit,F00) 'changing listDel from '//trim(listDel)//' to '//trim(cflag)
listDel = trim(cflag)
listDel2 = listDel//listDel
if (debug>1) call shr_timer_stop (t01)
end subroutine shr_string_listSetDel
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_string_listGetDel -- Get list delimeter character
!
! !DESCRIPTION:
! Get field delimeter character in lists
! \newline
! call shr\_string\_listGetDel(del)
!
! !REVISION HISTORY:
! 2005-May-15 - T. Craig - first prototype
!
! !INTERFACE: ------------------------------------------------------------------
subroutine shr_string_listGetDel(del),3
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*),intent(out) :: del
!EOP
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!--- formats ---
character(*),parameter :: subName = "(shr_string_listGetDel) "
character(*),parameter :: F00 = "('(shr_string_listGetDel) ',a) "
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
del = trim(listDel)
if (debug>1) call shr_timer_stop (t01)
end subroutine shr_string_listGetDel
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_string_setAbort -- Set local shr_string abort flag
!
! !DESCRIPTION:
! Set local shr_string abort flag, true = abort, false = print and continue
! \newline
! call shr\_string\_setAbort(.false.)
!
! !REVISION HISTORY:
! 2005-Apr-30 - T. Craig - first prototype
!
! !INTERFACE: ------------------------------------------------------------------
subroutine shr_string_setAbort(flag),3
implicit none
! !INPUT/OUTPUT PARAMETERS:
logical,intent(in) :: flag
!EOP
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!--- formats ---
character(*),parameter :: subName = "(shr_string_setAbort) "
character(*),parameter :: F00 = "('(shr_string_setAbort) ',a) "
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
if (debug > 0 .and. s_loglev > 0) then
if (flag) then
write(s_logunit,F00) 'setting abort to true'
else
write(s_logunit,F00) 'setting abort to false'
endif
endif
doabort = flag
if (debug>1) call shr_timer_stop (t01)
end subroutine shr_string_setAbort
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_string_setDebug -- Set local shr_string debug level
!
! !DESCRIPTION:
! Set local shr_string debug level, 0 = production
! \newline
! call shr\_string\_setDebug(2)
!
! !REVISION HISTORY:
! 2005-Apr-30 - T. Craig - first prototype
!
! !INTERFACE: ------------------------------------------------------------------
subroutine shr_string_setDebug(iFlag),3
implicit none
! !INPUT/OUTPUT PARAMETERS:
integer(SHR_KIND_IN),intent(in) :: iFlag ! requested debug level
!EOP
!--- local ---
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!--- formats ---
character(*),parameter :: subName = "(shr_string_setDebug) "
character(*),parameter :: F00 = "('(shr_string_setDebug) ',a) "
character(*),parameter :: F01 = "('(shr_string_setDebug) ',a,i3,a,i3) "
!-------------------------------------------------------------------------------
! NTOE: write statement can be expensive if called many times.
!-------------------------------------------------------------------------------
if (iFlag>1 .and. t01<1) call shr_timer_get(t01,subName)
if (iFlag>1) call shr_timer_start(t01)
! if (s_loglev > 0) write(s_logunit,F01) 'changing debug level from ',debug,' to ',iflag
debug = iFlag
if (iFlag>1) call shr_timer_stop (t01)
end subroutine shr_string_setDebug
!===============================================================================
!===============================================================================
subroutine shr_string_abort(string) 12,4
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*),optional,intent(in) :: string
!EOP
integer(SHR_KIND_IN) :: t01 = 0 ! timer
!--- local ---
character(SHR_KIND_CX) :: lstring
character(*),parameter :: subName = "(shr_string_abort)"
character(*),parameter :: F00 = "('(shr_string_abort) ',a)"
!-------------------------------------------------------------------------------
! NOTE:
! - no input or output string should be longer than SHR_KIND_CX
!-------------------------------------------------------------------------------
if (debug>1 .and. t01<1) call shr_timer_get(t01,subName)
if (debug>1) call shr_timer_start(t01)
lstring = ''
if (present(string)) lstring = string
if (doabort) then
call shr_sys_abort(trim(lstring))
else
write(s_logunit,F00) ' no abort:'//trim(lstring)
endif
if (debug>1) call shr_timer_stop (t01)
end subroutine shr_string_abort
!===============================================================================
!===============================================================================
end module shr_string_mod