revised logger (11d38f66) · Commits · Zolnierczuk, Piotr / DrSPINE

examples/match_test2

+1 −2

Original line number	Diff line number	Diff line
		@@ -36,6 +36,5 @@ match show
		! test fitting/collection
		fit res
		fit sam flag offset
		verbose dec ! warning
		verbose dec ! error
		verbose off ! only errors
		collect

sources/data_types.f90

+45 −19

Original line number	Diff line number	Diff line
		@@ -51,7 +51,8 @@ module data_types
		type(value_struct), dimension(:), allocatable :: counts_pixel_bin ! counts in pixel an lambda bin
		type(value_struct), dimension(:), allocatable :: monitor ! monitor counts

		! pixel "description"
		! parent scan and pixel description
		type(scan_data_struct), pointer :: parent ! pointer to the parent scan
		character(len=MAX_VAR_NAME_LENGTH) :: cpixel ! pixel description (mostly for debugging) [PAZ]

		!
		@@ -528,6 +529,12 @@ module data_types
		module procedure trap_div_dbl
		module procedure trap_div_int
		end interface

		interface cpixel
		module procedure cpixel_format1
		module procedure cpixel_format2
		end interface

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

		@@ -545,10 +552,11 @@ CONTAINS
		end subroutine init_sample_struct


		subroutine init_phase_scan_struct(this, nphases, cpixel)
		subroutine init_phase_scan_struct(this, nphases, cpixel, parent)
		type(phase_scan_struct), intent(out) :: this
		integer, intent(in) :: nphases
		character(len=*),intent(in), optional :: cpixel
		type(scan_data_struct), intent(in), target, optional :: parent
		!
		integer :: istat

		@@ -566,11 +574,10 @@ CONTAINS
		if (istat/=0) &
		call msg_fatal('init_scan_data_struct', 'memory exhausted')

		this%parent=>NULL()
		this%cpixel='<undefined>'
		if ( present(cpixel) ) then
		this%cpixel = cpixel(1:MIN(len_trim(cpixel),MAX_VAR_NAME_LENGTH))
		endif

		if (present(parent)) this%parent => parent
		if (present(cpixel)) this%cpixel = cpixel(1:MIN(len_trim(cpixel),MAX_VAR_NAME_LENGTH))
		this%max_phase = nphases

		call init_value(this%delta_j)
		@@ -714,7 +721,7 @@ CONTAINS


		subroutine init_scan_data_struct(this, nphases, nt, nx, ny)
		type(scan_data_struct), intent(out) :: this
		type(scan_data_struct), intent(out), target :: this
		integer, intent(in) :: nphases
		integer, intent(in) :: nt, nx, ny
		!
		@@ -748,7 +755,7 @@ CONTAINS
		call init_environment_parameters_struct(this%environment(i))
		end do

		call init_phase_scan_struct(this%centerbin, this%no_phases, "0:0-0")
		call init_phase_scan_struct(this%centerbin, this%no_phases, "0:0-0", this)

		if (allocated(this%pixelbin)) deallocate(this%pixelbin)
		allocate(this%pixelbin(0:this%no_lam, this%no_xpix, this%no_ypix), stat=istat)
		@@ -758,7 +765,7 @@ CONTAINS
		do ix=1,this%no_xpix
		do iy=1, this%no_ypix
		write(cpixel, '(i0,":",i0,"-",i0)') it, ix, iy
		call init_phase_scan_struct(this%pixelbin(it, ix, iy), this%no_phases, cpixel)
		call init_phase_scan_struct(this%pixelbin(it, ix, iy), this%no_phases, cpixel, this)
		end do
		end do
		end do
		@@ -867,6 +874,29 @@ CONTAINS
		end function is_pixel_ok


		!
		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)
		end function cpixel_format1

		!>
		!!
		function cpixel_format2(run, tau, pixel) result(cres)
		character(len=MAX_NAME_LENGTH) cres
		integer, intent(in), optional :: run
		integer, intent(in), optional :: tau
		character(len=*), intent(in), optional :: pixel
		!
		cres = ' '
		if (present(run )) write(cres,'(a,"run=",i0,",")') trim(cres), run
		if (present(tau )) write(cres,'(a,"tau=",i0,",")') trim(cres), tau
		if (present(pixel)) write(cres,'(a,"pix=",a ,",")') trim(cres), trim(pixel)
		if (len_trim(cres)>1) cres=cres(1:len_trim(cres)-1) ! remove trailing comma
		end function cpixel_format2


		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!! from here stuff to deal with collecting results into a binned sqt structure !!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		@@ -1050,27 +1080,23 @@ CONTAINS
		!!!>>> preliminary hint >>> !!!
		if(present(ps_background)) then
		call msg_fatal('add_pix_to_sqt', "ATTENTION: in the present version we do not yet treat background at this level")
		!write(6,*)" >>>> This Message was issued in subroutine add_pix_to_sqt <<<<"
		!stop
		endif
		!!!<<< 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', "pixel "//trim(ps_sample%cpixel)//&
		": sample and reference field integral match is outside of tolerance")
		call msg_warning('add_pix_to_sqt,'//cpixel(ps_sample),&
		"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', "pixel "//trim(ps_sample%cpixel)//&
		": sample and reference wavelength match is outside of tolerance")
		call msg_warning('add_pix_to_sqt,'//cpixel(ps_sample),&
		"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', "pixel "//trim(ps_sample%cpixel)//&
		": sample and reference scattering angle match is outside of tolerance")
		call msg_warning('add_pix_to_sqt,'//cpixel(ps_sample),&
		"sample and reference scattering angle match is outside of tolerance")
		endif

		!> @note we still have to include further exclusion criteria

