WebSVN – lagranto.wrf – Diff – /branches/met.nps.monterey/goodies/stringmod.f90


module strings
 
use precision
 
private :: value_dr,value_sr,value_di,value_si
private :: write_dr,write_sr,write_di,write_si
private :: writeq_dr,writeq_sr,writeq_di,writeq_si
 
interface value  ! Generic operator for converting a number string to a 
                 ! number. Calling syntax is 'call value(numstring,number,ios)' 
                 ! where 'numstring' is a number string and 'number' is a 
                 ! real number or an integer (single or double precision).         
   module procedure value_dr
   module procedure value_sr
   module procedure value_di
   module procedure value_si
end interface
 
interface writenum  ! Generic  interface for writing a number to a string. The 
                    ! number is left justified in the string. The calling syntax
                    ! is 'call writenum(number,string,format)' where 'number' is
                    ! a real number or an integer, 'string' is a character string
                    ! containing the result, and 'format' is the format desired, 
                    ! e.g., 'e15.6' or 'i5'.
   module procedure write_dr
   module procedure write_sr
   module procedure write_di
   module procedure write_si
end interface
 
interface writeq  ! Generic interface equating a name to a numerical value. The
                  ! calling syntax is 'call writeq(unit,name,value,format)' where
                  ! unit is the integer output unit number, 'name' is the variable
                  ! name, 'value' is the real or integer value of the variable, 
                  ! and 'format' is the format of the value. The result written to
                  ! the output unit has the form <name> = <value>.
   module procedure writeq_dr
   module procedure writeq_sr
   module procedure writeq_di
   module procedure writeq_si
end interface
 
 
!**********************************************************************
 
contains
 
!**********************************************************************
 
subroutine parse(str,delims,args,nargs)
 
! Parses the string 'str' into arguments args(1), ..., args(nargs) based on
! the delimiters contained in the string 'delims'. Preceding a delimiter in
! 'str' by a backslash (\) makes this particular instance not a delimiter.
! The integer output variable nargs contains the number of arguments found.
 
character(len=*) :: str,delims
character(len=len_trim(str)) :: strsav
character(len=*),dimension(:) :: args
 
strsav=str
call compact(str)
na=size(args)
do i=1,na
  args(i)=' '
end do  
nargs=0
lenstr=len_trim(str)
if(lenstr==0) return
k=0
 
do
   if(len_trim(str) == 0) exit
   nargs=nargs+1
   call split(str,delims,args(nargs))
   call removebksl(args(nargs))
end do   
str=strsav
 
end subroutine parse
 
!**********************************************************************
 
subroutine compact(str)
 
! Converts multiple spaces and tabs to single spaces; deletes control characters;
! removes initial spaces.
 
character(len=*):: str
character(len=1):: ch
character(len=len_trim(str)):: outstr
 
str=adjustl(str)
lenstr=len_trim(str)
outstr=' '
isp=0
k=0
 
do i=1,lenstr
  ch=str(i:i)
  ich=iachar(ch)
  
  select case(ich)
  
    case(9,32)     ! space or tab character
      if(isp==0) then
        k=k+1
        outstr(k:k)=' '
      end if
      isp=1
      
    case(33:)      ! not a space, quote, or control character
      k=k+1
      outstr(k:k)=ch
      isp=0
      
  end select
  
end do
 
str=adjustl(outstr)
 
end subroutine compact
 
!**********************************************************************
 
subroutine removesp(str)
 
! Removes spaces, tabs, and control characters in string str
 
character(len=*):: str
character(len=1):: ch
character(len=len_trim(str))::outstr
 
str=adjustl(str)
lenstr=len_trim(str)
outstr=' '
k=0
 
do i=1,lenstr
  ch=str(i:i)
  ich=iachar(ch)
  select case(ich)    
    case(0:32)  ! space, tab, or control character
         cycle       
    case(33:)  
      k=k+1
      outstr(k:k)=ch
  end select
end do
 
str=adjustl(outstr)
 
end subroutine removesp
 
!**********************************************************************
 
subroutine value_dr(str,rnum,ios)
 
! Converts number string to a double precision real number
 
character(len=*)::str
real(kr8)::rnum
integer :: ios
 
ilen=len_trim(str)
ipos=scan(str,'Ee')
if(.not.is_digit(str(ilen:ilen)) .and. ipos/=0) then
   ios=3
   return
end if
read(str,*,iostat=ios) rnum
 
end subroutine value_dr
 
!**********************************************************************
 
subroutine value_sr(str,rnum,ios)
 
! Converts number string to a single precision real number
 
character(len=*)::str
real(kr4) :: rnum
real(kr8) :: rnumd 
 
call value_dr(str,rnumd,ios)
if( abs(rnumd) > huge(rnum) ) then
  ios=15
  return
end if
if( abs(rnumd) < tiny(rnum) ) rnum=0.0_kr4
rnum=rnumd
 
end subroutine value_sr
 
!**********************************************************************
 
subroutine value_di(str,inum,ios)
 
! Converts number string to a double precision integer value
 
character(len=*)::str
integer(ki8) :: inum
real(kr8) :: rnum
 
call value_dr(str,rnum,ios)
if(abs(rnum)>huge(inum)) then
  ios=15
  return
end if
inum=nint(rnum,ki8)
 
end subroutine value_di
 
!**********************************************************************
 
subroutine value_si(str,inum,ios)
 
! Converts number string to a single precision integer value
 
character(len=*)::str
integer(ki4) :: inum
real(kr8) :: rnum
 
call value_dr(str,rnum,ios)
if(abs(rnum)>huge(inum)) then
  ios=15
  return
end if
inum=nint(rnum,ki4)
 
end subroutine value_si
 
!**********************************************************************
 
subroutine shiftstr(str,n)
 
! Shifts characters in in the string 'str' n positions (positive values
! denote a right shift and negative values denote a left shift). Characters
! that are shifted off the end are lost. Positions opened up by the shift 
! are replaced by spaces.
 
character(len=*):: str
 
lenstr=len(str)
nabs=iabs(n)
if(nabs>=lenstr) then
  str=repeat(' ',lenstr)
  return
end if
if(n<0) str=str(nabs+1:)//repeat(' ',nabs)  ! shift left
if(n>0) str=repeat(' ',nabs)//str(:lenstr-nabs)  ! shift right 
return
 
