Commit 3bcac83d authored by Zolnierczuk, Piotr's avatar Zolnierczuk, Piotr
Browse files

allow to add runs with unequal number of taus 

- adding will be done based on matching taupoint_match result
- move couple of subroutines to avoid circular dependencies
parent 4516bbcf

sources/base_types.f90

+36 −0
Original line number Diff line number Diff line
@@ -153,6 +153,7 @@ module base_types 
  public :: init_value, has_value, cformat_value, find_namedvalue

  public :: equal_value, add_value, sub_value, mul_value, div_value

  public :: ave_value, distribution_ave, sum_value

  public :: diff_values, diff_relative

  public :: parse_date, is_earlier, is_later

  public :: julian_day, julian_to_date
@@ -741,6 +742,41 @@ contains 
    return

  end function distribution_ave



  !--------------------------------------------------------------------------

  !> small helper function to compare two value_struct objects

  !! if optional tolerance parameter is given then the match will be

  !! computer relative to the tolerance

  !!@param aval [in]  first value to compare

  !!@param bval [in]  second value to compare

  !!@param tol  [in, optional] comparison tolerance

  function diff_values(aval, bval, tol) result(diff)

    type(value_struct), intent(in) :: aval

    type(value_struct), intent(in) :: bval

    real(kind=DBL), intent(in), optional :: tol

    real(kind=DBL) :: diff

    diff = abs(aval%value - bval%value)

    if ( present(tol) ) then

       if (tol /= 0.0_DBL) diff = diff/tol

    end if

  end function diff_values



  !--------------------------------------------------------------------------

  !> small helper function to calculate relative difference of

  !! two value_struct objects

  !!@param aval [in]  first value to compare

  !!@param bval [in]  second value to compare

  function diff_relative(aval, bval) result(diff)

    type(value_struct), intent(in) :: aval

    type(value_struct), intent(in) :: bval

    real(kind=DBL) :: diff

    !

    diff = abs(2*(aval%value-bval%value) / (aval%value+bval%value))

  end function diff_relative





  !--------------------------------------------------------------------------

  ! format value structs

  !--------------------------------------------------------------------------



  !> format value structure (format specified)

  function cformat_value_struct1(this, fmt, max_len) result(cresult)

sources/data_types.f90

+57 −18
Original line number Diff line number Diff line
@@ -2458,6 +2458,42 @@ endif 
 

  end subroutine consolidate_colldata



  !! ====================================================================================================================

  !! "raw" match function moved here to avoid circular dependence between modules matching <-> data types

  !! ====================================================================================================================



  !--------------------------------------------------------------------------

  !> basic function to compare single phase-scans by comparing

  !!fieldintgrals, phi and psi angles and frame parameters

  !!@param a [in]  scan_data_structure (taupoint to be compared)

  !!@param b [in]  scan_data_structure (taupoint to be compared)

  logical function taupoint_match(a,b)

    !--------------------------------------------------------------------------

    implicit none



    type(scan_data_struct), intent(in) :: a

    type(scan_data_struct), intent(in) :: b



    taupoint_match = .false.



    ! field integral

    if( diff_values  (a%physics%field_integral, b%physics%field_integral) > matching_tolerance%J0_abs) return

    if( diff_relative(a%physics%field_integral, b%physics%field_integral) > matching_tolerance%J0_rel) return



    ! scattering and sample angles

    if( diff_values(a%physics%scattering_angle, b%physics%scattering_angle) > matching_tolerance%scattering_angle) return

    if( diff_values(a%physics%sample_angle, b%physics%sample_angle) > matching_tolerance%sample_angle) return



    ! wavelength spectrum

    if( a%spectrum(0)%no_lambda_bins .ne. b%spectrum(0)%no_lambda_bins    )  return

    if(abs( (spectrum_min_lambda(a%spectrum(0))-spectrum_min_lambda(b%spectrum(0))) ) > matching_tolerance%lambda_min) return

    if(abs( (spectrum_max_lambda(a%spectrum(0))-spectrum_max_lambda(b%spectrum(0))) ) > matching_tolerance%lambda_max) return



    taupoint_match = .true.



  end function taupoint_match







!! ====================================================================================================================

