Initial commit

gen/metaf.f

@@ -0,0 +1,180 @@
+	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