end subroutine shiftstr
 
!**********************************************************************
 
subroutine insertstr(str,strins,loc)
 
! Inserts the string 'strins' into the string 'str' at position 'loc'. 
! Characters in 'str' starting at position 'loc' are shifted right to
! make room for the inserted string. Trailing spaces of 'strins' are 
! removed prior to insertion
 
character(len=*):: str,strins
character(len=len(str))::tempstr
 
lenstrins=len_trim(strins)
tempstr=str(loc:)
call shiftstr(tempstr,lenstrins)
tempstr(1:lenstrins)=strins(1:lenstrins)
str(loc:)=tempstr
return
 
end subroutine insertstr
 
!**********************************************************************
 
subroutine delsubstr(str,substr)
 
! Deletes first occurrence of substring 'substr' from string 'str' and
! shifts characters left to fill hole. Trailing spaces or blanks are
! not considered part of 'substr'.
 
character(len=*):: str,substr
 
lensubstr=len_trim(substr)
ipos=index(str,substr)
if(ipos==0) return
if(ipos == 1) then
   str=str(lensubstr+1:)
else
   str=str(:ipos-1)//str(ipos+lensubstr:)
end if   
return
 
end subroutine delsubstr
 
!**********************************************************************
 
subroutine delall(str,substr)
 
! Deletes all occurrences of substring 'substr' from string 'str' and
! shifts characters left to fill holes.
 
character(len=*):: str,substr
 
lensubstr=len_trim(substr)
do
   ipos=index(str,substr)
   if(ipos == 0) exit
   if(ipos == 1) then
      str=str(lensubstr+1:)
   else
      str=str(:ipos-1)//str(ipos+lensubstr:)
   end if
end do   
return
 
end subroutine delall
 
!**********************************************************************
 
function uppercase(str) result(ucstr)
 
! convert string to upper case
 
character (len=*):: str
character (len=len_trim(str)):: ucstr
 
ilen=len_trim(str)
ioffset=iachar('A')-iachar('a')     
iquote=0
ucstr=str
do i=1,ilen
  iav=iachar(str(i:i))
  if(iquote==0 .and. (iav==34 .or.iav==39)) then
    iquote=1
    iqc=iav
    cycle
  end if
  if(iquote==1 .and. iav==iqc) then
    iquote=0
    cycle
  end if
  if (iquote==1) cycle
  if(iav >= iachar('a') .and. iav <= iachar('z')) then
    ucstr(i:i)=achar(iav+ioffset)
  else
    ucstr(i:i)=str(i:i)
  end if
end do
return
 
end function uppercase
 
!**********************************************************************
 
function lowercase(str) result(lcstr)
 
! convert string to lower case
 
character (len=*):: str
character (len=len_trim(str)):: lcstr
 
ilen=len_trim(str)
ioffset=iachar('A')-iachar('a')
iquote=0
lcstr=str
do i=1,ilen
  iav=iachar(str(i:i))
  if(iquote==0 .and. (iav==34 .or.iav==39)) then
    iquote=1
    iqc=iav
    cycle
  end if
  if(iquote==1 .and. iav==iqc) then
    iquote=0
    cycle
  end if
  if (iquote==1) cycle
  if(iav >= iachar('A') .and. iav <= iachar('Z')) then
    lcstr(i:i)=achar(iav-ioffset)
  else
    lcstr(i:i)=str(i:i)
  end if
end do
return
 
end function lowercase
 
!**********************************************************************
 
subroutine readline(nunitr,line,ios)
 
! Reads line from unit=nunitr, ignoring blank lines
! and deleting comments beginning with an exclamation point(!)
 
character (len=*):: line
 
do  
  read(nunitr,'(a)', iostat=ios) line      ! read input line
  if(ios /= 0) return
  line=adjustl(line)
  ipos=index(line,'!')
  if(ipos == 1) cycle
  if(ipos /= 0) line=line(:ipos-1)
  if(len_trim(line) /= 0) exit
end do
return
 
end subroutine readline
 
!**********************************************************************
 
subroutine match(str,ipos,imatch)
 
! Sets imatch to the position in string of the delimiter matching the delimiter
! in position ipos. Allowable delimiters are (), [], {}, <>.
 
character(len=*) :: str
character :: delim1,delim2,ch
 
lenstr=len_trim(str)
delim1=str(ipos:ipos)
select case(delim1)
   case('(')
      idelim2=iachar(delim1)+1
      istart=ipos+1
      iend=lenstr
      inc=1
   case(')')
      idelim2=iachar(delim1)-1
      istart=ipos-1
      iend=1
      inc=-1
   case('[','{','<')
      idelim2=iachar(delim1)+2
      istart=ipos+1
      iend=lenstr
      inc=1
   case(']','}','>')
      idelim2=iachar(delim1)-2
      istart=ipos-1
      iend=1
      inc=-1
   case default
      write(*,*) delim1,' is not a valid delimiter'
      return
end select
if(istart < 1 .or. istart > lenstr) then
   write(*,*) delim1,' has no matching delimiter'
   return
end if
delim2=achar(idelim2) ! matching delimiter
 
isum=1
do i=istart,iend,inc
   ch=str(i:i)
   if(ch /= delim1 .and. ch /= delim2) cycle
   if(ch == delim1) isum=isum+1
   if(ch == delim2) isum=isum-1
   if(isum == 0) exit
end do
if(isum /= 0) then
   write(*,*) delim1,' has no matching delimiter'
   return
end if   
imatch=i
 
return
 
end subroutine match
 
!**********************************************************************
 
subroutine write_dr(rnum,str,fmt)
 
! Writes double precision real number rnum to string str using format fmt
 
real(kr8) :: rnum
character(len=*) :: str,fmt
character(len=80) :: formt
 
formt='('//trim(fmt)//')'
write(str,formt) rnum
str=adjustl(str)
 
end subroutine write_dr
 
!***********************************************************************
 
subroutine write_sr(rnum,str,fmt)
 
! Writes single precision real number rnum to string str using format fmt
 
real(kr4) :: rnum
character(len=*) :: str,fmt
character(len=80) :: formt
 
formt='('//trim(fmt)//')'
write(str,formt) rnum
str=adjustl(str)
 
end subroutine write_sr
 
!***********************************************************************
 
subroutine write_di(inum,str,fmt)
 
