update local (619cc985) · Commits · Zolnierczuk, Piotr / DrSPINE

sources/data_types.f90

+39 −37

Original line number	Diff line number	Diff line
		@@ -455,6 +455,34 @@ module data_types
		real(kind=DBL) :: thickness !> thickness d
		integer :: numor_tra !> representative run number for the sample/bgr where it applies
		end type transmission_struct

		!!!>>mm1216 added private structure for display purposes
		!integer, parameter, private :: max_entries = 500000 !mm hier ggf besser vorhersage aud den andere paremetern (oder allocatable..)
		!integer, private :: itaus ( max_entries )
		!integer, private :: iqs ( max_entries )
		!real, private :: taus ( max_entries )
		!real, private :: qs ( max_entries )
		!real, private :: weights ( max_entries )
		!integer, private :: n_entries

		!! paz replaced the above with the following struct
		integer, parameter :: MAX_SQTINFO_ENTRIES = 512*1024
		type sqtinfo_item_struct
		integer :: itau
		integer :: iq
		real(kind=SGL) :: tau
		real(kind=SGL) :: q
		real(kind=SGL) :: weight
		end type sqtinfo_item_struct

		type sqtinfo_struct
		integer :: max_entries ! current array size
		integer :: n_entries ! number of "filled" elements
		type(sqtinfo_item_struct), allocatable :: items(:)
		end type sqtinfo_struct

		! type(sqtinfo_struct) :: sqtinfo

		!
		type collection
		type(collection_item), allocatable :: tq_bin(:,:)
		@@ -476,6 +504,7 @@ module data_types
		type(transmission_struct) :: bgr_transmission !> transmission characteristics of bgr
		integer :: direct_bgr_subtracted

		type(sqtinfo_struct) :: sqtinfo !> sqt info collected stats
		end type collection


		@@ -489,34 +518,6 @@ module data_types
		!!!



		!!!>>mm1216 added private structure for display purposes
		!integer, parameter, private :: max_entries = 500000 !mm hier ggf besser vorhersage aud den andere paremetern (oder allocatable..)
		!integer, private :: itaus ( max_entries )
		!integer, private :: iqs ( max_entries )
		!real, private :: taus ( max_entries )
		!real, private :: qs ( max_entries )
		!real, private :: weights ( max_entries )
		!integer, private :: n_entries

		!! paz replaced the above with the following struct
		integer, parameter :: MAX_SQTINFO_ENTRIES = 512*1024
		type sqtinfo_item_struct
		integer :: itau
		integer :: iq
		real(kind=SGL) :: tau
		real(kind=SGL) :: q
		real(kind=SGL) :: weight
		end type sqtinfo_item_struct

		type sqtinfo_struct
		integer :: max_entries ! current array size
		integer :: n_entries ! number of "filled" elements
		type(sqtinfo_item_struct), allocatable :: items(:)
		end type sqtinfo_struct

		type(sqtinfo_struct) :: sqtinfo

		! =========================================================================================
		interface trap_div
		module procedure trap_div_dbl
		@@ -978,7 +979,7 @@ CONTAINS

		!! tau..., q... ??
		!!!>>mm1216 added private structure for display purposes
		call init_sqtinfo(sqtinfo)
		call init_sqtinfo(this%sqtinfo)
		!!!<<mm1216 added private structure for display purposes

		end subroutine init_collection_from_bins
		@@ -1239,7 +1240,7 @@ CONTAINS

		if(ps_sample%background_subtracted) sqt%direct_bgr_subtracted = sqt%direct_bgr_subtracted + 1
		!!!>> mm1216 >>
		call add_to_sqtinfo(sqtinfo, iq, it, qabs, tau, delta2)
		call add_to_sqtinfo(sqt%sqtinfo, iq, it, qabs, tau, delta2)
		!!?? proper weight must still be considered !!
		!!!<< mm1216 <<

		@@ -1893,9 +1894,10 @@ dotau: do it=it1,it2

		!!!>>mm1216 very experimental tau histogramming --> auto tau histo

		subroutine tau_histogramming(edges, mxedges, nedges, xcatch, linear)
		subroutine tau_histogramming(coll_data, edges, mxedges, nedges, xcatch, linear)
		! --------------------------------------------------------------------
		!implicit none
		type(collection), intent(in) :: coll_data
		integer , intent(in) :: mxedges ! max dim of edges
		double precision, intent(out) :: edges(mxedges) ! yields the edges
		integer , intent(out) :: nedges ! and the number of edges
		@@ -1918,29 +1920,29 @@ dotau: do it=it1,it2
		edges(1:mxedges) = 0
		nedges = 0

		if(sqtinfo%n_entries <= 0) then
		if(coll_data%sqtinfo%n_entries <= 0) then
		call msg_error('tau_histogramming', 'run collect prior to iterate histogramming!', ERROR_DATA_PROCESSING)
		return
		endif

		!! fill histogramm

		d1: do i = 1,sqtinfo%n_entries
		d1: do i = 1,coll_data%sqtinfo%n_entries

		if1: if(linear) then
		!ith = nint( hsize * abs(taus(i)/NS)/taumax )
		ith = nint( hsize * abs(sqtinfo%items(i)%tau/NS)/taumax )
		ith = nint( hsize * abs(coll_data%sqtinfo%items(i)%tau/NS)/taumax )
		ith = min ( ith , hsize+1 )
		else ! assume log scale
		!ith = nint( hsize * ( log(abs(taus(i)/NS)/taumin) / log(taumax/taumin) ) )
		ith = nint( hsize * ( log(abs(sqtinfo%items(i)%tau/NS)/taumin) / log(taumax/taumin) ) )
		ith = nint( hsize * ( log(abs(coll_data%sqtinfo%items(i)%tau/NS)/taumin) / log(taumax/taumin) ) )
		ith = min ( max(0, ith), hsize+1)
		endif if1

		!histo (ith) = histo(ith) + weights(i)
		!xhisto(ith) = xhisto(ith) + taus(i)/NS * weights(i)
		histo (ith) = histo(ith) + sqtinfo%items(i)%weight
		xhisto(ith) = xhisto(ith) + sqtinfo%items(i)%tau/NS * sqtinfo%items(i)%weight
		histo (ith) = histo(ith) + coll_data%sqtinfo%items(i)%weight
		xhisto(ith) = xhisto(ith) + coll_data%sqtinfo%items(i)%tau/NS * coll_data%sqtinfo%items(i)%weight

		enddo d1

