Initial commit
This commit is contained in:
229
gen/intprt.f
Normal file
229
gen/intprt.f
Normal file
@ -0,0 +1,229 @@
|
||||
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
|
||||
Reference in New Issue
Block a user