Initial commit

gen/dat_xys.f

@@ -0,0 +1,125 @@
+	subroutine dat_xys
+c	------------------
+
+	external dat_xys_desc
+	external dat_xys_read
+
+	integer dtype/0/
+
+	call dat_init_desc(dtype, dat_xys_desc)
+	call dat_init_read(dtype, dat_xys_read)
+	end
+
+
+	subroutine dat_xys_desc(text, opt)
+c	----------------------------------
+
+	implicit none
+
+! arguments dat_xys_desc
+	character*(*) text  ! (out) description
+	character*(*) opt   ! (out) options description
+
+! arguments dat_xys_read
+	integer lun	! (in) logical unit number (file will be closed if successful)
+	integer forced	! 0: read only if type is sure; 1: forced read
+	integer nread	! (out) >=0: = number of points read, file closed
+	                !       -1: not correct type, file rewinded
+	                !       -2: correct type, but unreadable, file rewinded
+	external putval ! (in) subroutine to put name/value pairs.
+	                ! for numeric data:     call putval('name', value)   ! value must be real
+			! for character data:   call putval('name=text', 0.0)
+	integer nmax    ! max. number of points
+	real xx(*)	! x-values
+	real yy(*)	! y-values
+	real ss(*)	! sigma
+	real ww(*)	! weights  (original monitor)
+
+! local
+	real none
+	parameter (none=-8.7654e29)
+	real x,y,s,ymon
+	integer i,j,l,errcnt
+	character line*132
+
+
+c             type    description
+c             ----------------------------------
+	text='XYS     (x,y,sigma) table, ev. with header'
+	opt='mon: monitor'
+	return
+
+
+	entry dat_xys_read(lun, forced, nread, putval, nmax,xx,yy,ss,ww)
+!	-----------------------------------------------------------------
+
+! check 10 lines (up to 30 header lines) for containing exactly three numeric values
+
+	if (forced .eq. 0) then
+	  read(lun,'(a)', err=29, end=26) line
+	  i=1
+	  j=0
+20	  read(line, *, err=25, end=25) x,y,s
+	  read(line, *, err=25, end=21) x,y,s,s
+25	  if (j .eq. 0 .and. i .le. 30) goto 22	! header line
+	  goto 29
+21	  j=j+1	! count good line (exactly 3 numbers)
+22	  read(lun,'(a)', err=29, end=26) line
+	  i=i+1	! count line
+	  if (j .lt. 10) goto 20
+	  goto 28
+29	  nread=-1
+c	  print *,j,i,' check XYS'
+	  rewind lun
+	  return
+26	  if (j .lt. i/2) goto 29
+28	  rewind lun
+	endif
+
+	call dat_start_options
+	ymon=0
+	call dat_real_option('mon', ymon)
+	nread=0
+	errcnt=0
+	call putval('Monitor', 0.0)
+
+1	read(lun, '(a)', end=9,err=9) line
+	if (nread .ge. nmax) goto 5
+	read(line, *, err=7,end=7) x,y,s
+	nread=nread+1
+	if (s .eq. 0) then
+	  ww(nread)=1.
+	  s=1
+	else
+	  ww(nread)=1.0/abs(s)
+	endif
+	ss(nread)=s
+	yy(nread)=y
+	xx(nread)=x
+	goto 1
+
+5	errcnt=errcnt+1
+	print *,'DAT_XYS: File too long'
+	goto 9
+
+7	if (nread .gt. 0) then	! count error only if not header
+	  errcnt=errcnt+1
+	  if (errcnt .le. 10) then
+	    print *,'Error in line ',nread+1
+	  endif
+	endif
+	goto 1
+
+9	inquire(lun, name=line)
+	call sys_parse(line, l, line, '.', 0)
+	if (errcnt .gt. 0) then
+	  print '(x,a,i5,2a,a1)','DAT_XYS: ',errcnt,
+	1      ' errors during read ', line(1:max(1,l)), 7
+	endif
+	if (nread .eq. 0) then
+	  rewind lun
+	  nread=-1
+	else
+	  close(lun)
+	endif
+	end