145 lines
3.5 KiB
Fortran
145 lines
3.5 KiB
Fortran
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
|