!! (experimental) feature:
@@ -2532,7 +2568,6 @@ endif 
    end do

  end function scan_point_append





  !> append scan_struct (echo file)

  function scan_struct_append(b, a ) result(res)

    implicit none
@@ -2540,7 +2575,7 @@ endif 
    type(scan_struct), intent(in)    :: a

    integer :: res

    !

    integer :: i

    integer :: i,j,n

    character(len=MAX_PATH_LENGTH)   :: cfile

    !

    res = 0
@@ -2552,24 +2587,28 @@ endif 
        b%id = a%id + 1000000                 ! FIXME: HARD CODED CONSTANT

        write(cfile,'("s",i0,".echo")')  b%id ! FIXME: change file name

        b%file = trim(cfile)

    else

        if (b%number_of_points .ne. a%number_of_points ) then

            call msg_warning('scan_struct_append', &

                msg='number of points is different',&

                values=msg_fmt('("numor=",i0," expected=",i0,", actual=",i0)',&

                        [a%id, b%number_of_points, a%number_of_points]))

            res=-1

            return

    end if



    n = 0 ! number of matches

    do i=1, b%number_of_points

            res = scan_point_append(b%scan_point(i), a%scan_point(i))

        do j=1, a%number_of_points

            if (taupoint_match(b%scan_point(i), a%scan_point(j))) then

                res = scan_point_append(b%scan_point(i), a%scan_point(j))

                if (res.ne.0) then

                    call msg_warning('scan_struct_append', &

                            msg='scan point append failed',&

                            values=msg_fmt('("numor=",i0)', a%id))

                    exit

                end if

                n = n + 1

            end if

        end do

    end do

    if (n<1) then

        call msg_warning('scan_struct_append', &

                        msg='no matching points found',&

                        values=msg_fmt('("numor=",i0)', a%id))

        res=-1

    end if

  end function scan_struct_append

sources/drspine.f90

+4 −3
Original line number Diff line number Diff line
@@ -1583,7 +1583,7 @@ CONTAINS 
    integer :: numor, i, j, k

    integer :: ires



    write(*,*) "*** EXPERIMENTAL ADDECHO COMMAND ****"

    call msg_warning('drspine', msg='USING EXPERIMENTAL ADDECHO COMMAND')



    call data_manager_add(k)

    if (k<=0) then
@@ -1602,9 +1602,10 @@ CONTAINS 
        ires = scan_struct_append(data_scan(k), data_scan(j))

        if (ires.ne.0) then

            call msg_error('drspine', msg='adding failed', &

                 values=msg_fmt('("numor=",i0)', numor),err=ERROR_DATA_PROCESSING)

                 values=msg_fmt('("run=",i0)', numor),err=ERROR_DATA_PROCESSING)

        else

            write(*,*) "*** added echo ", numor, " ***"

            call msg_info('drspine', msg='added echo', &

                 values=msg_fmt('("run=",i0)', numor))

        end if

    end do numor_loop

sources/matching.f90

+31 −57
Original line number Diff line number Diff line
@@ -21,64 +21,38 @@ module matching 
  public  :: match_show, match_clear



