Initial commit
This commit is contained in:
347
gen/dat_oldtas.f
Normal file
347
gen/dat_oldtas.f
Normal file
@ -0,0 +1,347 @@
|
||||
subroutine dat_oldtas
|
||||
c ---------------------
|
||||
|
||||
external dat_oldtas_desc
|
||||
external dat_oldtas_opts
|
||||
external dat_oldtas_read
|
||||
|
||||
integer dtype/0/
|
||||
|
||||
call dat_init_desc(dtype, dat_oldtas_desc)
|
||||
call dat_init_opts(dtype, dat_oldtas_opts)
|
||||
call dat_init_read(dtype, dat_oldtas_read)
|
||||
end
|
||||
|
||||
|
||||
subroutine dat_oldtas_desc(text)
|
||||
! --------------------------------
|
||||
character*(*) text ! (out) description
|
||||
|
||||
! type description
|
||||
! ----------------------------------
|
||||
text='OLDTAS old ILL TAS format (IN3)'
|
||||
end
|
||||
|
||||
|
||||
subroutine dat_oldtas_opts
|
||||
! --------------------------
|
||||
print '(x,a)'
|
||||
1,'x,y,mon: xaxis,yaxis,monitor to be choosen'
|
||||
end
|
||||
|
||||
|
||||
subroutine dat_oldtas_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
|
||||
real none
|
||||
parameter (none=-8.7654e29)
|
||||
|
||||
character line*132, preset*4, xaxis*8, yaxis*8, monam*8, col2*8
|
||||
character pnt*8
|
||||
real values(15), r, f, s, y, ymon, qhkle(4)
|
||||
integer i,j,l,mondiv,ncol,ccol,pcol,xcol
|
||||
|
||||
external dat_oldtas_val
|
||||
|
||||
! common
|
||||
real dqhkle(4)
|
||||
common/dat_oldtas_com/dqhkle
|
||||
|
||||
nread=0
|
||||
read(lun,'(a)',err=100,end=100) line
|
||||
|
||||
if (forced .le. 0) then
|
||||
if (line(1:2).ne.'IN' .or. line(39:44).ne.'A00120') goto 100
|
||||
else
|
||||
if (line(1:2).ne.'IN' .and. line(39:44).ne.'A00120') goto 100
|
||||
endif
|
||||
|
||||
xaxis=' '
|
||||
yaxis=' '
|
||||
monam=' '
|
||||
|
||||
call dat_start_options
|
||||
call dat_str_option('x', xaxis)
|
||||
call dat_str_option('y', yaxis)
|
||||
call dat_str_option('mon', monam)
|
||||
|
||||
call str_upcase(xaxis, xaxis)
|
||||
call str_upcase(yaxis, yaxis)
|
||||
call str_upcase(monam,monam)
|
||||
|
||||
call dat_group(1, putval)
|
||||
call putval('Instrument='//line(1:4),0.0)
|
||||
call putval('User='//line(11:20), 0.0)
|
||||
call putval('Date='//line(21:38), 0.0)
|
||||
|
||||
if (line(1:4) .eq. 'IN3 ' .and.
|
||||
1 (line(24:31) .eq. 'FEB-1995' .or.
|
||||
1 line(24:31) .eq. 'MAR-1995' ) ) then
|
||||
mondiv=100
|
||||
else
|
||||
mondiv=1
|
||||
endif
|
||||
call dat_delimiters(';', '=', '''')
|
||||
read(lun,'(a)',err=99,end=99) line
|
||||
if (line(32:35) .eq. 'HKLE') then
|
||||
call putval('Title='//line(20:31), 0.0)
|
||||
do i=1,4
|
||||
qhkle(i)=none
|
||||
dqhkle(i)=none
|
||||
enddo
|
||||
read(line(36:),*,err=11,end=11) qhkle, dqhkle
|
||||
11 continue
|
||||
if (qhkle(4) .ne. none) call putval('EN',qhkle(4))
|
||||
if (qhkle(3) .ne. none) then
|
||||
call putval('QH', qhkle(1))
|
||||
call putval('QK', qhkle(2))
|
||||
call putval('QL', qhkle(3))
|
||||
endif
|
||||
if (dqhkle(4) .ne. none) call putval('DEN',dqhkle(4))
|
||||
if (dqhkle(3) .ne. none) then
|
||||
call putval('DQH', dqhkle(1))
|
||||
call putval('DQK', dqhkle(2))
|
||||
call putval('DQL', dqhkle(3))
|
||||
endif
|
||||
|
||||
read(lun,*,err=99,end=99)
|
||||
call dat_group(2, putval)
|
||||
do i=1,4
|
||||
read(lun, '(a)') line
|
||||
call dat_intprt(line, dat_oldtas_val, putval)
|
||||
enddo
|
||||
else
|
||||
call putval('Title='//line(20:99), 0.0)
|
||||
read(lun,*,err=99,end=99)
|
||||
call dat_group(2, putval)
|
||||
do i=1,5
|
||||
read(lun, '(a)') line
|
||||
call dat_intprt(line, dat_oldtas_val, putval)
|
||||
enddo
|
||||
endif
|
||||
if (xaxis .eq. ' ') then
|
||||
if (dqhkle(1) .ne. 0) then
|
||||
xaxis='QH'
|
||||
elseif (dqhkle(2) .ne. 0) then
|
||||
xaxis='QK'
|
||||
elseif (dqhkle(3) .ne. 0) then
|
||||
xaxis='QL'
|
||||
elseif (dqhkle(4) .ne. 0) then
|
||||
xaxis='EN'
|
||||
endif
|
||||
endif
|
||||
|
||||
1 read(lun,'(a)',err=99,end=99) line
|
||||
if (line(1:4) .eq. '!POS') then
|
||||
read(line(5:),'(15F7.3)') values
|
||||
ccc call sym_put_array('Angles', values, 12,0)
|
||||
goto 1
|
||||
elseif (line(1:4) .eq. '!Z**') then
|
||||
read(line(5:),'(15F7.3)') values
|
||||
ccc call sym_put_array('Zeroes', values, 12,0)
|
||||
goto 1
|
||||
else
|
||||
if (line .ne. ' ') then
|
||||
call str_trim(line, line, l)
|
||||
print *,'DAT_OLDTAS: superflous text: ', line(1:l)
|
||||
goto 1
|
||||
endif
|
||||
endif
|
||||
2 continue
|
||||
call dat_group(1, putval)
|
||||
read(lun,'(a,F12.0)',err=99,end=99) preset, ymon
|
||||
preset=preset(2:3)
|
||||
if (preset .eq. 'MN') then
|
||||
preset='M1'
|
||||
ymon=ymon*mondiv
|
||||
elseif (preset .eq. 'TI') then
|
||||
preset='TIME'
|
||||
endif
|
||||
if (monam .eq. ' ') then
|
||||
monam=preset
|
||||
elseif (preset .ne. monam) then
|
||||
ymon=0
|
||||
endif
|
||||
|
||||
call putval('Preset='//preset, 0.0)
|
||||
|
||||
3 read(lun,'(a)',err=99,end=99) line
|
||||
if (line .eq. ' ') goto 3
|
||||
i=1
|
||||
line(len(line):len(line))=' '
|
||||
ncol=0
|
||||
ccol=0
|
||||
pcol=0
|
||||
xcol=0
|
||||
col2=' '
|
||||
31 do while (line(i:i) .eq. ' ')
|
||||
i=i+1
|
||||
if (i .gt. len(line)) goto 39
|
||||
enddo
|
||||
l=i
|
||||
do while (line(i:i) .ne. ' ')
|
||||
i=i+1
|
||||
enddo
|
||||
ncol=ncol+1
|
||||
if (ncol .eq. 2) col2=line(l:i)
|
||||
if (line(l:i) .eq. 'EN(MEV)') line(l:i)='EN'
|
||||
if (line(l:i) .eq. yaxis .or. yaxis .eq. ' ' .and.
|
||||
1 (line(l:i) .eq. 'CNTS' .or. line(l:i) .eq. 'D1')) ccol=ncol
|
||||
if (line(l:i) .eq. monam) pcol=ncol
|
||||
if (line(l:i) .eq. xaxis) xcol=ncol
|
||||
goto 31
|
||||
|
||||
39 if (ccol .eq. 0) then
|
||||
if (yaxis .eq. ' ') yaxis='CNTS/D1'
|
||||
print *,'no values found for ',yaxis
|
||||
goto 99
|
||||
endif
|
||||
if (pcol .eq. 0) then
|
||||
if (monam .eq. ' ') monam='Monitor'
|
||||
print *,'no values found for ',monam
|
||||
goto 99
|
||||
endif
|
||||
if (xcol .eq. 0) then
|
||||
if (xaxis .ne. ' ') then
|
||||
print *,'no values found for ',xaxis,', take ',col2
|
||||
endif
|
||||
xcol=2
|
||||
xaxis=col2
|
||||
endif
|
||||
|
||||
call putval('XAxis='//xaxis, 0.0)
|
||||
call putval('YAxis=Intensity', 0.0)
|
||||
call dat_group(1, putval)
|
||||
|
||||
l=max(xcol,pcol,ccol)
|
||||
f=1.0
|
||||
values(1)=0
|
||||
|
||||
4 read(lun,'(a8,15f8.0)',err=19,end=9) pnt, (values(j),j=2,l)
|
||||
i=0
|
||||
read(pnt, *, err=5, end=5) i ! special treatment for FLEX, where there may be stars in the first column
|
||||
5 if (i .eq. 0) then
|
||||
values(1)=values(1)+1 ! illegal value: add 1
|
||||
else
|
||||
values(1)=i
|
||||
endif
|
||||
if (nread .ge. nmax) goto 29
|
||||
y=values(ccol)
|
||||
r=values(pcol)
|
||||
if (ymon .eq. 0) then
|
||||
ymon=r
|
||||
if (r .eq. 0) r=1.
|
||||
endif
|
||||
if (r .le. 0.0) r=ymon
|
||||
f=ymon/r
|
||||
if (f .le. 0.0) f=1.0
|
||||
if (y .gt. 0) then
|
||||
s=sqrt(y) ! statistical error of detector
|
||||
else
|
||||
s=1
|
||||
endif
|
||||
nread=nread+1
|
||||
xx(nread)=values(xcol)
|
||||
yy(nread)=y*f
|
||||
ss(nread)=s*f
|
||||
ww(nread)=r
|
||||
goto 4
|
||||
|
||||
9 close(lun)
|
||||
call putval('Monitor', ymon)
|
||||
return
|
||||
|
||||
19 print *,'DAT_OLDTAS: error at point ',nread
|
||||
goto 4
|
||||
29 print *,'DAT_OLDTAS: too many points'
|
||||
goto 100
|
||||
99 print *,'DAT_OLDTAS: error during read'
|
||||
rewind lun
|
||||
nread=-2
|
||||
return
|
||||
100 nread=-1
|
||||
rewind lun
|
||||
end
|
||||
|
||||
|
||||
subroutine dat_oldtas_val(str, val, putval)
|
||||
|
||||
character*(*) str
|
||||
real val
|
||||
external putval
|
||||
|
||||
real dqhkle(4)
|
||||
common/dat_oldtas_com/dqhkle
|
||||
integer i, nq/0/, ndq/0/
|
||||
|
||||
c the names with include number sign (#) are for compatibility
|
||||
c with an intermediate version of IN3 data files,
|
||||
c where QHKL and DQHKL were stored as an array
|
||||
|
||||
if (str .eq. ' ') then ! reset
|
||||
ndq=0
|
||||
nq=0
|
||||
return
|
||||
endif
|
||||
if (val .eq. 0) then
|
||||
i=index(str, '=')
|
||||
else
|
||||
i=0
|
||||
endif
|
||||
if (i .eq. 0) then ! numeric
|
||||
if (str .eq. 'DQHKL') then
|
||||
ndq=ndq+1
|
||||
if (ndq .le. 4) dqhkle(ndq)=val
|
||||
if (ndq .eq. 1) then
|
||||
call putval('DQH', val)
|
||||
else if (ndq .eq. 2) then
|
||||
call putval('DQK', val)
|
||||
else if (ndq .eq. 3) then
|
||||
call putval('DQL', val)
|
||||
else if (ndq .eq. 4) then
|
||||
call putval('DEN', val)
|
||||
endif
|
||||
return
|
||||
endif
|
||||
if (str .eq. 'QHKL') then
|
||||
nq=nq+1
|
||||
if (nq .eq. 1) then
|
||||
call putval('QH', val)
|
||||
else if (nq .eq. 2) then
|
||||
call putval('QK', val)
|
||||
else if (nq .eq. 3) then
|
||||
call putval('QL', val)
|
||||
else if (nq .eq. 4) then
|
||||
call putval('EN', val)
|
||||
endif
|
||||
return
|
||||
endif
|
||||
if (str .eq. 'DQH') then
|
||||
dqhkle(1)=val
|
||||
elseif (str .eq. 'DQK') then
|
||||
dqhkle(2)=val
|
||||
elseif (str .eq. 'DQL') then
|
||||
dqhkle(3)=val
|
||||
elseif (str .eq. 'DEN') then
|
||||
dqhkle(4)=val
|
||||
endif
|
||||
endif
|
||||
call putval(str, val)
|
||||
end
|
||||
Reference in New Issue
Block a user