string_mod.F90

Go to the documentation of this file.

module string
  implicit none

!  integer, parameter :: * = 132

contains

!-----------------------------------------------------------------------
integer function i1_from_char(s1)
  implicit none
  character(*) :: s1

  character(10) :: n10 = '0123456789'

  i1_from_char = indx2(n10,10,s1,1)-1

  return
end function i1_from_char

!-----------------------------------------------------------------------
integer function indx2(s1,l1,s2,l2)
  implicit none
  character(*) :: s1,s2
  integer :: l1, l2
  integer :: n1, i, i2

  n1=l1-l2+1
  indx2=0
  if (n1 < 1) return

  do i=1,n1
      i2=i+l2-1
      if (s1(i:i2) == s2(1:l2)) then
          indx2=i
          return
      endif
  enddo

  return
end function indx2

!-----------------------------------------------------------------------
INTEGER FUNCTION indx1(S1,S2,L2)
  implicit none
  CHARACTER(*) :: S1,S2
  integer :: l2
  integer :: n1, i, i2

  n1=len_trim(s1)-l2+1
  indx1=0
  IF (n1 < 1) return

  DO 100 i=1,n1
      i2=i+l2-1
      IF (s1(i:i2) == s2(1:l2)) THEN
          indx1=i
          return
      ENDIF
  100 END DO

  return
END FUNCTION indx1

!-----------------------------------------------------------------------
INTEGER FUNCTION indx_cut(S1,S2,L2)
  implicit none
  CHARACTER(*) :: S1,S2
  integer :: l2

  integer :: i1, n1, i, i2, n2
  i1=indx1(s1,s2,l2)

  IF (i1 /= 0) THEN
  
      n1=len_trim(s1)-l2
      DO 100 i=i1,n1
          i2=i+l2
      !           remove the 1st occurance of S2 from S1.
          s1(i:i)=s1(i2:i2)
      100 END DO
      n2=n1+1
      DO 200 i=n2,len_trim(s1)
          s1(i:i)=' '
      200 END DO
  ENDIF

  indx_cut=i1
  return
END FUNCTION indx_cut

!-----------------------------------------------------------------------
subroutine csplit(s0,s1,s2,l0)
  implicit none
  CHARACTER(*) :: S0,S1,S2
  integer :: l0

  integer :: i2, i1

  i2=indx_cut(s1,s2,l0)
  IF (i2 == 0) return

  i1=i2-1
  CALL blank(s0,len(s0))
  s0(1:i1)=s1(1:i1)
  CALL lshft(s1,i2)

  return
end subroutine csplit
!-----------------------------------------------------------------------
subroutine lshft(string,ipt)
  implicit none
  CHARACTER(*) :: STRING
  integer :: ipt
  integer :: j, ij

  DO j=1,len(string)-ipt
      ij=ipt+j-1
      string(j:j)=string(ij:ij)
  END DO
  DO j=len(string)-ipt,len(string)
      string(j:j)=' '
  END DO
  return
end subroutine lshft

!-----------------------------------------------------------------------
subroutine ljust(string)
  implicit none
  CHARACTER(*) :: STRING
  integer :: i, j, ij

  IF (string(1:1) /= ' ') return

  DO i=2,len(string)
  
      IF (string(i:i) /= ' ') THEN
          DO j=1,133-i
              ij=i+j-1
              string(j:j)=string(ij:ij)
          END DO
          DO j=134-i,132
              string(j:j)=' '
          END DO
          return
      ENDIF
  
  END DO

  return
end subroutine ljust

!-----------------------------------------------------------------------
subroutine capit(lettrs,n)
  implicit none
  CHARACTER(*) :: LETTRS
  integer, optional :: n
  integer :: i, int, ni

  if (present(n)) then
    ni = n
  else  
    ni = len(lettrs)
  endif

  DO i=1,ni
      int=ichar(lettrs(i:i))
      IF(int >= 97 .AND. int <= 122) THEN
          int=int-32
          lettrs(i:i)=char(int)
      ENDIF
  END DO
  return
end subroutine capit

!-----------------------------------------------------------------------
LOGICAL FUNCTION ifgtrl(VALUE,LINE)
  use kinds, only : dp
  implicit none
  real(DP) :: value
  CHARACTER(*) :: LINE

  CHARACTER(len(line)) :: WORK
  CHARACTER(8) ::  FMAT
  integer :: ifldw
  real(DP) :: TVAL

!   Note that the format Fn.0 is appropriate for fields of type:
!        34   34.0  34.0e+00
!   The only difficulty would be with '34' but since we identify
!   the field width exactly, there is no problem.

  ifgtrl= .false. 
  VALUE=0.0

  work=line
  CALL ljust(work)
  ifldw=indx1(work,' ',1)-1

  IF (ifldw > 0) THEN
      WRITE(fmat,10) ifldw
      10 FORMAT('(F',i3.3,'.0)')
      READ(work,fmat,err=100,end=100) tval
      VALUE=tval
      ifgtrl= .true. 
      return
  ENDIF

  100 CONTINUE
  return
END FUNCTION ifgtrl

!-----------------------------------------------------------------------
LOGICAL FUNCTION ifgtil(IVALUE,LINE)
  use kinds, only : dp
  implicit none
  integer :: ivalue
  CHARACTER(*) :: LINE
  CHARACTER(len(line)) :: WORK
  CHARACTER(8) ::  FMAT

  integer :: ifldw
  real(DP) :: tval

  ifgtil= .false. 
  ivalue=0

  work=line
  CALL ljust(work)
  ifldw=indx1(work,' ',1)-1

  IF (ifldw > 0) THEN
      WRITE(fmat,10) ifldw
      10 FORMAT('(F',i3.3,'.0)')
      READ(work,fmat,err=100,end=100) tval
      ivalue=int(tval)
      ifgtil= .true. 
      return
  ENDIF

  100 CONTINUE
  return
END FUNCTION ifgtil

integer function ltrunc(string,l)
  implicit none
  integer :: l
  CHARACTER(L) :: STRING
  integer :: i, l1
  CHARACTER(1) :: BLNK=' '

  DO 100 i=l,1,-1
      l1=i
      IF (string(i:i) /= blnk) goto 200
  100 END DO
  l1=0
  200 CONTINUE
  ltrunc=l1
  return
end function ltrunc

!----------------------------------------------------------------------- 
subroutine cscan(sout,key,nk) 
  implicit none 
  character(*) :: sout,key 
  character(len(sout)) :: tmp_string 
  integer :: i, nk 
 
  do i=1,100000000 
      call blank(tmp_string,len(sout)) 
      read (nk,80,end=100,err=100) tmp_string 
      call chcopy(sout, tmp_string,len(sout))
  !        write (6,*) tmp_string
      if (indx1(tmp_string,key,nk) /= 0) return
  enddo
  100 continue

  80 format(a132)
  return

end subroutine cscan
!-----------------------------------------------------------------------


end module string