contains

  !--------------------------------------------------------------------------

  !> small helper function to compare two value_struct objects

  !! if optional tolerance parameter is given then the match will be

  !! computer relative to the tolerance

  !!@param aval [in]  first value to compare

  !!@param bval [in]  second value to compare

  !!@param tol  [in, optional] comparison tolerance

  function diff_values(aval, bval, tol) result(diff)

    type(value_struct), intent(in) :: aval

    type(value_struct), intent(in) :: bval

    real(kind=DBL), intent(in), optional :: tol

    real(kind=DBL) :: diff

    diff = abs(aval%value - bval%value)

    if ( present(tol) ) then

       if (tol /= 0.0_DBL) diff = diff/tol

    end if

  end function diff_values





  function diff_relative(aval, bval) result(diff)

    type(value_struct), intent(in) :: aval

    type(value_struct), intent(in) :: bval

    real(kind=DBL) :: diff

    !

    diff = abs(2*(aval%value-bval%value) / (aval%value+bval%value))

  end function diff_relative





  !--------------------------------------------------------------------------

  !> basic function to compare single phase-scans by comparing

  !!fieldintgrals, phi and psi angles and frame parameters

  !!@param a [in]  scan_data_structure (taupoint to be compared)

  !!@param b [in]  scan_data_structure (taupoint to be compared)

  logical function taupoint_match(a,b)

    !--------------------------------------------------------------------------

    implicit none



    type(scan_data_struct), intent(in) :: a

    type(scan_data_struct), intent(in) :: b



    taupoint_match = .false.



    ! field integral

    if( diff_values  (a%physics%field_integral, b%physics%field_integral) > matching_tolerance%J0_abs) return

    if( diff_relative(a%physics%field_integral, b%physics%field_integral) > matching_tolerance%J0_rel) return



    ! scattering and sample angles

    if( diff_values(a%physics%scattering_angle, b%physics%scattering_angle) > matching_tolerance%scattering_angle) return

    if( diff_values(a%physics%sample_angle, b%physics%sample_angle) > matching_tolerance%sample_angle) return



    ! wavelength spectrum

    if( a%spectrum(0)%no_lambda_bins .ne. b%spectrum(0)%no_lambda_bins    )  return

    if(abs( (spectrum_min_lambda(a%spectrum(0))-spectrum_min_lambda(b%spectrum(0))) ) > matching_tolerance%lambda_min) return

    if(abs( (spectrum_max_lambda(a%spectrum(0))-spectrum_max_lambda(b%spectrum(0))) ) > matching_tolerance%lambda_max) return



    taupoint_match = .true.



  end function taupoint_match

!!  !--------------------------------------------------------------------------

!!  !> basic function to compare single phase-scans by comparing

!!  !!fieldintgrals, phi and psi angles and frame parameters

!!  !!@param a [in]  scan_data_structure (taupoint to be compared)

!!  !!@param b [in]  scan_data_structure (taupoint to be compared)

!!  logical function taupoint_match(a,b)

!!    !--------------------------------------------------------------------------

!!    implicit none

!!

!!    type(scan_data_struct), intent(in) :: a

!!    type(scan_data_struct), intent(in) :: b

!!

!!    taupoint_match = .false.

!!

!!    ! field integral

!!    if( diff_values  (a%physics%field_integral, b%physics%field_integral) > matching_tolerance%J0_abs) return

!!    if( diff_relative(a%physics%field_integral, b%physics%field_integral) > matching_tolerance%J0_rel) return

!!

!!    ! scattering and sample angles

!!    if( diff_values(a%physics%scattering_angle, b%physics%scattering_angle) > matching_tolerance%scattering_angle) return

!!    if( diff_values(a%physics%sample_angle, b%physics%sample_angle) > matching_tolerance%sample_angle) return

!!

!!    ! wavelength spectrum

!!    if( a%spectrum(0)%no_lambda_bins .ne. b%spectrum(0)%no_lambda_bins    )  return

!!    if(abs( (spectrum_min_lambda(a%spectrum(0))-spectrum_min_lambda(b%spectrum(0))) ) > matching_tolerance%lambda_min) return

!!    if(abs( (spectrum_max_lambda(a%spectrum(0))-spectrum_max_lambda(b%spectrum(0))) ) > matching_tolerance%lambda_max) return

!!

!!    taupoint_match = .true.

!!

!!  end function taupoint_match

!!



  ! -------------------------------------------------------------------------

  ! (paz) unused function - commented out for now

tests/testbase.f90

+6 −0
Original line number Diff line number Diff line
@@ -301,6 +301,12 @@ contains 
    call init_value(vsx, val=1.0_DBL, err=0.1_DBL)

    call assert(trim(cformat_value(vsx))=='  1.00000    , 0.100000', "with error")



    call init_value(v1, val=1.0_DBL, err=0.1_DBL)

    call init_value(v2, val=2.0_DBL, err=0.1_DBL)

    call assert(diff_values  (v1,v2)==1.0_DBL,          "diff_values(1.0,2.0)")

    call assert(diff_values  (v1,v2,0.1_DBL)==10.0_DBL, "diff_values(1.0,2.0,0.1)")

    call assert(diff_relative(v1,v2)==2.0_DBL/3,         "diff_relative(1.0,2.0)")



    write(*,*) '-> OK'



  end subroutine test_value_struct