sources/drspine.f90

+36 −13

Original line number	Diff line number	Diff line
		@@ -432,7 +432,8 @@ program drspine
		if(command('read ', &
		" read <filename(s)> [as (ref\|sample\|background\|auto)] [tfac <val>] [phase_offset <val>]"//LF//&
		" - read filename(s) and assign a role to them (default auto)"//LF//&
		" tfac <val> - set the relative transmission factor to <val>"//LF//&
		" transmission_ratio <val> - set the relative transmission factor to <val>"//LF//&
		" tfac <val> - set the relative transmission factor (short) to <val>"//LF//&
		" <val> = transmission(sample)/transmission(bgr)"//LF//&
		" phase_offset <val> - set the initial phase offset"//LF//&
		" read "//LF//&
		@@ -553,6 +554,7 @@ program drspine
		if(command('bgrsub ', &
		' bgrsub [transmission_ratio <tr>] '//LF//&
		' - subtracts background from sample directly phasepoint-wise'//LF//&
		' - if transmission_ratio is secified, it overrides the tfac value from read!'//LF//&
		' NOTE: only valid if manetics were stable and same between sample and bgr expt.!'//LF//&
		' USE prior to fit, if sample and/or bgr do not allow to fit valid phase offsets. $' )) then
		! ===============
		@@ -1048,6 +1050,7 @@ CONTAINS
		end subroutine cmd_bins

		!> helper subroutine for cmd_histo and cmd_collect
		!! FIXME: (paz) unused, obsolete function
		subroutine auto_histogramming(xbins, role)
		type(double_bin_struct), intent(inout) :: xbins
		integer, intent(in) :: role
		@@ -1059,6 +1062,7 @@ CONTAINS

		nsize = xbins%nbins
		nsize = 0
		n = 0
		do i=1, data_manager_size()
		if (is_valid_scan(data_scan(i), role=role)) then
		nsize = nsize + get_scan_struct_size(data_scan(i))
		@@ -1191,7 +1195,7 @@ CONTAINS
		call msg_debug('cmd_histo','histo: entering tau histogramming '//&
		trim(msg_fmt("('xcatch=',g12.6)", xcatch ))//' '//&
		trim(msg_fmt("('maxbins=',i0)" , maxbins)))
		call tau_histogramming(xedges, maxbins, nbins, xcatch, .not. log_scale)
		call tau_histogramming(collected_data, xedges, maxbins, nbins, xcatch, .not. log_scale)
		if (nbins<=0 .or. maxbins<nbins) return ! paz avoid empty histos
		call create_bin_struct(xbins, xedges(1:nbins))
		call msg_debug('cmd_histo', 'histo: tau(iterated): '//trim(cformat_bin_struct(xbins)))
		@@ -1271,18 +1275,24 @@ CONTAINS
		character(len=MAX_LINE_LENGTH) :: chrole
		!character(len=MAX_LINE_LENGTH) :: chgroup
		integer :: i, k
		integer :: inewtfac, inewphoff
		real(kind=DBL) :: tfac
		real(kind=DBL) :: phase_offset
		! flags and "override parameters
		integer :: itfac, iphase_offset, isample_temp, iscattering_angle
		real(kind=DBL) :: tfac, phase_offset, sample_temp, scattering_angle
		!
		logical :: fexists ! flag to check whether file exists

		call msg_info('drspine', '===> reading')
		chrole = ' '
		tfac = 1.0
		tfac = 1.0d0
		phase_offset = 0.0
		if ( parse_role_arg(chrole) < 0 ) return
		tfac = get_named_value('tfac', tfac, inewtfac)
		phase_offset = get_named_value('phase_offset', phase_offset, inewphoff)
		tfac = get_named_value('tfac', tfac, itfac)
		if(itfac <= 0) &
		tfac = get_named_value('transmission_ratio', tfac, itfac) !! synonym to be consistent with bgrsub

		phase_offset = get_named_value('phase_offset', phase_offset, iphase_offset)
		sample_temp = get_named_value('sample_temp', sample_temp, isample_temp)
		scattering_angle = get_named_value('scattering_angle', scattering_angle, iscattering_angle)

		! make sure we have all the geometry right
		call configure_instrument_geometry()
		@@ -1338,10 +1348,18 @@ CONTAINS
		!else
		! continue
		!endif
		if (inewtfac>0) &

		! FIXME: perhaps we need to come up with a less laborous scheme
		! override parameters, if set
		if (itfac>0) &
		call set_transmission_factor(data_scan(k), tfac)
		if (inewphoff>0) &
		if (iphase_offset>0) &
		call set_initial_phase_offset(data_scan(k), phase_offset)
		if (isample_temp>0) &
		call set_sample_temperature(data_scan(k), sample_temp)
		if (iscattering_angle>0) &
		call set_scattering_angle(data_scan(k), DEG2RAD(scattering_angle), instrument_parameters)
		! check data, if required
		if (len_trim(program_param%file_checkflag)>0) &
		call check_scan_data(data_scan(k), trim(program_param%file_checkflag))
		program_param%last_run = data_scan(k)%id
		@@ -1648,7 +1666,7 @@ CONTAINS
		! ===========
		implicit none
		integer :: inew
		real(kind=DBL), save :: transmission_ratio = 1d0
		real(kind=DBL) :: transmission_ratio = 0d0

		call msg_info('bgrsub', '===> direct background subtraction')

		@@ -1967,6 +1985,7 @@ CONTAINS
		call msg_info('drspine', '===> sqtmap done, figure is: sqtmap.pdf')
		!!!<< mm1216

		call collect_stats(collected_data)
		call unused( 1, 1, 1, ier)

		end subroutine cmd_collect
		@@ -3538,6 +3557,8 @@ se: if(found('close') .or. found('end')) then
		if(xmax < 10d0) xmax = 10d0
		if(xmax > 1000d0) xmax = 1000d0

		ymax = 1.05d0 !!??! !!TEST!!

		!??! xmax = max(min(xmax,1000d0), 0.1d0)
		call insert_plot_axis(comment,"$\tau$ / ns",ylabel="F(q,t)",xrange=[0d0,xmax], yrange=[0d0,ymax], more=trim(leg))

		@@ -3575,7 +3596,9 @@ ntxi: if(ntx>ntxmin) then
		call tex(trim(buf1))

		call add_plot_curdat(n= ntx, xval=tau, yval=fqt, yerrors=fqt_err,more= "only marks ")
		if( coll_data%direct_bgr_subtracted > 0 ) then !!TEST!!
		call add_plot_curdat(n= ntx, xval=tau, yval=fqt_alt , yerrors=fqt_alt_err,more= "only marks ") !!TEST!! fitting curve with simple streched exponential
		endif !!TEST!!
		a0 = fqt(1)
		if(.not. fit_a0) then
		a0 = a0_start

sources/fit_utils.f90

+2 −2

Original line number	Diff line number	Diff line
		@@ -352,7 +352,7 @@ contains
		if(refpix%status .ne. PIXEL_OK ) cycle dtypd
		if(all ( [ refpix%average%value > reduction_parameters%average_min_value,&
		refpix%fqt%value > reduction_parameters%fqt_min_value,&
		refpix%fqt%sigma2 < reduction_parameters%fqt_max_sigma] )) then
		sqrt(refpix%fqt%sigma2) < reduction_parameters%fqt_max_sigma] )) then

		eshape_lams%nbin = [datpix%tbin_1, datpix%tbin_2]
		call linextract(eshape, datpix, eshape_lams, datpix%delta_J_symm%value+dj, ssq)

