132 lines
2.2 KiB
Fortran
132 lines
2.2 KiB
Fortran
!! string handling
|
|
!!
|
|
subroutine STR_TRIM(RETSTR, STR, RETLEN) !!
|
|
!!
|
|
!! if RETSTR=STR then RETSTR is not touched
|
|
!!
|
|
!! Arguments:
|
|
character*(*) STR, RETSTR !! in,out
|
|
integer RETLEN !! out
|
|
integer i
|
|
|
|
i=len(str)
|
|
if (str(1:1) .gt. ' ') then
|
|
10 if (str(i:i) .le. ' ') then
|
|
i=i-1
|
|
goto 10
|
|
endif
|
|
else
|
|
20 if (str(i:i) .le. ' ') then
|
|
if (i .gt. 1) then
|
|
i=i-1
|
|
goto 20
|
|
endif
|
|
endif
|
|
endif
|
|
retlen=min(len(retstr),i)
|
|
if (retstr .ne. str) then ! avoid copy to retstr if equal
|
|
retstr=str(1:i)
|
|
endif
|
|
end
|
|
|
|
!!
|
|
subroutine STR_UPCASE(RETSTR, STR) !!
|
|
!!
|
|
!! Arguments:
|
|
character STR*(*), RETSTR*(*) !! in,out
|
|
integer i, ch
|
|
|
|
retstr=str
|
|
do i=1,len(retstr)
|
|
ch=ichar(retstr(i:i))
|
|
if (ch .ge. ichar('a') .and. ch .le. ichar('z')) then
|
|
retstr(i:i)=char(ch-(ichar('a')-ichar('A')))
|
|
endif
|
|
enddo
|
|
end
|
|
|
|
!!
|
|
subroutine STR_LOWCASE(RETSTR, STR) !!
|
|
!!
|
|
!! Arguments:
|
|
character STR*(*), RETSTR*(*) !! in,out
|
|
integer i, ch
|
|
|
|
retstr=str
|
|
do i=1,len(retstr)
|
|
ch=ichar(retstr(i:i))
|
|
if (ch .ge. ichar('A') .and. ch .le. ichar('Z')) then
|
|
retstr(i:i)=char(ch+(ichar('a')-ichar('A')))
|
|
endif
|
|
enddo
|
|
end
|
|
|
|
!!
|
|
subroutine STR_APPEND(str, length, add) !!
|
|
!!
|
|
implicit none
|
|
|
|
character*(*) str, add !!
|
|
integer length !!
|
|
|
|
if (len(add)+length .gt. len(str)) then
|
|
if (length .lt. len(str)) then
|
|
str(length+1:)=add
|
|
length=len(str)
|
|
endif
|
|
else
|
|
str(length+1:length+len(add))=add
|
|
length=length+len(add)
|
|
endif
|
|
end
|
|
|
|
!!
|
|
integer function STR_CMP(str1, str2) !!
|
|
!!
|
|
!! if strings are equal: return 0
|
|
!! else return position of first different character
|
|
|
|
character str1*(*), str2*(*) !!
|
|
|
|
integer i
|
|
|
|
do i=0,min(len(str1),len(str2))-1
|
|
if (str1(i+1:i+1) .ne. str2(i+1:i+1)) then
|
|
str_cmp=i+1
|
|
return
|
|
endif
|
|
enddo
|
|
do i=len(str1),len(str2)-1
|
|
if (str2(i+1:i+1) .ne. ' ') then
|
|
str_cmp=i+1
|
|
return
|
|
endif
|
|
enddo
|
|
do i=len(str2),len(str1)-1
|
|
if (str1(i+1:i+1) .ne. ' ') then
|
|
str_cmp=i+1
|
|
return
|
|
endif
|
|
enddo
|
|
str_cmp=0
|
|
return
|
|
end
|
|
|
|
!!
|
|
subroutine STR_FIRST_NONBLANK(STR, POS) !!
|
|
!!
|
|
!! Arguments:
|
|
character*(*) STR !! in
|
|
integer POS !! out
|
|
integer i
|
|
|
|
do i=1,len(str)
|
|
if (str(i:i) .gt. ' ') then
|
|
pos=i
|
|
return
|
|
endif
|
|
enddo
|
|
pos=0
|
|
end
|
|
|