subroutine dat_spec ! ------------------- external dat_spec_desc external dat_spec_opts external dat_spec_read integer dtype/0/ call dat_init_desc(dtype, dat_spec_desc) call dat_init_opts(dtype, dat_spec_opts) call dat_init_read(dtype, dat_spec_read) end subroutine dat_spec_desc(text) ! ------------------------------ character*(*) text ! (out) description ! type description ! ---------------------------------- text='SPEC spec data format (esrf)' end subroutine dat_spec_opts ! ------------------------ print '(x,a)' 1,'from: first dataset (default: 1)' 1,'to: last dataset (default: from)' 1,'x,y,mon: columns to be read (as number or name)' 1,'space: spaces between header items (sls:1,esrf:2)' 1,' ' 1,'err: how to calculate error:' 1,' err=s for sqrt(y), this is the default' 1,' err=c for constant value' 1,' err=p for a factor to be multiplied with y' 1,'val: value for err=c and err=p' end subroutine dat_spec_read 1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww) ! ---------------------------------------------------- implicit none 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 integer maxcol, n_nn, n_nl parameter (maxcol=64,n_nn=1024,n_nl=64) real values(maxcol) integer i, i1, i2, idx, l, m, nread0, iset, spc integer nc, ncol, mcol, xcol, ycol, ycol0 real r, ymon, errvalue integer iostat character line*1024, title*132, errtype*1 character xaxis*16, yaxis*16, monam*16, xup*16, yup*16, mup*16 character unam*16, yaxis0*16 character prefix(n_nl)*4, names(n_nn)*16 integer nidx(n_nl) integer nn, nl, ni, j read(lun, '(a)',err=100,end=100) line if (line(1:3) .ne. '#F') goto 100 read(lun, '(a)',err=100,end=100) line if (line(1:3) .ne. '#E') goto 100 read(lun, '(a)',err=100,end=100) line if (line(1:3) .ne. '#D') goto 100 read(lun, '(a)',err=100,end=100) title if (title(1:3) .ne. '#C') goto 100 call putval('Date='//line(4:), 0.0) call putval('Title='//title(4:), 0.0) !----- options ------ call dat_start_options i1=0 call dat_int_option('from', i1) i2=0 call dat_int_option('to', i2) spc=0 call dat_int_option('space', spc) if (spc .le. 0) then spc=-1 else spc=spc-1 endif if (i2 .eq. 0) then if (i1 .eq. 0) then i1=1 i2=999999 else i2=i1 endif endif call dat_get_index(idx) if (idx .ne. 0) then i1=i1+idx-1 i2=i1 endif xaxis=' ' call dat_str_option('x', xaxis) yaxis=' ' call dat_str_option('y', yaxis) monam='Monitor' call dat_str_option('mon', monam) call str_upcase(xup, xaxis) call str_upcase(yup, yaxis) call str_upcase(mup, monam) errtype='s' 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 !----- end options ------ nn=0 nl=0 !--- read parameter names --- 5 read(lun, '(a)', err=99, end=50) line if (nl .ge. n_nl) goto 9 if (line(1:3) .eq. '#UE') then ! this is not present at ESRF if (spc .lt. 0) spc = 0 ! assume SLS format (one space as separator) nl=nl+1 prefix(nl)='UH'//line(4:5) else if (line(1:2) .eq. '#O') then nl=nl+1 prefix(nl)='P'//line(3:4) else if (line(1:1) .eq. '#') then goto 5 else goto 9 endif if (spc .lt. 0) spc=1 ! of no #UE lines, ESRF format (2 spaces as sep.) nidx(nl)=nn line(len(line)-spc:)=' ' ! stopper at end i=5 6 continue do while (line(i:i) .eq. ' ') i=i+1 if (i .gt. len(line)) goto 5 enddo l=i do while (line(i:i+spc) .ne. ' ') i=i+1 enddo if (nn .lt. n_nn) then nn=nn+1 names(nn)=line(l:i) endif goto 6 9 continue nidx(nl+1)=nn m=0 nread=0 10 read(lun, '(a)', err=99, end=50) line if (line(1:3) .ne. '#S') goto 10 read(line(4:), *, err=99, end=99) iset if (iset .gt. i2) goto 50 if (iset .lt. i1) goto 10 call dat_group(2, putval) 12 read(lun, '(a)', err=99, end=99) line if (line(1:2) .eq. '#P' .or. line(1:3) .eq. '#UH') then if (line(1:2) .eq. '#P') then l=4 else l=5 endif do i=1,nl if (prefix(i) .eq. line(2:l)) then ni=nidx(i+1)-nidx(i) do j=1,ni values(j)=0 enddo read(line(l:), *, iostat=iostat) (values(j),j=1,ni) do j=1,ni call putval(names(nidx(i)+j), values(j)) enddo endif enddo endif if (line(1:3) .ne. '#N') goto 12 call dat_group(1, putval) read(line(4:), *, err=99, end=99) ncol read(lun, '(a)', err=99, end=99) line if (line(1:3) .ne. '#L') goto 99 xcol=0 mcol=0 ycol=0 ycol0=0 yaxis0=' ' i=3 line(len(line)-1:)=' ' do nc=1,ncol if (line(i:) .eq. ' ') goto 39 do while (line(i:i) .eq. ' ') i=i+1 enddo l=i 31 do while (line(i:i+spc) .ne. ' ') i=i+1 enddo call str_upcase(unam, line(l:i-1)) if (unam .eq. xup) then xcol=nc xaxis=line(l:i-1) endif if (unam .eq. yup) then ycol=nc yaxis=line(l:i-1) endif if (ycol .eq. 0 .and. ycol0 .eq. 0) then if (unam .eq. 'DETECTOR' .or. unam .eq. 'APD') then ycol0=nc yaxis0=line(l:i-1) endif endif if (unam .eq. mup) mcol=nc enddo 39 continue if (xcol .eq. 0) then read(xup, *, iostat=iostat) xcol endif if (ycol .eq. 0) then read(yup, *, iostat=iostat) ycol endif if (mcol .eq. 0) then read(mup, *, iostat=iostat) mcol endif if (xcol .eq. 0) then xcol=1 if (xaxis .ne. ' ') then call str_trim(xaxis, xaxis, l) print *,'DAT_SPEC: ',xaxis(1:l),' not found, take 1st column' endif endif if (ycol .eq. 0) then if (ycol0 .eq. 0) then print *,'DAT_SPEC: column not found: ',yaxis goto 99 endif if (yup .ne. ' ') then call str_trim(yaxis, yaxis, l) print *,'DAT_SPEC: ',yaxis(1:l),' not found, take ',yaxis0 endif ycol=ycol0 yaxis=yaxis0 endif call putval('XAxis='//xaxis,0.0) call putval('YAxis='//yaxis,0.0) l=min(maxcol,max(mcol,xcol,ycol)) nread0=nread 40 read(lun, *, err=49,end=49) (values(i),i=1,l) if (nread .ge. nmax) goto 49 nread=nread+1 if (mcol .eq. 0) then r=1 else r=values(mcol) if (ymon .eq. 0) ymon=r if (r .eq. 0) r=1 endif ww(nread)=r yy(nread)=values(ycol) xx(nread)=values(xcol) goto 40 49 m=m+1 call fit_dat_table(m, 1, nread-nread0) goto 10 50 continue if (errtype .eq. 'S') then do i=1,nread ss(i)=sqrt(max(1.0,yy(i)*errvalue)) if (ymon .gt. 0) then yy(i)=yy(i)*ymon/ww(i) ss(i)=ss(i)*ymon/ww(i) endif 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 if (ymon .gt. 0) then yy(i)=yy(i)*ymon/ww(i) ss(i)=ss(i)*ymon/ww(i) endif enddo else if (errtype .ne. 'C') then print *,'illegal option: err=',errtype endif do i=1,nread ss(i)=errvalue if (ymon .gt. 0) then yy(i)=yy(i)*ymon/ww(i) endif enddo endif call putval('Monitor', ymon) close(lun) return 99 print *,'DAT_SPEC: error during read' 98 nread=-2 rewind lun return 100 nread=-1 rewind lun end