sources/drspine.f90

+3 −2

Original line number	Diff line number	Diff line
		@@ -2453,7 +2453,7 @@ CONTAINS
		case (E_ON)
		call set_loglevel(LOG_DEBUG)
		case (E_OFF)
		call set_loglevel(LOG_WARNING)
		call set_loglevel(LOG_ERROR)
		case (E_DEC)
		call dec_loglevel()
		case (E_INC)
		@@ -2463,9 +2463,10 @@ CONTAINS
		'and "default" are mutually exclusive')
		return
		case default
		write(output_unit,*) 'log level is: '//trim(get_cloglevel())
		write(output_unit,*) 'logging level is: '//trim(get_cloglevel())
		end select


		end subroutine cmd_verbose

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

sources/echo_shapes.f90

+2 −2

Original line number	Diff line number	Diff line
		@@ -641,7 +641,7 @@ 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(phase_scan%cpixel)//': '//&
		call msg_warning('linextpha1:'//trim(cpixel(phase_scan)),&
		trim(msg_fmt("('fit failed, max iterations exceeded=',i0)",stat)))
		stat = -MAX_NUMBER_OF_ITERATIONS
		endif

sources/logger.f90

+77 −29

Original line number	Diff line number	Diff line
		@@ -2,9 +2,9 @@
		module logger
		use, intrinsic :: iso_fortran_env, only : output_unit, error_unit
		use new_com

		implicit none

		save
		character(len=1), parameter :: LF = CHAR(10) !'\n'

		integer, parameter :: LOG_MSGLEN = 1024
		@@ -22,6 +22,8 @@ module logger
		integer, private :: ilog = 80 ! log file


		!> message format "fmt" + variable(s)
		!! returns a formatted string
		interface msg_fmt
		module procedure msg_fmtlog
		module procedure msg_fmtint
		@@ -32,6 +34,10 @@ module logger
		module procedure msg_fmtdblarr
		end interface

		interface logmsg
		module procedure logmsg1
		module procedure logmsg2
		end interface

		contains

		@@ -75,7 +81,6 @@ contains
		!! Get the log I/O unit
		integer function ilogunit()
		ilogunit=ilog
		return
		end function ilogunit

		!> @brief
		@@ -129,19 +134,20 @@ contains
		! ----------------------------------------------
		!> @brief
		!! Emit a log message
		subroutine logmsg(ilevel, subrou, messg)
		subroutine logmsg1(ilevel, location, messg)
		integer, intent(in) :: ilevel
		character(len=*), intent(in) :: subrou
		character(len=*), intent(in) :: location
		character(len=*), intent(in) :: messg

		! local variables
		character(len=12) clevel
		character(len=*), parameter :: fmt1 = "(a5,1x,a1,a,a1,1x,a)"
		character(len=8) clevel
		character(len=*), parameter :: fmt1 = '(a8,1x,"[",a,"]",1x,a)'

		select case (ilevel)
		case (LOG_TRACE)
		clevel = 'TRACE '
		case (LOG_DEBUG)
		clevel = 'DEBU '
		clevel = 'DEBUG '
		case (LOG_INFO)
		clevel = 'INFO '
		case (LOG_WARNING)
		@@ -157,9 +163,7 @@ contains
		! log to stdout/stderr
		if (iclevel.ge.ilevel) then
		if(LOG_WARNING.ge.ilevel) then ! write warnings/errors to stderr
		!?mm write(output_unit,'(a)') REPEAT('*', 80)
		write(output_unit,'(a,1x,a)') clevel, trim(messg)
		!?mm write(output_unit,'(a)') REPEAT('*', 80)
		else
		write(output_unit,'(a)') trim(messg)
		endif
		@@ -167,57 +171,101 @@ contains

		! log to file
		if (iflevel.ge.ilevel) then
		write (ilog,fmt1) clevel, '[', subrou, ']', trim(messg)
		write (ilog,fmt1) clevel, trim(location), trim(messg)
		endif

		! stop if log level is fatal
		if (ilevel.le.LOG_FATAL) STOP
		end subroutine logmsg1

		subroutine logmsg2(ilevel, location, arg1, arg2)
		integer, intent(in) :: ilevel
		character(len=*), intent(in) :: location
		character(len=*), intent(in) :: arg1
		character(len=*), intent(in) :: arg2
		!
		integer :: ilen
		character(len=:),allocatable :: ctmp
		ilen = len_trim(arg1)+len_trim(arg2)+2
		allocate(character(len=ilen) :: ctmp)
		write(ctmp,'(a," ",a)') trim(arg1), trim(arg2)
		call logmsg1(ilevel, location, ctmp)
		deallocate(ctmp)
		end subroutine logmsg2

		end subroutine logmsg

		!> @brief
		!! Trace message (most verbose)
		subroutine msg_trace(subrou, messg)
		character(len=*), intent(in) :: subrou, messg
		call logmsg(LOG_TRACE, subrou, messg)
		subroutine msg_trace(location, arg1, arg2)
		character(len=*), intent(in) :: location
		character(len=*), intent(in) :: arg1
		character(len=*), intent(in), optional :: arg2
		!
		if (present(arg2)) then
		call logmsg(LOG_TRACE, location, arg1, arg2)
		else
		call logmsg(LOG_TRACE, location, arg1)
		end if
		return
		end subroutine msg_trace

		!> @brief
		!! Debug message (verbose)
		subroutine msg_debug(subrou, messg)
		character(len=*), intent(in) :: subrou, messg
		call logmsg(LOG_DEBUG, subrou, messg)
		subroutine msg_debug(location, arg1, arg2)
		character(len=*), intent(in) :: location
		character(len=*), intent(in) :: arg1
		character(len=*), intent(in), optional :: arg2
		!
		if (present(arg2)) then
		call logmsg(LOG_DEBUG, location, arg1, arg2)
		else
		call logmsg(LOG_DEBUG, location, arg1)
		end if
		return
		end subroutine msg_debug

		!> @brief
		!! Info message ("neutral")
		subroutine msg_info(subrou, messg)
		character(len=*), intent(in) :: subrou, messg
		call logmsg(LOG_INFO, subrou, messg)
		subroutine msg_info(location, arg1, arg2)
		character(len=*), intent(in) :: location
		character(len=*), intent(in) :: arg1
		character(len=*), intent(in), optional :: arg2
		!
		if (present(arg2)) then
		call logmsg(LOG_INFO, location, arg1, arg2)
		else
		call logmsg(LOG_INFO, location, arg1)
		end if
		return
		end subroutine msg_info

		!> @brief
		!! Warning message
		subroutine msg_warning(subrou, messg)
		character(len=*), intent(in) :: subrou, messg
		call logmsg(LOG_WARNING, subrou, messg)
		subroutine msg_warning(location, arg1, arg2)
		character(len=*), intent(in) :: location
		character(len=*), intent(in) :: arg1
		character(len=*), intent(in), optional :: arg2
		!
		if (present(arg2)) then
		call logmsg(LOG_WARNING, location, arg1, arg2)
		else
		call logmsg(LOG_WARNING, location, arg1)
		end if
		return
		end subroutine msg_warning

		!> @brief
		!! Error message
		subroutine msg_error(subrou, messg, ierror)
		character(len=*), intent(in) :: subrou, messg
		subroutine msg_error(subrou, arg1, ierror)
		character(len=*), intent(in) :: subrou, arg1
		integer, intent(in), optional :: ierror
		!
		integer :: error_code
		call logmsg(LOG_ERROR, subrou, messg)
		call logmsg(LOG_ERROR, subrou, arg1)
		!
		error_code = ERROR_UNKNOWN
		if (present(ierror)) error_code = ierror
		call errsig(error_code) !,trim(messg)//' $') !signal command interpreter
		call errsig(error_code) ! signal command interpreter
		return
		end subroutine msg_error

		@@ -227,8 +275,8 @@ contains
		character(len=*), intent(in) :: subrou, messg
		integer, intent(in), optional :: ierror
		call logmsg(LOG_FATAL, subrou, messg)
		if (present(ierror))&
		call errsig(ierror) !,trim(messg)//' $') !signal command interpreter
		!
		if (present(ierror)) call errsig(ierror) ! signal command interpreter
		return
		end subroutine msg_fatal