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