Merge branch 'pztest' of jugit.fz-juelich.de:nse/drspine into pztest (6fd6cc37) · Commits · Zolnierczuk, Piotr / DrSPINE

sources/Makefile

+8 −2

Original line number	Diff line number	Diff line
		@@ -10,6 +10,7 @@ CFLAGS =
		FCFLAGS=-g -O2
		ARFLAGS= cr
		GRDIR = /usr/local/gr
		#OLDCOM =

		MAKEDEPEND := $(shell command -v makedepend 2> /dev/null)
		MAKEDEPF90 := $(shell command -v makedepf90 2> /dev/null)
		@@ -36,8 +37,13 @@ PROGSRC=\

		FSOURCES1=\
		drspine_version.F90 \
		os_utils.F90 \
		new_com.F90
		os_utils.F90

		ifndef OLDCOM
		FSOURCES1 += new_com.F90
		else
		FSOURCES1 += old_com.F90
		endif

		FSOURCES2=\
		drspine_parameters.f90 \

sources/Makefile.depend

+2 −2

Original line number	Diff line number	Diff line
		# Makefile.depend Fri Sep 6 15:36:51 EDT 2019
		# Makefile.depend Thu Sep 19 13:42:27 EDT 2019
		drspine_version.o : drspine_version.F90
		os_utils.o : os_utils.F90 strings_module.o drspine_parameters.o
		new_com.o : new_com.F90 os_utils.o

sources/drspine.f90

+53 −66