! Writes double precision integer inum to string str using format fmt
 
integer(ki8) :: inum
character(len=*) :: str,fmt
character(len=80) :: formt
 
formt='('//trim(fmt)//')'
write(str,formt) inum
str=adjustl(str)
 
end subroutine write_di
 
!***********************************************************************
 
subroutine write_si(inum,str,fmt)
 
! Writes single precision integer inum to string str using format fmt
 
integer(ki4) :: inum
character(len=*) :: str,fmt
character(len=80) :: formt
 
formt='('//trim(fmt)//')'
write(str,formt) inum
str=adjustl(str)
 
end subroutine write_si
 
!***********************************************************************
 
subroutine trimzero(str)
 
! Deletes nonsignificant trailing zeroes from number string str. If number
! string ends in a decimal point, one trailing zero is added.
 
character(len=*) :: str
character :: ch
character(len=10) :: exp
 
ipos=scan(str,'eE')
if(ipos>0) then
   exp=str(ipos:)
   str=str(1:ipos-1)
endif
lstr=len_trim(str)
do i=lstr,1,-1
   ch=str(i:i)
   if(ch=='0') cycle          
   if(ch=='.') then
      str=str(1:i)//'0'
      if(ipos>0) str=trim(str)//trim(exp)
      exit
   endif
   str=str(1:i)
   exit
end do
if(ipos>0) str=trim(str)//trim(exp)
 
end subroutine trimzero
 
!**********************************************************************
 
subroutine writeq_dr(unit,namestr,value,fmt)
 
! Writes a string of the form <name> = value to unit
 
real(kr8) :: value
integer :: unit
character(len=*) :: namestr,fmt
character(len=32) :: tempstr
 
call writenum(value,tempstr,fmt)
call trimzero(tempstr)
write(unit,*) trim(namestr)//' = '//trim(tempstr)
 
end subroutine writeq_dr
 
!**********************************************************************
 
subroutine writeq_sr(unit,namestr,value,fmt)
 
! Writes a string of the form <name> = value to unit
 
real(kr4) :: value
integer :: unit
character(len=*) :: namestr,fmt
character(len=32) :: tempstr
 
call writenum(value,tempstr,fmt)
call trimzero(tempstr)
write(unit,*) trim(namestr)//' = '//trim(tempstr)
 
end subroutine writeq_sr
 
!**********************************************************************
 
subroutine writeq_di(unit,namestr,ivalue,fmt)
 
! Writes a string of the form <name> = ivalue to unit
 
integer(ki8) :: ivalue
integer :: unit
character(len=*) :: namestr,fmt
character(len=32) :: tempstr
call writenum(ivalue,tempstr,fmt)
call trimzero(tempstr)
write(unit,*) trim(namestr)//' = '//trim(tempstr)
 
end subroutine writeq_di
 
!**********************************************************************
 
subroutine writeq_si(unit,namestr,ivalue,fmt)
 
! Writes a string of the form <name> = ivalue to unit
 
integer(ki4) :: ivalue
integer :: unit
character(len=*) :: namestr,fmt
character(len=32) :: tempstr
call writenum(ivalue,tempstr,fmt)
call trimzero(tempstr)
write(unit,*) trim(namestr)//' = '//trim(tempstr)
 
end subroutine writeq_si
 
!**********************************************************************
 
function is_letter(ch) result(res)
 
! Returns .true. if ch is a letter and .false. otherwise
 
character :: ch
logical :: res
 
select case(ch)
case('A':'Z','a':'z')
  res=.true.
case default
  res=.false.
end select
return
 
end function is_letter
 
!**********************************************************************
 
function is_digit(ch) result(res)
 
! Returns .true. if ch is a digit (0,1,...,9) and .false. otherwise
 
character :: ch
logical :: res
 
select case(ch)
case('0':'9')
  res=.true.
case default
  res=.false.
end select
return
 
end function is_digit
 
!**********************************************************************
 
subroutine split(str,delims,before,sep)
 
! Routine finds the first instance of a character from 'delims' in the
! the string 'str'. The characters before the found delimiter are
! output in 'before'. The characters after the found delimiter are
! output in 'str'. The optional output character 'sep' contains the 
! found delimiter. A delimiter in 'str' is treated like an ordinary 
! character if it is preceded by a backslash (\). If the backslash 
! character is desired in 'str', then precede it with another backslash.
 
character(len=*) :: str,delims,before
character,optional :: sep
logical :: pres
character :: ch,cha
 
pres=present(sep)
str=adjustl(str)
call compact(str)
lenstr=len_trim(str)
if(lenstr == 0) return        ! string str is empty
k=0
ibsl=0                        ! backslash initially inactive
before=' '
do i=1,lenstr
   ch=str(i:i)
   if(ibsl == 1) then          ! backslash active
      k=k+1
      before(k:k)=ch
      ibsl=0
      cycle
   end if
   if(ch == '\\') then          ! backslash with backslash inactive
      k=k+1
      before(k:k)=ch
      ibsl=1
      cycle
   end if
   ipos=index(delims,ch)         
   if(ipos == 0) then          ! character is not a delimiter
      k=k+1
      before(k:k)=ch
      cycle
   end if
   if(ch /= ' ') then          ! character is a delimiter that is not a space
      str=str(i+1:)
      if(pres) sep=ch
      exit
   end if
   cha=str(i+1:i+1)            ! character is a space delimiter
   iposa=index(delims,cha)
   if(iposa > 0) then          ! next character is a delimiter
      str=str(i+2:)
      if(pres) sep=cha
      exit
   else
      str=str(i+1:)
      if(pres) sep=ch
      exit
   end if
end do
if(i >= lenstr) str=''
str=adjustl(str)              ! remove initial spaces
return
 
end subroutine split
 
!**********************************************************************
 
subroutine removebksl(str)
 
! Removes backslash (\) characters. Double backslashes (\\) are replaced
! by a single backslash.
 
character(len=*):: str
character(len=1):: ch
character(len=len_trim(str))::outstr
 
str=adjustl(str)
lenstr=len_trim(str)
outstr=' '
k=0
ibsl=0                        ! backslash initially inactive
 
do i=1,lenstr
  ch=str(i:i)
  if(ibsl == 1) then          ! backslash active
   k=k+1
   outstr(k:k)=ch
   ibsl=0
   cycle
  end if
  if(ch == '\\') then          ! backslash with backslash inactive
   ibsl=1
   cycle
  end if
  k=k+1
  outstr(k:k)=ch              ! non-backslash with backslash inactive
