! Earth System Modeling Framework ! Copyright 2002-2003, University Corporation for Atmospheric Research, ! Massachusetts Institute of Technology, Geophysical Fluid Dynamics ! Laboratory, University of Michigan, National Centers for Environmental ! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, ! NASA Goddard Space Flight Center. ! Licensed under the GPL. ! !============================================================================== ! ! ESMF BaseTime Module module ESMF_BaseTimeMod ! !============================================================================== ! ! This file contains the BaseTime class definition and all BaseTime class ! methods. ! !------------------------------------------------------------------------------ ! INCLUDES #include <ESMF_TimeMgr.inc> ! !=============================================================================== !BOPI ! !MODULE: ESMF_BaseTimeMod - Base ESMF time definition ! ! !DESCRIPTION: ! Part of Time Manager F90 API wrapper of C++ implemenation ! ! This module serves only as the common Time definition inherited ! by {\tt ESMF\_TimeInterval} and {\tt ESMF\_Time} ! ! See {\tt ../include/ESMC\_BaseTime.h} for complete description ! !------------------------------------------------------------------------------ ! !USES: use ESMF_BaseMod ! ESMF Base class implicit none ! !------------------------------------------------------------------------------ ! !PRIVATE TYPES: private !------------------------------------------------------------------------------ ! ! ESMF_BaseTime ! ! ! Base class type to match C++ BaseTime class in size only; ! ! all dereferencing within class is performed by C++ implementation type ESMF_BaseTime integer(ESMF_KIND_I8) :: S ! whole seconds integer(ESMF_KIND_I8) :: Sn ! fractional seconds, numerator integer(ESMF_KIND_I8) :: Sd ! fractional seconds, denominator end type ESMF_BaseTime !------------------------------------------------------------------------------ ! !PUBLIC TYPES: public ESMF_BaseTime !------------------------------------------------------------------------------ ! ! !PUBLIC MEMBER FUNCTIONS: ! ! overloaded operators public seccmp public normalize_basetime public operator(+) private ESMF_BaseTimeSum public operator(-) private ESMF_BaseTimeDifference public operator(/) private ESMF_BaseTimeQuotI private ESMF_BaseTimeQuotI8 public operator(.EQ.) private ESMF_BaseTimeEQ public operator(.NE.) private ESMF_BaseTimeNE public operator(.LT.) private ESMF_BaseTimeLT public operator(.GT.) private ESMF_BaseTimeGT public operator(.LE.) private ESMF_BaseTimeLE public operator(.GE.) private ESMF_BaseTimeGE !============================================================================== ! ! INTERFACE BLOCKS ! !============================================================================== interface operator(+) module procedure ESMF_BaseTimeSum end interface operator(+) interface operator(-) module procedure ESMF_BaseTimeDifference end interface operator(-) interface operator(/) module procedure ESMF_BaseTimeQuotI,ESMF_BaseTimeQuotI8 end interface operator(/) interface operator(.EQ.) module procedure ESMF_BaseTimeEQ end interface operator(.EQ.) interface operator(.NE.) module procedure ESMF_BaseTimeNE end interface operator(.NE.) interface operator(.LT.) module procedure ESMF_BaseTimeLT end interface operator(.LT.) interface operator(.GT.) module procedure ESMF_BaseTimeGT end interface operator(.GT.) interface operator(.LE.) module procedure ESMF_BaseTimeLE end interface operator(.LE.) interface operator(.GE.) module procedure ESMF_BaseTimeGE end interface operator(.GE.) !============================================================================== contains !============================================================================== SUBROUTINE normalize_basetime( basetime ) ! Factor so abs(Sn) < Sd and ensure that signs of S and Sn match. ! Also, enforce consistency. ! YR and MM fields are ignored. IMPLICIT NONE TYPE(ESMF_BaseTime), INTENT(INOUT) :: basetime !PRINT *,'DEBUG: BEGIN normalize_basetime()' ! Consistency check... IF ( basetime%Sd < 0 ) THEN CALL wrf_error_fatal( & 'normalize_basetime: denominator of seconds cannot be negative' ) ENDIF IF ( ( basetime%Sd == 0 ) .AND. ( basetime%Sn .NE. 0 ) ) THEN CALL wrf_error_fatal( & 'normalize_basetime: denominator of seconds cannot be zero when numerator is non-zero' ) ENDIF ! factor so abs(Sn) < Sd IF ( basetime%Sd > 0 ) THEN IF ( ABS( basetime%Sn ) .GE. basetime%Sd ) THEN !PRINT *,'DEBUG: normalize_basetime() A1: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd basetime%S = basetime%S + ( basetime%Sn / basetime%Sd ) basetime%Sn = mod( basetime%Sn, basetime%Sd ) !PRINT *,'DEBUG: normalize_basetime() A2: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd ENDIF ! change sign of Sn if it does not match S IF ( ( basetime%S > 0 ) .AND. ( basetime%Sn < 0 ) ) THEN !PRINT *,'DEBUG: normalize_basetime() B1: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd basetime%S = basetime%S - 1_ESMF_KIND_I8 basetime%Sn = basetime%Sn + basetime%Sd !PRINT *,'DEBUG: normalize_basetime() B2: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd ENDIF IF ( ( basetime%S < 0 ) .AND. ( basetime%Sn > 0 ) ) THEN !PRINT *,'DEBUG: normalize_basetime() C1: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd basetime%S = basetime%S + 1_ESMF_KIND_I8 basetime%Sn = basetime%Sn - basetime%Sd !PRINT *,'DEBUG: normalize_basetime() C2: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd ENDIF ENDIF !PRINT *,'DEBUG: END normalize_basetime()' END SUBROUTINE normalize_basetime !============================================================================== ! Add two basetimes FUNCTION ESMF_BaseTimeSum( basetime1, basetime2 ) TYPE(ESMF_BaseTime) :: ESMF_BaseTimeSum TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 ! locals INTEGER (ESMF_KIND_I8) :: Sn1, Sd1, Sn2, Sd2, lcd ! PRINT *,'DEBUG: BEGIN ESMF_BaseTimeSum()' ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): basetime1%S = ',basetime1%S ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): basetime1%Sn = ',basetime1%Sn ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): basetime1%Sd = ',basetime1%Sd ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): basetime2%S = ',basetime2%S ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): basetime2%Sn = ',basetime2%Sn ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): basetime2%Sd = ',basetime2%Sd ESMF_BaseTimeSum = basetime1 ESMF_BaseTimeSum%S = ESMF_BaseTimeSum%S + basetime2%S Sn1 = basetime1%Sn Sd1 = basetime1%Sd Sn2 = basetime2%Sn Sd2 = basetime2%Sd ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): Sn1 = ',Sn1 ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): Sd1 = ',Sd1 ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): Sn2 = ',Sn2 ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): Sd2 = ',Sd2 IF ( ( Sd1 .EQ. 0 ) .AND. ( Sd2 .EQ. 0 ) ) THEN ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): no fractions' ESMF_BaseTimeSum%Sn = 0 ESMF_BaseTimeSum%Sd = 0 ELSE IF ( ( Sd1 .NE. 0 ) .AND. ( Sd2 .EQ. 0 ) ) THEN ESMF_BaseTimeSum%Sn = Sn1 ESMF_BaseTimeSum%Sd = Sd1 ELSE IF ( ( Sd1 .EQ. 0 ) .AND. ( Sd2 .NE. 0 ) ) THEN ESMF_BaseTimeSum%Sn = Sn2 ESMF_BaseTimeSum%Sd = Sd2 ELSE IF ( ( Sd1 .NE. 0 ) .AND. ( Sd2 .NE. 0 ) ) THEN CALL compute_lcd( Sd1 , Sd2 , lcd ) ESMF_BaseTimeSum%Sd = lcd ESMF_BaseTimeSum%Sn = (Sn1 * lcd / Sd1) + (Sn2 * lcd / Sd2) ENDIF ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): ESMF_BaseTimeSum%S = ',ESMF_BaseTimeSum%S ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): ESMF_BaseTimeSum%Sn = ',ESMF_BaseTimeSum%Sn ! PRINT *,'DEBUG: ESMF_BaseTimeSum(): ESMF_BaseTimeSum%Sd = ',ESMF_BaseTimeSum%Sd CALL normalize_basetime( ESMF_BaseTimeSum ) ! PRINT *,'DEBUG: END ESMF_BaseTimeSum()' END FUNCTION ESMF_BaseTimeSum ! Subtract two basetimes FUNCTION ESMF_BaseTimeDifference( basetime1, basetime2 ) TYPE(ESMF_BaseTime) :: ESMF_BaseTimeDifference TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 ! locals TYPE(ESMF_BaseTime) :: neg2 neg2%S = -basetime2%S neg2%Sn = -basetime2%Sn neg2%Sd = basetime2%Sd ESMF_BaseTimeDifference = basetime1 + neg2 END FUNCTION ESMF_BaseTimeDifference ! Divide basetime by 8-byte integer FUNCTION ESMF_BaseTimeQuotI8( basetime, divisor ) TYPE(ESMF_BaseTime) :: ESMF_BaseTimeQuotI8 TYPE(ESMF_BaseTime), INTENT(IN) :: basetime INTEGER(ESMF_KIND_I8), INTENT(IN) :: divisor ! locals INTEGER(ESMF_KIND_I8) :: d, n, dinit !PRINT *,'DEBUG ESMF_BaseTimeQuotI8() A: S,Sn,Sd = ', & ! basetime%S,basetime%Sn,basetime%Sd !PRINT *,'DEBUG ESMF_BaseTimeQuotI8() A: divisor = ', divisor IF ( divisor == 0_ESMF_KIND_I8 ) THEN CALL wrf_error_fatal( 'ESMF_BaseTimeQuotI8: divide by zero' ) ENDIF !$$$ move to default constructor ESMF_BaseTimeQuotI8%S = 0 ESMF_BaseTimeQuotI8%Sn = 0 ESMF_BaseTimeQuotI8%Sd = 0 ! convert to a fraction and divide by multipling the denonminator by ! the divisor IF ( basetime%Sd == 0 ) THEN dinit = 1_ESMF_KIND_I8 ELSE dinit = basetime%Sd ENDIF n = basetime%S * dinit + basetime%Sn d = dinit * divisor !PRINT *,'DEBUG ESMF_BaseTimeQuotI8() B: n,d = ',n,d CALL simplify( n, d, ESMF_BaseTimeQuotI8%Sn, ESMF_BaseTimeQuotI8%Sd ) !PRINT *,'DEBUG ESMF_BaseTimeQuotI8() C: S,Sn,Sd = ', & ! ESMF_BaseTimeQuotI8%S,ESMF_BaseTimeQuotI8%Sn,ESMF_BaseTimeQuotI8%Sd CALL normalize_basetime( ESMF_BaseTimeQuotI8 ) !PRINT *,'DEBUG ESMF_BaseTimeQuotI8() D: S,Sn,Sd = ', & ! ESMF_BaseTimeQuotI8%S,ESMF_BaseTimeQuotI8%Sn,ESMF_BaseTimeQuotI8%Sd END FUNCTION ESMF_BaseTimeQuotI8 ! Divide basetime by integer FUNCTION ESMF_BaseTimeQuotI( basetime, divisor ) TYPE(ESMF_BaseTime) :: ESMF_BaseTimeQuotI TYPE(ESMF_BaseTime), INTENT(IN) :: basetime INTEGER, INTENT(IN) :: divisor IF ( divisor == 0 ) THEN CALL wrf_error_fatal( 'ESMF_BaseTimeQuotI: divide by zero' ) ENDIF ESMF_BaseTimeQuotI = basetime / INT( divisor, ESMF_KIND_I8 ) END FUNCTION ESMF_BaseTimeQuotI ! .EQ. for two basetimes FUNCTION ESMF_BaseTimeEQ( basetime1, basetime2 ) LOGICAL :: ESMF_BaseTimeEQ TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 INTEGER :: retval CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, & basetime2%S, basetime2%Sn, basetime2%Sd, & retval ) ESMF_BaseTimeEQ = ( retval .EQ. 0 ) END FUNCTION ESMF_BaseTimeEQ ! .NE. for two basetimes FUNCTION ESMF_BaseTimeNE( basetime1, basetime2 ) LOGICAL :: ESMF_BaseTimeNE TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 INTEGER :: retval CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, & basetime2%S, basetime2%Sn, basetime2%Sd, & retval ) ESMF_BaseTimeNE = ( retval .NE. 0 ) END FUNCTION ESMF_BaseTimeNE ! .LT. for two basetimes FUNCTION ESMF_BaseTimeLT( basetime1, basetime2 ) LOGICAL :: ESMF_BaseTimeLT TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 INTEGER :: retval CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, & basetime2%S, basetime2%Sn, basetime2%Sd, & retval ) ESMF_BaseTimeLT = ( retval .LT. 0 ) END FUNCTION ESMF_BaseTimeLT ! .GT. for two basetimes FUNCTION ESMF_BaseTimeGT( basetime1, basetime2 ) LOGICAL :: ESMF_BaseTimeGT TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 INTEGER :: retval CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, & basetime2%S, basetime2%Sn, basetime2%Sd, & retval ) ESMF_BaseTimeGT = ( retval .GT. 0 ) END FUNCTION ESMF_BaseTimeGT ! .LE. for two basetimes FUNCTION ESMF_BaseTimeLE( basetime1, basetime2 ) LOGICAL :: ESMF_BaseTimeLE TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 INTEGER :: retval CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, & basetime2%S, basetime2%Sn, basetime2%Sd, & retval ) ESMF_BaseTimeLE = ( retval .LE. 0 ) END FUNCTION ESMF_BaseTimeLE ! .GE. for two basetimes FUNCTION ESMF_BaseTimeGE( basetime1, basetime2 ) LOGICAL :: ESMF_BaseTimeGE TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 INTEGER :: retval CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, & basetime2%S, basetime2%Sn, basetime2%Sd, & retval ) ESMF_BaseTimeGE = ( retval .GE. 0 ) END FUNCTION ESMF_BaseTimeGE !============================================================================== SUBROUTINE compute_lcd( e1, e2, lcd ) IMPLICIT NONE INTEGER(ESMF_KIND_I8), INTENT(IN) :: e1, e2 INTEGER(ESMF_KIND_I8), INTENT(OUT) :: lcd INTEGER, PARAMETER :: nprimes = 9 INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/) INTEGER i INTEGER(ESMF_KIND_I8) d1, d2, p d1 = e1 ; d2 = e2 IF ( d1 .EQ. 0 .AND. d2 .EQ. 0 ) THEN ; lcd = 1 ; RETURN ; ENDIF IF ( d1 .EQ. 0 ) d1 = d2 IF ( d2 .EQ. 0 ) d2 = d1 IF ( d1 .EQ. d2 ) THEN ; lcd = d1 ; RETURN ; ENDIF lcd = d1 * d2 DO i = 1, nprimes p = primes(i) DO WHILE (lcd/p .NE. 0 .AND. & mod(lcd/p,d1) .EQ. 0 .AND. mod(lcd/p,d2) .EQ. 0) lcd = lcd / p END DO ENDDO END SUBROUTINE compute_lcd !============================================================================== SUBROUTINE simplify( ni, di, no, do ) IMPLICIT NONE INTEGER(ESMF_KIND_I8), INTENT(IN) :: ni, di INTEGER(ESMF_KIND_I8), INTENT(OUT) :: no, do INTEGER, PARAMETER :: nprimes = 9 INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/) INTEGER(ESMF_KIND_I8) :: pr, d, n INTEGER :: np LOGICAL keepgoing IF ( ni .EQ. 0 ) THEN do = 1 no = 0 RETURN ENDIF IF ( mod( di , ni ) .EQ. 0 ) THEN do = di / ni no = 1 RETURN ENDIF d = di n = ni DO np = 1, nprimes pr = primes(np) keepgoing = .TRUE. DO WHILE ( keepgoing ) keepgoing = .FALSE. IF ( d/pr .NE. 0 .AND. n/pr .NE. 0 .AND. MOD(d,pr) .EQ. 0 .AND. MOD(n,pr) .EQ. 0 ) THEN d = d / pr n = n / pr keepgoing = .TRUE. ENDIF ENDDO ENDDO do = d no = n RETURN END SUBROUTINE simplify !============================================================================== ! spaceship operator for seconds + Sn/Sd SUBROUTINE seccmp(S1, Sn1, Sd1, S2, Sn2, Sd2, retval ) IMPLICIT NONE INTEGER, INTENT(OUT) :: retval ! ! !ARGUMENTS: INTEGER(ESMF_KIND_I8), INTENT(IN) :: S1, Sn1, Sd1 INTEGER(ESMF_KIND_I8), INTENT(IN) :: S2, Sn2, Sd2 ! local INTEGER(ESMF_KIND_I8) :: lcd, n1, n2 n1 = Sn1 n2 = Sn2 if ( ( n1 .ne. 0 ) .or. ( n2 .ne. 0 ) ) then CALL compute_lcd( Sd1, Sd2, lcd ) if ( Sd1 .ne. 0 ) n1 = n1 * ( lcd / Sd1 ) if ( Sd2 .ne. 0 ) n2 = n2 * ( lcd / Sd2 ) endif if ( S1 .GT. S2 ) retval = 1 if ( S1 .LT. S2 ) retval = -1 IF ( S1 .EQ. S2 ) THEN IF (n1 .GT. n2) retval = 1 IF (n1 .LT. n2) retval = -1 IF (n1 .EQ. n2) retval = 0 ENDIF END SUBROUTINE seccmp !============================================================================== end module ESMF_BaseTimeMod