181 lines
3.2 KiB
Fortran
181 lines
3.2 KiB
Fortran
subroutine meta_put(str, value)
|
|
character str*(*)
|
|
real value
|
|
|
|
integer i
|
|
|
|
if (value .eq. 0.0) then
|
|
i=index(str,'=')
|
|
if (i .gt. 0) then
|
|
if (i .eq. 1) return
|
|
if (i .eq. len(str)) then
|
|
call meta_put_str(str(1:i-1), ' ', 0)
|
|
else
|
|
call meta_put_str(str(1:i-1), str(i+1:), 0)
|
|
endif
|
|
return
|
|
endif
|
|
endif
|
|
call meta_put_real(str, value, 0)
|
|
end
|
|
|
|
subroutine sym_put_str(name, str)
|
|
character name*(*), str*(*)
|
|
|
|
call meta_put_str(name, str, 1)
|
|
end
|
|
|
|
subroutine sym_put_real(name, value)
|
|
character name*(*)
|
|
real value
|
|
|
|
call meta_put_real(name, value, 1)
|
|
end
|
|
|
|
subroutine sym_get_str(name, l, str)
|
|
character name*(*), str*(*)
|
|
integer l
|
|
|
|
str=' '
|
|
call meta_get_str(name, str)
|
|
call str_trim(str, str, l)
|
|
end
|
|
|
|
subroutine sym_get_real(name, value)
|
|
character name*(*)
|
|
real value
|
|
|
|
call meta_get_real(name, value)
|
|
end
|
|
|
|
subroutine fit_put_str(name, str)
|
|
character name*(*), str*(*)
|
|
|
|
call meta_put_str(name, str, 1)
|
|
end
|
|
|
|
subroutine fit_put_real(name, value)
|
|
character name*(*)
|
|
real value
|
|
|
|
call meta_put_real(name, value, 1)
|
|
end
|
|
|
|
subroutine fit_get_str(name, l, str)
|
|
character name*(*), str*(*)
|
|
integer l
|
|
|
|
str=' '
|
|
call meta_get_str(name, str)
|
|
call str_trim(str, str, l)
|
|
end
|
|
|
|
subroutine fit_get_real(name, value)
|
|
character name*(*)
|
|
real value
|
|
|
|
call meta_get_real(name, value)
|
|
end
|
|
|
|
subroutine sym_list(lun, listmode, to_lev, except)
|
|
integer lun, listmode
|
|
integer to_lev
|
|
character*(*) except
|
|
|
|
integer l
|
|
external sym_out_file
|
|
integer meta_lim_level
|
|
|
|
if (listmode .gt. 0) call sym_out_lev(1)
|
|
do l=meta_lim_level(-99999),meta_lim_level(to_lev)
|
|
if (listmode .eq. 0) call sym_out_lev(l)
|
|
call meta_list(l, listmode, 0, sym_out_file, lun, except)
|
|
call meta_list(l, listmode, 1, sym_out_file, lun, except)
|
|
call sym_out_ln(lun) ! line break
|
|
enddo
|
|
end
|
|
|
|
subroutine sym_out_file(lun, line)
|
|
integer lun, lvl
|
|
character line*(*) ! empty line means evt. line break
|
|
|
|
character buf*256
|
|
integer l/0/, lev/0/
|
|
save buf, l, lev
|
|
integer ll
|
|
character ind*32/' '/
|
|
|
|
call str_trim(line, line, ll)
|
|
if (l+ll .gt. 80-lev) then
|
|
if (lev .eq. 0) then
|
|
write(lun, '(a)') buf(1:l)
|
|
else
|
|
write(lun, '(a,a)') ind(1:lev),buf(1:l)
|
|
endif
|
|
l=0
|
|
elseif (l .gt. 0) then
|
|
buf(l+1:l+2)=';'
|
|
l=l+2
|
|
endif
|
|
buf(l+1:)=line
|
|
l=l+ll
|
|
return
|
|
|
|
entry sym_out_ln(lun)
|
|
if (l .gt. 0) then
|
|
if (lev .eq. 0) then
|
|
write(lun, '(a)') buf(1:l)
|
|
else
|
|
write(lun, '(a,a)') ind(1:lev),buf(1:l)
|
|
endif
|
|
endif
|
|
l=0
|
|
return
|
|
|
|
entry sym_out_lev(lvl)
|
|
lev=lvl
|
|
end
|
|
|
|
subroutine sym_show(lev)
|
|
integer lev
|
|
|
|
call meta_set_level(lev)
|
|
end
|
|
|
|
subroutine sym_newline
|
|
entry sym_level
|
|
end
|
|
|
|
subroutine sym_read(lun, wrapper)
|
|
integer lun
|
|
external wrapper
|
|
|
|
character line*132
|
|
external meta_put
|
|
integer j, iostat
|
|
|
|
call wrapper(' ', 0.0, meta_put) ! reset
|
|
call dat_delimiters(';', '=', '''')
|
|
10 continue
|
|
read(lun, '(a)', iostat=iostat) line
|
|
if (iostat .ne. 0 .or. line .eq. ' ') return
|
|
j=0
|
|
do while (line(j+1:j+1) .eq. ' ')
|
|
j=j+1
|
|
enddo
|
|
call meta_set_level(j)
|
|
call dat_intprt(line, wrapper, meta_put)
|
|
goto 10
|
|
end
|
|
|
|
|
|
subroutine sym_purge(lev)
|
|
integer lev
|
|
|
|
call meta_purge(lev, 99999)
|
|
end
|
|
|
|
subroutine obsolete
|
|
print *,'obsolete function called'
|
|
end
|