end do
 
str=adjustl(outstr)
 
end subroutine removebksl
 
!**********************************************************************
 
end module strings  
 
 

Rev 2	Rev 10
1	`module strings`	1	`module strings`
2		2
3	`use precision`	3	`use precision`
4		4
5	`private :: value_dr,value_sr,value_di,value_si`	5	`private :: value_dr,value_sr,value_di,value_si`
6	`private :: write_dr,write_sr,write_di,write_si`	6	`private :: write_dr,write_sr,write_di,write_si`
7	`private :: writeq_dr,writeq_sr,writeq_di,writeq_si`	7	`private :: writeq_dr,writeq_sr,writeq_di,writeq_si`
8		8
9	`interface value ! Generic operator for converting a number string to a`	9	`interface value ! Generic operator for converting a number string to a`
10	`! number. Calling syntax is 'call value(numstring,number,ios)'`	10	`! number. Calling syntax is 'call value(numstring,number,ios)'`
11	`! where 'numstring' is a number string and 'number' is a`	11	`! where 'numstring' is a number string and 'number' is a`
12	`! real number or an integer (single or double precision).`	12	`! real number or an integer (single or double precision).`
13	`module procedure value_dr`	13	`module procedure value_dr`
14	`module procedure value_sr`	14	`module procedure value_sr`
15	`module procedure value_di`	15	`module procedure value_di`
16	`module procedure value_si`	16	`module procedure value_si`
17	`end interface`	17	`end interface`
18		18
19	`interface writenum ! Generic interface for writing a number to a string. The`	19	`interface writenum ! Generic interface for writing a number to a string. The`
20	`! number is left justified in the string. The calling syntax`	20	`! number is left justified in the string. The calling syntax`
21	`! is 'call writenum(number,string,format)' where 'number' is`	21	`! is 'call writenum(number,string,format)' where 'number' is`
22	`! a real number or an integer, 'string' is a character string`	22	`! a real number or an integer, 'string' is a character string`
23	`! containing the result, and 'format' is the format desired,`	23	`! containing the result, and 'format' is the format desired,`
24	`! e.g., 'e15.6' or 'i5'.`	24	`! e.g., 'e15.6' or 'i5'.`
25	`module procedure write_dr`	25	`module procedure write_dr`
26	`module procedure write_sr`	26	`module procedure write_sr`
27	`module procedure write_di`	27	`module procedure write_di`
28	`module procedure write_si`	28	`module procedure write_si`
29	`end interface`	29	`end interface`
30		30
31	`interface writeq ! Generic interface equating a name to a numerical value. The`	31	`interface writeq ! Generic interface equating a name to a numerical value. The`
32	`! calling syntax is 'call writeq(unit,name,value,format)' where`	32	`! calling syntax is 'call writeq(unit,name,value,format)' where`
33	`! unit is the integer output unit number, 'name' is the variable`	33	`! unit is the integer output unit number, 'name' is the variable`
34	`! name, 'value' is the real or integer value of the variable,`	34	`! name, 'value' is the real or integer value of the variable,`
35	`! and 'format' is the format of the value. The result written to`	35	`! and 'format' is the format of the value. The result written to`
36	`! the output unit has the form <name> = <value>.`	36	`! the output unit has the form <name> = <value>.`
37	`module procedure writeq_dr`	37	`module procedure writeq_dr`
38	`module procedure writeq_sr`	38	`module procedure writeq_sr`
39	`module procedure writeq_di`	39	`module procedure writeq_di`
40	`module procedure writeq_si`	40	`module procedure writeq_si`
41	`end interface`	41	`end interface`
42		42
43		43
44	`!**********************************************************************`	44	`!**********************************************************************`
45		45
46	`contains`	46	`contains`
47		47
48	`!**********************************************************************`	48	`!**********************************************************************`
49		49
50	`subroutine parse(str,delims,args,nargs)`	50	`subroutine parse(str,delims,args,nargs)`
51		51
52	`! Parses the string 'str' into arguments args(1), ..., args(nargs) based on`	52	`! Parses the string 'str' into arguments args(1), ..., args(nargs) based on`
53	`! the delimiters contained in the string 'delims'. Preceding a delimiter in`	53	`! the delimiters contained in the string 'delims'. Preceding a delimiter in`
54	`! 'str' by a backslash (\) makes this particular instance not a delimiter.`	54	`! 'str' by a backslash (\) makes this particular instance not a delimiter.`
55	`! The integer output variable nargs contains the number of arguments found.`	55	`! The integer output variable nargs contains the number of arguments found.`
56		56
57	`character(len=*) :: str,delims`	57	`character(len=*) :: str,delims`
58	`character(len=len_trim(str)) :: strsav`	58	`character(len=len_trim(str)) :: strsav`
59	`character(len=*),dimension(:) :: args`	59	`character(len=*),dimension(:) :: args`
60		60
61	`strsav=str`	61	`strsav=str`
62	`call compact(str)`	62	`call compact(str)`
63	`na=size(args)`	63	`na=size(args)`
64	`do i=1,na`	64	`do i=1,na`
65	`args(i)=' '`	65	`args(i)=' '`
66	`end do`	66	`end do`
67	`nargs=0`	67	`nargs=0`
68	`lenstr=len_trim(str)`	68	`lenstr=len_trim(str)`
69	`if(lenstr==0) return`	69	`if(lenstr==0) return`
70	`k=0`	70	`k=0`
71		71
72	`do`	72	`do`
73	`if(len_trim(str) == 0) exit`	73	`if(len_trim(str) == 0) exit`
74	`nargs=nargs+1`	74	`nargs=nargs+1`
75	`call split(str,delims,args(nargs))`	75	`call split(str,delims,args(nargs))`
76	`call removebksl(args(nargs))`	76	`call removebksl(args(nargs))`
77	`end do`	77	`end do`
78	`str=strsav`	78	`str=strsav`
79		79
80	`end subroutine parse`	80	`end subroutine parse`
81		81
82	`!**********************************************************************`	82	`!**********************************************************************`
83		83
84	`subroutine compact(str)`	84	`subroutine compact(str)`
85		85
86	`! Converts multiple spaces and tabs to single spaces; deletes control characters;`	86	`! Converts multiple spaces and tabs to single spaces; deletes control characters;`
87	`! removes initial spaces.`	87	`! removes initial spaces.`
88		88
89	`character(len=*):: str`	89	`character(len=*):: str`
90	`character(len=1):: ch`	90	`character(len=1):: ch`
91	`character(len=len_trim(str)):: outstr`	91	`character(len=len_trim(str)):: outstr`
92		92
93	`str=adjustl(str)`	93	`str=adjustl(str)`
94	`lenstr=len_trim(str)`	94	`lenstr=len_trim(str)`
95	`outstr=' '`	95	`outstr=' '`
96	`isp=0`	96	`isp=0`
97	`k=0`	97	`k=0`
98		98
99	`do i=1,lenstr`	99	`do i=1,lenstr`
100	`ch=str(i:i)`	100	`ch=str(i:i)`
101	`ich=iachar(ch)`	101	`ich=iachar(ch)`
102		102
103	`select case(ich)`	103	`select case(ich)`
104		104
105	`case(9,32) ! space or tab character`	105	`case(9,32) ! space or tab character`
106	`if(isp==0) then`	106	`if(isp==0) then`
107	`k=k+1`	107	`k=k+1`
108	`outstr(k:k)=' '`	108	`outstr(k:k)=' '`
109	`end if`	109	`end if`
110	`isp=1`	110	`isp=1`
111		111
112	`case(33:) ! not a space, quote, or control character`	112	`case(33:) ! not a space, quote, or control character`
113	`k=k+1`	113	`k=k+1`
114	`outstr(k:k)=ch`	114	`outstr(k:k)=ch`
115	`isp=0`	115	`isp=0`
116		116
117	`end select`	117	`end select`
118		118
119	`end do`	119	`end do`
120		120
121	`str=adjustl(outstr)`	121	`str=adjustl(outstr)`
122		122
123	`end subroutine compact`	123	`end subroutine compact`
124		124
125	`!**********************************************************************`	125	`!**********************************************************************`
126		126
127	`subroutine removesp(str)`	127	`subroutine removesp(str)`
128		128
129	`! Removes spaces, tabs, and control characters in string str`	129	`! Removes spaces, tabs, and control characters in string str`
130		130
131	`character(len=*):: str`	131	`character(len=*):: str`
132	`character(len=1):: ch`	132	`character(len=1):: ch`
133	`character(len=len_trim(str))::outstr`	133	`character(len=len_trim(str))::outstr`
134		134
135	`str=adjustl(str)`	135	`str=adjustl(str)`
136	`lenstr=len_trim(str)`	136	`lenstr=len_trim(str)`
137	`outstr=' '`	137	`outstr=' '`
138	`k=0`	138	`k=0`
139		139
140	`do i=1,lenstr`	140	`do i=1,lenstr`
141	`ch=str(i:i)`	141	`ch=str(i:i)`
142	`ich=iachar(ch)`	142	`ich=iachar(ch)`
143	`select case(ich)`	143	`select case(ich)`
144	`case(0:32) ! space, tab, or control character`	144	`case(0:32) ! space, tab, or control character`
145	`cycle`	145	`cycle`
146	`case(33:)`	146	`case(33:)`
147	`k=k+1`	147	`k=k+1`
148	`outstr(k:k)=ch`	148	`outstr(k:k)=ch`
149	`end select`	149	`end select`
150	`end do`	150	`end do`
151		151
152	`str=adjustl(outstr)`	152	`str=adjustl(outstr)`
153		153
154	`end subroutine removesp`	154	`end subroutine removesp`
155		155
156	`!**********************************************************************`	156	`!**********************************************************************`
157		157
158	`subroutine value_dr(str,rnum,ios)`	158	`subroutine value_dr(str,rnum,ios)`
159		159
160	`! Converts number string to a double precision real number`	160	`! Converts number string to a double precision real number`
161		161
162	`character(len=*)::str`	162	`character(len=*)::str`
163	`real(kr8)::rnum`	163	`real(kr8)::rnum`
164	`integer :: ios`	164	`integer :: ios`
165		165
166	`ilen=len_trim(str)`	166	`ilen=len_trim(str)`
167	`ipos=scan(str,'Ee')`	167	`ipos=scan(str,'Ee')`
168	`if(.not.is_digit(str(ilen:ilen)) .and. ipos/=0) then`	168	`if(.not.is_digit(str(ilen:ilen)) .and. ipos/=0) then`
169	`ios=3`	169	`ios=3`
170	`return`	170	`return`
171	`end if`	171	`end if`
172	`read(str,*,iostat=ios) rnum`	172	`read(str,*,iostat=ios) rnum`
173		173
174	`end subroutine value_dr`	174	`end subroutine value_dr`
175		175
176	`!**********************************************************************`	176	`!**********************************************************************`
177		177
178	`subroutine value_sr(str,rnum,ios)`	178	`subroutine value_sr(str,rnum,ios)`
179		179
180	`! Converts number string to a single precision real number`	180	`! Converts number string to a single precision real number`
181		181
182	`character(len=*)::str`	182	`character(len=*)::str`
183	`real(kr4) :: rnum`	183	`real(kr4) :: rnum`
184	`real(kr8) :: rnumd`	184	`real(kr8) :: rnumd`
185		185
186	`call value_dr(str,rnumd,ios)`	186	`call value_dr(str,rnumd,ios)`
187	`if( abs(rnumd) > huge(rnum) ) then`	187	`if( abs(rnumd) > huge(rnum) ) then`
188	`ios=15`	188	`ios=15`
189	`return`	189	`return`
190	`end if`	190	`end if`
191	`if( abs(rnumd) < tiny(rnum) ) rnum=0.0_kr4`	191	`if( abs(rnumd) < tiny(rnum) ) rnum=0.0_kr4`
192	`rnum=rnumd`	192	`rnum=rnumd`
193		193
194	`end subroutine value_sr`	194	`end subroutine value_sr`
195		195
196	`!**********************************************************************`	196	`!**********************************************************************`
197		197
198	`subroutine value_di(str,inum,ios)`	198	`subroutine value_di(str,inum,ios)`
199		199
200	`! Converts number string to a double precision integer value`	200	`! Converts number string to a double precision integer value`
201		201
202	`character(len=*)::str`	202	`character(len=*)::str`
203	`integer(ki8) :: inum`	203	`integer(ki8) :: inum`
204	`real(kr8) :: rnum`	204	`real(kr8) :: rnum`
205		205
206	`call value_dr(str,rnum,ios)`	206	`call value_dr(str,rnum,ios)`
207	`if(abs(rnum)>huge(inum)) then`	207	`if(abs(rnum)>huge(inum)) then`
208	`ios=15`	208	`ios=15`
209	`return`	209	`return`
210	`end if`	210	`end if`
211	`inum=nint(rnum,ki8)`	211	`inum=nint(rnum,ki8)`
212		212
213	`end subroutine value_di`	213	`end subroutine value_di`
214		214
215	`!**********************************************************************`	215	`!**********************************************************************`
216		216
217	`subroutine value_si(str,inum,ios)`	217	`subroutine value_si(str,inum,ios)`
218		218
219	`! Converts number string to a single precision integer value`	219	`! Converts number string to a single precision integer value`
220		220
221	`character(len=*)::str`	221	`character(len=*)::str`
222	`integer(ki4) :: inum`	222	`integer(ki4) :: inum`
223	`real(kr8) :: rnum`	223	`real(kr8) :: rnum`
224		224
225	`call value_dr(str,rnum,ios)`	225	`call value_dr(str,rnum,ios)`
226	`if(abs(rnum)>huge(inum)) then`	226	`if(abs(rnum)>huge(inum)) then`
227	`ios=15`	227	`ios=15`
228	`return`	228	`return`
229	`end if`	229	`end if`
230	`inum=nint(rnum,ki4)`	230	`inum=nint(rnum,ki4)`
231		231
232	`end subroutine value_si`	232	`end subroutine value_si`
233		233
234	`!**********************************************************************`	234	`!**********************************************************************`
235		235
236	`subroutine shiftstr(str,n)`	236	`subroutine shiftstr(str,n)`
237		237
238	`! Shifts characters in in the string 'str' n positions (positive values`	238	`! Shifts characters in in the string 'str' n positions (positive values`
239	`! denote a right shift and negative values denote a left shift). Characters`	239	`! denote a right shift and negative values denote a left shift). Characters`
240	`! that are shifted off the end are lost. Positions opened up by the shift`	240	`! that are shifted off the end are lost. Positions opened up by the shift`
241	`! are replaced by spaces.`	241	`! are replaced by spaces.`
242		242
243	`character(len=*):: str`	243	`character(len=*):: str`
244		244
245	`lenstr=len(str)`	245	`lenstr=len(str)`
246	`nabs=iabs(n)`	246	`nabs=iabs(n)`
247	`if(nabs>=lenstr) then`	247	`if(nabs>=lenstr) then`
248	`str=repeat(' ',lenstr)`	248	`str=repeat(' ',lenstr)`
249	`return`	249	`return`
250	`end if`	250	`end if`
251	`if(n<0) str=str(nabs+1:)//repeat(' ',nabs) ! shift left`	251	`if(n<0) str=str(nabs+1:)//repeat(' ',nabs) ! shift left`
252	`if(n>0) str=repeat(' ',nabs)//str(:lenstr-nabs) ! shift right`	252	`if(n>0) str=repeat(' ',nabs)//str(:lenstr-nabs) ! shift right`
253	`return`	253	`return`
254		254
255	`end subroutine shiftstr`	255	`end subroutine shiftstr`
256		256
257	`!**********************************************************************`	257	`!**********************************************************************`
258		258
259	`subroutine insertstr(str,strins,loc)`	259	`subroutine insertstr(str,strins,loc)`
260		260
261	`! Inserts the string 'strins' into the string 'str' at position 'loc'.`	261	`! Inserts the string 'strins' into the string 'str' at position 'loc'.`
262	`! Characters in 'str' starting at position 'loc' are shifted right to`	262	`! Characters in 'str' starting at position 'loc' are shifted right to`
263	`! make room for the inserted string. Trailing spaces of 'strins' are`	263	`! make room for the inserted string. Trailing spaces of 'strins' are`
264	`! removed prior to insertion`	264	`! removed prior to insertion`
265		265
266	`character(len=*):: str,strins`	266	`character(len=*):: str,strins`
267	`character(len=len(str))::tempstr`	267	`character(len=len(str))::tempstr`
268		268
269	`lenstrins=len_trim(strins)`	269	`lenstrins=len_trim(strins)`
270	`tempstr=str(loc:)`	270	`tempstr=str(loc:)`
271	`call shiftstr(tempstr,lenstrins)`	271	`call shiftstr(tempstr,lenstrins)`
272	`tempstr(1:lenstrins)=strins(1:lenstrins)`	272	`tempstr(1:lenstrins)=strins(1:lenstrins)`
273	`str(loc:)=tempstr`	273	`str(loc:)=tempstr`
274	`return`	274	`return`
275		275
276	`end subroutine insertstr`	276	`end subroutine insertstr`
277		277
278	`!**********************************************************************`	278	`!**********************************************************************`
279		279
280	`subroutine delsubstr(str,substr)`	280	`subroutine delsubstr(str,substr)`
281		281
282	`! Deletes first occurrence of substring 'substr' from string 'str' and`	282	`! Deletes first occurrence of substring 'substr' from string 'str' and`
283	`! shifts characters left to fill hole. Trailing spaces or blanks are`	283	`! shifts characters left to fill hole. Trailing spaces or blanks are`
284	`! not considered part of 'substr'.`	284	`! not considered part of 'substr'.`
285		285
286	`character(len=*):: str,substr`	286	`character(len=*):: str,substr`
287		287
288	`lensubstr=len_trim(substr)`	288	`lensubstr=len_trim(substr)`
289	`ipos=index(str,substr)`	289	`ipos=index(str,substr)`
290	`if(ipos==0) return`	290	`if(ipos==0) return`
291	`if(ipos == 1) then`	291	`if(ipos == 1) then`
292	`str=str(lensubstr+1:)`	292	`str=str(lensubstr+1:)`
293	`else`	293	`else`
294	`str=str(:ipos-1)//str(ipos+lensubstr:)`	294	`str=str(:ipos-1)//str(ipos+lensubstr:)`
295	`end if`	295	`end if`
296	`return`	296	`return`
297		297
298	`end subroutine delsubstr`	298	`end subroutine delsubstr`
299		299
300	`!**********************************************************************`	300	`!**********************************************************************`
301		301
302	`subroutine delall(str,substr)`	302	`subroutine delall(str,substr)`
303		303
304	`! Deletes all occurrences of substring 'substr' from string 'str' and`	304	`! Deletes all occurrences of substring 'substr' from string 'str' and`
305	`! shifts characters left to fill holes.`	305	`! shifts characters left to fill holes.`
306		306
307	`character(len=*):: str,substr`	307	`character(len=*):: str,substr`
308		308
309	`lensubstr=len_trim(substr)`	309	`lensubstr=len_trim(substr)`
310	`do`	310	`do`
311	`ipos=index(str,substr)`	311	`ipos=index(str,substr)`
312	`if(ipos == 0) exit`	312	`if(ipos == 0) exit`
313	`if(ipos == 1) then`	313	`if(ipos == 1) then`
314	`str=str(lensubstr+1:)`	314	`str=str(lensubstr+1:)`
315	`else`	315	`else`
316	`str=str(:ipos-1)//str(ipos+lensubstr:)`	316	`str=str(:ipos-1)//str(ipos+lensubstr:)`
317	`end if`	317	`end if`
318	`end do`	318	`end do`
319	`return`	319	`return`
320		320
321	`end subroutine delall`	321	`end subroutine delall`
322		322
323	`!**********************************************************************`	323	`!**********************************************************************`
324		324
325	`function uppercase(str) result(ucstr)`	325	`function uppercase(str) result(ucstr)`
326		326
327	`! convert string to upper case`	327	`! convert string to upper case`
328		328
329	`character (len=*):: str`	329	`character (len=*):: str`
330	`character (len=len_trim(str)):: ucstr`	330	`character (len=len_trim(str)):: ucstr`
331		331
332	`ilen=len_trim(str)`	332	`ilen=len_trim(str)`
333	`ioffset=iachar('A')-iachar('a')`	333	`ioffset=iachar('A')-iachar('a')`
334	`iquote=0`	334	`iquote=0`
335	`ucstr=str`	335	`ucstr=str`
336	`do i=1,ilen`	336	`do i=1,ilen`
337	`iav=iachar(str(i:i))`	337	`iav=iachar(str(i:i))`
338	`if(iquote==0 .and. (iav==34 .or.iav==39)) then`	338	`if(iquote==0 .and. (iav==34 .or.iav==39)) then`
339	`iquote=1`	339	`iquote=1`
340	`iqc=iav`	340	`iqc=iav`
341	`cycle`	341	`cycle`
342	`end if`	342	`end if`
343	`if(iquote==1 .and. iav==iqc) then`	343	`if(iquote==1 .and. iav==iqc) then`
344	`iquote=0`	344	`iquote=0`
345	`cycle`	345	`cycle`
346	`end if`	346	`end if`
347	`if (iquote==1) cycle`	347	`if (iquote==1) cycle`
348	`if(iav >= iachar('a') .and. iav <= iachar('z')) then`	348	`if(iav >= iachar('a') .and. iav <= iachar('z')) then`
349	`ucstr(i:i)=achar(iav+ioffset)`	349	`ucstr(i:i)=achar(iav+ioffset)`
350	`else`	350	`else`
351	`ucstr(i:i)=str(i:i)`	351	`ucstr(i:i)=str(i:i)`
352	`end if`	352	`end if`
353	`end do`	353	`end do`
354	`return`	354	`return`
355		355
356	`end function uppercase`	356	`end function uppercase`
357		357
358	`!**********************************************************************`	358	`!**********************************************************************`
359		359
360	`function lowercase(str) result(lcstr)`	360	`function lowercase(str) result(lcstr)`
361		361
362	`! convert string to lower case`	362	`! convert string to lower case`
363		363
364	`character (len=*):: str`	364	`character (len=*):: str`
365	`character (len=len_trim(str)):: lcstr`	365	`character (len=len_trim(str)):: lcstr`
366		366
367	`ilen=len_trim(str)`	367	`ilen=len_trim(str)`
368	`ioffset=iachar('A')-iachar('a')`	368	`ioffset=iachar('A')-iachar('a')`
369	`iquote=0`	369	`iquote=0`
370	`lcstr=str`	370	`lcstr=str`
371	`do i=1,ilen`	371	`do i=1,ilen`
372	`iav=iachar(str(i:i))`	372	`iav=iachar(str(i:i))`
373	`if(iquote==0 .and. (iav==34 .or.iav==39)) then`	373	`if(iquote==0 .and. (iav==34 .or.iav==39)) then`
374	`iquote=1`	374	`iquote=1`
375	`iqc=iav`	375	`iqc=iav`
376	`cycle`	376	`cycle`
377	`end if`	377	`end if`
378	`if(iquote==1 .and. iav==iqc) then`	378	`if(iquote==1 .and. iav==iqc) then`
379	`iquote=0`	379	`iquote=0`
380	`cycle`	380	`cycle`
381	`end if`	381	`end if`
382	`if (iquote==1) cycle`	382	`if (iquote==1) cycle`
383	`if(iav >= iachar('A') .and. iav <= iachar('Z')) then`	383	`if(iav >= iachar('A') .and. iav <= iachar('Z')) then`
384	`lcstr(i:i)=achar(iav-ioffset)`	384	`lcstr(i:i)=achar(iav-ioffset)`
385	`else`	385	`else`
386	`lcstr(i:i)=str(i:i)`	386	`lcstr(i:i)=str(i:i)`
387	`end if`	387	`end if`
388	`end do`	388	`end do`
389	`return`	389	`return`
390		390
391	`end function lowercase`	391	`end function lowercase`
392		392
393	`!**********************************************************************`	393	`!**********************************************************************`
394		394
395	`subroutine readline(nunitr,line,ios)`	395	`subroutine readline(nunitr,line,ios)`
396		396
397	`! Reads line from unit=nunitr, ignoring blank lines`	397	`! Reads line from unit=nunitr, ignoring blank lines`
398	`! and deleting comments beginning with an exclamation point(!)`	398	`! and deleting comments beginning with an exclamation point(!)`
399		399
400	`character (len=*):: line`	400	`character (len=*):: line`
401		401
402	`do`	402	`do`
403	`read(nunitr,'(a)', iostat=ios) line ! read input line`	403	`read(nunitr,'(a)', iostat=ios) line ! read input line`
404	`if(ios /= 0) return`	404	`if(ios /= 0) return`
405	`line=adjustl(line)`	405	`line=adjustl(line)`
406	`ipos=index(line,'!')`	406	`ipos=index(line,'!')`
407	`if(ipos == 1) cycle`	407	`if(ipos == 1) cycle`
408	`if(ipos /= 0) line=line(:ipos-1)`	408	`if(ipos /= 0) line=line(:ipos-1)`
409	`if(len_trim(line) /= 0) exit`	409	`if(len_trim(line) /= 0) exit`
410	`end do`	410	`end do`
411	`return`	411	`return`
412		412
413	`end subroutine readline`	413	`end subroutine readline`
414		414
415	`!**********************************************************************`	415	`!**********************************************************************`
416		416
417	`subroutine match(str,ipos,imatch)`	417	`subroutine match(str,ipos,imatch)`
418		418
419	`! Sets imatch to the position in string of the delimiter matching the delimiter`	419	`! Sets imatch to the position in string of the delimiter matching the delimiter`
420	`! in position ipos. Allowable delimiters are (), [], {}, <>.`	420	`! in position ipos. Allowable delimiters are (), [], {}, <>.`
421		421
422	`character(len=*) :: str`	422	`character(len=*) :: str`
423	`character :: delim1,delim2,ch`	423	`character :: delim1,delim2,ch`
424		424
425	`lenstr=len_trim(str)`	425	`lenstr=len_trim(str)`
426	`delim1=str(ipos:ipos)`	426	`delim1=str(ipos:ipos)`
427	`select case(delim1)`	427	`select case(delim1)`
428	`case('(')`	428	`case('(')`
429	`idelim2=iachar(delim1)+1`	429	`idelim2=iachar(delim1)+1`
430	`istart=ipos+1`	430	`istart=ipos+1`
431	`iend=lenstr`	431	`iend=lenstr`
432	`inc=1`	432	`inc=1`
433	`case(')')`	433	`case(')')`
434	`idelim2=iachar(delim1)-1`	434	`idelim2=iachar(delim1)-1`
435	`istart=ipos-1`	435	`istart=ipos-1`
436	`iend=1`	436	`iend=1`
437	`inc=-1`	437	`inc=-1`
438	`case('[','{','<')`	438	`case('[','{','<')`
439	`idelim2=iachar(delim1)+2`	439	`idelim2=iachar(delim1)+2`
440	`istart=ipos+1`	440	`istart=ipos+1`
441	`iend=lenstr`	441	`iend=lenstr`
442	`inc=1`	442	`inc=1`
443	`case(']','}','>')`	443	`case(']','}','>')`
444	`idelim2=iachar(delim1)-2`	444	`idelim2=iachar(delim1)-2`
445	`istart=ipos-1`	445	`istart=ipos-1`
446	`iend=1`	446	`iend=1`
447	`inc=-1`	447	`inc=-1`
448	`case default`	448	`case default`
449	`write(,) delim1,' is not a valid delimiter'`	449	`write(,) delim1,' is not a valid delimiter'`
450	`return`	450	`return`
451	`end select`	451	`end select`
452	`if(istart < 1 .or. istart > lenstr) then`	452	`if(istart < 1 .or. istart > lenstr) then`
453	`write(,) delim1,' has no matching delimiter'`	453	`write(,) delim1,' has no matching delimiter'`
454	`return`	454	`return`
455	`end if`	455	`end if`
456	`delim2=achar(idelim2) ! matching delimiter`	456	`delim2=achar(idelim2) ! matching delimiter`
457		457
458	`isum=1`	458	`isum=1`
459	`do i=istart,iend,inc`	459	`do i=istart,iend,inc`
460	`ch=str(i:i)`	460	`ch=str(i:i)`
461	`if(ch /= delim1 .and. ch /= delim2) cycle`	461	`if(ch /= delim1 .and. ch /= delim2) cycle`
462	`if(ch == delim1) isum=isum+1`	462	`if(ch == delim1) isum=isum+1`
463	`if(ch == delim2) isum=isum-1`	463	`if(ch == delim2) isum=isum-1`
464	`if(isum == 0) exit`	464	`if(isum == 0) exit`
465	`end do`	465	`end do`
466	`if(isum /= 0) then`	466	`if(isum /= 0) then`
467	`write(,) delim1,' has no matching delimiter'`	467	`write(,) delim1,' has no matching delimiter'`
468	`return`	468	`return`
469	`end if`	469	`end if`
470	`imatch=i`	470	`imatch=i`
471		471
472	`return`	472	`return`
473		473
474	`end subroutine match`	474	`end subroutine match`
475		475
476	`!**********************************************************************`	476	`!**********************************************************************`
477		477
478	`subroutine write_dr(rnum,str,fmt)`	478	`subroutine write_dr(rnum,str,fmt)`
479		479
480	`! Writes double precision real number rnum to string str using format fmt`	480	`! Writes double precision real number rnum to string str using format fmt`
481		481
482	`real(kr8) :: rnum`	482	`real(kr8) :: rnum`
483	`character(len=*) :: str,fmt`	483	`character(len=*) :: str,fmt`
484	`character(len=80) :: formt`	484	`character(len=80) :: formt`
485		485
486	`formt='('//trim(fmt)//')'`	486	`formt='('//trim(fmt)//')'`
487	`write(str,formt) rnum`	487	`write(str,formt) rnum`
488	`str=adjustl(str)`	488	`str=adjustl(str)`
489		489
490	`end subroutine write_dr`	490	`end subroutine write_dr`
491		491
492	`!***********************************************************************`	492	`!***********************************************************************`
493		493
494	`subroutine write_sr(rnum,str,fmt)`	494	`subroutine write_sr(rnum,str,fmt)`
495		495
496	`! Writes single precision real number rnum to string str using format fmt`	496	`! Writes single precision real number rnum to string str using format fmt`
497		497
498	`real(kr4) :: rnum`	498	`real(kr4) :: rnum`
499	`character(len=*) :: str,fmt`	499	`character(len=*) :: str,fmt`
500	`character(len=80) :: formt`	500	`character(len=80) :: formt`

Subversion Repositories lagranto.wrf

(root)/branches/met.nps.monterey/goodies/stringmod.f90 – Rev 2 → 10