new logger updates - big change (36fc8103) · Commits · Zolnierczuk, Piotr / DrSPINE

sources/data_manager.f90

+9 −9

Original line number	Diff line number	Diff line
		@@ -45,13 +45,13 @@ contains
		if (present(stat)) stat = istat
		allocate(data_scan(max_size), stat=istat, errmsg=cmsg)
		if (istat/=0 ) then
		call msg_error('data_manager_init', 'data_manager: '//trim(cmsg), ERROR_NO_MEMORY)
		call msg_error('data_manager_init', msg='data_manager: '//trim(cmsg), err=ERROR_NO_MEMORY)
		if (present(stat)) stat=istat
		return
		end if
		allocate(data_table(max_size), stat=istat, errmsg=cmsg)
		if (istat/=0 ) then
		call msg_error('data_manager_init', 'data_manager: '//trim(cmsg), ERROR_NO_MEMORY)
		call msg_error('data_manager_init', msg='data_manager: '//trim(cmsg), err=ERROR_NO_MEMORY)
		if (present(stat)) stat=istat
		deallocate(data_scan)
		!deallocate(data_group)
		@@ -79,13 +79,13 @@ contains
		if (present(stat)) stat = istat
		if (allocated(data_table)) deallocate(data_table, stat=istat, errmsg=cmsg)
		if (istat/=0 ) then
		call msg_error('data_manager_init', 'data_manager: '//trim(cmsg), ERROR_NO_MEMORY)
		call msg_error('data_manager_init', msg='data_manager: '//trim(cmsg), err=ERROR_NO_MEMORY)
		if (present(stat)) stat=istat
		return
		end if
		if (allocated(data_scan )) deallocate(data_scan , stat=istat, errmsg=cmsg)
		if (istat/=0 ) then
		call msg_error('data_manager_init', 'data_manager: '//trim(cmsg), ERROR_NO_MEMORY)
		call msg_error('data_manager_init', msg='data_manager: '//trim(cmsg), err=ERROR_NO_MEMORY)
		if (present(stat)) stat=istat
		return
		end if
		@@ -117,7 +117,7 @@ contains
		!
		integer :: i
		if (data_size <=0 ) then
		call msg_error('data_manager_print', 'data manager: memory not initialized', ERROR_MEMORY_INVALID)
		call msg_error('data_manager_print', msg='data manager: memory not initialized', err=ERROR_MEMORY_INVALID)
		return
		end if

		@@ -162,12 +162,12 @@ contains
		!
		iaddr = DATA_MANAGER_OK
		if (data_size <= 0 ) then
		call msg_error('data_manager_next', 'data manager: memory not initialized', ERROR_MEMORY_INVALID)
		call msg_error('data_manager_next', msg='data manager: memory not initialized', err=ERROR_MEMORY_INVALID)
		iaddr = DATA_MANAGER_NOTINIT
		return
		end if
		if (data_manager_used() >= data_size ) then
		call msg_error('data_manager_next', 'data manager: memory full', ERROR_NO_MEMORY)
		call msg_error('data_manager_next', msg='data manager: memory full', err=ERROR_NO_MEMORY)
		iaddr = DATA_MANAGER_MEMFULL
		return
		end if
		@@ -189,12 +189,12 @@ contains
		!
		isuccess = DATA_MANAGER_OK
		if (data_size <= 0 ) then
		call msg_error('data_manager_free', 'data manager: memory not initialized', ERROR_MEMORY_INVALID)
		call msg_error('data_manager_free', msg='data manager: memory not initialized', err=ERROR_MEMORY_INVALID)
		isuccess = DATA_MANAGER_NOTINIT
		return
		end if
		if ( iaddr<0 .or. data_size<iaddr) then
		call msg_error('data_manager_free', 'data manager: invalid address', ERROR_MEMORY_INVALID)
		call msg_error('data_manager_free', msg='data manager: invalid address', err=ERROR_MEMORY_INVALID)
		isuccess = DATA_MANAGER_INVADDR
		return
		end if

sources/data_types.f90

+39 −12

Original line number	Diff line number	Diff line
		@@ -530,11 +530,16 @@ module data_types
		module procedure trap_div_int
		end interface

		interface cpoint
		module procedure cpoint_format1
		module procedure cpoint_format2
		end interface

		interface cpixel
		module procedure cpixel_format1
		module procedure cpixel_format2
		end interface


		! =========================================================================================
		CONTAINS

		@@ -874,11 +879,33 @@ CONTAINS
		end function is_pixel_ok


		!
		function cpoint_format1(this, phase_point) result(cres)
		character(len=MAX_NAME_LENGTH) :: cres
		type(phase_scan_struct), intent(in) :: this
		integer, intent(in), optional :: phase_point

		write(cres,'(i0,",",i0)') this%parent%id, this%parent%point
		if (present(phase_point)) write(cres,'(a,",",i0)') trim(cres), phase_point
		end function cpoint_format1
		!
		function cpoint_format2(run, tau, phase_point) result(cres)
		character(len=MAX_NAME_LENGTH) cres
		integer, intent(in), optional :: run
		integer, intent(in), optional :: tau
		integer, intent(in), optional :: phase_point
		!
		cres = ''
		if (present(run )) write(cres,'(a,",",i0)') trim(cres), run
		if (present(tau )) write(cres,'(a,",",i0)') trim(cres), tau
		if (present(phase_point)) write(cres,'(a,",",i0)') trim(cres), phase_point
		end function cpoint_format2

		!
		function cpixel_format1(this) result(cres)
		character(len=MAX_NAME_LENGTH) :: cres
		type(phase_scan_struct), intent(in) :: this
		write(cres,'("run=",i0,",tau=",i0,",pix=",a)') this%parent%id, this%parent%point, trim(this%cpixel)
		write(cres,'(a)') trim(this%cpixel)
		end function cpixel_format1

		!>
		@@ -1084,19 +1111,19 @@ CONTAINS
		!!!<<< preliminary hint <<< !!!

		if( abs(ps_reference%J0 - ps_sample%J0)/ps_reference%J0 > matching_tolerance%J0_rel ) then
		call msg_warning('add_pix_to_sqt,'//cpixel(ps_sample),&
		"sample and reference field integral match is outside of tolerance")
		call msg_warning('add_pix_to_sqt', pixel=cpixel(ps_sample), point=cpoint(ps_sample),&
		msg="sample and reference field integral match is outside of tolerance")
		endif

		if( (abs(ps_reference%lambda_1 - ps_sample%lambda_1) > matching_tolerance%lambda_min) .or. &
		(abs(ps_reference%lambda_2 - ps_sample%lambda_2) > matching_tolerance%lambda_max) ) then
		call msg_warning('add_pix_to_sqt,'//cpixel(ps_sample),&
		"sample and reference wavelength match is outside of tolerance")
		call msg_warning('add_pix_to_sqt', pixel=cpixel(ps_sample), point=cpoint(ps_sample),&
		msg="sample and reference wavelength match is outside of tolerance")
		endif

		if( abs(ps_reference%scattering_angle_polar - ps_sample%scattering_angle_polar) > matching_tolerance%scattering_angle) then
		call msg_warning('add_pix_to_sqt,'//cpixel(ps_sample),&
		"sample and reference scattering angle match is outside of tolerance")
		call msg_warning('add_pix_to_sqt', pixel=cpixel(ps_sample), point=cpoint(ps_sample),&
		msg="sample and reference scattering angle match is outside of tolerance")
		endif

		!> @note we still have to include further exclusion criteria
		@@ -1965,7 +1992,7 @@ dotau: do it=it1,it2
		nedges = 0

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

		@@ -2042,7 +2069,7 @@ i1: if( xhisto(i) > 0 .and. histo(i) > 0) then
		nedges = nedges + 1
		if(nedges > mxedges) then
		!write(6,*)"tau_histogramming: too many edges!"
		call msg_error('tau_histogramming', 'too many edges in tau_histogramming!', ERROR_DATA_PROCESSING)
		call msg_error('tau_histogramming', msg='too many edges in tau_histogramming!', err=ERROR_DATA_PROCESSING)
		return
		endif
		edges(nedges) = cedges(ith)
		@@ -2179,7 +2206,7 @@ t1: do it=0,nt

		if(nq2 > mq) then
		write(,) "ERROR(consolidate data): nq2 > mq", nq2, mq
		call msg_fatal("consolidate_colldata", "nq2 > mq", 9999)
		call msg_fatal("consolidate_colldata", msg="nq2 > mq", err=9999)
		goto 99
		endif
		! ... and use the average q-value of it as first anchor
		@@ -2195,7 +2222,7 @@ t2: do it=0,nt
		it2 = it2+1
		if(it2 > mt) then
		write(,) "ERROR(consolidate data): it2 > mt", it2, mt
		call msg_fatal("consolidate_colldata", "it2 > mt", 9999)
		call msg_fatal("consolidate_colldata", msg="it2 > mt", err=9999)
		goto 99
		endif
		if(it2 > nt2) nt2 = it2

sources/drspine.f90

+33 −29

Original line number	Diff line number	Diff line
		@@ -358,7 +358,7 @@ program drspine
		!!> we may introduce an extraction function 'get_last_error_codes' reporting the error code accumulated in new_com either
		!!> during comand parsing/interpretation or obtained during calls of 'unused' and 'errsig'
		call unused( icmdus=2, ivnuse=2, irpuse=2, iretus=iunused)
		if(iunused .ne. 0) call msg_error('drspine', 'unknown option in last command', ERROR_OPTION_UNKNOWN)
		if(iunused .ne. 0) call msg_error('drspine', 'unknown option in last command', err=ERROR_OPTION_UNKNOWN)

		if(ierrs > 0) call close_all_macros()
		ierrs = 0
		@@ -860,7 +860,7 @@ program drspine
		getval("temperature" ,0d0 ), &
		ier)
		if(ier .ne. 0) then
		call msg_error('drspine',"directory not found in:"//trim(MXX_ECHO_DIR), ERROR_DIR_NOT_FOUND)
		call msg_error('drspine',"directory not found in:"//trim(MXX_ECHO_DIR), err=ERROR_DIR_NOT_FOUND)
		cycle commandloop
		endif

		@@ -999,7 +999,7 @@ CONTAINS
		call unused( icmdus=1, ivnuse=1, irpuse=1, iretus=iunused)
		! this is not working
		if(iunused .ne. 0) then
		call msg_error('drspine', "unknown option in command clear", ERROR_OPTION_UNKNOWN)
		call msg_error('drspine', "unknown option in command clear", err=ERROR_OPTION_UNKNOWN)
		return
		endif

		@@ -1053,11 +1053,13 @@ CONTAINS
		ibins = parse_command_flags('nbins,custom')

		if (iwhat<0) then ! error
		call msg_error('drspine', 'command bins: keywords "tof" and "pix" are mutually exclusive', ERROR_OPTION_SYNTAX)
		call msg_error('drspine', 'command bins: keywords "tof" and "pix" are mutually exclusive',&
		err=ERROR_OPTION_SYNTAX)
		return
		endif
		if (ibins<0) then ! error
		call msg_error('drspine', 'command bins: keywords "nbins" and "custom" are mutually exclusive', ERROR_OPTION_SYNTAX)
		call msg_error('drspine', 'command bins: keywords "nbins" and "custom" are mutually exclusive',&
		err=ERROR_OPTION_SYNTAX)
		return
		endif

		@@ -1081,10 +1083,10 @@ CONTAINS
		else
		call msg_error('drspine', &
		msg_fmt("('command bins: nbins must be a power of 2 in the range [1,',i0,']')",&
		MAX_NO_PIX), ERROR_OPTION_ARG)
		MAX_NO_PIX), err=ERROR_OPTION_ARG)
		end if
		else
		call msg_error('drspine', 'command bins: missing argument to nbins', ERROR_OPTION_ARG)
		call msg_error('drspine', 'command bins: missing argument to nbins', err=ERROR_OPTION_ARG)
		end if
		case (E_TOF)
		nrange = get_named_value('range ', MAX_NO_LAMBDA_BINS, inew)
		@@ -1095,16 +1097,16 @@ CONTAINS
		else
		call msg_error('drspine', &
		msg_fmt("('command bins: need a divisor of ',i0, ' or use custom binning')",&
		nrange), ERROR_OPTION_ARG)
		nrange), err=ERROR_OPTION_ARG)
		end if
		else
		call msg_error('drspine', 'command bins: missing argument to nbins', ERROR_OPTION_ARG)
		call msg_error('drspine', 'command bins: missing argument to nbins', err=ERROR_OPTION_ARG)
		end if
		end select
		case(E_CUSTOM)
		select case(iwhat)
		case (E_PIX)
		call msg_error('drspine', 'command bins: keywords "custom" is not valid for "pix"', ERROR_OPTION_SYNTAX)
		call msg_error('drspine', 'command bins: keywords "custom" is not valid for "pix"', err=ERROR_OPTION_SYNTAX)
		return
		case (E_TOF)
		nbins = iparf()
		@@ -1113,7 +1115,7 @@ CONTAINS
		if ( tedges(i)<1 .or. MAX_NO_LAMBDA_BINS<tedges(i)) then
		call msg_error('drspine', &
		msg_fmt("('command bins: TOF need a number between 1 and ',i3)",&
		MAX_NO_LAMBDA_BINS), ERROR_OPTION_ARG)
		MAX_NO_LAMBDA_BINS), err=ERROR_OPTION_ARG)
		return
		end if
		end do
		@@ -1126,7 +1128,7 @@ CONTAINS
		!!mmnc
		call unused( icmdus=0, ivnuse=2, irpuse=2, iretus=iunused)
		if(iunused .ne. 0) then
		call msg_error('drspine', "unknown option in command bins", ERROR_OPTION_UNKNOWN)
		call msg_error('drspine', "unknown option in command bins", err=ERROR_OPTION_UNKNOWN)
		return
		endif
		!!mmnc
		@@ -1222,11 +1224,13 @@ CONTAINS

		! process q/tau binning
		if (iwhat<0) then ! error both are present
		call msg_error('drspine', 'command histo: keywords "tof" and "q" are mutually exclusive', ERROR_OPTION_SYNTAX)
		call msg_error('drspine', msg='command histo: keywords "tof" and "q" are mutually exclusive',&
		err=ERROR_OPTION_SYNTAX)
		return
		endif
		if (ibins<0) then
		call msg_error('drspine', 'command histo: keywords "nbins", "custom" and "auto" are mutually exclusive', ERROR_OPTION_SYNTAX)
		call msg_error('drspine', msg='command histo: keywords "nbins", "custom" and "auto" are mutually exclusive',&
		err=ERROR_OPTION_SYNTAX)
		return
		endif

		@@ -1247,7 +1251,7 @@ CONTAINS
		case(E_Q)
		xbins = q_bins
		case default
		call msg_error('drspine', 'command histo: unknown selection', ERROR_OPTION_UNKNOWN)
		call msg_error('drspine', msg='command histo: unknown selection', err=ERROR_OPTION_UNKNOWN)
		return
		end select

		@@ -1298,7 +1302,7 @@ CONTAINS
		!!mmnc
		call unused( icmdus=0, ivnuse=2, irpuse=2, iretus=iunused)
		if(iunused .ne. 0) then
		call msg_error('drspine', "unknown option in command histo", ERROR_OPTION_UNKNOWN)
		call msg_error('drspine', msg="unknown option in command histo", err=ERROR_OPTION_UNKNOWN)
		return
		endif
		!!mmnc
		@@ -1327,7 +1331,7 @@ CONTAINS
		if ( found('positive') ) echo_sign = +1

		if (nselect < 0 ) then
		call msg_error('drspine', 'command eshape: echo shape keywords are mutually exclusive', ERROR_OPTION_SYNTAX)
		call msg_error('drspine', 'command eshape: echo shape keywords are mutually exclusive', err=ERROR_OPTION_SYNTAX)
		return
		else if (nselect==0 .and. echo_sign==0) then
		write(output_unit,'(a, i0, a)', advance='no') ' current echo shape: '//trim(cformat_eshape())//' [', eshape_get(), ']'
		@@ -1413,14 +1417,14 @@ CONTAINS
		! test if file exists
		inquire( file=filename, exist=fexists)
		if ( .not. fexists ) then
		call msg_error('drspine', 'file '//trim(filename)//' does not exist', ERROR_FILE_NOT_FOUND)
		call msg_error('drspine', 'file '//trim(filename)//' does not exist', err=ERROR_FILE_NOT_FOUND)
		exit read_loop
		end if
		! reading data
		call msg_info('drspine', '===> filename: '//trim(filename))
		call data_manager_add(k)
		if (k<=0) then
		call msg_error('drspine', 'not enough room to read data', ERROR_NO_MEMORY)
		call msg_error('drspine', 'not enough room to read data', err=ERROR_NO_MEMORY)
		exit read_loop
		end if
		call read_echo_data(data_scan(k), filename, instrument_parameters, tbins)
		@@ -1590,7 +1594,7 @@ CONTAINS

		iwhat = parse_command_flags('pix,tau,q')
		if (iwhat<0) then ! error both are present
		call msg_error('drspine', 'command mask: keywords "pix", "tau" and "q" are mutually exclusive', ERROR_OPTION_SYNTAX)
		call msg_error('drspine', 'command mask: keywords "pix", "tau" and "q" are mutually exclusive', err=ERROR_OPTION_SYNTAX)
		return
		endif

		@@ -1613,7 +1617,7 @@ CONTAINS
		call set_detector_mask(instrument_parameters%detector, 'const', ival, xmask)
		else if ( do_win ) then ! set a rectangular mask
		if (iparf()<4) then
		call msg_error('drspine/mask', 'mask win - need 4 window parameters (x1,y1,x2,y2)', ERROR_OPTION_ARG)
		call msg_error('drspine/mask', 'mask win - need 4 window parameters (x1,y1,x2,y2)', err=ERROR_OPTION_ARG)
		else
		do i=1,4
		xmask(i) = real(rparf(i), kind=SGL)
		@@ -1622,7 +1626,7 @@ CONTAINS
		end if
		else if ( do_ring ) then ! set a ring mask
		if (iparf()<4) then
		call msg_error('drspine/mask', 'mask ring - need 4 ring parameters (x0,y0,r1,r2)', ERROR_OPTION_ARG)
		call msg_error('drspine/mask', 'mask ring - need 4 ring parameters (x0,y0,r1,r2)', err=ERROR_OPTION_ARG)
		else
		do i=1,4
		xmask(i) = real(rparf(i), kind=SGL)
		@@ -1880,7 +1884,7 @@ CONTAINS
		iwhat = parse_command_flags("run,clear,show") ! comma separated, no spaces

		if (iwhat<0) then ! error
		call msg_error('drspine', 'command match: keywords force, clear and show are mutually exclusive', ERROR_OPTION_SYNTAX)
		call msg_error('drspine', 'command match: keywords force, clear and show are mutually exclusive', err=ERROR_OPTION_SYNTAX)
		return
		end if

		@@ -2157,7 +2161,7 @@ CONTAINS
		if (ier/=0) then
		call msg_error('drspine/collect', 'cannot create directory '//trim(save_path)//&
		' '//trim(msg_fmt("('(ier =', i0,')')", ier)),&
		ERROR_DIR_ACCESS)
		err=ERROR_DIR_ACCESS)
		return
		end if

		@@ -2463,7 +2467,7 @@ CONTAINS
		'and "default" are mutually exclusive')
		return
		case default
		write(output_unit,*) 'logging level is: '//trim(get_cloglevel())
		write(output_unit,*) 'logging level is: '//get_cloglevel()
		end select


		@@ -2587,7 +2591,7 @@ CONTAINS
		! initializing with header
		s0: if(found('start') .or. found('init')) then
		if(tex_output .ne. 0) then
		call msg_error('drspine',"tex_output already active!", ERROR_DATA_PROCESSING)
		call msg_error('drspine',"tex_output already active!", err=ERROR_DATA_PROCESSING)
		return
		endif

		@@ -2610,7 +2614,7 @@ d1: do i=1, data_manager_size()

		if(numor == 0) then
		call msg_error('drspine',"no scans with role=sample loaded, reporting not started! Load data and try again!",&
		ERROR_DATA_PROCESSING)
		err=ERROR_DATA_PROCESSING)
		return
		endif
		if (len_trim(report_name)<=0)then
		@@ -4763,13 +4767,13 @@ ntl2: do i=0, nt
		chrole = chrval('as',chrole, res)
		if ( res==0 ) return ! not found
		if ( res<0 ) then ! found keyword, but not value
		call msg_error("parse_role_arg", "role argument is missing", ERROR_OPTION_ARG)
		call msg_error("parse_role_arg", msg="role argument is missing", err=ERROR_OPTION_ARG)
		return
		else
		chrole = tolower(chrole)
		if ( trim(chrole) == 'auto' ) return ! special keyword
		if (get_data_role(tolower(chrole))==ROLE_UNDEFINED) then
		call msg_error("parse_role_arg", "role '"//trim(chrole)//"' is unknown", ERROR_OPTION_ARG)
		call msg_error("parse_role_arg", msg="role '"//trim(chrole)//"' is unknown", err=ERROR_OPTION_ARG)
		res = -res
		return
		endif

sources/echo_shapes.f90

+2 −2

Original line number	Diff line number	Diff line
		@@ -641,8 +641,8 @@ contains
		call brent( delta_J0(1), delta_J0(2), dJ, stat, chisq, tolerance)
		if ( 0<stat .and. stat<MAX_NUMBER_OF_ITERATIONS ) cycle
		if ( stat >= MAX_NUMBER_OF_ITERATIONS ) then
		call msg_warning('linextpha1:'//trim(cpixel(phase_scan)),&
		trim(msg_fmt("('fit failed, max iterations exceeded=',i0)",stat)))
		call msg_warning('linextpha1', pixel=cpixel(phase_scan), point=cpoint(phase_scan),&
		msg=msg_fmt("('fit failed, max iterations exceeded=',i0)",stat))
		stat = -MAX_NUMBER_OF_ITERATIONS
		endif
		return

sources/fit_data.f90

+6 −5

Original line number	Diff line number	Diff line
		@@ -245,8 +245,8 @@ contains
		djoffset = 0
		if (apply_offset) then
		if (present(offset) ) djoffset = offset
		call msg_info('get_echo_param:'//cpixel(run=scan_point%id, tau=scan_point%point), &
		trim(msg_fmt("(1x,'applying phase offset: ',f12.3,' deg')", &
		call msg_info('get_echo_param',point=cpoint(run=scan_point%id, tau=scan_point%point), &
		msg=trim(msg_fmt("(1x,'applying phase offset: ',f12.3,' deg')", &
		rad2deg(get_precession_phase(djoffset,scan_point%physics%lambda))))//&
		trim(msg_fmt("(1x,'(',g12.5,' uTm)')", djoffset/UTESLA))//&
		trim(msg_fmt("(1x,'to scan[',i0,'/',i0,']:')", [scan_point%id, scan_point%point])))
		@@ -422,9 +422,10 @@ contains
		! check counting statistics
		if ( phase_scan%average_raw%value.lt.reduction_parameters%min_counts_per_pixel) then
		phase_scan%status = ior(phase_scan%status, PIXEL_STATISTICS)
		!call msg_debug('check_raw_data', trim(phase_scan%cpixel)//' not enough statistics'//&
		! trim(msg_fmt('(" counts=",g12.6)', phase_scan%average_raw%value))//&
		! trim(msg_fmt('(" status=",i0 )', phase_scan%status )))
		call msg_trace('check_raw_data', pixel=cpixel(phase_scan), point=cpoint(phase_scan),&
		msg='not enough statistics'//&
		trim(msg_fmt('(" counts=",g12.6)', phase_scan%average_raw%value))//&
		trim(msg_fmt('(" status=",i0 )', phase_scan%status)))
		return
		end if