sources/module_gen_makro.f90

+2 −2

Original line number	Diff line number	Diff line
		@@ -421,8 +421,8 @@ rl: do
		read(line(iq+3:itemp),*) q (iread)
		read(line(itemp+3:ilam),*) temp (iread)
		read(line(ilam+5:ilam+10),*) lambda(iread)
		sample (iread) = line(i1+7:iq)
		datum (iread) = line(ilam+14:ilam+38)
		sample (iread) = line(max(i1+7,1):min(iq,llen)) ! silenced F08 warning
		datum (iread) = line(max(ilam+14,1):min(ilam+38,llen))
		ico = min(max(index(line," >"),ilam+39),llent-1)
		icoe = min(max(index(line,"< "),ico+1),llent)
		comment(iread) = line(ico+2:icoe-1)

sources/plot_utils.f90

+5 −5

Original line number	Diff line number	Diff line
		@@ -101,7 +101,7 @@ contains
		call gr_axes(0.25D0, 10d0**nint(log10(ymax)) /5, xmin, ymin, 1, 1, 0.01D0)

		!wmax = maxval(weights(1:n_entries))
		wmax = maxval(sqtinfo%items(1:sqtinfo%n_entries)%weight)
		wmax = maxval(coll_data%sqtinfo%items(1:coll_data%sqtinfo%n_entries)%weight)

		if(Qcatch > 0d0 ) then
		dtrqs0: do iq =1, cdout%q_bin%nbins
		@@ -148,8 +148,8 @@ contains



		entries: do i = 1, sqtinfo%n_entries
		sqtitem = sqtinfo%items(i)
		entries: do i = 1, coll_data%sqtinfo%n_entries
		sqtitem = coll_data%sqtinfo%items(i)
		it = sqtitem%itau
		iq = sqtitem%iq
		tau = real(sqtitem%tau / NS, kind=SGL)
		@@ -167,8 +167,8 @@ contains
		endif

		!wmax = maxval(weights(1:n_entries), MASK=(iqs(1:n_entries)==iq))
		wmax = maxval(sqtinfo%items(1:sqtinfo%n_entries)%weight,&
		MASK=(sqtinfo%items(1:sqtinfo%n_entries)%iq==iq))
		wmax = maxval(coll_data%sqtinfo%items(1:coll_data%sqtinfo%n_entries)%weight,&
		MASK=(coll_data%sqtinfo%items(1:coll_data%sqtinfo%n_entries)%iq==iq))

		call gr_setlinewidth( sqrt( sqtitem%weight / wmax ) )
		call gr_setmarkersize( sqrt( sqtitem%weight / wmax ) )