!! 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 !! subroutine STR_SPLIT(STR, DELIM, START, ENDE) !! !! !! split string into sequences separated by DELIM !! for the first sequence set ENDE=0 and START=0 (or START=n for other start position n+1) !! result: end of list: ENDE=-1 !! empty sequence: START=ENDE+1 !! normal sequence: STR(START:ENDE) without delimiter !! !! if ENDE has not a legal value, nothing happens character STR*(*), DELIM*(*) !! (in) string, delimiter integer START, ENDE !! (in/out) start/end position integer i if (ende .lt. 0 .or. ende .ge. len(str) .or. start .lt. 0) then ende=-1 RETURN endif if (ende .ne. 0) start=ende+len(delim) if (start .ge. len(str)) then if (start .gt. len(str)) then ende=-1 RETURN endif i=0 else i=index(str(start+1:), delim) endif if (i .eq. 0) then ende=len(str) else ende=start+i-1 endif start=start+1 end !! subroutine STR_GET_ELEM(STR, POS, ELEM) !! !! !! reads next element ELEM from string STR(POS:). Elements are separated by !! spaces combined with one control-char (assume tab) or one comma. !! return ' ' when STR(POS:) contains only whitespace or when pos is to high !! character STR*(*) !! (in) input string character ELEM*(*) !! (out) element read integer POS !! (in/out) read position integer start 1 if (pos .gt. len(str)) then elem=' ' RETURN endif if (str(pos:pos) .eq. ' ') then pos=pos+1 goto 1 endif start=pos 2 if (str(pos:pos) .gt. ' ' .and. str(pos:pos) .ne. ',') then pos=pos+1 if (pos .le. len(str)) then goto 2 endif pos=pos-1 endif if (str(pos:pos) .eq. ',' .or. str(pos:pos) .lt. ' ') then if (start .eq. pos) then elem=str(start:pos) if (elem(1:1) .lt. ' ') elem(1:1)=' ' else elem=str(start:pos-1) endif pos=pos+1 RETURN endif elem=str(start:pos-1) if (str(pos:) .eq. ' ') then RETURN endif 3 if (str(pos:pos) .eq. ' ') then pos=pos+1 if (pos .gt. len(str)) stop 'STR_GET_ELEM: assertion failed' goto 3 endif if (str(pos:pos) .eq. ',' .or. str(pos:pos) .lt. ' ') then pos=pos+1 endif end !! subroutine STR_GET_WORD(STR, POS, WORD) !! !! !! reads next WORD from string STR(POS:). Words are separated by !! whitespace. !! return ' ' when STR(POS:) contains only whitespace or when pos is to high !! character STR*(*) !! (in) input string character WORD*(*) !! (out) element read integer POS !! (in/out) read position integer start integer i 1 if (pos .gt. len(str)) then word=' ' RETURN endif if (str(pos:pos) .le. ' ') then pos=pos+1 goto 1 endif start=pos do i=pos,len(str) if (str(i:i) .le. ' ') then pos=i word=str(start:i-1) RETURN endif enddo word=str(start:) pos=len(str)+1 RETURN end !! integer function STR_FIND_ELEM(STR, ELEM) !! !! !! find column index of element ELEM (case insensitive) !! only the first 64 chars of each element are checked !! 0 is returned when not found !! character STR*(*), ELEM*(*) character ups*64, upe*64 integer pos, idx pos=1 call str_upcase(upe, elem) idx=0 call str_get_elem(str, pos, ups) do while (ups .ne. ' ') idx=idx+1 call str_upcase(ups, ups) if (ups .eq. upe) then str_find_elem=idx RETURN endif call str_get_elem(str, pos, ups) enddo str_find_elem=0 RETURN end