230 lines
6.0 KiB
Fortran
230 lines
6.0 KiB
Fortran
subroutine dat_intprt(text, putval, userarg)
|
|
|
|
!
|
|
! Interprete TEXT containing name / value parameters.
|
|
! You must call DAT_DELIMITERS(SEP, ASS, QUOTE) before in order to define
|
|
! the separator symbol SEP
|
|
! the assignment symbol ASS and
|
|
! the text quote character QUOTE.
|
|
!
|
|
! DAT_INTPRT calls the subroutine PUTVAL(NAME, VALUE, USERARG)
|
|
! for each name/value pair.
|
|
! For numeric values NAME and VALUE contain name and value.
|
|
! For textual values, the argument NAME contains a concatenation
|
|
! of name '=' and the text between the quotes. In that case, VALUE
|
|
! is guaranteed to be 0.0.
|
|
!
|
|
! There may be up to 32 numeric values per name in TEXT, separated by
|
|
! blanks or commas (comma not allowed when SEP=',').
|
|
! If more then one value per name is given, PUTVAL is called several times
|
|
!
|
|
! Example:
|
|
!
|
|
! CALL DAT_DELIMITERS(';', ':=', '"')
|
|
! TEXT='first:=3.3;second:="name";third:=10,10.5,11'
|
|
! CALL DAT_INTPRT(TEXT, PUTVAL, 0)
|
|
!
|
|
! we are using ':=' as assignment symbol
|
|
! ';' as separator
|
|
! '"' as quote character
|
|
!
|
|
! DAT_INTPRT will call PUTVAL(NAME, VALUE, 0) 5 times with the following arguments:
|
|
!
|
|
! NAME VALUE
|
|
! ------------------
|
|
! 'first' 3.3
|
|
! 'second=name' 0.0
|
|
! 'third' 10.0
|
|
! 'third' 10.5
|
|
! 'third' 11.0
|
|
!
|
|
|
|
character text*(*) ! text to interprete. must not be longer than 160-len(ASS) characters
|
|
external putval ! procedure to call for each name/value pair
|
|
external userarg ! user argument
|
|
|
|
! arguments for dat_delimiters:
|
|
character sep_symbol*(*) ! separator between subsequent name/value pairs
|
|
! must not be blank
|
|
character ass_symbol*(*) ! assignment symbol separator between name and values
|
|
! must not be blank
|
|
character quote_char*1 ! quote character (may be blank)
|
|
|
|
integer l,p,m,j,ln,i,k,q
|
|
|
|
character line*160
|
|
logical nodecpoint
|
|
|
|
integer maxarr
|
|
parameter (maxarr=32)
|
|
real arr(maxarr)
|
|
|
|
integer ls/0/, la/0/
|
|
character sep*32, ass*32, quote*1
|
|
save sep, ass, quote
|
|
|
|
if (ls .eq. 0)
|
|
1 stop 'DAT_INTPRT: DAT_DELIMITERS must be called first'
|
|
if (len(text)+max(la,ls) .gt. len(line))
|
|
1 stop 'DAT_INTPRT: text too long'
|
|
|
|
call str_trim(line, text, l)
|
|
|
|
line(l+1:l+1)='!'
|
|
l=index(line,'!')-1
|
|
if (l .le. 0) RETURN
|
|
if (line(1:l) .eq. ' ') RETURN
|
|
p=0
|
|
1 continue
|
|
line(l+1:l+la)=ass ! set stopper
|
|
|
|
! read blanks
|
|
if (p .lt. l) then
|
|
do while (line(p+1:p+1) .le. ' ')
|
|
p=p+1
|
|
enddo
|
|
endif
|
|
|
|
if (p .ge. l) RETURN
|
|
|
|
j=p
|
|
p=p+index(line(p+1:), ass(1:la))-1 ! position of assignment char.
|
|
12 i=index(line(j+1:p+1), sep(1:ls))
|
|
if (i .ne. 0) then
|
|
print *,'DAT_INTPRT: missing "',ass(1:la),'" : '
|
|
1 , line(1:j+i+ls-1)
|
|
p=j+i+ls
|
|
goto 1
|
|
endif
|
|
if (j .eq. p) then
|
|
print *,'DAT_INTPRT: missing name: ', line
|
|
line(l+1:l+ls)=sep ! set stopper
|
|
p=j+index(line(j+1:), sep(1:ls))+ls
|
|
goto 1
|
|
endif
|
|
m=p
|
|
do while (line(m:m) .le. ' ')
|
|
m=m-1
|
|
enddo
|
|
if (p .ge. l) then
|
|
print *,'DAT_INTPRT: missing "',ass(1:la),'" : ', line(1:p)
|
|
RETURN
|
|
endif
|
|
p=p+la
|
|
|
|
! read blanks
|
|
line(l+1:l+1)=quote ! stopper
|
|
if (line(p+1:l+1) .eq. ' ') then
|
|
p=l
|
|
else
|
|
do while (line(p+1:p+1) .le. ' ')
|
|
p=p+1
|
|
enddo
|
|
endif
|
|
|
|
if (quote .gt. ' ' .and. line(p+1:p+1) .eq. quote) then ! --- quoted text
|
|
|
|
p=p+1
|
|
ln=index(line(p+1:), quote)-1
|
|
if (ln .eq. 0) then
|
|
call putval(line(j+1:m)//'= ', 0.0, userarg)
|
|
else
|
|
call putval(line(j+1:m)//'='//line(p+1:p+ln), 0.0, userarg)
|
|
endif
|
|
p=p+ln
|
|
ln=index(line(p+1:),sep(1:ls))-1
|
|
if (ln .lt. 0) ln=l-p
|
|
if (line(p+1:p+ln) .ne. quote) then
|
|
print *,'DAT_INTPRT: superflous characters: ',line(1:p+ln)
|
|
endif
|
|
p=p+ln+ls
|
|
|
|
elseif (index('-.0123456789',line(p+1:p+1)) .ne. 0) then ! --- numeric
|
|
|
|
i=0
|
|
line(l+1:l+ls)=sep(1:ls) ! stopper
|
|
|
|
k=p
|
|
do while (line(k+1:k+1) .eq. ' ') ! skip blanks
|
|
k=k+1
|
|
enddo
|
|
q=p
|
|
11 continue
|
|
nodecpoint=.true.
|
|
do while (line(k+1:k+1) .ne. ' '
|
|
1 .and. line(k+1:k+1) .ne. ','
|
|
1 .and. line(k+1:k+ls) .ne. sep(1:ls))
|
|
k=k+1
|
|
enddo
|
|
do while (line(k+1:k+1) .eq. ' ') ! skip blanks
|
|
k=k+1
|
|
enddo
|
|
if (line(k+1:k+1) .eq. ',' .and.
|
|
1 line(k+1:k+ls) .ne. sep(1:ls)) then ! skip one comma
|
|
k=k+1
|
|
do while (line(k+1:k+1) .eq. ' ') ! skip blanks
|
|
k=k+1
|
|
enddo
|
|
endif
|
|
if (i .lt. maxarr) then
|
|
if (index(line(p+1:k), '.') .ne. 0) nodecpoint=.false.
|
|
read(line(p+1:k), *, err=103) arr(i+1)
|
|
endif
|
|
i=i+1
|
|
if (line(k+1:k+ls) .ne. sep(1:ls)) then
|
|
p=k
|
|
goto 11
|
|
endif
|
|
|
|
p=k+ls
|
|
|
|
if (nodecpoint) call meta_format(5003) ! set to integer format
|
|
if (i .eq. 1) then
|
|
call putval(line(j+1:m), arr(1), userarg)
|
|
else
|
|
ln=i
|
|
if (ln .gt. maxarr) goto 103
|
|
do i=1,ln
|
|
call putval(line(j+1:m), arr(i), userarg)
|
|
enddo
|
|
endif
|
|
if (nodecpoint) call meta_format(0) ! reset format
|
|
|
|
else ! --- literal
|
|
|
|
ln=index(line(p+1:),sep(1:ls))-1
|
|
if (ln .lt. 0) ln=l-p
|
|
i=p+ln
|
|
do while (line(i:i) .le. ' ') ! truncate trailing blanks
|
|
i=i-1
|
|
enddo
|
|
if (i .le. p) then
|
|
call putval(line(j+1:m)//'= ', 0.0, userarg)
|
|
else
|
|
call putval(line(j+1:m)//'='//line(p+1:i), 0.0, userarg)
|
|
endif
|
|
p=p+ln+ls
|
|
|
|
endif
|
|
goto 1
|
|
|
|
103 p=p+index(line(p+1:), sep(1:ls))-1
|
|
call str_trim(line(q+1:p), line(q+1:p), ln)
|
|
call putval(line(j+1:m)//'='//line(q+1:q+ln), 0.0, userarg)
|
|
p=p+ls
|
|
goto 1
|
|
|
|
entry dat_delimiters(sep_symbol, ass_symbol, quote_char)
|
|
|
|
quote=quote_char
|
|
call str_trim(sep, sep_symbol, ls)
|
|
call str_trim(ass, ass_symbol, la)
|
|
if (sep(1:ls) .le. ' ')
|
|
1 stop 'DAT_DELIMITERS: separator must not be blank'
|
|
if (ass(1:la) .le. ' ')
|
|
1 stop 'DAT_DELIMITERS: assignment symbol must not be blank'
|
|
if (quote .eq. sep(1:1) .or. quote .eq. ass(1:1)) then
|
|
stop 'DAT_DELIMITERS: QUOTE must be different from SEP and ASS'
|
|
endif
|
|
end
|