Source module last modified on Fri, 5 May 2006, 19:42;
HTML image of Fortran source automatically generated by
for2html on Mon, 29 May 2006, 15:06.
#///////////////////////////////////////////////////////////////////////////
#//// C $Id: strings.f,v 1.4 2006/05/05 17:42:56 saroun Exp $
#//// strings.f - v.1.2, (c) J.Saroun, 1999-2001
#////
#//// String handling subroutines for RESTRAX
#////
#///////////////////////////////////////////////////////////////////////////
#////
#////
#//// CALL FINDPAR(LINE,IPAR,ISTART,ILEN)
#//// .... find possition of the IPAR-th parameter on the LINE
#////
#//// + other useful routines for handling strings
#////
#///////////////////////////////////////////////////////////////////////////
# -----------------------------------------------------------------
SUBROUTINE READ_R8(name, line, result, ierr)
# Read REAL*8 number from the LINE identified by NAME
# suppose format "NAME=number " or "NAME number "
# -----------------------------------------------------------------
implicit none
character*(*) line,name
integer*4 l,istart,ilen,i,iname,lname,ierr,is
real*8 z,result
character*1 ch
ierr=-1
call BOUNDS(name,iname,lname)
if (lname.le.0) goto 99
l=len_trim(line)
is=1
10 i=index(line(is:l),name(iname:iname+lname-1))
if (i.gt.1) then
if (line(is+i-2:is+i-2).ne. ' ') then ! space delimiter must precede the name
is=is+i-1+lname ! try other occurences after this one
goto 10
endif
endif
#// identifier NAME found
if (i.gt.0) then
i=i+is-1+lname ! i=1st character after NAME
#// name must be followed by = or space
if (line(i:i).ne. '='.and.line(i:i).ne. ' ') return
i=i+1
istart=1
call FINDPAR(line(i:l),1,istart,ilen) ! find next substring
istart=istart+i-1
ch=line(istart:istart)
#// skip the '=' character
if(ilen.ge.1.and.ch.eq. '=') istart=istart+1
#// exclude T and F, which might be interpreted as a valid number on some systems
if (ch.eq. 'T'.or.ch.eq. 'F') return
#// try to read number from the rest of the line
read(line(istart:l),*,err=99) z
ierr=0
result=z
# write(*,*) LINE(ISTART:L)//'=',Z
# pause
endif
return
99 ierr=-2 ! cannot read value
end
# -----------------------------------------------------------------
SUBROUTINE READ_I4(name,line,result,ierr)
# Read INTEGER*4 number from the LINE identified by NAME
# suppose format "NAME=number " or "NAME number "
# -----------------------------------------------------------------
implicit none
character*(*) line,name
integer*4 l,istart,ilen,i,iname,lname,ierr,is
integer*4 z,result
character*1 ch
ierr=-1
call BOUNDS(name,iname,lname)
if (lname.le.0) goto 99
l=len_trim(line)
is=1
10 i=index(line,name(iname:iname+lname-1))
if (i.gt.1) then
if (line(is+i-2:is+i-2).ne. ' ') then ! space delimiter must precede the name
is=is+i-1+lname ! try other occurences after this one
goto 10
endif
endif
#// identifier NAME found
if(i.gt.0) then
i=i+is-1+lname ! i=first character after NAME
#// name must be followed by = or space
if (line(i:i).ne. '='.and.line(i:i).ne. ' ') return
i=i+1
istart=1
call FINDPAR(line(i:l),1,istart,ilen) ! find next substring
istart=istart+i-1
ch=line(istart:istart)
#// skip the '=' character
if(ilen.ge.1.and.ch.eq. '=') istart=istart+1
#// try to read a number from the rest of the line
read(line(istart:l),*,err=99) z
ierr=0
result=z
endif
return
99 ierr=-2 ! cannot read value
end
# -----------------------------------------------------------------
SUBROUTINE READ_STR(name,line,result,ierr)
# Read STRING from the LINE identified by NAME
# suppose format "NAME=string"
# -----------------------------------------------------------------
implicit none
character*(*) line,name
integer*4 l,istart,ilen,i,iname,lname,ierr,lr,is
character*(*) result
character*1 ch
# write(*,*) 'READ_STR: ',TRIM(LINE)
ierr=-1
call BOUNDS(name,iname,lname)
if (lname.le.0) goto 99
l=len_trim(line)
lr=len(result)
is=1
10 i=index(line(is:l),name(iname:iname+lname-1)// '=')
# write(*,*) 'READ_STR: ',i
if (i.gt.1) then
if (line(is+i-2:is+i-2).ne. ' ') then ! space delimiter must precede the name
is=is+i-1+lname ! try other occurences after this one
goto 10
endif
endif
# write(*,*) 'READ_STR: ',IS,INAME,LNAME,TRIM(NAME)
#// identifier NAME found
if(i.gt.0) then
i=i+is-1+lname ! i=first character after NAME
#// name must be followed by = or space
# write(*,*) LINE(i:i)//'>'
if (line(i:i).ne. '='.and.line(i:i).ne. ' ') return
i=i+1
istart=1
# write(*,*) LINE(1:i-1)//'='//LINE(i:L)
call FINDPAR(line(i:l),1,istart,ilen) ! find next substring
istart=istart+i-1
ch=line(istart:istart)
#// skip the '=' character
if(ilen.gt.0.and.ch.eq. '=') istart=istart+1
if(ilen.gt.lr) ilen=lr
# write(*,*) LINE(1:i-1)//'='//LINE(ISTART:ISTART+ILEN-1)
if(ilen.gt.0) then
#// result is all after the delimiter (=)
result=line(istart:istart+ilen-1)
else
result= ' '
endif
ierr=0
endif
return
99 ierr=-2 ! cannot read value
end
# -----------------------------------------------------------------
SUBROUTINE FINDPAR(line,ipar,istart,ilen)
# Finds IPAR-th parameter found on LINE, starting from
# ISTART-th character
# returns starting position in ISTART and length in ILEN
# -----------------------------------------------------------------
implicit none
character*(*) line
integer*4 l,i1,i2,ipar,istart,ilen,k
logical*4 log1
1 format(a)
ilen=0
l=len(line)
i1=istart
i2=0
do k=1,ipar
if (i1.lt.1) i1=1
do while (i1.le.l.and.line(i1:i1).eq. ' ')
i1=i1+1
end do
log1=(i1.gt.l)
if (.not.log1) log1=(i1.eq.l.and.line(i1:i1).eq. ' ')
if (log1) then
istart=0
ilen=0
return
endif
i2=i1
do while (i2.le.l.and.line(i2:i2).ne. ' ')
i2=i2+1
end do
if (k.lt.ipar) i1=i2
enddo
ilen=i2-i1
istart=i1
end
# ---------------------------------------------------
character*(*) FUNCTION STRIP(line)
# removes initial and terminal spaces
# ---------------------------------------------------
implicit none
character*(*) line
integer*4 l,i
l=len(line)
if (l.eq.0) then
STRIP= ' '
return
endif
do while (line(l:l).eq. ' '.and.l.gt.0)
l=l-1
enddo
i=1
do while (line(i:i).eq. ' '.and.i.lt.l)
i=i+1
enddo
if (i.gt.l) then
STRIP= ' '
else
STRIP=line(i:l)
endif
end
# ---------------------------------------------------
character*(*) FUNCTION CONCAT(str1,str2)
# connects 2 strings without spaces in between
# ---------------------------------------------------
implicit none
character*(*) str1,str2
integer*4 i1,i2,j1,j2
call BOUNDS(str1,i1,j1)
call BOUNDS(str2,i2,j2)
CONCAT=str1(i1:i1+j1-1)//str2(i2:i2+j2-1)
end
# ---------------------------------------------------
SUBROUTINE BOUNDS(line,istart,ilen)
# get position of string by stripping off the surrounding spaces
# ---------------------------------------------------
implicit none
character*(*) line
integer*4 l,i,istart,ilen
l=len_trim(line)
istart=1
if (l.eq.0) then
ilen=0
else
i=1
do while (i.le.l.and.(line(i:i).eq. ' '.or.line(i:i).eq.char(0)))
i=i+1
enddo
if (i.gt.l) then
ilen=0
else
istart=i
ilen=l-i+1
endif
endif
end
# ---------------------------------------------------
SUBROUTINE STRCOMPACT(line,istart,ilen)
# remove multiplied spaces, return start (ISTART) and length (ILEN) of the resulting string
# NOTE: line is modified !
# ---------------------------------------------------
implicit none
character*(*) line
integer*4 l,i,j,istart,ilen
l=len(line)
i=1
do while (i.lt.l)
if (line(i:i+1).eq. ' ') then
do j=i+1,l-1
line(j:j)=line(j+1:j+1)
enddo
line(l:l)= ' '
l=l-1
else
i=i+1
endif
enddo
call BOUNDS(line,istart,ilen)
end
# -------------------------------------------------------------------
integer*4 FUNCTION TRUELEN(line)
# return true length of the string
# (without trailing spaces or NULL characters)
# equivalent of LEN_TRIM
# -------------------------------------------------------------------
implicit none
character*(*) line
integer*4 l
TRUELEN=0
l=len(line)
if (l.eq.0) then
TRUELEN=0
return
endif
do while (l.gt.0. and.(line(l:l).eq. ' '.or.line(l:l).eq.char(0)))
l=l-1
enddo
TRUELEN=l
end
# ---------------------------------------------------
SUBROUTINE WRITELINE(line,iu)
# writes LINE to IU without surrounding spaces
# ---------------------------------------------------
implicit none
character*(*) line
integer*4 l,is,iu
call BOUNDS(line,is,l)
1 format(a)
write(iu,1) line(is:is+l-1)
end
# ---------------------------------------------------
character*(*) FUNCTION UPCASE(line)
# converts LINE to uppercase
# ---------------------------------------------------
implicit none
character*(*) line
integer*4 l,i
l=len_trim(line)
do i=1,l
if((line(i:i).ge. 'a').and.(line(i:i).le. 'z')) then
UPCASE(i:i)=char(ichar(line(i:i))-32)
else
UPCASE(i:i)=line(i:i)
endif
enddo
end
# ---------------------------------------------------
SUBROUTINE MKUPCASE(line)
# converts LINE to uppercase, subroutine version
# ---------------------------------------------------
implicit none
character*(*) line
integer*4 l,i
l=len(line)
do i=1,l
if((line(i:i).ge. 'a').and.(line(i:i).le. 'z')) then
line(i:i)=char(ichar(line(i:i))-32)
endif
enddo
end
# ---------------------------------------------------
logical*4 FUNCTION IsNumber(line)
# true if LINE is a number
# ---------------------------------------------------
implicit none
character*(*) line
integer*4 l
real*8 rnum
l=len(line)
if (l.le.0.or.(index( 'tTfF',line(1:1)).gt.0)) goto 10
read(line(1:l),*,err=10) rnum
IsNumber=.true.
return
10 IsNumber=.false.
end
# ---------------------------------------------------
logical*4 FUNCTION IsInteger(line)
# true if LINE is an integer
# ---------------------------------------------------
implicit none
character*(*) line
integer*4 l
integer*4 inum
l=len(line)
if (l.le.0.or.(index( 'tTfF',line(1:1)).gt.0)) goto 10
read(line(1:l),*,err=10) inum
IsInteger=.true.
return
10 IsInteger=.false.
end
#---------------------------------------------------
SUBROUTINE GETLINPARG(line,arg,n,narg)
# Get numerical arguments from the line and store them in ARG
# Takes only consecutive serie of space-delimited numbers,
# stops enumerating at a non-number parameter or EOL
#---------------------------------------------------
implicit none
character*(*) line
integer*4 narg,n,ierr,is,l,i
real*8 arg(n)
logical*4 IsNumber
narg=0
do i=1,n
arg(i)=0.d0
enddo
ierr=0
is=1
do while (ierr.eq.0.and.is.lt.len(line).and.narg.lt.n) ! read parameters
call FINDPAR(line,1,is,l)
if (l.gt.0) then
if (IsNumber(line(is:is+l-1))) then
read(line(is:is+l-1),*,iostat=ierr,err=100) arg(narg+1)
narg=narg+1
is=is+l
else
ierr=1
endif
else
ierr=1
endif
100 continue
enddo
end
#-----------------------------------------------------------------
SUBROUTINE FINDSTRPAR(line,dlm,ipar,istart,ilen)
# Finds IPAR-th string parameter found on LINE
# DLM ... delimiter character
# returns starting position in ISTART and length in ILEN
# ILEN<0 ... not found
# ILEN=0 ... empty string (e.g. the 2nd item in "abc::def:qwerty:")
#-----------------------------------------------------------------
implicit none
character*(*) line
character*1 dlm
integer*4 l,i1,i2,ipar,istart,ilen,k
integer*4 TRUELEN
1 format(a)
l=TRUELEN(line)
if (l.lt.1) goto 99 ! no characters
k=1
i1=1
i2=index(line(i1:l),dlm)
if (i2.le.0) then ! no delimiter
if (ipar.gt.1) goto 99
ilen=l-i1+1
return
endif
# write(*,*) 'FINDSTRPAR: ',i1,L,i2,K,IPAR
do while (i2.gt.0.and.k.lt.ipar.and.i1+i2.le.l)
i1=i1+i2
i2=index(line(i1:l),dlm)
k=k+1
enddo
if (k.lt.ipar) goto 99 ! no IPAR-th item on the list
if (i2.le.0) then
i2=l+1-i1 ! last string does not end with DLM
else
i2=i2-1 ! item ends before next DLM
endif
# write(*,*) 'FINDSTRPAR END: ',i1,i2
istart=i1
ilen=i2
return
99 ilen=-1
end
#-----------------------------------------------------------------
SUBROUTINE FNSPLIT(line,dlm,fpath,fname,fext)
# Split the full filename (LINE) to path, name and extension
# path includes terminal delimiter, extension includes initial dot
# INPUT:
# line ... full filename
# dlm ... path delimiter
# OUTPUT:
# fpath ... path
# fname ... name
# fext ... extension
#-----------------------------------------------------------------
implicit none
character*(*) line,fpath,fname,fext
character*1 dlm
integer*4 l,i1,i2,il
integer*4 TRUELEN
i1=1
l=TRUELEN(line)
if (l.le.0) then
fpath= ' '
fname= ' '
fext= ' '
return
endif
i2=index(line(i1:l),dlm)
do while (i2.gt.0.and.l.gt.i1)
i1=i1+i2
i2=index(line(i1:l),dlm)
enddo
i1=i1-1
#// i1 points to the last path delimiter or =0
i2=index(line(i1+1:l), '.')
if (i2.gt.0) i2=i1+i2
#// i2 points to the dot or =0
#// get FEXT
if (i2.gt.0) then
il=l
il=min(il,len(fext)+i2-1)
fext=line(i2:il)
else
fext= ' '
endif
#// get FPATH
if (i1.gt.0) then
il=i1
il=min(il,len(fpath))
fpath=line(1:il)
else
fpath= ' '
endif
#// get FNAME
if (i2.le.0) i2=l+1
il=i2-i1-1
if (il.gt.0) then
il=min(il,len(fname))
fname=line(i1+1:i1+il)
else
fname= ' '
endif
end
#-----------------------------------------------------------------
SUBROUTINE FLOAT2STR(z,str)
# Converts real number into a string with as short format as possible
# path includes terminal delimiter, extension includes initial dot
# INPUT:
# Z ... real*8 number
# OUTPUT:
# STR ... output string
#-----------------------------------------------------------------
implicit none
real*8 z
character*(*) str
character*64 s
integer*4 is,il
1 format(g10.4)
2 format(i6)
3 format(f9.3)
if (z.lt.0.001.or.z.ge.10000) then
write(s,1) z
else if (1.d0*nint(z).eq.z) then
write(s,2) nint(z)
else
write(s,3) z
endif
call BOUNDS(s,is,il)
#// strip unsignificant zeros off
if (index(s, '.').gt.0.and.index(s, 'E').le.0) then
do while (s(is+il-1:is+il-1).eq. '0')
# write(*,*) S(IS+IL-1:IS+IL-1)
il=il-1
enddo
if (s(is+il-1:is+il-1).eq. '.') il=il-1
endif
str=s(is:is+il-1)
end
#-----------------------------------------------------------------
SUBROUTINE LASTSUBSTR(str,substr,ipos)
# Find last occurence of the SUBSTR in STR
# Return position in IPOS (=0 if not found)
# path includes terminal delimiter, extension includes initial dot
#-----------------------------------------------------------------
implicit none
integer*4 ipos
character*(*) str,substr
integer*4 is,ls,iss,lss,ll,i
call BOUNDS(str,is,ls)
ll=is+ls-1
call BOUNDS(substr,iss,lss)
i=1
ipos=0
if (ls.gt.0.and.lss.gt.0.and.i.gt.0.and.is.le.ll) then
i=index(str(is:ll),substr(iss:iss+lss-1))
if (i.gt.0) then
ipos=is+i-1
is=ipos+lss
endif
endif
end