dc_calendar_internal.f90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright (c) 2000-2026 Gtool Development Group. All rights reserved.
!-----------------------------------------------------------------------
!>
!> @author    Yasuhiro MORIKAWA
!> @copyright Copyright (C) GFD Dennou Club, 2009-2026. All rights reserved. <br/>
!>            License is BSD-2-Clause. see [COPYRIGHT](@ref COPYRIGHT) in detail
!> @private
!> @en
!> @brief Internal module for dc_calendar
!> @details
!> This module provides internal constants, variables, and procedures
!> used by the dc_calendar module.
!>
!> @section dccal_internal_procedures Internal procedures
!>
!> | Procedure              | Description                               |
!> |------------------------|-------------------------------------------|
!> | default_cal_set        | Set default calendar to Gregorian         |
!> | dccaldate_normalize    | Normalize date information                |
!> | dccaldate_ym2d         | Convert year/month/day to day of year     |
!> | dccaltype_str          | Convert calendar type to string           |
!> | dccaldate_str2ustr     | Parse unit string and return unit string  |
!> | dccaldate_str2usym     | Parse unit string and return unit symbol  |
!>
!> @enden
!>
!> @ja
!> @brief dc_calendar用の内部モジュール
!> @details
!> dc_calendar モジュール内で使用される内部向け定数, 変数, 手続き群を
!> 提供します.
!>
!> @section dccal_internal_procedures_ja 内部手続一覧
!>
!> | 手続名                 | 説明                                      |
!> |------------------------|-------------------------------------------|
!> | default_cal_set        | デフォルトの暦をグレゴリオ暦に設定        |
!> | dccaldate_normalize    | 日時情報の正規化                          |
!> | dccaldate_ym2d         | 年月日を年始からの通日に変換              |
!> | dccaltype_str          | 暦タイプを文字列に変換                    |
!> | dccaldate_str2ustr     | 単位文字列を解釈し単位文字列を返す        |
!> | dccaldate_str2usym     | 単位文字列を解釈し単位シンボルを返す      |
!>
!> @endja
!>
 
module dc_calendar_internal
 
  use dc_calendar_types, only: dc_cal, dc_cal_date
  use dc_types, only: dp
  implicit none
  private
  public:: default_cal_set, dccaldate_normalize, &
    &      dccaltype_str, dccaldate_str2ustr, &
    &      dccaldate_str2usym, dccaldate_ym2d
 
  !> @var default_cal
  !> @en Default calendar object
  !> @enden
  !> @ja
  !> デフォルトの暦.
  !> DCCal で始まる手続のうち, DC_CAL 型の省略可能引数が与えられない
  !> 場合にはこの暦が設定もしくは利用される.
  !> @endja
  type(dc_cal), save, target, public:: default_cal
 
  !> @var default_date
  !> @en Default date object
  !> @enden
  !> @ja
  !> デフォルトの日時.
  !> DCCalDate で始まる手続のうち, DC_CAL_DATE 型の省略可能引数が
  !> 与えられない場合にはこの日時が設定もしくは利用される.
  !> @endja
  type(dc_cal_date), save, target, public:: default_date
 
