Skip to content
Snippets Groups Projects
Commit ce2bd940 authored by WAUTELET Philippe's avatar WAUTELET Philippe
Browse files

Philippe 27/10/2022: datetime: add <= and > operators and improve older...

Philippe 27/10/2022: datetime: add <= and > operators and improve older comparison subroutines (more robust but slower)
parent 63c80010
No related branches found
No related tags found
No related merge requests found
......@@ -7,7 +7,7 @@
! P. Wautelet 22/02/2019: use MOD intrinsics with same kind for all arguments (to respect Fortran standard)
! P. Wautelet 19/04/2019: use modd_precision kinds
! P. Wautelet 20/07/2021: modify DATETIME_TIME2REFERENCE and DATETIME_DISTANCE to allow correct computation with 32-bit floats
! P. Wautelet 27/10/2022: add + operator via DATETIME_TIME_ADD subroutine
! P. Wautelet 27/10/2022: add +, <= and > operators and improve older comparison subroutines (more robust but slower)
!-----------------------------------------------------------------
MODULE MODE_DATETIME
!
......@@ -21,6 +21,8 @@ PRIVATE
!
PUBLIC :: DATETIME_DISTANCE, DATETIME_CORRECTDATE
PUBLIC :: OPERATOR(<)
PUBLIC :: OPERATOR(<=)
PUBLIC :: OPERATOR(>)
PUBLIC :: OPERATOR(>=)
PUBLIC :: OPERATOR(+)
!
......@@ -32,6 +34,14 @@ INTERFACE OPERATOR(<)
MODULE PROCEDURE DATETIME_LT
END INTERFACE
!
INTERFACE OPERATOR(<=)
MODULE PROCEDURE DATETIME_LE
END INTERFACE
!
INTERFACE OPERATOR(>)
MODULE PROCEDURE DATETIME_GT
END INTERFACE
!
INTERFACE OPERATOR(>=)
MODULE PROCEDURE DATETIME_GE
END INTERFACE
......@@ -260,16 +270,23 @@ SELECT CASE(KMONTH)
END SELECT
!
END SUBROUTINE DATETIME_GETMONTHLGT
FUNCTION DATETIME_LT(TPT1, TPT2) RESULT (OLT)
!
! TRUE if TPT1 .LT. TPT2
!
ELEMENTAL FUNCTION DATETIME_LT(TPT1, TPT2) RESULT (OLT)
IMPLICIT NONE
LOGICAL :: OLT
TYPE(DATE_TIME), INTENT(IN) :: TPT1, TPT2
!
! TRUE if TPT1 .LT. TPT2
!
!
LOGICAL :: OLT
INTEGER :: IDAYS1, IDAYS2
REAL :: ZSEC1, ZSEC2
#if 0
!Simpler but works only for correct dates (see DATETIME_CORRECTDATE)
IF ( TPT1%nyear .EQ. TPT2%nyear ) THEN
IF ( TPT1%nmonth .EQ. TPT2%nmonth ) THEN
IF ( TPT1%nday .EQ. TPT2%nday ) THEN
......@@ -283,23 +300,97 @@ IF ( TPT1%nyear .EQ. TPT2%nyear ) THEN
ELSE
OLT = TPT1%nyear .LT. TPT2%nyear
ENDIF
!
#else
CALL DATETIME_TIME2REFERENCE( TPT1, IDAYS1, ZSEC1 )
CALL DATETIME_TIME2REFERENCE( TPT2, IDAYS2, ZSEC2 )
OLT = .FALSE.
IF ( IDAYS1 < IDAYS2 ) THEN
OLT = .TRUE.
ELSE IF ( IDAYS1 == IDAYS2 ) THEN
IF ( ZSEC1 < ZSEC2 ) OLT = .TRUE.
END IF
#endif
END FUNCTION DATETIME_LT
FUNCTION DATETIME_LE(TPT1, TPT2) RESULT (OLE)
!
! TRUE if TPT1 <= TPT2
!
ELEMENTAL FUNCTION DATETIME_GE(TPT1, TPT2) RESULT (OLT)
IMPLICIT NONE
LOGICAL :: OLT
TYPE(DATE_TIME), INTENT(IN) :: TPT1, TPT2
LOGICAL :: OLE
INTEGER :: IDAYS1, IDAYS2
REAL :: ZSEC1, ZSEC2
#if 0
!Simpler but works only for correct dates (see DATETIME_CORRECTDATE)
IF ( TPT1%nyear == TPT2%nyear ) THEN
IF ( TPT1%nmonth == TPT2%nmonth ) THEN
IF ( TPT1%nday == TPT2%nday ) THEN
OLE = TPT1%xtime <= TPT2%xtime
ELSE
OLE = TPT1%nday <= TPT2%nday
END IF
ELSE
OLE = TPT1%nmonth <= TPT2%nmonth
END IF
ELSE
OLE = TPT1%nyear <= TPT2%nyear
ENDIF
#else
CALL DATETIME_TIME2REFERENCE( TPT1, IDAYS1, ZSEC1 )
CALL DATETIME_TIME2REFERENCE( TPT2, IDAYS2, ZSEC2 )
OLE = .FALSE.
IF ( IDAYS1 < IDAYS2 ) THEN
OLE = .TRUE.
ELSE IF ( IDAYS1 == IDAYS2 ) THEN
IF ( ZSEC1 <= ZSEC2 ) OLE = .TRUE.
END IF
#endif
!
! TRUE if TPT1 .GE. TPT2
END FUNCTION DATETIME_LE
FUNCTION DATETIME_GE(TPT1, TPT2) RESULT (OGE)
!
OLT = .NOT.DATETIME_LT(TPT1,TPT2)
! TRUE if TPT1 >=. TPT2
!
IMPLICIT NONE
TYPE(DATE_TIME), INTENT(IN) :: TPT1, TPT2
LOGICAL :: OGE
OGE = .NOT. DATETIME_LT( TPT1, TPT2 )
END FUNCTION DATETIME_GE
ELEMENTAL FUNCTION DATETIME_TIME_ADD( TPIN, PTIME ) RESULT ( TPOUT )
FUNCTION DATETIME_GT(TPT1, TPT2) RESULT (OGT)
!
! TRUE if TPT1 > TPT2
!
IMPLICIT NONE
TYPE(DATE_TIME), INTENT(IN) :: TPT1, TPT2
LOGICAL :: OGT
OGT = .NOT. DATETIME_LE( TPT1, TPT2 )
END FUNCTION DATETIME_GT
FUNCTION DATETIME_TIME_ADD( TPIN, PTIME ) RESULT ( TPOUT )
IMPLICIT NONE
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment