Initial commit
This commit is contained in:
343
gen/dat_spec.f
Normal file
343
gen/dat_spec.f
Normal file
@@ -0,0 +1,343 @@
|
||||
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
|
||||
Reference in New Issue
Block a user