contains
 
  !>
  !> @en
  !> @brief Set default calendar to Gregorian
  !> @details
  !> When DCCal procedures are called without DC_CAL argument,
  !> this procedure is called first to set the default calendar
  !> to Gregorian calendar.
  !>
  !> If default_cal is already initialized, this procedure
  !> does nothing and returns immediately.
  !> @enden
  !>
  !> @ja
  !> @brief デフォルトの暦をグレゴリオ暦として設定します
  !> @details
  !> DCCal で始まる手続が呼び出され, DC_CAL 型の引数に暦の設定が
  !> 行われていない場合には, まずこの手続を呼び出して,
  !> デフォルトの暦 default_cal をグレゴリオ暦として設定します.
  !>
  !> 既に default_cal に暦が設定されている場合にはこの手続内で
  !> それを判定して何もせずに手続を終了するため, この手続は
  !> 何度呼び出しても良く, 呼び出す側で状態の有無を確認する
  !> 必要はありません.
  !> @endja
  !>
  subroutine default_cal_set
    use dc_calendar_types, only: cal_gregorian
    implicit none
    type(dc_cal), pointer:: calp =>null()
  continue
    calp => default_cal
 
    if ( calp % initialized ) return
 
    calp % cal_type = cal_gregorian
    calp % month_in_year = 12
    calp % hour_in_day   = 24
    calp % min_in_hour   = 60
    calp % sec_in_min    = 60.0_dp
    allocate( calp % day_in_month(1:12) )
    calp % day_in_month(1:12) = &
      & (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /)
 
    calp % initialized = .true.
    nullify( calp )
  end subroutine default_cal_set
 
 
  !>
  !> @en
  !> @brief Normalize date information
  !> @details
  !> Normalizes date information according to calendar.
  !> This is an internal procedure for dc_calendar module.
  !>
  !> Normalization is performed in the following cases:
  !> - sec exceeds "seconds in a minute": carry over to minute
  !> - min exceeds "minutes in an hour": carry over to hour
  !> - hour exceeds "hours in a day": carry over to day
  !> - day exceeds "days in a month": carry over to month/year
  !> - sec, min, hour, day are negative: borrow from upper unit
  !> - day is 0: borrow from upper unit
  !>
  !> @param[in,out] year   Year
  !> @param[in,out] month  Month
  !> @param[in,out] day    Day
  !> @param[in,out] hour   Hour
  !> @param[in,out] min    Minute
  !> @param[in,out] sec    Second
  !> @param[in]     cal    Calendar object
  !> @return Status (DC_NOERR on success, DC_EINCONSISTCALDATE on error)
  !> @enden
  !>
  !> @ja
  !> @brief 日時情報の正規化を行います
  !> @details
  !> 暦情報 cal に従い, 日時情報の正規化を行います.
  !> dc_calendar モジュール内部で使用されることを前提とします.
  !>
  !> 以下の場合に正規化を実施します:
  !> - sec が「1分の秒数」を超えている: 分に繰り上げ
  !> - min が「1時間の分数」を超えている: 時に繰り上げ
  !> - hour が「1日の時間数」を超えている: 日に繰り上げ
  !> - day が「1月の日数」を超えている: 月/年に繰り上げ
  !> - sec, min, hour, day が負: 上位の単位から借りる
  !> - day が 0: 上位の単位から借りる
  !>
  !> @param[in,out] year   年
  !> @param[in,out] month  月
  !> @param[in,out] day    日
  !> @param[in,out] hour   時
  !> @param[in,out] min    分
  !> @param[in,out] sec    秒
  !> @param[in]     cal    暦情報を収めたオブジェクト
  !> @return ステータス (成功時は DC_NOERR, エラー時は DC_EINCONSISTCALDATE)
  !> @endja
  !>
  function dccaldate_normalize( year, month, day, hour, min, sec, cal ) result(stat)
    use dc_error, only: dc_noerr, dc_einconsistcaldate
    use dc_calendar_types, only: &
      & cal_user_defined, cal_julian, cal_gregorian
    implicit none
    integer:: stat
    integer, intent(inout):: year
    integer, intent(inout):: month
    integer, intent(inout):: day
    integer, intent(inout):: hour
    integer, intent(inout):: min
    real(dp), intent(inout):: sec
    type(dc_cal), intent(in):: cal
 
    integer:: day_in_month_jg
    integer, pointer:: day_in_month(:) =>null()
 
    integer:: month_in_year
    integer:: hour_in_day
    integer:: min_in_hour
    real(dp):: sec_in_min
 
    real(dp):: wyear, wday, whour, wmin
    real(dp):: wdb, ychunk_e6, ychunk_e3, chunk_scale_e6, chunk_scale_e3
  continue
    stat = dc_noerr
 
    select case( cal % cal_type )
    case( cal_user_defined )
      if ( month > cal % month_in_year ) stat = dc_einconsistcaldate
    case default
      if ( month > 12 ) stat = dc_einconsistcaldate
    end select
 
    if ( stat /= dc_noerr ) return
 
    month_in_year = cal % month_in_year
    hour_in_day   = cal % hour_in_day
    min_in_hour   = cal % min_in_hour
    sec_in_min    = cal % sec_in_min
    day_in_month => cal % day_in_month
 
    select case( cal % cal_type )
    case( cal_julian )
      chunk_scale_e6 = 4.0e+5
      ychunk_e6 = 146100000.0_dp
      chunk_scale_e3 = 4.0e+2
      ychunk_e3 = 146100.0_dp
    case( cal_gregorian )
      chunk_scale_e6 = 4.0e+5
      ychunk_e6 = 146097000.0_dp
      chunk_scale_e3 = 4.0e+2
      ychunk_e3 = 146097.0_dp
    case default
      chunk_scale_e6 = 1.0e+6
      ychunk_e6 = chunk_scale_e6 * sum( day_in_month(:) )
      chunk_scale_e3 = 1.0e+3
      ychunk_e3 = chunk_scale_e3 * sum( day_in_month(:) )
    end select
 
    wyear  = real( year, dp )
    wday   = real( day, dp )
    whour  = real( hour, dp )
    wmin   = real( min, dp )
 
    if ( .not. sec < sec_in_min ) then
      wmin = wmin + aint( sec / sec_in_min )
      sec = mod( sec, sec_in_min )
    elseif ( sec < 0.0_dp ) then
      wdb = ceiling( abs(sec) / sec_in_min )
      wmin = wmin - wdb
      sec = sec + wdb * sec_in_min
    end if
 
    if ( .not. wmin < min_in_hour ) then
      whour = whour + aint( wmin / min_in_hour )
      wmin = mod( wmin, real( min_in_hour, dp ) )
    elseif ( wmin < 0 ) then
      wdb = ceiling( abs(wmin) / real(min_in_hour) )
      whour = whour - wdb
      wmin = wmin + wdb * min_in_hour
    end if
 
    if ( .not. whour < hour_in_day ) then
      wday = wday + aint( whour / hour_in_day )
      whour = mod( whour, real( hour_in_day, dp ) )
    elseif ( whour < 0 ) then
      wdb = ceiling( abs(whour) / real(hour_in_day) )
      wday = wday - wdb
      whour = whour + wdb * hour_in_day
    end if
 
    if ( wday < 1.0_dp ) then
      select case( cal % cal_type )
      case( cal_julian )
        do while ( wday < 1.0_dp )
          if ( wday < - ychunk_e6 ) then
            wyear = wyear + chunk_scale_e6 * ( aint( wday / ychunk_e6 ) - 1.0_dp )
            wday = mod( wday, ychunk_e6 ) + ychunk_e6
          end if
          if ( wday < 1.0_dp ) then
            wyear = wyear + chunk_scale_e3 * ( aint( wday / ychunk_e3 ) - 1.0_dp )
            wday = mod( wday, ychunk_e3 ) + ychunk_e3
          end if
        end do
      case( cal_gregorian )
        do while ( wday < 1.0_dp )
          if ( wday < - ychunk_e6 ) then
            wyear = wyear + chunk_scale_e6 * ( aint( wday / ychunk_e6 ) - 1.0_dp )
            wday = mod( wday, ychunk_e6 ) + ychunk_e6
          end if
          if ( wday < 1.0_dp ) then
            wyear = wyear + chunk_scale_e3 * ( aint( wday / ychunk_e3 ) - 1.0_dp )
            wday = mod( wday, ychunk_e3 ) + ychunk_e3
          end if
        end do
      case default
        do while ( wday < 1.0_dp )
          if ( wday < - ychunk_e6 ) then
            wyear = wyear + chunk_scale_e6 * ( aint( wday / ychunk_e6 ) - 1.0_dp )
            wday = mod( wday, ychunk_e6 ) + ychunk_e6
          end if
          if ( wday < 1.0_dp ) then
            wyear = wyear + chunk_scale_e3 * ( aint( wday / ychunk_e3 ) - 1.0_dp )
            wday = mod( wday, ychunk_e3 ) + ychunk_e3
          end if
        end do
      end select
    end if
 
    select case( cal % cal_type )
    case( cal_julian )
      if ( wday > ychunk_e6 ) then
        wyear = wyear + chunk_scale_e6 * aint( wday / ychunk_e6 )
        wday = mod( wday, ychunk_e6 )
      end if
      if ( wday > ychunk_e3 ) then
        wyear = wyear + chunk_scale_e3 * aint( wday / ychunk_e3 )
        wday = mod( wday, ychunk_e3 )
      end if
      do
        if ( month == 2 ) then
          if ( mod( nint(wyear), 4 ) == 0 ) then
            day_in_month_jg = 29
          else
            day_in_month_jg = 28
          end if
        else
          day_in_month_jg = day_in_month(month)
        end if
        if ( .not. wday > day_in_month_jg ) exit
        wday = wday - day_in_month_jg
        month = month + 1
        if ( month > month_in_year ) then
          month = 1
          wyear = wyear + 1
        end if
      end do
    case( cal_gregorian )
      if ( wday > ychunk_e6 ) then
        wyear = wyear + chunk_scale_e6 * aint( wday / ychunk_e6 )
        wday = mod( wday, ychunk_e6 )
      end if
      if ( wday > ychunk_e3 ) then
        wyear = wyear + chunk_scale_e3 * aint( wday / ychunk_e3 )
        wday = mod( wday, ychunk_e3 )
      end if
      do
        if ( month == 2 ) then
          if ( mod( nint(wyear), 400 ) == 0 ) then
            day_in_month_jg = 29
          elseif ( mod( nint(wyear), 100 ) == 0 ) then
            day_in_month_jg = 28
          elseif ( mod( nint(wyear), 4 ) == 0 ) then
            day_in_month_jg = 29
          else
            day_in_month_jg = 28
          end if
        else
          day_in_month_jg = day_in_month(month)
        end if
        if ( .not. wday > day_in_month_jg ) exit
        wday = wday - day_in_month_jg
        month = month + 1
        if ( month > month_in_year ) then
          month = 1
          wyear = wyear + 1
        end if
      end do
    case default
      if ( wday > ychunk_e6 ) then
        wyear = wyear + chunk_scale_e6 * aint( wday / ychunk_e6 )
        wday = mod( wday, ychunk_e6 )
      end if
      if ( wday > ychunk_e3 ) then
        wyear = wyear + chunk_scale_e3 * aint( wday / ychunk_e3 )
        wday = mod( wday, ychunk_e3 )
      end if
      do while ( wday > day_in_month(month) )
        wday = wday - day_in_month(month)
        month = month + 1
        if ( month > month_in_year ) then
          month = 1
          wyear = wyear + 1
        end if
      end do
    end select
 
    year  = int(wyear)
    day   = int(wday)
    hour  = int(whour)
    min   = int(wmin)
 
  end function dccaldate_normalize
 
  !>
  !> @en
  !> @brief Convert year/month/day to day of year
  !> @details
  !> Converts year/month/day to day of year according to calendar.
  !> Should be called after normalization by dccaldate_normalize.
  !> @param[in]  year        Year
  !> @param[in]  month       Month
  !> @param[in]  day         Day
  !> @param[in]  cal         Calendar object
  !> @param[out] day_of_year Day of year (double precision)
  !> @return Status (DC_NOERR on success)
  !> @enden
  !>
  !> @ja
  !> @brief 年月日を年始からの通日に変換します
  !> @details
  !> 暦情報 cal に従い, 月日をその年が始まった時からの通日に変換します.
  !> 結果は倍精度実数として day_of_year に返ります.
  !> dccaldate_normalize によって正規化した後に呼び出してください.
  !> @param[in]  year        年
  !> @param[in]  month       月
  !> @param[in]  day         日
  !> @param[in]  cal         暦情報を収めたオブジェクト
  !> @param[out] day_of_year 年始からの通日 (倍精度実数)
  !> @return ステータス (成功時は DC_NOERR)
  !> @endja
  !>
  function dccaldate_ym2d( year, month, day, cal, day_of_year ) result(stat)
    use dc_error, only: dc_noerr, dc_einconsistcaldate
    use dc_calendar_types, only: &
      & cal_user_defined, cal_julian, cal_gregorian
    implicit none
    integer:: stat
    integer, intent(in):: year
    integer, intent(in):: month
    integer, intent(in):: day
    real(dp), intent(out):: day_of_year
    type(dc_cal), intent(in):: cal
 
    integer:: i
 
  continue
    stat = dc_noerr
 
    select case( cal % cal_type )
    case( cal_user_defined )
      if ( month > cal % month_in_year ) stat = dc_einconsistcaldate
    case default
      if ( month > 12 ) stat = dc_einconsistcaldate
    end select
 
    if ( stat /= dc_noerr ) return
 
    day_of_year  = real( day, dp )
 
    select case( cal % cal_type )
    case( cal_julian )
      do i = 1, month - 1
        if ( i == 2 ) then
          if ( mod( year, 4 ) == 0 ) then
            day_of_year = day_of_year + 29
          else
            day_of_year = day_of_year + 28
          end if
        else
          day_of_year = day_of_year + cal % day_in_month(i)
        end if
      end do
    case( cal_gregorian )
      do i = 1, month - 1
        if ( i == 2 ) then
          if ( mod( year, 400 ) == 0 ) then
            day_of_year = day_of_year + 29
          elseif ( mod( year, 100 ) == 0 ) then
            day_of_year = day_of_year + 28
          elseif ( mod( year, 4 ) == 0 ) then
            day_of_year = day_of_year + 29
          else
            day_of_year = day_of_year + 28
          end if
        else
          day_of_year = day_of_year + cal % day_in_month(i)
        end if
      end do
    case default
      do i = 1, month - 1
        day_of_year = day_of_year + cal % day_in_month(i)
      end do
    end select
 
  end function dccaldate_ym2d
 
 
  !>
  !> @en
  !> @brief Convert calendar type integer to string
  !> @details
  !> Converts integer calendar type to string representation.
  !> Returns empty string for invalid calendar type.
  !> @param[in] cal_type Calendar type integer
  !> @return Calendar type string
  !> @enden
  !>
  !> @ja
  !> @brief 整数型の暦タイプを文字列に変換します
  !> @details
  !> 整数型の暦タイプ cal_type を文字列に変換します.
  !> 不正な cal_type の場合は空文字が返ります.
  !> @param[in] cal_type 暦タイプ (整数)
  !> @return 暦タイプ文字列
  !> @endja
  !>
  function dccaltype_str( cal_type ) result(str)
    use dc_calendar_types, only: &
      & cal_user_defined, &
      & cal_cyclic, cal_noleap, cal_julian, cal_gregorian, cal_360day
    use dc_types, only: token
    implicit none
    character(TOKEN):: str
    integer, intent(in):: cal_type
 
  continue
    select case( cal_type )
    case(cal_user_defined) ; str = 'user_defined'
    case(cal_cyclic)       ; str = 'cyclic      '
    case(cal_noleap)       ; str = 'noleap      '
    case(cal_julian)       ; str = 'julian      '
    case(cal_gregorian)    ; str = 'gregorian   '
    case(cal_360day)       ; str = '360day      '
    case default           ; str = '            '
    end select
  end function dccaltype_str
 
 
  !>
  !> @en
  !> @brief Parse unit string and return unit string
  !> @details
  !> Interprets the string given in str and returns the unit string.
  !> Case insensitive. Returns the first element of the unit array.
  !> Returns empty string for unrecognized unit.
  !> @param[in] str Input unit string
  !> @return Standardized unit string
  !> @enden
  !>
  !> @ja
  !> @brief 単位文字列を解釈し単位文字列を返します
  !> @details
  !> 引数 str に与えられた文字列を解釈し, 日時の単位を unit に返します.
  !> 大文字と小文字は区別されません.
  !> 返る文字列は単位配列の先頭の文字列です.
  !> 該当しない文字列の場合は空文字が返ります.
  !> @param[in] str 入力単位文字列
  !> @return 標準化された単位文字列
  !> @endja
  !>
  function dccaldate_str2ustr(str) result(unit)
    use dc_types, only: token
    use dc_calendar_types, only: unit_year, unit_month, unit_day, &
      & unit_hour, unit_min, unit_sec
    use dc_string, only: strieq
    implicit none
    character(*), intent(in):: str
    character(TOKEN):: unit
    integer :: unit_str_size, i
  continue
    unit = adjustl(str)
 
    unit_str_size = size(unit_sec)
    do i = 1, unit_str_size
      if (strieq(trim(unit), trim(unit_sec(i)))) then
        unit = unit_sec(1)
        return
      end if
    end do
 
    unit_str_size = size(unit_min)
    do i = 1, unit_str_size
      if (strieq(trim(unit), trim(unit_min(i)))) then
        unit = unit_min(1)
        return
      end if
    end do
 
    unit_str_size = size(unit_hour)
    do i = 1, unit_str_size
      if (strieq(trim(unit), trim(unit_hour(i)))) then
        unit = unit_hour(1)
        return
      end if
    end do
 
    unit_str_size = size(unit_day)
    do i = 1, unit_str_size
      if (strieq(trim(unit), trim(unit_day(i)))) then
        unit = unit_day(1)
        return
      end if
    end do
 
    unit_str_size = size(unit_month)
    do i = 1, unit_str_size
      if (strieq(trim(unit), trim(unit_month(i)))) then
        unit = unit_month(1)
        return
      end if
    end do
 
    unit_str_size = size(unit_year)
    do i = 1, unit_str_size
      if (strieq(trim(unit), trim(unit_year(i)))) then
        unit = unit_year(1)
        return
      end if
    end do
 
    unit = ''
 
  end function dccaldate_str2ustr
 
  !>
  !> @en
  !> @brief Parse unit string and return unit symbol
  !> @details
  !> Interprets the string given in str and returns the unit symbol integer.
  !> Case insensitive. Returns UNIT_SYMBOL_ERR for unrecognized unit.
  !> @param[in] str Input unit string
  !> @return Unit symbol integer
  !> @enden
  !>
  !> @ja
  !> @brief 単位文字列を解釈し単位シンボルを返します
  !> @details
  !> 引数 str に与えられた文字列を解釈し, 日時の単位を示す整数
  !> symbol を返します. 大文字と小文字は区別しません.
  !> 該当しない文字列の場合は UNIT_SYMBOL_ERR が返ります.
  !> @param[in] str 入力単位文字列
  !> @return 単位シンボル (整数)
  !> @endja
  !>
  function dccaldate_str2usym(str) result(symbol)
    use dc_types, only: token
    use dc_calendar_types, only: unit_year, unit_month, unit_day, &
      & unit_hour, unit_min, unit_sec, &
      & unit_symbol_year, unit_symbol_month, unit_symbol_day, &
      & unit_symbol_hour, unit_symbol_min, unit_symbol_sec, &
      & unit_symbol_err
    use dc_string, only: strieq
    implicit none
    character(*), intent(in):: str
    integer:: symbol
    integer:: unit_str_size, i
    character(TOKEN):: unit
  continue
    unit = adjustl(str)
 
    unit_str_size = size(unit_sec)
    do i = 1, unit_str_size
      if (strieq(trim(unit), trim(unit_sec(i)))) then
        symbol = unit_symbol_sec
        return
      end if
    end do
 
    unit_str_size = size(unit_min)
    do i = 1, unit_str_size
      if (strieq(trim(unit), trim(unit_min(i)))) then
        symbol = unit_symbol_min
        return
      end if
    end do
 
    unit_str_size = size(unit_hour)
    do i = 1, unit_str_size
      if (strieq(trim(unit), trim(unit_hour(i)))) then
        symbol = unit_symbol_hour
        return
      end if
    end do
 
    unit_str_size = size(unit_day)
    do i = 1, unit_str_size
      if (strieq(trim(unit), trim(unit_day(i)))) then
        symbol = unit_symbol_day
        return
      end if
    end do
 
    unit_str_size = size(unit_month)
    do i = 1, unit_str_size
      if (strieq(trim(unit), trim(unit_month(i)))) then
        symbol = unit_symbol_month
        return
      end if
    end do
 
    unit_str_size = size(unit_year)
    do i = 1, unit_str_size
      if (strieq(trim(unit), trim(unit_year(i)))) then
        symbol = unit_symbol_year
        return
      end if
    end do
 
    symbol = unit_symbol_err
 
  end function dccaldate_str2usym
 
end module dc_calendar_internal