src/strings.f

Fortran project RESTRAX, source module src/strings.f.

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