912 lines
26 KiB
Fortran
912 lines
26 KiB
Fortran
subroutine dat_nexus
|
|
c --------------------
|
|
|
|
external dat_nexus_desc
|
|
external dat_nexus_opts
|
|
external dat_get_datanumber ! get number on first line
|
|
external dat_nexus_read
|
|
|
|
integer dtype/0/
|
|
|
|
call dat_init_desc(dtype, dat_nexus_desc)
|
|
call dat_init_opts(dtype, dat_nexus_opts)
|
|
call dat_init_high(dtype, dat_get_datanumber)
|
|
call dat_init_read(dtype, dat_nexus_read)
|
|
end
|
|
|
|
|
|
subroutine dat_nexus_desc(text)
|
|
! -------------------------------
|
|
character*(*) text ! (out) description
|
|
|
|
! type description
|
|
! ----------------------------------
|
|
text='NEXUS NeXus data format'
|
|
end
|
|
|
|
|
|
subroutine dat_nexus_opts
|
|
! -------------------------
|
|
implicit none
|
|
character spec*16
|
|
|
|
call sys_getenv('dat_defspec', spec)
|
|
call str_upcase(spec, spec)
|
|
if (spec .ne. ' ') then
|
|
print '(x,2a/)','valid only for instrument ',spec
|
|
endif
|
|
if (spec(1:5) .eq. 'FOCUS') then
|
|
print '(x,a)'
|
|
1 ,'from,to: detector range (default: averaged over all)'
|
|
1 ,'bank: detector bank, u,b,l,m (default: m=merged)'
|
|
1 ,'axis: time or theta'
|
|
else if (spec(1:4) .eq. 'RITA') then
|
|
print '(x,a)'
|
|
1 ,'from: window number (default: middle window)'
|
|
1 ,'from,to: window range'
|
|
1 ,'axis: x-axis to be choosen'
|
|
1 ,'y: y-axis to be choosen (aux, mon)'
|
|
else if (spec(1:5) .eq. 'CAMEA') then
|
|
print '(x,a)'
|
|
1 ,'axis: x-axis to be choosen'
|
|
1 ,'y: y-axis to be choosen (0 (summed_counts), 1, 8 (segment number), tot (total_counts), mon, aux)'
|
|
else if (spec(1:5) .eq. 'TRICS') then
|
|
print '(x,a)'
|
|
1 ,'from,to: detector range'
|
|
1 ,'axis: x-axis to be choosen'
|
|
1 ,'frame: frame number (default: all frames)'
|
|
1 ,'det: detector number (default: 2)'
|
|
else if (spec(1:3) .eq. 'DMC') then
|
|
print '(x,a)'
|
|
1 ,'cal: calibration file'
|
|
1 ,'filter: threshold for spike filter (default: 4)'
|
|
else if (spec(1:4) .eq. 'HRPT') then
|
|
print '(x,a)'
|
|
1 ,'from,to: time channel range (default: averaged over all)'
|
|
1 ,'cal: calibration file'
|
|
1 ,'filter: threshold for spike filter (default: 4)'
|
|
else if (spec(1:5) .eq. 'MARS') then
|
|
print '(x,a)'
|
|
1 ,'bank: detector bank, e,i,m1,m2'
|
|
1 ,' (elastic, inelastic, mon1, mon2)'
|
|
1 ,'from,to: detector range (default: averaged over all)'
|
|
else if (spec .eq. ' ') then
|
|
print '(x,a)'
|
|
1 ,'from: first or only dataset (default: 1, RITA: middle window)'
|
|
1 ,'to: last dataset (default: max. or single)'
|
|
1 ,'bank: on FOCUS: detector bank, u,b,l,m (default: m=merged)'
|
|
1 ,'axis: x-axis to be choosen'
|
|
1 ,'frame: on TRICS: frame number (default 0)'
|
|
1 ,'det: on TRICS: detector number (default: 1)'
|
|
1 ,'cal: calibration file'
|
|
endif
|
|
print '(x,a)'
|
|
1 ,'mon: monitor for normalisation (auto, smon, pmon, bmon, time)'
|
|
end
|
|
|
|
|
|
subroutine dat_nexus_read
|
|
1 (lun, forced, nread, pv, 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 pv ! (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
|
|
include 'dat_nexus.inc'
|
|
|
|
integer i,j
|
|
character magic*4, filename*256
|
|
integer li, lc, lm
|
|
character cnt*64, mono*64, ins*64, axis2*64, signal*64
|
|
character yaxis*64
|
|
integer nsum, ngrp, nblk, xlen, nset
|
|
real totcnts, sta, stp, weight
|
|
integer from, to, lb, idet, icomp, iframe
|
|
character bank*64, buf*16
|
|
character monarray*64
|
|
integer p_weight(2), p_monarray(2)
|
|
integer istart
|
|
integer n_monarray
|
|
|
|
integer dat_comp
|
|
external dat_comp, dat_nexus_putval
|
|
|
|
|
|
if (forced .le. 0) then ! check for HDF-file
|
|
magic=' '
|
|
read(lun,'(a4)',err=9,end=9) magic
|
|
9 if (magic .ne. char(14)//char(3)//char(19)//char(1) .and.
|
|
1 magic(2:4) .ne. 'HDF') then
|
|
rewind lun
|
|
nread=-1
|
|
return
|
|
endif
|
|
endif
|
|
|
|
c assume that we can open the HDF file, even when it is opened already by Fortran
|
|
|
|
inquire(lun, name=filename)
|
|
call NXswitchReport(0)
|
|
status=NXopen(filename, NXacc_read, fileid)
|
|
|
|
if (status .ne. NX_ok) then
|
|
rewind lun
|
|
call NXswitchReport(1)
|
|
nread=-1
|
|
return
|
|
endif
|
|
lp=1
|
|
path='/'
|
|
|
|
call dat_nexus_get('/instrument')
|
|
if (type .ne. NX_char .or. status .ne. NX_OK) then
|
|
if (index(filename,'rita') .ne. 0) then
|
|
cdata = 'RITA2'
|
|
elseif (index(filename,'camea') .ne. 0) then
|
|
cdata = 'CAMEA'
|
|
else
|
|
goto 999 ! no instrument attribute
|
|
endif
|
|
endif
|
|
|
|
i=index(cdata, ' ')
|
|
j=index(cdata, ',')
|
|
if (j .eq. 0) j=len(cdata)
|
|
i=min(i,j)-1
|
|
if (i .lt. 1) goto 999 ! bad instrument attribute
|
|
|
|
call dat_group(2, pv) ! importance level 2
|
|
call pv('instrument='//cdata(1:i), 0.0)
|
|
|
|
call str_upcase(instr, cdata(1:1)) ! take the first letter as code for the instrument
|
|
|
|
call dat_start_options
|
|
from=0
|
|
to=0
|
|
bank=' '
|
|
xaxis=' '
|
|
yaxis=' '
|
|
iframe=-1
|
|
idet=2
|
|
if (instr .eq. 'F') then
|
|
call dat_int_option('from', from)
|
|
call dat_int_option('to', to)
|
|
call dat_str_option('bank', bank)
|
|
call dat_str_option('axis', xaxis)
|
|
elseif (instr .eq. 'R') then
|
|
call dat_int_option('from', from)
|
|
call dat_int_option('to', to)
|
|
call dat_str_option('axis', xaxis)
|
|
call str_lowcase(xaxis, xaxis)
|
|
call dat_str_option('y', yaxis)
|
|
call str_lowcase(yaxis, yaxis)
|
|
elseif (instr .eq. 'C') then
|
|
call dat_str_option('axis', xaxis)
|
|
call str_lowcase(xaxis, xaxis)
|
|
call dat_str_option('y', yaxis)
|
|
call str_lowcase(yaxis, yaxis)
|
|
elseif (instr .eq. 'T') then
|
|
call dat_int_option('from', from)
|
|
call dat_int_option('to', to)
|
|
call dat_int_option('det', idet)
|
|
call dat_str_option('axis', xaxis)
|
|
call dat_int_option('frame', iframe)
|
|
elseif (instr .eq. 'H') then
|
|
call dat_int_option('from', from)
|
|
call dat_int_option('to', to)
|
|
elseif (instr .eq. 'M') then
|
|
call dat_str_option('bank', bank)
|
|
call dat_int_option('from', from)
|
|
call dat_int_option('to', to)
|
|
endif
|
|
ymon=0
|
|
monitor='auto'
|
|
call dat_str_option('mon', monitor)
|
|
icomp=0
|
|
call dat_int_option('bin', icomp)
|
|
nframes=0
|
|
axis2=' '
|
|
n_monarray=0
|
|
if (yaxis .eq. ' ') yaxis='counts'
|
|
|
|
if (instr .eq. 'D') then ! dmc
|
|
call str_trim(ins, '/nxentry/dmc/', li)
|
|
! this will also match NXpsd!
|
|
call str_trim(cnt, ins(1:li)//'nxdetector/', lc)
|
|
xaxis='two_theta'
|
|
axis1=cnt(1:lc)//'two_theta'
|
|
signal=cnt(1:lc)//'counts'
|
|
else if (instr .eq. 'H') then ! hrpt
|
|
call str_trim(ins, '/nxentry/hrpt/', li)
|
|
! this will also match NXpsd!
|
|
call str_trim(cnt, ins(1:li)//'nxdetector/', lc)
|
|
xaxis='two_theta'
|
|
axis1=cnt(1:lc)//'two_theta'
|
|
signal=cnt(1:lc)//'counts'
|
|
axis2=cnt(1:lc)//'stroboscopic_time'
|
|
monarray='/nxentry/stroboscopic_monitor/data'
|
|
if (monitor .eq. 'auto' .or. monitor .eq. 'smon') then
|
|
n_monarray=-1
|
|
endif
|
|
elseif (instr .eq. 'F') then ! focus
|
|
call str_trim(ins, '/nxentry/focus/', li)
|
|
call str_trim(cnt, ins(1:li)//'counter/', lc)
|
|
if (xaxis .eq. ' ') xaxis='time'
|
|
call str_lowcase(bank, bank)
|
|
if (bank(1:1) .eq. 't') then
|
|
call str_trim(bank, ins(1:li)//'tof_monitor/', lb)
|
|
axis1=ins(1:li)//'merged/time_binning'
|
|
signal=ins(1:li)//'tof_monitor'
|
|
else
|
|
if (bank(1:1) .eq. 'u') then
|
|
call str_trim(bank,'upperbank',lb)
|
|
elseif (bank(1:1) .eq. 'l') then
|
|
call str_trim(bank,'lowerbank',lb)
|
|
elseif (bank(1:1) .eq. 'b') then
|
|
call str_trim(bank,'bank1',lb)
|
|
else
|
|
call str_trim(bank,'merged',lb)
|
|
endif
|
|
call str_trim(bank, ins(1:li)//bank(1:lb)//'/', lb)
|
|
if (xaxis .eq. 'time') then
|
|
axis1=bank(1:lb)//'time_binning'
|
|
axis2=bank(1:lb)//'theta'
|
|
else
|
|
axis2=bank(1:lb)//'time_binning'
|
|
axis1=bank(1:lb)//'theta'
|
|
endif
|
|
signal=bank(1:lb)//'counts'
|
|
endif
|
|
elseif (instr .eq. 'T') then ! trics
|
|
call str_trim(ins, '/frame0000/trics/', li)
|
|
if (iframe .ge. 0) write(ins(1:10), '(a,i4.4)') '/frame',iframe
|
|
call str_trim(cnt, ins(1:li)//'count_control/', lc)
|
|
if (xaxis .eq. ' ') xaxis='x'
|
|
if (idet .le. 0) idet=1
|
|
if (idet .gt. 3) idet=3
|
|
call str_trim(bank, ins(1:li)//'detector'//char(48+idet)//'/'
|
|
1 , lb)
|
|
if (xaxis .eq. 'x') then
|
|
axis1=bank(1:lb)//'x'
|
|
axis2=bank(1:lb)//'y'
|
|
else
|
|
axis1=bank(1:lb)//'y'
|
|
axis2=bank(1:lb)//'x'
|
|
endif
|
|
signal=bank(1:lb)//'counts'
|
|
nframes=1
|
|
elseif (instr .eq. 'C') then ! camea
|
|
call str_trim(ins, '/nxentry/CAMEA/', li)
|
|
call str_trim(cnt, ins(1:li)//'detector/', lc)
|
|
axis1=' '
|
|
if (yaxis .eq. 'aux') then
|
|
signal='/nxentry/aux_detector/data'
|
|
elseif (yaxis .eq. 'mon') then
|
|
signal='/nxentry/control/data'
|
|
elseif (yaxis .eq. 'tot') then
|
|
signal=cnt(1:lc)//'total_counts'
|
|
elseif (yaxis(2:) .eq. ' ' .and. yaxis(1:1) .ge. '0' .and. yaxis(1:1) .le. '9') then
|
|
signal='/nxentry/CAMEA/segment_'//yaxis(1:1)//'/data'
|
|
else
|
|
signal='/nxentry/data/summed_counts'
|
|
endif
|
|
call dat_nexus_get('/nxentry/data/*')
|
|
elseif (instr .eq. 'R') then ! rita
|
|
call str_trim(ins, '/nxentry/rita-2/', li)
|
|
call str_trim(cnt, ins(1:li)//'detector/', lc)
|
|
axis1=' '
|
|
if (yaxis .eq. 'aux') then
|
|
signal='/nxentry/aux_detector/data'
|
|
elseif (yaxis .eq. 'mon') then
|
|
signal='/nxentry/control/data'
|
|
else
|
|
axis2='w'
|
|
yaxis='counts'
|
|
signal=cnt(1:lc-1)//'windows/counts'
|
|
endif
|
|
if (from .gt. 0) then
|
|
if (to .lt. from) to=from
|
|
else if (from .eq. 0) then
|
|
from = 5
|
|
to = 5
|
|
endif
|
|
call dat_nexus_get('/nxentry/data/*')
|
|
elseif (instr .eq. 'M') then
|
|
call str_lowcase(bank, bank)
|
|
if (bank(1:1) .eq. 'i') then
|
|
call str_trim(ins, '/inelastic/MARS/', li)
|
|
call str_trim(cnt, ins(1:li)//'inelastic_bank/', lc)
|
|
axis1=cnt(1:lc)//'time_binning'
|
|
axis2=cnt(1:lc)//'scattering_angle'
|
|
else
|
|
call str_trim(ins, '/elastic/MARS/', li)
|
|
if (bank .eq. 'm1') then
|
|
call str_trim(cnt, '/elastic/pre_sample_monitor/', lc)
|
|
axis1=cnt(1:lc)//'time_of_flight'
|
|
else if (bank .eq. 'm2') then
|
|
call str_trim(cnt, '/elastic/after_sample_monitor/', lc)
|
|
axis1=cnt(1:lc)//'time_of_flight'
|
|
else
|
|
call str_trim(cnt, ins(1:li)//'elastic_bank/', lc)
|
|
axis1=cnt(1:lc)//'time_binning'
|
|
axis2=cnt(1:lc)//'scattering_angle'
|
|
endif
|
|
endif
|
|
signal=cnt(1:lc)//'data'
|
|
else ! any instrument
|
|
call str_trim(ins, '/nxentry/nxinstrument/', li)
|
|
call str_trim(cnt, ins(1:li)//'count_control/', lc)
|
|
axis1=' '
|
|
signal=cnt(1:lc)//'counts'
|
|
endif
|
|
call str_trim(mono, ins(1:li)//'monochromator/', lm)
|
|
|
|
call dat_group(1, pv) ! importance level 1
|
|
|
|
! the first column is a code (first letter of the instrument) saying that the item is present
|
|
! a question mark is used for optional items
|
|
|
|
call dat_nexus_r(pv,'DHFT M/owner')
|
|
call dat_nexus_r(pv,' T /nxentry/currentframenumber=frames')
|
|
call dat_nexus_r(pv,'DHFTRCM/nxentry/title=Title')
|
|
call dat_nexus_r(pv,'DHFTRCM/nxentry/start_time=Date')
|
|
call dat_nexus_r(pv,'DHF '//mono(1:lm)//'lambda')
|
|
call dat_nexus_r(pv,' T '//mono(1:lm)//'wavelength')
|
|
call dat_nexus_r(pv,'DH /nxentry/sample/sample_name=sample')
|
|
call dat_nexus_r(pv,' FTRCM/nxentry/sample/name=sample')
|
|
call dat_nexus_r(pv,' FTRCM?/nxentry/sample/temperature=Temp')
|
|
fvalue=0.0
|
|
call dat_nexus_r(
|
|
1 dat_nexus_putval,'DH ?/nxentry/sample/temperature_mean=Temp')
|
|
if (fvalue .ne. 0.0) then
|
|
call pv('Temp', fvalue)
|
|
else
|
|
call dat_nexus_r(pv
|
|
1 ,'DH TRC ?/nxentry/sample/sample_temperature=Temp')
|
|
end if
|
|
call dat_nexus_r(pv
|
|
1 ,'DH RC ?/nxentry/sample/temperature_stdDev=dTemp')
|
|
call dat_nexus_r(pv,'DHFT ?/nxentry/sample/magfield')
|
|
call dat_nexus_r(pv,' RC ?/nxentry/sample/magnetic_field')
|
|
call dat_nexus_r(pv,' T /nxentry/sample/omega=om')
|
|
call dat_nexus_r(pv,' H ?/nxentry/sample/x_translation=stx')
|
|
call dat_nexus_r(pv,' H ?/nxentry/sample/y_translation=sty')
|
|
call dat_nexus_r(pv,' H ?/nxentry/sample/sample_stick_rotation=dom')
|
|
call dat_nexus_r(pv,'DH '//cnt(1:lc)//'two_theta_start=a4')
|
|
|
|
call dat_group(2, pv) ! importance level 2
|
|
|
|
call dat_nexus_r(pv,'D F '//mono(1:lm)//'theta=a1')
|
|
call dat_nexus_r(pv,'D FT '//mono(1:lm)//'two_theta=a2')
|
|
call dat_nexus_r(pv
|
|
1 ,'DH ?/nxentry/sample/sample_table_rotation=a3')
|
|
call dat_nexus_r(pv,'DHFTRC ?/nxentry/sample/device_name')
|
|
call dat_nexus_r(pv,'D '//mono(1:lm)//'curvature=mcv')
|
|
call dat_nexus_r(pv,'D '//mono(1:lm)//'x_translation=mtx')
|
|
call dat_nexus_r(pv,'D '//mono(1:lm)//'y_translation=mty')
|
|
call dat_nexus_r(pv,'D '//mono(1:lm)//'phi=mgu')
|
|
call dat_nexus_r(pv,'D '//mono(1:lm)//'chi=mgl')
|
|
call dat_nexus_r(pv,'DH '//cnt(1:lc)//'countermode=Preset')
|
|
call dat_nexus_r(pv,' F '//cnt(1:lc)//'count_mode=Preset')
|
|
call dat_nexus_r(pv,' T '//cnt(1:lc)//'countmode=Preset')
|
|
call dat_nexus_r(pv,' RC /nxentry/control/mode=Preset')
|
|
call dat_nexus_r(pv,' RC /nxentry/control/preset=sMon')
|
|
call dat_nexus_r(pv,'DHFT ?'//cnt(1:lc)//'time')
|
|
call dat_nexus_r(pv,'DHFT '//cnt(1:lc)//'monitor=sMon')
|
|
call dat_nexus_r(pv,'DHFT '//cnt(1:lc)//'beam_monitor=bMon')
|
|
call dat_nexus_r(pv,'D '//cnt(1:lc)//'additional_monitor=aMon')
|
|
call dat_nexus_r(pv,
|
|
1 ' H '//cnt(1:lc)//'radial_collimator_status=radcolstat')
|
|
call dat_nexus_r(pv,
|
|
1 ' H '//cnt(1:lc)//'radial_collimator_type=radcol')
|
|
call dat_nexus_r(pv,'DH '//cnt(1:lc)//'proton_monitor=pMon')
|
|
call dat_nexus_r(pv,'DH /nxentry/sample/sample_mur=muR')
|
|
call dat_nexus_r(pv,' T /nxentry/sample/chi')
|
|
call dat_nexus_r(pv,' T /nxentry/sample/phi')
|
|
call dat_nexus_r(pv,
|
|
1 ' H /nxentry/sample/sample_changer_position=chpos')
|
|
call dat_nexus_r(pv,
|
|
1 ' H /nxentry/sample/sample_rotation_state=sarot')
|
|
call dat_nexus_r(pv,' T '//ins(1:li)//'detector2/two_theta=stt')
|
|
call dat_nexus_r(pv,' T ?'//ins(1:li)//'detector1/tilt=dg1')
|
|
call dat_nexus_r(pv,' T ?'//ins(1:li)//'detector2/tilt=dg2')
|
|
call dat_nexus_r(pv,' T ?'//ins(1:li)//'detector3/tilt=dg3')
|
|
call dat_nexus_r(pv,' F /nxentry/end_time')
|
|
call dat_nexus_r(pv
|
|
1 ,' H '//ins(1:li)//'Kollimator1/kollimator1=cex1')
|
|
call dat_nexus_r(pv
|
|
1 ,' H '//ins(1:li)//'Kollimator1/kollimator2=cex2')
|
|
call dat_nexus_r(pv
|
|
1 ,' H '//ins(1:li)//'exit_slit/width=d1w')
|
|
call dat_nexus_r(pv
|
|
1 ,' H ?'//ins(1:li)//'beam_reduction/bottom=brbo')
|
|
call dat_nexus_r(pv
|
|
1 ,' H ?'//ins(1:li)//'beam_reduction/left=brle')
|
|
call dat_nexus_r(pv
|
|
1 ,' H ?'//ins(1:li)//'beam_reduction/right=brri')
|
|
call dat_nexus_r(pv
|
|
1 ,' H ?'//ins(1:li)//'beam_reduction/top=brto')
|
|
call dat_nexus_r(pv,' H '//mono(1:lm)//'curvature_lower=mcvl')
|
|
call dat_nexus_r(pv,' H '//mono(1:lm)//'curvature_upper=mcvu')
|
|
call dat_nexus_r(pv,' H '//mono(1:lm)//'lift=mexz')
|
|
call dat_nexus_r(pv,' H '//mono(1:lm)//'omega_lower=moml')
|
|
call dat_nexus_r(pv,' H '//mono(1:lm)//'omega_upper=momu')
|
|
call dat_nexus_r(pv,' H '//mono(1:lm)//'vertical_tilt_upper=mgvu')
|
|
call dat_nexus_r(pv,' H '//mono(1:lm)//'paralell_tilt_upper=mgpu')
|
|
|
|
call dat_group(3, pv) ! importance level 3
|
|
call pv('Xaxis='//xaxis, 0.0)
|
|
call pv('Yaxis='//yaxis, 0.0)
|
|
|
|
if (axis1 .ne. ' ') then
|
|
call dat_nexus_get(axis1)
|
|
if (status .ne. NX_ok) then
|
|
print *,'axis ',axis1,' not found'
|
|
xlen=0
|
|
else
|
|
xlen=min(nmax,length)
|
|
if (icomp .gt. 1) then
|
|
stp=icomp
|
|
if (stp .lt. 1) stp = 1
|
|
xlen=dat_comp(0,0, p_array, xlen, 1, 1, 0.0
|
|
1 , stp, xlen/icomp,0)
|
|
call dat_copy2f(p_array, xx, xlen, 1)
|
|
do i=1,xlen
|
|
xx(i)=xx(i)/icomp
|
|
enddo
|
|
else
|
|
if (rank .eq. 2) then ! for rita: take 'from' window
|
|
if (sdate .gt. '2006-12-20') then ! new rita
|
|
if (from .ge. dim(1)) then
|
|
istart = 4
|
|
else
|
|
istart = (from - 1)
|
|
endif
|
|
xlen = dim(2)
|
|
call dat_extract(p_array, istart, dim(1), xx, xlen, 1)
|
|
else
|
|
if (from .ge. dim(2)) from = dim(2)
|
|
istart = dim(1) * (from - 1)
|
|
xlen = dim(1)
|
|
call dat_extract(p_array, istart, 1, xx, xlen, 1)
|
|
endif
|
|
else if (rank .eq. 1) then
|
|
call dat_copy2f(p_array, xx, xlen, 1)
|
|
else
|
|
xx(1)=0
|
|
endif
|
|
endif
|
|
endif
|
|
else
|
|
xlen=0
|
|
endif
|
|
nread=0
|
|
nset=0
|
|
70 if (n_monarray .ne. 0) then
|
|
call dat_nexus_get(monarray)
|
|
if (status .eq. NX_ok) then ! monitor array present
|
|
p_monarray(1)=p_array(1)
|
|
p_monarray(2)=p_array(2)
|
|
if (rank .eq. 1) then
|
|
n_monarray=dim(1)
|
|
else
|
|
print *,'illegal stroboscopic monitor dimension'
|
|
n_monarray=0
|
|
endif
|
|
endif
|
|
endif
|
|
call dat_nexus_get(signal)
|
|
if (status .ne. NX_ok) then
|
|
if (instr .eq. 'R') then
|
|
call dat_nexus_get('/nxentry/data/summed_counts')
|
|
axis2=' '
|
|
endif
|
|
if (status .ne. NX_ok) then
|
|
print *,'signal ',signal,' not found'
|
|
goto 999
|
|
endif
|
|
endif
|
|
if (rank .eq. 0) then
|
|
call dat_copy2p(p_array, fvalue)
|
|
endif
|
|
if (instr .eq. 'H') then
|
|
if (rank .ne. 2) then
|
|
axis2=' '
|
|
if (n_monarray .ne. 0) then
|
|
n_monarray=0
|
|
endif
|
|
endif
|
|
endif
|
|
if (axis2 .ne. ' ') then ! reduction axis
|
|
if (from .le. 0) then
|
|
if (to .eq. 0) to=999999
|
|
from=1
|
|
endif
|
|
if (to .lt. from) to=from
|
|
if (instr .eq. 'H' .or. xaxis .eq. 'x' .or. xaxis .eq. 'theta') then ! x on TriCS, theta on FOCUS
|
|
nsum=dim(1)
|
|
ngrp=1
|
|
nblk=dim(2)
|
|
else if (instr(1:1) .eq. 'R' .and. sdate .gt. '2006-12-20') then ! new rita
|
|
nsum=dim(1)
|
|
ngrp=1
|
|
nblk=dim(2)
|
|
else ! old rita or focus
|
|
nsum=dim(2)
|
|
ngrp=dim(1)
|
|
nblk=1
|
|
endif
|
|
if (from .gt. nsum) from=nsum
|
|
if (to .gt. nsum) to=nsum
|
|
if (from .eq. to) then
|
|
write(buf, '(9x,i7)') from
|
|
else
|
|
write(buf, '(i7,a,i7)') from,'..',to
|
|
endif
|
|
i=10
|
|
do while (buf(i:i) .eq. ' ')
|
|
i=i+1
|
|
enddo
|
|
buf(10:)=buf(i:)
|
|
i=1
|
|
do while (buf(i+1:i+1) .eq. ' ')
|
|
i=i+1
|
|
enddo
|
|
call pv('Range='//buf(i:), 0.0)
|
|
sta=(from+to)*0.5-1
|
|
stp=to+1-from
|
|
length=dat_comp(2,0, p_array, nsum, ngrp, nblk
|
|
1 , sta, stp, 1, p_weight)
|
|
if (n_monarray .gt. 0) then
|
|
i=dat_comp(0,0,p_monarray, nsum, ngrp, 1
|
|
1 , sta, stp, 1, 0)
|
|
call dat_copy2f(p_monarray, weight, 1, 1)
|
|
if (ymon .ne. 0) then
|
|
weight = weight / ymon
|
|
endif
|
|
else
|
|
call dat_copy2f(p_weight, weight, 1, 1)
|
|
endif
|
|
if (icomp .gt. 1) then
|
|
stp=icomp
|
|
weight=weight*icomp
|
|
length=dat_comp(0,0, p_array, length,1,1,-0.5
|
|
1 ,stp,length/icomp,0)
|
|
endif
|
|
else
|
|
weight=1
|
|
endif
|
|
if (nset .eq. 0) then
|
|
if (xlen .eq. 0) then
|
|
xlen=length
|
|
do i=1,length
|
|
xx(nread+i)=i
|
|
enddo
|
|
endif
|
|
if (length .ne. xlen) then
|
|
print *,'xaxis and signal length do not match', length, xlen
|
|
endif
|
|
endif
|
|
length=min(length,xlen)
|
|
if (status .ne. NX_ok) then
|
|
print *,'signal ',signal,'not found'
|
|
goto 999
|
|
endif
|
|
if (length .gt. nmax) then
|
|
print *,'too large, data truncated from', length,' to',nmax
|
|
length=nmax
|
|
endif
|
|
call dat_copy2f(p_array, yy(nread+1), length, 1)
|
|
if (ymon .eq. 0) ymon=1.
|
|
totcnts=0.0
|
|
ymon=ymon*weight
|
|
do i=1,length
|
|
j=nread+i
|
|
totcnts=totcnts+yy(j)
|
|
ss(j)=sqrt(max(1.0,yy(j)))
|
|
ww(j)=ymon
|
|
enddo
|
|
if (nset .gt. 0) then
|
|
do i=1,length
|
|
xx(nread+i)=xx(i)
|
|
enddo
|
|
endif
|
|
nread=nread+length
|
|
if (nframes .gt. 0 .and. iframe .le. 0) then
|
|
nset=nset+1
|
|
write(signal(1:10), '(a,i4.4)') '/frame',nset
|
|
if (nset .lt. nframes) goto 70
|
|
call fit_dat_table(1, 1, length)
|
|
endif
|
|
call dat_group(1, pv)
|
|
call pv('Monitor', ymon)
|
|
call pv('Counts', totcnts)
|
|
i=NXclose(fileid)
|
|
close(lun)
|
|
call NXswitchReport(1)
|
|
! call nxlistreport
|
|
RETURN
|
|
|
|
999 i=NXclose(fileid)
|
|
nread=-2
|
|
call NXswitchReport(1)
|
|
! call nxlistreport
|
|
end
|
|
|
|
|
|
subroutine dat_nexus_get(datapath)
|
|
|
|
include 'dat_nexus.inc'
|
|
|
|
character datapath*(*)
|
|
|
|
character attr*64, nam*64, clss*64, low*64
|
|
integer i, j, atype, l
|
|
logical isdet
|
|
integer start0(32)/32*0/
|
|
real*8 dvalue
|
|
|
|
logical end_of_path
|
|
byte idata(257)
|
|
|
|
integer dat_nexus_getslab
|
|
|
|
if (datapath(1:1) .ne. '/') then
|
|
status=NX_error
|
|
RETURN
|
|
endif
|
|
do while (path(1:lp) .ne. datapath(1:min(lp,len(datapath))))
|
|
! go up in path
|
|
status=NXclosegroup(fileid)
|
|
lp=lp-1
|
|
do while (path(lp:lp) .ne. '/')
|
|
lp=lp-1
|
|
if (lp .lt. 1) then
|
|
lp=1
|
|
path='/'
|
|
status=NX_error
|
|
RETURN
|
|
endif
|
|
enddo
|
|
enddo
|
|
|
|
end_of_path=.false.
|
|
10 continue ! loop
|
|
i=index(datapath(lp+1:), '/')-1
|
|
if (i .lt. 0) then
|
|
if (lp .eq. 1) then ! get global attribute
|
|
! assume global attributes are all of type char
|
|
type=NX_char
|
|
length=len(cdata)
|
|
axis_signal=0
|
|
units=' '
|
|
name=datapath(2:)
|
|
status=NXgetattr(fileid, name, idata, length, type)
|
|
if (status .ne. NX_ok) RETURN
|
|
type=NX_char
|
|
call replace_string(cdata, idata)
|
|
if (length .le. 0) then
|
|
cdata=' '
|
|
length=1
|
|
endif
|
|
call str_trim(cdata, cdata(1:length), length)
|
|
RETURN
|
|
endif
|
|
call str_trim(datapath(lp+1:), datapath(lp+1:), i)
|
|
end_of_path=.true.
|
|
endif
|
|
call str_lowcase(low, datapath(lp+1:lp+i))
|
|
isdet = low .eq. 'nxdetector'
|
|
status=NXinitgroupdir(fileid)
|
|
if (status .ne. NX_ok) RETURN
|
|
11 status=NXgetnextentry(fileid, name, class, type)
|
|
do while (status .eq. NX_ok)
|
|
call str_lowcase(nam, name)
|
|
call str_lowcase(clss, class)
|
|
if (nam .eq. low .or. clss .eq. low) goto 12
|
|
if (isdet .and. clss .eq. 'nxpsd') goto 12
|
|
if (low .eq. '*') then
|
|
if (nam .eq. xaxis) then
|
|
axis1=datapath(1:lp)//name
|
|
xaxis=name
|
|
else
|
|
status=NXopendata(fileid, name)
|
|
l=2
|
|
atype=NX_char
|
|
attr='axis'
|
|
status=NXgetattr(fileid, attr, axis_signal, l, atype)
|
|
if (status .eq. NX_ok
|
|
1 .and. axis_signal .eq. ichar('1')
|
|
1 .and. xaxis .eq. ' ') then
|
|
axis1=datapath(1:lp)//name
|
|
xaxis=name
|
|
endif
|
|
endif
|
|
endif
|
|
status=NXgetnextentry(fileid, name, class, type)
|
|
enddo
|
|
RETURN ! not found
|
|
12 continue ! go down in path
|
|
if (end_of_path) goto 19
|
|
if (class .eq. 'SDS') goto 11 ! skip SDS when looking for groups
|
|
status=NXopengroup(fileid, name, class)
|
|
if (status .ne. NX_ok) RETURN
|
|
i=i+1
|
|
low(i:i)='/'
|
|
path(lp+1:)=low(1:i)
|
|
lp=lp+i
|
|
status=NXinitgroupdir(fileid)
|
|
i=index(datapath(lp+1:), '/')
|
|
goto 10
|
|
19 continue ! open data
|
|
status=NXopendata(fileid, name)
|
|
if (status .ne. NX_ok) RETURN ! not found
|
|
status=NXgetinfo(fileid, rank, dim, type)
|
|
if (status .ne. NX_ok) goto 9
|
|
if (rank .gt. 16) status=NX_error
|
|
j=0
|
|
length=1
|
|
do i=1,rank
|
|
if (dim(i) .gt. 1) then
|
|
j=i
|
|
length=length*dim(i)
|
|
endif
|
|
enddo
|
|
rank0=rank
|
|
if (j .eq. 0) then
|
|
dim(1)=1
|
|
rank=1
|
|
else
|
|
rank=j
|
|
endif
|
|
if (rank .le. 1 .and. length .le. len(cdata) .and.
|
|
1 (type .eq. nx_char .or.
|
|
1 type .eq. nx_uint8 .or. type .eq. nx_int8)) then ! character (up to 256 chars)
|
|
type=nx_char
|
|
status=NXgetdata(fileid, idata)
|
|
if (status .ne. NX_ok) goto 9
|
|
call replace_string(cdata, idata)
|
|
call str_trim(cdata, cdata(1:length), length)
|
|
elseif (rank .eq. 0) then ! scalar data
|
|
if (type .eq. nx_int32) then
|
|
status=NXgetdata(fileid, ivalue)
|
|
if (status .ne. NX_ok) goto 9
|
|
fvalue=ivalue
|
|
elseif (type .eq. nx_float32) then
|
|
status=NXgetdata(fileid, fvalue)
|
|
if (status .ne. NX_ok) goto 9
|
|
elseif (type .eq. nx_float64) then
|
|
dvalue = 0
|
|
status=NXgetdata(fileid, dvalue)
|
|
if (status .ne. NX_ok) goto 9
|
|
fvalue = dvalue
|
|
endif
|
|
else
|
|
if (type .eq. nx_char) type=nx_uint8
|
|
status=dat_nexus_getslab(fileid, type, rank0, start0
|
|
1 , dim, p_array)
|
|
if (status .ne. NX_ok) goto 9
|
|
endif
|
|
status=NXgetnextattr(fileid, attr, l, atype)
|
|
axis_signal=0
|
|
units=' '
|
|
do while (status .ne. NX_eod)
|
|
if (status .ne. NX_ok) goto 9
|
|
if (attr .eq. 'signal') then
|
|
axis_signal=-1
|
|
else if (attr .eq. 'axis') then
|
|
l=1
|
|
status=NXgetattr(fileid, attr, axis_signal, l, atype)
|
|
else if (attr .eq. 'units') then
|
|
l=len(units)
|
|
status=NXgetattr(fileid, attr, idata, l, atype)
|
|
call replace_string(cdata, idata)
|
|
endif
|
|
status=NXgetnextattr(fileid, attr, l, atype)
|
|
enddo
|
|
status=NXclosedata(fileid)
|
|
RETURN
|
|
|
|
9 i=NXclosedata(fileid)
|
|
end
|
|
|
|
|
|
|
|
subroutine dat_nexus_r(pv, desc)
|
|
|
|
include 'dat_nexus.inc'
|
|
|
|
external pv
|
|
character desc*(*)
|
|
|
|
integer l,j,i
|
|
character enam*64
|
|
|
|
i=index(desc, '/')
|
|
if (i .eq. 0) stop 'DAT_NEXUS_R: illegal descriptor'
|
|
j=index(desc(1:i), instr)
|
|
if (j .eq. 0) RETURN
|
|
l=index(desc(i:), '=')
|
|
if (l .eq. 0) then
|
|
call str_trim(desc, desc, l)
|
|
j=l
|
|
do while (desc(j:j) .ne. '/')
|
|
j=j-1
|
|
enddo
|
|
enam=desc(j+1:l)
|
|
else
|
|
enam=desc(i+l:)
|
|
l=i+l-2
|
|
endif
|
|
call dat_nexus_get(desc(i:l))
|
|
if (status .ne. NX_ok) then
|
|
! optional items are marked with a question mark
|
|
if (index(desc(1:i), '?') .eq. 0) then
|
|
print *,'path ',desc(i:l),' not found'
|
|
endif
|
|
else if (type .eq. nx_char) then
|
|
if (enam .eq. 'Date') then
|
|
sdate=cdata
|
|
endif
|
|
if (enam .eq. 'Preset') then
|
|
if (monitor .eq. 'auto') then
|
|
call str_lowcase(monitor, cdata)
|
|
if (monitor(1:1) .eq. 'm') then
|
|
monitor='smon'
|
|
else
|
|
monitor='time'
|
|
endif
|
|
endif
|
|
endif
|
|
call pv(enam//'='//cdata(1:length), 0.0)
|
|
else if (type .eq. nx_int32 .or. type .eq. nx_float32 .or. type .eq. nx_float64) then
|
|
if (rank .gt. 0) call dat_nexus_average
|
|
if (enam .eq. 'frames' .and. nframes .gt. 0) then
|
|
nframes=nint(fvalue)
|
|
else
|
|
call pv(enam, fvalue)
|
|
call str_lowcase(enam, enam)
|
|
if (enam .eq. monitor) then
|
|
ymon=fvalue
|
|
endif
|
|
endif
|
|
else
|
|
print *,enam,' has a strange type'
|
|
if (rank .gt. 0) then
|
|
call dat_copy2f(p_array, 0, 0, 1) ! free p_array
|
|
endif
|
|
endif
|
|
end
|
|
|
|
subroutine dat_nexus_average
|
|
|
|
include 'dat_nexus.inc'
|
|
|
|
integer l
|
|
integer dat_comp
|
|
external dat_comp
|
|
|
|
l=dat_comp(0,0,p_array,length,1,1,(length-1)*0.5,length*1.0,1,0)
|
|
call dat_copy2f(p_array, fvalue, 1, 1)
|
|
fvalue=fvalue/length
|
|
end
|
|
|
|
subroutine dat_nexus_putval(name, value)
|
|
|
|
character name*(*)
|
|
real value
|
|
end
|