Initial commit

gen/dat_xy.f

@@ -0,0 +1,144 @@
+	subroutine dat_xy
+c	------------------
+
+	external dat_xy_desc
+	external dat_xy_read
+
+	integer dtype/0/
+
+	call dat_init_desc(dtype, dat_xy_desc)
+	call dat_init_read(dtype, dat_xy_read)
+	end
+
+
+	subroutine dat_xy_desc(text, opt)
+c	---------------------------------
+
+	implicit none
+
+! arguments dat_xy_desc
+	character*(*) text  ! (out) description
+	character*(*) opt   ! (out) options description
+
+! arguments dat_xy_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,errvalue,ymon
+	integer i,j,l,errcnt
+	character line*132, errtype*1
+
+c             type    description
+c             ------------------------------------
+	text='XY      (x,y)-table, ev. with header'
+	opt='err: s (square root of y), c (constant), p (percentage), '
+	1//'val: value of error, mon: monitor'
+	return
+
+
+	entry dat_xy_read(lun, forced, nread, putval, nmax,xx,yy,ss,ww)
+!	----------------------------------------------------------------
+
+! check 10 lines (up to 30 header lines) for containing exactly two 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
+	  read(line, *, err=25, end=21) x,y,s
+25	  if (j .eq. 0 .and. i .le. 30) goto 22	! header line
+	  goto 29
+21	  j=j+1	! count good line (exactly 2 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
+	  rewind lun
+	  return
+26	  if (j .lt. i/2) goto 29
+28	  rewind lun
+	endif
+
+	call dat_start_options
+	errtype='c'
+	call dat_str_option('err', errtype)
+	call str_upcase(errtype, errtype)
+	errvalue=1.0
+	call dat_real_option('val', errvalue)
+	if (errvalue .le. 0.0) then
+	  print *,'value for error must be > 0'
+	  errvalue=1.0
+	endif
+	ymon=0
+	call dat_real_option('mon', ymon)
+	nread=0
+	errcnt=0
+	call putval('Monitor', ymon)
+
+1	read(lun, '(a)', end=9,err=9) line
+	if (nread .ge. nmax) goto 5
+	read(line, *, err=7,end=7) x,y
+	nread=nread+1
+	ww(nread)=1.
+	yy(nread)=y
+	xx(nread)=x
+	goto 1
+
+5	errcnt=errcnt+1
+	print *,'DAT_XY: 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	if (errtype .eq. 'S') then
+	  do i=1,nread
+	    ss(i)=sqrt(max(1.0,yy(i)*errvalue))
+	  enddo
+	else if (errtype .eq. 'P') then
+	  do i=1,nread
+	    ss(i)=yy(i)*errvalue
+	    if (ss(i) .eq. 0.0) ss(i)=1.0
+	  enddo
+	else
+	  if (errtype .ne. 'C') then
+	    print *,'illegal option: err=',errtype
+	  endif
+	  do i=1,nread
+	    ss(i)=errvalue
+	  enddo
+	endif
+	inquire(lun, name=line)
+	call sys_parse(line, l, line, '.', 0)
+	if (errcnt .gt. 0) then
+	  print '(x,a,i5,2a,a1)','DAT_XY: ',errcnt,
+	1      ' errors during read ', line(1:max(1,l)), 7
+	endif
+	if (nread .eq. 0) then
+	  nread=-1
+	  rewind lun
+	else
+	  close(lun)
+	endif
+	end