tentative direct bgrsub, still to be checked/corrected??, all testwrites !!TEST!! (d098ebff) · Commits · Zolnierczuk, Piotr / DrSPINE

sources/base_types.f90

+36 −2

Original line number	Diff line number	Diff line
		@@ -58,6 +58,7 @@ module base_types

		!> values equal
		interface equal_value
		module procedure equal_value_arrays
		module procedure equal_value_struct
		module procedure equal_namedvalue
		module procedure equal_datetime
		@@ -225,6 +226,29 @@ contains
		end function equal_value_struct


		function equal_value_arrays(arg1, arg2, tol, tols) result(res)
		type(value_struct), dimension(:), intent(in) :: arg1, arg2
		real(kind=DBL), intent(in), optional :: tol
		real(kind=DBL), intent(in), optional :: tols
		logical :: res
		real(kind=DBL) :: tolerance, sigma_tolerance
		integer :: i
		res = .false.

		if(size(arg1) .ne. size(arg2)) return

		tolerance = 0.0_DBL
		sigma_tolerance = HUGE(sigma_tolerance)
		if ( present(tol) ) tolerance = tol
		if ( present(tols) ) sigma_tolerance = tols
		do i=1,size(arg1) !! TBD cases where first index is not 1 .... TBD
		if ( abs(arg1(i)%value - arg2(i)%value ) > tolerance ) return
		if ( abs(arg1(i)%sigma2 - arg2(i)%sigma2) > sigma_tolerance ) return
		enddo
		res = .true.
		end function equal_value_arrays


		function equal_namedvalue(arg1, arg2, tol) result(res)
		type(namedvalue_struct), intent(in) :: arg1, arg2
		real(kind=DBL), intent(in), optional :: tol
		@@ -432,6 +456,16 @@ contains
		type(value_struct) :: res
		real(kind=DBL) :: weight1=0.0_DBL, weight2=0.0_DBL

		if(arg1%state == VAL_UNDEFINED .or. arg1%sigma2 == 0.0_DBL) then
		res = arg2
		return
		endif

		if(arg2%state == VAL_UNDEFINED .or. arg2%sigma2 == 0.0_DBL) then
		res = arg1
		return
		endif

		if(arg1%sigma2>0.0_DBL) weight1 = 1/arg1%sigma2
		if(arg2%sigma2>0.0_DBL) weight2 = 1/arg2%sigma2

		@@ -444,8 +478,8 @@ contains

		res%value = (arg1%value * weight1 + arg2%value * weight2)/(weight1+weight2)
		res%sigma2 = 1.0_DBL / (weight1+weight2)
		!!TEST!! write(*,'(a,3(i3,2f18.9))')"TAVE: ", arg1, arg2, res
		!!TEST!! write(*,'(4(a,e15.7))')"TAVE w1=",weight1," w2=",weight2," a1=",arg1%value," a2=",arg2%value
		! write(*,'(a,3(i3,2f18.9))')"TAVE: ", arg1, arg2, res !!TEST!!
		! write(*,'(4(a,e15.7))')"TAVE w1=",weight1," w2=",weight2," a1=",arg1%value," a2=",arg2%value !!TEST!!

		end function ave_value0

sources/data_types.f90

+4 −0

Original line number	Diff line number	Diff line
		@@ -98,6 +98,8 @@ module data_types
		integer :: n_up ! (see above)

		integer :: status ! if 0, pixel is OK
		logical :: normalized
		logical :: background_subtracted ! direct background has been subtracted
		end type phase_scan_struct


		@@ -609,6 +611,8 @@ CONTAINS
		this%n_up = 0
		!
		this%status = PIXEL_OK
		this%normalized = .false. ! maybe not needed since done while reading TBDmm
		this%background_subtracted = .false.

		end subroutine init_phase_scan_struct

sources/drspine.f90

+34 −0

Original line number	Diff line number	Diff line
		@@ -306,6 +306,8 @@ program drspine
		!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		info = 0
		mycommand = " "
		! call push_cmd_line("drspine_profile")
		init_file_path = "drspine_profile"
		commandloop: do


		@@ -545,6 +547,19 @@ program drspine
		cycle commandloop
		endif

		!-------------------------------------------------------------
		!> COMMAND: bgrsub
		!-------------------------------------------------------------
		if(command('bgrsub ', &
		' bgrsub [transmission_ratio <tr>] '//LF//&
		' - subtracts background from sample directly phasepoint-wise'//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
		! ===============
		call cmd_bgrsub()
		cycle commandloop
		endif

		!-------------------------------------------------------------
		!> COMMAND: fit
		!-------------------------------------------------------------
		@@ -1626,6 +1641,25 @@ CONTAINS

		end subroutine cmd_match

		!-------------------------------------------------------------
		!> implementation COMMAND: bgrsub
		!-------------------------------------------------------------
		subroutine cmd_bgrsub()
		! ===========
		implicit none
		integer :: inew
		real(kind=DBL), save :: transmission_ratio = 1d0

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

		transmission_ratio = get_named_value('transmission_ratio',transmission_ratio, inew)

		call direct_bgr_subtraction(data_scan, data_manager_size(), transmission_ratio)

		call unused( 1, 1, 1, ier)

		end subroutine cmd_bgrsub


		!-------------------------------------------------------------
		!> implementation COMMAND: fit

sources/fit_utils.f90

+2 −1

Original line number	Diff line number	Diff line
		@@ -374,7 +374,8 @@ contains

		if(ssq_norpix == 0d0 .or. ssq_norpix >= HUGE(1d0)) then
		call msg_error('get_phase_offset','phase offset determination failed ('&
		//trim(msg_fmt("('ssq normalization: ', g9.5)", ssq_norpix))//')')
		! //trim(msg_fmt("('ssq normalization: ', g9.5)", ssq_norpix))//')' &
		//'Check: r-parameters r.ave_min, r.fqt_min or r.fqt_maxsigma !)')
		djoffset = 0
		return
		endif

sources/matching.f90

+5 −0

Original line number	Diff line number	Diff line
		@@ -277,4 +277,9 @@ contains
		end do source_loop
		end subroutine match_scans






		end module matching