Support listings with second `filename`, this is for example used to specify... (53e46ce3) · Commits · CAMS / CSO

oper/src/cso_listing.F90

+443 −12

Original line number	Diff line number	Diff line
		@@ -10,11 +10,15 @@
		! 2018/06/S5p_RPRO_NO2_03274.nc;2018-06-01T04:52:43.586000000;2018-06-01T04:59:12.377000000;03274
		!
		!
		! HISTORY
		! CHANGES
		!
		! 2022-09, Arjo Segers
		! Extended error messages.
		!
		! 2026-07, Arjo Segers
		! Support listings with second `filename`, this is for example used to specify both data and state files.
		! Added method `Create` to initialize an empty listing that will be filled and saved.
		! Added method `Select` to select records based on time interval.
		!
		!#################################################################
		!
		@@ -50,6 +54,7 @@ module CSO_Listing
		type T_CSO_Record
		! filename:
		character(len=256) :: filename
		character(len=256) :: filename2
		! timerange:
		type(T_CSO_DateTime) :: t1, t2
		! average:
		@@ -57,6 +62,7 @@ module CSO_Listing
		contains
		procedure :: Init => Record_Init
		procedure :: Done => Record_Done
		procedure :: Get => Record_Get
		procedure :: Match => Record_Match
		end type T_CSO_Record

		@@ -72,12 +78,23 @@ module CSO_Listing
		! number of records:
		integer :: nrec
		! storage:
		type(T_CSO_Record), allocatable :: rec(:) ! (n)
		type(T_CSO_Record), allocatable :: rec(:) ! (nrec)
		! selection flags:
		logical, pointer :: selected(:) ! (nrec)
		integer, pointer :: selection(:) ! (nrec)
		integer :: nselect
		!
		contains
		procedure :: Init => Listing_Init
		procedure :: Done => Listing_Done
		procedure :: Show => Listing_Show
		procedure :: Create => Listing_Create
		procedure :: AddRecord => Listing_AddRecord
		procedure :: PutOut => Listing_PutOut
		procedure :: Get => Listing_Get
		procedure :: GetRecord => Listing_GetRecord
		procedure :: SearchFile => Listing_SearchFile
		procedure :: Select => Listing_Select
		end type T_CSO_Listing


		@@ -93,7 +110,8 @@ contains
		! ==============================================================


		subroutine Record_Init( self, filename, t1, t2, status )
		subroutine Record_Init( self, filename, t1, t2, status, &
		filename2 )

		use CSO_DateTimes, only : operator(+), operator(-), operator(*)

		@@ -103,6 +121,7 @@ contains
		character(len=*), intent(in) :: filename
		type(T_CSO_DateTime), intent(in) :: t1, t2
		integer, intent(out) :: status
		character(len=*), intent(in), optional :: filename2

		! --- const ---------------------------

		@@ -119,6 +138,12 @@ contains
		! fill average:
		self%taver = self%t1 + 0.5*( self%t2 - self%t1 )

		! extra?
		if ( present(filename2) ) then
		self%filename2 = trim(filename2)
		else
		self%filename2 = ''
		end if
		! ok
		status = 0

		@@ -130,12 +155,12 @@ contains

		subroutine Record_Done( self, status )

		! --- in/out -----------------
		! --- in/out -----------------------

		class(T_CSO_Record), intent(inout) :: self
		integer, intent(out) :: status

		! --- const ----------------------
		! --- const ------------------------

		character(len=*), parameter :: rname = mname//'/Record_Done'

		@@ -145,6 +170,35 @@ contains
		status = 0

		end subroutine Record_Done
		! ***


		subroutine Record_Get( self, status, filename, filename2, t1, t2 )

		! --- in/out -----------------------

		class(T_CSO_Record), intent(in) :: self
		integer, intent(out) :: status
		character(len=*), intent(out), optional :: filename
		character(len=*), intent(out), optional :: filename2
		type(T_CSO_DateTime), intent(out), optional :: t1, t2

		! --- const ------------------------

		character(len=*), parameter :: rname = mname//'/Record_Get'

		! --- begin ------------------------

		! copy:
		if ( present(filename ) ) filename = trim(self%filename)
		if ( present(filename2) ) filename2 = trim(self%filename2)
		if ( present(t1 ) ) t1 = self%t1
		if ( present(t2 ) ) t2 = self%t2

		! ok
		status = 0

		end subroutine Record_Get


		! ***
		@@ -154,6 +208,7 @@ contains
		!
		! How the record is matched depends on the timekey:
		! 'aver' : record time average in (t1,t2]
		! 'overlap' : record time range overlaps with (t1,t2]
		!
		! Return value:
		! match : .true. if matched
		@@ -183,10 +238,17 @@ contains
		! switch:
		select case ( trim(timekey) )

		!~ average?
		!~ check if record average time is in (t1,t2]:
		case ( 'aver' )
		! average should be in interval:
		match = (t1 < self%taver) .and. (self%taver <= t2)
		!~ check if record range overlaps with (t1,t2]
		case ( 'overlap' )
		! compare boundaries:
		! record self%t1 self%t2
		! o-----------------o
		! target (t1,t2] (t1,t2] (t1,t2]
		match = (self%t1 <= t2) .and. (t1 < self%t2)

		!~ unknown ...
		case default
		@@ -210,6 +272,9 @@ contains
		! ===
		! ==============================================================

		!
		! Create lising object from table file.
		!

		subroutine Listing_Init( self, filename, status )

		@@ -236,6 +301,7 @@ contains
		character(len=1024) :: line0
		integer :: irec
		character(len=1024) :: rec_filename
		character(len=1024) :: rec_filename2
		type(T_CSO_DateTime) :: rec_t1, rec_t2

		! --- begin ----------------------------
		@@ -373,9 +439,17 @@ contains
		write (csol,'(" ",a)') trim(line); call csoErr
		TRACEBACK; status=1; return
		end if
		!~ extra?
		if ( len_trim(line) > 0 ) then
		call CSO_ReadFromLine( line, rec_filename2, status, sep=self%sep )
		IF_NOT_OK_RETURN(status=1)
		else
		rec_filename2 = ''
		end if

		! store:
		call self%rec(irec)%Init( rec_filename, rec_t1, rec_t2, status )
		call self%rec(irec)%Init( rec_filename, rec_t1, rec_t2, status, &
		filename2=rec_filename2 )
		IF_NOT_OK_RETURN(status=1)

		end do ! records
		@@ -388,6 +462,12 @@ contains
		TRACEBACK; status=1; return
		end if

		! storage for selection flags:
		allocate( self%selected(self%nrec), source=.false., stat=status )
		IF_NOT_OK_RETURN(status=1)
		allocate( self%selection(self%nrec), source=-999, stat=status )
		IF_NOT_OK_RETURN(status=1)

		end if ! n>0

		! ok
		@@ -417,7 +497,7 @@ contains
		! --- begin ------------------------

		! any?
		if ( self%nrec > 0 ) then
		if ( allocated(self%rec) ) then
		! loop:
		do irec = 1, self%nrec
		! clear:
		@@ -427,6 +507,13 @@ contains
		! clear:
		deallocate( self%rec, stat=status )
		IF_NOT_OK_RETURN(status=1)
		! clear:
		if ( associated(self%selected) ) then
		deallocate( self%selected, stat=status )
		IF_NOT_OK_RETURN(status=1)
		deallocate( self%selection, stat=status )
		IF_NOT_OK_RETURN(status=1)
		end if
		! empty:
		self%nrec = 0
		end if ! n>0
		@@ -437,6 +524,167 @@ contains
		end subroutine Listing_Done


		!
		! Create empty lising object.
		! Specify target file to which content will be written.
		! Specify maximum number of records.
		!

		subroutine Listing_Create( self, filename, maxrec, status )

		use CSO_File , only : CSO_GetDirname

		! --- in/out ------------------------

		class(T_CSO_Listing), intent(out) :: self
		character(len=*), intent(in) :: filename
		integer, intent(in) :: maxrec
		integer, intent(out) :: status

		! --- const ---------------------------

		character(len=*), parameter :: rname = mname//'/Listing_Create'

		! --- local ----------------------------

		! --- begin ----------------------------

		! store:
		self%filename = trim(filename)

		! directory part:
		call CSO_GetDirname( self%filename, self%dirname, status )
		IF_NOT_OK_RETURN(status=1)

		! formatting:
		self%sep = ';'

		! storage:
		allocate( self%rec(maxrec), stat=status )
		IF_NOT_OK_RETURN(status=1)
		! no records yet:
		self%nrec = 0

		! ok
		status = 0

		end subroutine Listing_Create


		! ***


		subroutine Listing_AddRecord( self, filename, t1, t2, status, &
		filename2 )

		! --- in/out ------------------------

		class(T_CSO_Listing), intent(inout) :: self
		character(len=*), intent(in) :: filename
		type(T_CSO_DateTime), intent(in) :: t1, t2
		integer, intent(out) :: status
		character(len=*), intent(in), optional :: filename2

		! --- const ---------------------------

		character(len=*), parameter :: rname = mname//'/Listing_AddRecord'

		! --- local ----------------------------

		! --- begin ----------------------------

		! increase counter:
		self%nrec = self%nrec + 1
		! check ..
		if ( self%nrec > size(self%rec) ) then
		write (csol,'("could not add record after maximum number of ",i0)') size(self%rec); call csoErr
		TRACEBACK; status=1; return
		end if

		! fill:
		call self%rec(self%nrec)%Init( filename, t1, t2, status, filename2=filename2 )
		IF_NOT_OK_RETURN(status=1)

		! ok
		status = 0

		end subroutine Listing_AddRecord


		! ***


		!
		! Write listing file.
		!

		subroutine Listing_PutOut( self, status )

		use CSO_Comm , only : csoc
		use CSO_File , only : CSO_GetFU
		use CSO_File , only : CSO_CheckDir
		use CSO_DateTimes, only : Pretty

		! --- in/out ------------------------

		class(T_CSO_Listing), intent(in) :: self
		integer, intent(out) :: status

		! --- const ---------------------------

		character(len=*), parameter :: rname = mname//'/Listing_PutOut'

		! --- local ----------------------------

		integer :: fu
		integer :: irec

		! --- begin ----------------------------

		! write from root only ..
		if ( csoc%root ) then

		! create directory if necessary:
		call CSO_CheckDir( self%filename, status )
		IF_NOT_OK_RETURN(status=1)

		! select free file unit:
		Call CSO_GetFU( fu, status )
		IF_NOT_OK_RETURN(status=1)

		! create file:
		open( unit=fu, file=trim(self%filename), iostat=status, form='formatted' )
		if ( status /= 0 ) then
		write (csol,'("from file creation :")'); call csoErr
		write (csol,'(" file name : ",a)') trim(self%filename); call csoErr
		TRACEBACK; status=1; return
		end if

		! write header:
		write (fu,'("filename;start_time;end_time;filename_state")')
		! loop over records:
		do irec = 1, self%nrec
		! write records:
		write (fu,'(7a)') trim(self%rec(irec)%filename), self%sep, &
		trim(Pretty(self%rec(irec)%t1)), self%sep, &
		trim(Pretty(self%rec(irec)%t2)), self%sep, &
		trim(self%rec(irec)%filename2)
		end do ! records

		! close file:
		close( unit=fu, iostat=status )
		if ( status /= 0 ) then
		write (csol,'("from closing file:")'); call csoErr
		write (csol,'(" ",a)') trim(self%filename); call csoErr
		TRACEBACK; status=1; return
		end if

		end if ! root

		! ok
		status = 0

		end subroutine Listing_PutOut
		! ***


		@@ -476,6 +724,124 @@ contains
		end subroutine Listing_Show


		! ***


		subroutine Listing_Get( self, status, nrec, filename )

		! --- in/out -----------------

		class(T_CSO_Listing), intent(in) :: self
		integer, intent(out) :: status
		integer, intent(out), optional :: nrec
		character(len=*), intent(out), optional :: filename

		! --- const ----------------------

		character(len=*), parameter :: rname = mname//'/Listing_Get'

		! --- local ------------------------

		! --- begin ------------------------

		! number of records:
		if ( present(nrec) ) nrec = self%nrec
		! listing file:
		if ( present(filename) ) filename = trim(self%filename)

		! ok
		status = 0

		end subroutine Listing_Get


		! ***

		!
		! Return record valus based on either:
		! irec : record index
		! iselect : selection index
		!

		subroutine Listing_GetRecord( self, status, irec, iselect, &
		filename, filename2, t1, t2 )

		! --- in/out -----------------

		class(T_CSO_Listing), intent(in) :: self
		integer, intent(out) :: status
		integer, intent(in), optional :: irec
		integer, intent(in), optional :: iselect
		character(len=*), intent(out), optional :: filename
		character(len=*), intent(out), optional :: filename2
		type(T_CSO_DateTime), intent(out), optional :: t1, t2

		! --- const ----------------------

		character(len=*), parameter :: rname = mname//'/Listing_GetRecord'

		! --- local ------------------------

		integer :: narg
		integer :: indx
		character(len=1024) :: fname

		! --- begin ------------------------

		! check ...
		narg = count( (/present(irec),present(iselect)/) )
		if ( narg /= 1 ) then
		write (csol,'("exactly one of arguments `irec` and `iselect` sould be present, found: ",i0)') narg; call csoErr
		TRACEBACK; status=1; return
		end if

		! record index:
		if ( present(irec) ) then
		! check ...
		if ( (irec < 1) .or. (irec > self%nrec) ) then
		write (csol,'("record index ",i0," out of range 1,..,",i0)') irec, self%nrec; call csoErr
		TRACEBACK; status=1; return
		end if
		! store:
		indx = irec
		else
		! check ...
		if ( (iselect < 1) .or. (iselect > self%nselect) ) then
		write (csol,'("selection index ",i0," out of range 1,..,",i0)') iselect, self%nselect; call csoErr
		TRACEBACK; status=1; return
		end if
		! store:
		indx = self%selection(iselect)
		end if

		! full path ..
		if ( present(filename) ) then
		! copy:
		call self%rec(indx)%Get( status, filename=fname )
		IF_NOT_OK_RETURN(status=1)
		! include path to listing file:
		write (filename,'(a,"/",a)') trim(self%dirname), trim(fname)
		end if

		! full path ..
		if ( present(filename2) ) then
		! copy:
		call self%rec(indx)%Get( status, filename2=fname )
		IF_NOT_OK_RETURN(status=1)
		! include path to listing file:
		write (filename2,'(a,"/",a)') trim(self%dirname), trim(fname)
		end if

		! timerange:
		call self%rec(indx)%Get( status, t1=t1, t2=t2 )
		IF_NOT_OK_RETURN(status=1)

		! ok
		status = 0

		end subroutine Listing_GetRecord


		! ***

		!
		@@ -483,6 +849,7 @@ contains
		!
		! How the record is matched depends on the timekey:
		! 'aver' : record time average in [t1,t2]
		! 'overlap' : record time range overlaps with (t1,t2]
		!
		! Return value:
		! filename: full path to file, empty if not file found
		@@ -533,5 +900,69 @@ contains
		end subroutine Listing_SearchFile


		! ***

		!
		! Search records that assigned to time range [t1,t2] .
		!
		! How the record is matched depends on the timekey:
		! 'aver' : record time average in [t1,t2]
		! 'overlap' : record time range overlaps with (t1,t2]
		!
		! Return value:
		! nselect : number of selected records
		! status: 0 if ok, >0 error
		!

		subroutine Listing_Select( self, t1, t2, timekey, nselect, selection, status )

		use CSO_DateTimes, only : Pretty

		! --- in/out -----------------

		class(T_CSO_Listing), intent(inout) :: self
		type(T_CSO_Datetime), intent(in) :: t1, t2
		character(len=*), intent(in) :: timekey
		integer, intent(out) :: nselect
		integer, pointer :: selection(:)
		integer, intent(out) :: status

		! --- const ----------------------

		character(len=*), parameter :: rname = mname//'/Listing_Select'

		! --- local ------------------------

		integer :: irec

		! --- begin ------------------------

		! init counter:
		self%nselect = 0
		! loop until first match:
		do irec = 1, self%nrec
		! match?
		call self%rec(irec)%Match( t1,t2, timekey, self%selected(irec), status )
		IF_NOT_OK_RETURN(status=1)
		! selected?
		if ( self%selected(irec) ) then
		! increase counter:
		self%nselect = self%nselect + 1
		! store record index:
		self%selection(self%nselect) = irec
		end if
		end do ! records

		! return number of selected records:
		nselect = self%nselect
		! pointer to selection array:
		selection => self%selection

		! ok
		status = 0

		end subroutine Listing_Select



		end module CSO_Listing