Original line number	Diff line number	Diff line
		@@ -316,7 +316,12 @@ program drspine
		!!> TO BE DONE: check here for errors issued in the last command and perform appropriate action if available
		!!> 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', 9901)

		if(ierrs > 0) call close_all_macros()
		ierrs = 0


		!------------------------------------------------------------
		!> get the next command line from keyboard or makro file
		@@ -860,19 +865,7 @@ program drspine
		!-------------------------------------------------------------
		!> finally check for makro files
		call makro(mycommand)
		call unused( 2, 1, 1, ier)


		!!>>>>
		!!mmnc
		call unused( icmdus=2, ivnuse=2, irpuse=2, iretus=iunused)
		if(iunused .ne. 0) then
		call errsig(9901,"ERROR: unknown option in last command ! $")
		endif

		if(ierrs > 0) call close_all_macros()
		ierrs = 0
		!!mmnc
		call unused( 1, 1, 1, ier)


		enddo commandloop
		@@ -1309,7 +1302,7 @@ CONTAINS
		if (len_trim(filename) == 0) exit read_loop
		else
		if ( inamf() < i ) exit read_loop
		if ( lvused(i) ) cycle read_loop
		if ( item_used(i) ) cycle read_loop
		filename = trim(vnamef(i))
		if (len_trim(filename) == 0) exit read_loop
		filename = format_path(data_path, filename=filename)
		@@ -1643,12 +1636,14 @@ CONTAINS
		implicit none
		integer :: i
		integer :: fit_flag
		integer :: fit_run
		logical :: fit_resolution, fit_sample, fit_background
		character(len=MAX_LINE_LENGTH) :: cflag
		character(len=MAX_LINE_LENGTH) :: cwhat
		real(kind=DBL) :: phase_offset

		fit_flag = -1
		fit_run = -1
		fit_resolution = .true.
		fit_sample = .true.
		fit_background = .true.
		@@ -1656,12 +1651,21 @@ CONTAINS
		cwhat = repeat(' ', MAX_LINE_LENGTH)
		cflag = repeat(' ', MAX_LINE_LENGTH)

		! parse run argument
		fit_run = get_named_value('run ', fit_run, ier)
		if (ier>0 .and. fit_run > 0 ) then
		fit_resolution = .false.
		fit_sample = .false.
		fit_background = .false.
		end if
		phase_offset = get_named_value('phase_offset',phase_offset, ier)

		! now parse "what"
		cwhat = trim(chrnxt('fit', ier)) ! weird way of getting next parameter
		if (ier>0) then
		if (trim(cwhat)=='all'.or.trim(cwhat)=='flag') then
		continue
		else
		select case(trim(cwhat))
		case ('fit','run','flag','all')
		case default
		fit_resolution = .false.
		fit_sample = .false.
		fit_background = .false.
		@@ -1678,7 +1682,7 @@ CONTAINS
		//trim(cwhat)//"' - expected all, res, sam or bgr")
		return
		end select
		end if
		end select
		end if

		if ( found('flag') ) then
		@@ -1690,16 +1694,11 @@ CONTAINS
		return
		else
		fit_flag = parse_fit_flag(cflag)
		print *, fit_flag
		end if
		else
		fit_flag = get_named_value('flag ',fit_flag, ier)
		fit_flag = get_named_value('flag ',fit_flag, ier) ! FIXME: never gets executed ier>0
		end if
		!if (ier<=0) then
		!end if
		end if
		phase_offset = get_named_value('phase_offset',phase_offset, ier)


		if( fit_resolution ) &
		call msg_info('cmd_fit', "fitting data with role RESOLUTION using flag="//trim(cformat_fit_flag(fit_flag)))
		@@ -1707,16 +1706,8 @@ CONTAINS
		call msg_info('cmd_fit', "fitting data with role SAMPLE using flag="//trim(cformat_fit_flag(fit_flag)))
		if( fit_background ) &
		call msg_info('cmd_fit', "fitting data with role BACKGROUND using flag="//trim(cformat_fit_flag(fit_flag)))


		!fit_loop: do i=1, data_size
		! if (.not. is_valid_scan(data_scan(i))) cycle fit_loop
		! use_flag = 0
		! if (fit_resolution .and. has_role(data_scan(i)%role, ROLE_REFERENCE )) fit_flag = PHASE_FIT_DEFAULT
		! if (fit_sample .and. has_role(data_scan(i)%role, ROLE_SAMPLE )) fit_flag = PHASE_USE
		! if (fit_background .and. has_role(data_scan(i)%role, ROLE_BACKGROUND)) fit_flag = PHASE_USE
		!end do fit_loop

		if( fit_run>0) &
		call msg_info('cmd_fit', "fitting "//trim(msg_fmt("('run =',i0)", fit_run))//" flag="//trim(cformat_fit_flag(fit_flag)))

		if ( fit_resolution ) then
		!!<!mm if (fit_flag<0) fit_flag = PHASE_FIT_DEFAULT ! fit and amplitude positive
		@@ -1762,8 +1753,17 @@ CONTAINS
		end do
		end if

		call unused( 1, 1, 1, ier)

		if ( fit_run > 0 ) then
		call msg_info('fit', '===> fitting run')
		do i=1, data_manager_size()
		if ( data_scan(i)%id /= fit_run ) cycle
		if ( fit_flag == -1 ) then
		call fit_echo_data(data_scan(i), PHASE_FIT_DEFAULT, phase_offset=phase_offset) ! FIXME: is this a right default
		else
		call fit_echo_data(data_scan(i), fit_flag, phase_offset=phase_offset)
		end if
		end do
		end if
		end subroutine cmd_fit


		@@ -4347,19 +4347,6 @@ ntl2: do i=0, nt
		end function parse_fit_flag


		! TODO: move it to the new_com (PAZ)
		subroutine extract_int(varname, intval, ierror)
		character(len=*), intent(in) :: varname
		integer, intent(inout) :: intval
		integer, intent(inout), optional :: ierror
		!
		real(kind=DBL) :: tmpval
		integer :: ier
		call extract(varname, tmpval, ier)
		intval = INT(tmpval)
		if (present(ierror)) ierror=ier
		end subroutine extract_int


		!> @brief set user defined variables
		subroutine set_progvar()
		@@ -4380,7 +4367,7 @@ ntl2: do i=0, nt
		call setudf("r.phase_minoff " , reduction_parameters%symmetry_phase_min_offset, ier)
		!
		call setudf("r.max_chisq " , reduction_parameters%max_chisquare, ier)
		call setudf("r.center_size " , real(reduction_parameters%central_detector_area_size, kind=DBL), ier)
		call setudf("r.center_size " , reduction_parameters%central_detector_area_size, ier)
		!
		!
		call setudf("r.postcoll_qcat ", reduction_parameters%post_collection_qcatch, ier)
		@@ -4389,7 +4376,7 @@ ntl2: do i=0, nt
		call set_instrument_vars()

		! program config
		call setudf("c.last_run " , real(program_param%last_run, kind=DBL), ier)
		call setudf("c.last_run " , program_param%last_run, ier)
		end subroutine set_progvar

		!> get user defined variables
		@@ -4411,7 +4398,7 @@ ntl2: do i=0, nt
		!
		call extract("r.max_chisq " , reduction_parameters%max_chisquare, ier)

		call extract_int("r.center_size " , reduction_parameters%central_detector_area_size)
		call extract("r.center_size " , reduction_parameters%central_detector_area_size, ier)

		call extract("r.postcoll_qcat ", reduction_parameters%post_collection_qcatch, ier)

		@@ -4419,7 +4406,7 @@ ntl2: do i=0, nt
		call get_instrument_vars()

		! program config
		call extract_int("c.last_run " , program_param%last_run)
		call extract("c.last_run " , program_param%last_run, ier)

		! show parameters
		call msg_debug('get_progvar', msg_fmt("('r.min_counts =', g12.5)", reduction_parameters%min_counts_per_pixel))

sources/logger.f90

+2 −2

Original line number	Diff line number	Diff line
		@@ -214,7 +214,7 @@ contains
		integer, intent(in), optional :: ierror
		call logmsg(LOG_ERROR, subrou, messg)
		if (present(ierror))&
		call errsig(ierror,trim(messg)//' $') !signal command interpreter
		call errsig(ierror) !,trim(messg)//' $') !signal command interpreter
		return
		end subroutine msg_error

		@@ -225,7 +225,7 @@ contains
		integer, intent(in), optional :: ierror
		call logmsg(LOG_FATAL, subrou, messg)
		if (present(ierror))&
		call errsig(ierror,trim(messg)//' $') !signal command interpreter
		call errsig(ierror) !,trim(messg)//' $') !signal command interpreter
		return
		end subroutine msg_fatal

sources/new_com.F90

+56 −36

Original line number	Diff line number	Diff line
		@@ -57,6 +57,15 @@ MODULE new_com
		module procedure getval, intval, chrval
		end interface

		interface extract
		module procedure extract_dbl
		module procedure extract_int
		end interface

		interface setudf
		module procedure setudf_dbl
		module procedure setudf_int
		end interface

		#ifdef USE_LINENOISE
		!----------------------------------------------------------------------------
		@@ -320,8 +329,10 @@ MODULE new_com
		public :: getitem
		public :: evaluate
		public :: cappend
		public :: extract
		public :: setudf
		public :: extract_dbl
		public :: extract_int
		public :: setudf_dbl
		public :: setudf_int
		public :: clrudf
		public :: shwudf
		public :: settit
		@@ -357,8 +368,6 @@ MODULE new_com
		public :: inamf
		public :: inapf
		!
		public :: lvused ! whether the parameter has already been "used"


		public :: close_all_macros

		@@ -500,7 +509,7 @@ CONTAINS

		character*1024 ma_fil
		integer ilma, i, j, k, l, ii, ipmlen, isum, ioold
		integer ier, ierr, ioldna, inew, iival
		integer ier, ierr, ioldna, iival !, inew is unused

		integer :: init_run = 1, irc=0
		double precision val
		@@ -1606,8 +1615,7 @@ CONTAINS
		do i=1,iitems
		if(iot.gt.0) &
		write(6,*)'item: ',i,cmd_item(i)(1:lclen(vname(i),80)+1)
		if(.not.item_used(i)) then
		!mmnc item_used(i) = .true.
		if(iot.gt.0.and..not.item_used(i)) then
		if(ivnuse.gt.0 .or. irpuse.gt.0) then
		call errsig(max(ivnuse-1,irpuse-1),'item not used:'// &
		cmd_item(i)(1:lclen(vname(i),80)+1)//'$')
		@@ -1620,7 +1628,7 @@ CONTAINS
		do i=1,inames
		if(iot.gt.0) &
		write(6,*)'vname: ',i,vname(i)(1:lclen(vname(i),80)+1)
		if(.not.vused(i)) then
		if(iot.gt.0.and..not.vused(i)) then
		!mmnc vused(i) = .true.
		if(ivnuse.gt.0) then
		call errsig(ivnuse-1,'name not used:'// &
		@@ -1895,13 +1903,15 @@ CONTAINS
		! ===========================
		implicit none
		integer, intent(in) ::ierr
		character(*), intent(in), optional :: say
		!
		integer ::lsay
		character(*), intent(in) :: say
		! ----------------------------------------------------------------------
		! error signalisierung
		! ----------------------------------------------------------------------
		ierrr = ierr
		ierrs = ierrs+1 ! check which one we need
		if (.not.present(say)) return
		lsay = laenge(say,cmd_len,'$')
		write(6,*)'error:',ierr,' ',say(1:lsay)
		if(iot.gt.0) then
		@@ -2021,8 +2031,8 @@ CONTAINS
		double precision, intent(in) :: defval
		integer, intent(out), optional :: inew0

		double precision :: inew, ev_val
		integer :: ev_err
		double precision :: ev_val
		integer :: inew, ev_err

		inew = 0
		valnxt = defval
		@@ -3300,14 +3310,14 @@ CONTAINS
		END function compare


		subroutine extract(nam,val,ier)
		subroutine extract_dbl(nam,val,ier)
		! -------------------------------

		implicit none
		integer i, ier
		character(*) :: nam
		double precision val

		double precision :: val
		integer :: ier
		!
		integer :: i

		ier = 0
		! --- look in uservars ---
		@@ -3325,10 +3335,24 @@ CONTAINS
		! --- user defined vals ---
		call newcom_usrextr(nam,val,ier)
		return
		END subroutine extract
		END subroutine extract_dbl

		subroutine extract_int(nam,val,ier)
		! -------------------------------

		implicit none
		character(*) :: nam
		integer :: val
		integer :: ier
		!
		double precision :: tmpval

		call extract_dbl(nam, tmpval, ier)
		val = int(tmpval)
		return
		end subroutine extract_int

		subroutine setudf(nam,val,ier)
		subroutine setudf_dbl(nam,val,ier)
		! ------------------------------
		implicit none
		character(len=*), intent(in) :: nam
		@@ -3372,7 +3396,17 @@ CONTAINS
		ier = 200
		endif
		return
		END subroutine setudf
		END subroutine setudf_dbl

		subroutine setudf_int(nam,val,ier)
		! ------------------------------
		implicit none
		character(len=*), intent(in) :: nam
		integer, intent(in) :: val
		integer, intent(out) :: ier

		call setudf_dbl(nam, real(val, kind=8), ier)
		end subroutine setudf_int


		subroutine clrudf(nam)
		@@ -3482,9 +3516,11 @@ CONTAINS
		search: do i=1,inames
		if(compar(vname(i),pname//' ')) then
		vused(i) = .true.
		item_used(i) = .true.
		if ( len_trim(vname(i+1)) > 0 ) then
		chrval = vname(i+1)
		vused(i+1) = .true.
		item_used(i+1) = .true.
		inew = i
		else
		inew = -i ! argument not found
		@@ -3894,22 +3930,6 @@ END SUBROUTINE intnva
		s = prompt
		end function get_prompt




		! (paz) whether "name" has been used
		function lvused(iname) result(res)
		integer, intent(in) :: iname
		logical :: res
		res = vused(iname)
		end function lvused







		! =========================================================================
		!> convert blanks between quoites to ~ (aux function to enable newcom to deal
		!> with quote strings as nametype items