MAPL_CF_Time.F90 Source File

#include "MAPL_Exceptions.h"
#include "MAPL_ErrLog.h"
module MAPL_CF_Time

   use, intrinsic :: iso_fortran_env, only : R64 => real64
   use MAPL_KeywordEnforcerMod
   use MAPL_ExceptionHandling
   use MAPL_DateTime_Parsing

   implicit none

! Comment to test all procedures
   private

! PUBLIC PROCEDURES (ACCESS):
   public :: extract_ISO8601_from_CF_Time
   public :: extract_CF_Time_duration
   public :: extract_CF_Time_unit
   public :: convert_CF_Time_to_datetime_duration
! Convert ISO8601 datetime string to CF_Time_base_datetime
   public :: convert_ISO8601_to_CF_Time_base_datetime
   public :: CF_Time, CF_Time_Integer, CF_Time_Real

   public :: MAX_CHARACTER_LENGTH

! PUBLIC PROCEDURES (INTERFACES):

! Extract an ISO8601 datetime string from the base datetime string in a CF_Time. 
   interface extract_ISO8601_from_CF_Time
      module procedure :: extract_ISO8601_from_CF_Time_units
      module procedure :: extract_ISO8601_from_CF_Time_cf_time
   end interface extract_ISO8601_from_CF_Time

! Extract the duration of a CF Time.
   interface extract_CF_Time_duration
      module procedure :: extract_CF_Time_duration_cf_time_real
      module procedure :: extract_CF_Time_duration_cf_time_integer
   end interface extract_CF_Time_duration

! Extract the time units from a CF Time.
   interface extract_CF_Time_unit
      module procedure :: extract_CF_Time_unit_cf_time
      module procedure :: extract_CF_Time_unit_units
   end interface extract_CF_Time_unit

! Extract datetime_duration from CF Time.
   interface convert_CF_Time_to_datetime_duration
      module procedure :: convert_CF_Time_to_datetime_duration_integer
      module procedure :: convert_CF_Time_to_datetime_duration_real
      module procedure :: convert_CF_Time_to_datetime_duration_integer_duration
      module procedure :: convert_CF_Time_to_datetime_duration_real_duration
   end interface convert_CF_Time_to_datetime_duration


! PRIVATE INTERFACES:

   interface split
      module procedure :: split_characters
   end interface split


! TYPES (DEFINITIONS):

! CF_TIME: derived type to hold the data for CF Time values
   type, abstract :: CF_Time
      logical :: is_valid
      character(len=:), allocatable :: time_unit
      character(len=:), allocatable :: base_datetime
   end type CF_Time

   type, extends(CF_Time) :: CF_Time_Integer
      integer :: duration
   end type CF_Time_Integer

   type, extends(CF_Time) :: CF_Time_Real
      real(kind=R64) :: duration
   end type CF_Time_Real
   
   interface CF_Time_Integer
      module procedure :: construct_cf_time_integer
   end interface CF_Time_Integer

   interface CF_Time_Real
      module procedure :: construct_cf_time_real
   end interface CF_Time_Real

! END CF_TIME 


! CONSTANTS:
   character, parameter :: DATE_DELIM = '-'
   character, parameter :: TIME_DELIM = ':'
   character, parameter :: ISO_DELIM = 'T'
   character(len=2), parameter :: CF_DELIM = ' ' // ISO_DELIM
   character(len=*), parameter :: EMPTY_STRING = ''
   character, parameter :: DECIMAL_POINT = '.'
   !character(len=*), parameter :: DIGIT_CHARACTERS = '1234567890'

contains


! PUBLIC PROCEDURES (DEFINITION):

   subroutine extract_ISO8601_from_CF_Time_units(units, isostring, rc)
      character(len=*), intent(in) :: units
      character(len=MAX_CHARACTER_LENGTH), intent(out) :: isostring
      integer, optional, intent(out) :: rc
      integer :: status
      
      call extract_ISO8601_from_CF_Time(CF_Time_Integer(0, units), isostring, _RC)

      _RETURN(_SUCCESS)

   end subroutine extract_ISO8601_from_CF_Time_units

   subroutine extract_ISO8601_from_CF_Time_cf_time(cft, isostring, rc)
      class(CF_Time), intent(in) :: cft
      character(len=MAX_CHARACTER_LENGTH), intent(out) :: isostring
      integer, optional, intent(out) :: rc 

      if(cft % is_valid) then
         isostring = convert_CF_Time_datetime_string_to_ISO8601(cft % base_datetime)
         _RETURN(_SUCCESS)
      end if
      
      _RETURN(_FAILURE)

   end subroutine extract_ISO8601_from_CF_Time_cf_time
   
   subroutine extract_CF_Time_duration_cf_time_real(cft, duration, rc)
      class(CF_Time_Real), intent(in) :: cft
      real(kind=R64), intent(out) :: duration
      integer, optional, intent(out) :: rc
      
      if(cft % is_valid) then
         duration = cft % duration
         _RETURN(_SUCCESS)
      end if

      _RETURN(_FAILURE)

   end subroutine extract_CF_Time_duration_cf_time_real

   subroutine extract_CF_Time_duration_cf_time_integer(cft, duration, rc)
      class(CF_Time_Integer), intent(in) :: cft
      integer, intent(out) :: duration
      integer, optional, intent(out) :: rc
      
      if(cft % is_valid) then
         duration = cft % duration
         _RETURN(_SUCCESS)
      end if

      _RETURN(_FAILURE)
      
   end subroutine extract_CF_Time_duration_cf_time_integer
   
   subroutine extract_CF_Time_unit_cf_time(cft, time_unit, rc) 
      class(CF_Time), intent(in) :: cft
      character(len=MAX_CHARACTER_LENGTH), intent(out) :: time_unit
      integer, optional, intent(out) :: rc

      if(cft % is_valid) then
         time_unit = cft % time_unit
         _RETURN(_SUCCESS)
      end if

      _RETURN(_FAILURE)

   end subroutine extract_CF_Time_unit_cf_time

   subroutine extract_CF_Time_unit_units(units, time_unit, rc)
      character(len=*), intent(in) :: units
      character(len=MAX_CHARACTER_LENGTH), intent(out) :: time_unit
      integer, optional, intent(out) :: rc
      integer :: status

      call extract_CF_Time_unit(CF_Time_Integer(0, units), time_unit, _RC)

      _RETURN(_SUCCESS)

   end subroutine extract_CF_Time_unit_units

   subroutine convert_CF_Time_to_datetime_duration_integer(cft, dt_duration, rc)
      class(CF_Time_Integer), intent(in) :: cft
      type(datetime_duration), intent(out) :: dt_duration
      integer, optional, intent(out) :: rc
      integer(kind(TIME_UNIT)) :: tu

      if(.not. cft % is_valid) then
         _RETURN(_FAILURE)
      end if

      tu = get_time_unit(cft % time_unit)
      _ASSERT(tu /= UNKNOWN_TIME_UNIT, 'Unable to find TIME_UNIT ' // cft % time_unit) 

      call dt_duration % set_value(tu, cft % duration)
      
      _RETURN(_SUCCESS)

   end subroutine convert_CF_Time_to_datetime_duration_integer
   
   subroutine convert_CF_Time_to_datetime_duration_real(cft, dt_duration, rc)
      class(CF_Time_Real), intent(in) :: cft
      type(datetime_duration), intent(out) :: dt_duration
      integer, optional, intent(out) :: rc
      integer(kind(TIME_UNIT)) :: tu

      if(.not. cft % is_valid) then
         _RETURN(_FAILURE)
      end if

      tu = get_time_unit(cft % time_unit)
      _ASSERT(tu /= UNKNOWN_TIME_UNIT, 'Unable to find TIME_UNIT ' // cft % time_unit) 

      call dt_duration % set_value(tu, cft % duration)

      _RETURN(_SUCCESS)

   end subroutine convert_CF_Time_to_datetime_duration_real

   subroutine convert_CF_Time_to_datetime_duration_integer_duration(duration, units, dt_duration, rc)
      integer, intent(in) :: duration
      character(len=*), intent(in) :: units
      type(datetime_duration), intent(out) :: dt_duration
      integer, optional, intent(out) :: rc
      integer :: status

      call convert_CF_Time_to_datetime_duration(CF_Time_Integer(duration, units), dt_duration, _RC)

      _RETURN(_SUCCESS)

   end subroutine convert_CF_Time_to_datetime_duration_integer_duration
   
   subroutine convert_CF_Time_to_datetime_duration_real_duration(duration, units, dt_duration, rc)
      real(kind=R64), intent(in) :: duration
      character(len=*), intent(in) :: units
      type(datetime_duration), intent(out) :: dt_duration
      integer, optional, intent(out) :: rc
      integer :: status

      call convert_CF_Time_to_datetime_duration(CF_Time_Real(duration, units), dt_duration, _RC)

      _RETURN(_SUCCESS)

   end subroutine convert_CF_Time_to_datetime_duration_real_duration
   
   function convert_CF_Time_datetime_string_to_ISO8601(datetime_string) result(isodatetime)
      character(len=*), intent(in) :: datetime_string
      character(len=MAX_CHARACTER_LENGTH) :: isodatetime
      character(len=MAX_CHARACTER_LENGTH) :: remainder
      character(len=MAX_CHARACTER_LENGTH) :: part(NUM_TIME_UNITS)

      isodatetime = EMPTY_STRING
      remainder = datetime_string

      call split(trim(remainder), part(YEAR_TIME_UNIT), remainder, DATE_DELIM)
      call split(trim(remainder), part(MONTH_TIME_UNIT), remainder, DATE_DELIM)
      call split(trim(remainder), part(DAY_TIME_UNIT), remainder, CF_DELIM)
      call split(trim(remainder), part(HOUR_TIME_UNIT), remainder, TIME_DELIM)
      call split(trim(remainder), part(MINUTE_TIME_UNIT), remainder, TIME_DELIM)
      part(SECOND_TIME_UNIT) = trim(remainder) 

      call update_datetime(isodatetime, part(YEAR_TIME_UNIT), 4, DATE_DELIM)
      call update_datetime(isodatetime, part(MONTH_TIME_UNIT), 2, DATE_DELIM)
      call update_datetime(isodatetime, part(DAY_TIME_UNIT), 2, ISO_DELIM)
      call update_datetime(isodatetime, part(HOUR_TIME_UNIT), 2, TIME_DELIM)
      call update_datetime(isodatetime, part(MINUTE_TIME_UNIT), 2, TIME_DELIM)
      call update_datetime(isodatetime, part(SECOND_TIME_UNIT), 2)
      
   contains

      subroutine update_datetime(datetime_, text, width, delm)
         character(len=MAX_CHARACTER_LENGTH), intent(inout) :: datetime_
         character(len=*), intent(in) :: text
         integer, optional, intent(in) :: width
         character(len=*), optional, intent(in) :: delm
         character(len=MAX_CHARACTER_LENGTH) :: text_
         
         text_ = text
         if(present(width)) text_ = zero_pad(text, width)
         datetime_ = trim(datetime_) // trim(text_)
         if(present(delm)) datetime_ = trim(datetime_) // trim(delm)

      end subroutine update_datetime

   end function convert_CF_Time_datetime_string_to_ISO8601

   function convert_ISO8601_to_CF_Time_base_datetime(isostring) result(base_datetime) 
      character(len=*), intent(in) :: isostring
      character(len=len(isostring)) :: base_datetime

      base_datetime = remove_zero_pad(isostring)
      base_datetime = substitute(base_datetime, 'T', ' ')

   end function convert_ISO8601_to_CF_Time_base_datetime 

! END PUBLIC PROCEDURES (DEFINITION)


! CONSTRUCTORS:

! CF_TIME (CONSTRUCTORS):

   function construct_cf_time_integer(duration, units) result (cft)
      integer, intent(in) :: duration
      character(len=*), intent(in) :: units
      type(CF_Time_Integer) :: cft
      
      cft % duration = duration
      call initialize_cf_time(cft, units)

   end function construct_cf_time_integer

   function construct_cf_time_real(duration, units) result (cft)
      real(kind=R64), intent(in) :: duration
      character(len=*), intent(in) :: units
      type(CF_Time_Real) :: cft
      
      cft % duration = duration
      call initialize_cf_time(cft, units)

   end function construct_cf_time_real

   subroutine initialize_cf_time(cft, units)
      class(CF_Time), intent(inout) :: cft
      character(len=*), intent(in) :: units
      character(len=MAX_CHARACTER_LENGTH) :: token, remainder
      
      cft % is_valid = .FALSE.
      remainder = units
      if(len_trim(remainder) == 0) return
      call split(trim(remainder), token, remainder, CF_DELIM)
      cft % time_unit = token
      call split(trim(remainder), token, remainder, CF_DELIM)
      cft % base_datetime = remainder
      cft % is_valid = .TRUE.

   end subroutine initialize_cf_time

! END CONSTRUCTORS


! UTILITY PROCEDURES:

! ZERO_PAD - UTILITY
   function zero_pad(number_string, width) result(padded)
      character(len=*), intent(in) :: number_string
      integer, intent(in) :: width
      character(len=MAX_CHARACTER_LENGTH) :: padded
      integer :: num_zeros

      num_zeros = width - len_trim(number_string)
      if(num_zeros > 0) then
         padded = repeat('0', num_zeros) // number_string
      else
         padded = number_string
      end if

   end function zero_pad

! SPLITTER - UTILITY
   subroutine split_characters(characters, token, remainder, delimiters)
      character(len=*), intent(in) :: characters
      character(len=MAX_CHARACTER_LENGTH), intent(out) :: token
      character(len=MAX_CHARACTER_LENGTH), intent(out) :: remainder
      character(len=*), optional, intent(in) :: delimiters
      character(len=:), allocatable :: delims
      integer :: i

      delims = ' '
      if(present(delimiters)) delims = delimiters
      
      i = scan(characters, delims)

      if(i > 0) then
         token = characters(:(i-1))
         remainder = characters((i+1):) 
      else
         token = characters
         remainder = EMPTY_STRING
      endif

   end subroutine split_characters
      
! UTILITIES

   function remove_zero_pad(isostring) result(unpadded)
      character(len=*), intent(in) :: isostring
      character(len=len(isostring)) :: unpadded
      character(len=:), allocatable :: part(:)
      character(len=len(isostring)) :: fraction_part
      integer :: i

      part = get_ISO8601_substrings(isostring)
      fraction_part = get_ISO8601_fractional_seconds(isostring)
      unpadded = trim(part(1))
      do i = 2, size(part)
         part(i) = strip_zero(part(i))
         unpadded = trim(unpadded) // trim(part(i)) 
      end do

      fraction_part = strip_zero(fraction_part, back = .TRUE.)
      if(len_trim(fraction_part) > 0) unpadded = trim(unpadded) // DECIMAL_POINT // trim(fraction_part)

   end function remove_zero_pad
   
   function substitute(string, ch1, ch2) result(replaced)
      character(len=*), intent(in) :: string
      character, intent(in) :: ch1, ch2
      character(len=len(string)) :: replaced
      integer :: i, j

      j = 0
      replaced = string
      i = index(replaced((j+1):), ch1) 
      do while (i > 0)
         j = j + i
         if(j > len(replaced)) exit
         replaced(j:j) = ch2
         if(j == len(replaced)) exit
         i = index(replaced((j+1):), ch1) 
      end do

   end function substitute

   elemental logical function is_zero(ch)
      character, intent(in) :: ch
      is_zero = (ch == '0')
   end function is_zero

   function get_ISO8601_substrings(isostring) result(substring)
      character(len=*), intent(in) :: isostring
      integer, parameter :: NUM_DT_PARTS = 6
      integer, parameter :: DT_PART_WIDTH = 5
      character(len=DT_PART_WIDTH) :: substring(NUM_DT_PARTS)

      substring = EMPTY_STRING

      substring(1) = isostring(1:5)
      substring(2) = isostring(6:8)
      substring(3) = isostring(9:11)
      substring(4) = isostring(12:14)
      substring(5) = isostring(15:17)
      substring(6) = isostring(18:19)
      
   end function get_ISO8601_substrings

   function get_ISO8601_fractional_seconds(isostring) result(fs)
      character(len=*), intent(in) :: isostring
      integer, parameter :: FIRST_INDEX = 20
      character(len=len(isostring)) :: fs
      integer :: i, j

      fs = EMPTY_STRING
      if(len_trim(isostring) < FIRST_INDEX) return
      i = FIRST_INDEX
      if(isostring(i:i) /= DECIMAL_POINT) return
      i = i + 1
      j = verify(isostring(i:), DIGIT_CHARACTERS)
      select case(j)
         case(0)
            fs = isostring(i:)
         case(1)
            return
         case default
            j = j + i - 2
            fs = isostring(i:j)
      end select

   end function get_ISO8601_fractional_seconds

   function strip_zero(string, back) result(stripped)
      character(len=*), intent(in) :: string
      logical, optional, intent(in) :: back
      character(len=len(string)) :: stripped
      logical :: back_
      integer :: i, j, n
      character :: ch

      stripped = EMPTY_STRING
      back_ = .FALSE.
      if(present(back)) back_ = back

      n = len_trim(string)
      if(back_) then
         i = 1
         do j = n, i, -1
            ch = string(j:j)
            if(.not. is_zero(ch)) exit
         end do
      else
         j = n
         do i = 1, n
            ch = string(i:i)
            if(.not. is_zero(ch)) exit
         end do
         i = min(i, j)
      end if

      stripped = string(i:j)

   end function strip_zero

end module MAPL_CF_Time