dccalcreate.f90

Go to the documentation of this file.

! -*- mode: f90; coding: utf-8 -*-
!-----------------------------------------------------------------------
! Copyright (c) 2000-2026 Gtool Development Group. All rights reserved.
!-----------------------------------------------------------------------
!>
!> @author    Youhei SASAKI, 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
!> @en
!> @brief Calendar creation procedures
!> @details
!> Procedures described in this file are provided from "dc_calendar" module.
!> @enden
!>
!> @ja
!> @brief 暦の設定手続
!> @details
!> このファイルに記載される手続き群は dc_calendar モジュールから提供されます.
!> @endja
!>
 
!> @en
!> @brief Create calendar with predefined calendar type
!> @details
!> Set calendar.
!>
!> This subroutine sets previously-defined calendars by "dc_calendar" module.
!> If number of days of a month, number of seconds of a day, etc.
!> want to be specified arbitrarily, use the following homonymous subroutine.
!>
!> Following strings are valid as `cal_type`.
!> If any other string is specified, an error is caused.
!> They are not case-sensitive.
!>
!> | cal_type   | Description                                                |
!> |------------|------------------------------------------------------------|
!> | gregorian  | Gregorian calendar                                         |
!> | julian     | Julian calendar                                            |
!> | noleap     | A calendar without leap year                               |
!> | 360day     | A calendar in which number of days of a month is 30        |
!> | cyclic     | A calendar in which number of days of a year is "30.6 x (number of months) - (total days until last month)" (truncate fractional part) |
!>
!> If an optional argument `cal` is omitted,
!> the calendar setting is stored to a "dc_calendar_types#DC_CAL"
!> variable that is saved in the "dc_calendar".
!> When `cal` is omitted in subsequent procedures, the internal calendar
!> is used.
!> If `cal` is not omitted, the settings is stored to the `cal`.
!> In order to use the calendar setting, use the "dc_calendar_types#DC_CAL"
!> variable to subsequent procedures.
!>
!> @param[in] cal_type Strings that specify a previously-defined calendar
!> @param[out] cal An object that stores information of calendar
!> @param[out] err Exception handling flag
!> @enden
!>
!> @ja
!> @brief 既定の暦タイプで暦を作成
!> @details
!> 暦の設定を行います.
!>
!> このサブルーチンは "dc_calendar" モジュールで用意した
!> 既定の暦を設定するものです. 1 ヶ月の日数, 1 日の秒数などを
!> 任意に指定する場合には, 下記の同名のサブルーチンを使用して下さい.
!>
!> `cal_type` として以下のものが有効です. これ以外の文字列
!> を与えた場合にはエラーが発生します. 大文字と小文字は区別しません.
!>
!> | cal_type   | 説明                                                       |
!> |------------|------------------------------------------------------------|
!> | gregorian  | グレゴリオ暦                                               |
!> | julian     | ユリウス暦                                                 |
!> | noleap     | 閏年無しの暦                                               |
!> | 360day     | 1ヶ月が 30 日の暦                                          |
!> | cyclic     | ある月の日数を「30.6 × 月数 − 前月までの総日数」の小数点以下切捨とする暦 |
!>
!> 省略可能引数 `cal` が省略された場合には, dc_calendar 内部で
!> 保持される "dc_calendar_types#DC_CAL" 型の変数に暦が
!> 設定されます. その後の手続きで `cal` を省略した場合には
!> この暦が使用されます.
!> `cal` が省略されない場合にはその変数に暦が設定されます.
!> その暦を使用する場合, 手続きにその "dc_calendar_types#DC_CAL" 型の変数
!> を与えてください.
!>
!> @param[in] cal_type 既定の暦を指定する文字列
!> @param[out] cal 暦情報を収めたオブジェクト
!> @param[out] err 例外処理用フラグ.
!>                 デフォルトでは, この手続き内でエラーが生じた場合,
!>                 プログラムは強制終了します.
!>                 引数 `err` が与えられる場合, プログラムは強制終了せず,
!>                 代わりに `err` に .true. が代入されます.
!> @endja
subroutine dccalcreate1( cal_type, cal, err )
 
  use dc_calendar_types, only: dc_cal, &
    & cal_cyclic, cal_noleap, cal_julian, cal_gregorian, cal_360day
  use dc_calendar_internal, only: default_cal
  use dc_message, only: messagenotify
  use dc_string, only: lchar
  use dc_trace, only: beginsub, endsub
  use dc_error, only: storeerror, dc_noerr, dc_ebadcaltype
  use dc_types, only: string, dp
  implicit none
  character(*), intent(in):: cal_type
  type(dc_cal), intent(out), optional, target:: cal
  logical, intent(out), optional:: err
 
  ! 作業変数
  ! Work variables
  !
  type(dc_cal), pointer:: calp =>null()
  integer:: stat
  character(STRING):: cause_c
  character(*), parameter:: version = &
    & '$Name:  $' // &
    & '$Id: dccalcreate.f90,v 1.4 2009-10-18 12:02:32 morikawa Exp $'
  character(*), parameter:: subname = 'DCCalCreate1'
continue
  call beginsub( subname, version )
  stat = dc_noerr
  cause_c = ''
 
  ! オブジェクトのポインタ割付
  ! Associate pointer of an object
  !
  if ( present( cal ) ) then
    calp => cal
  else
    calp => default_cal
  end if
 
  ! 暦の種別の正当性のチェック
  ! Validate a kind of calendar
  !
  select case( lchar(trim(cal_type)) )
  case('cyclic')
    calp % cal_type = cal_cyclic
  case('noleap')
    calp % cal_type = cal_noleap
  case('julian')
    calp % cal_type = cal_julian
  case('gregorian')
    calp % cal_type = cal_gregorian
  case('360day')
    calp % cal_type = cal_360day
  case default
    stat = dc_ebadcaltype
    call messagenotify('W', subname, &
      & 'cal_type=<%c> is invalid calender type.', &
      & c1 = trim(cal_type) )
    goto 999
  end select
 
  ! 各要素への値の設定
  ! Configure elements
  !
  allocate( calp % day_in_month(1:12) )
  calp % month_in_year = 12
  calp % hour_in_day   = 24
  calp % min_in_hour   = 60
  calp % sec_in_min    = 60.0_dp
 
  select case( calp % cal_type )
  case(cal_cyclic)
    calp % day_in_month(1:12) = &
      & (/ 31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31, 30 /)
  case(cal_noleap)
    calp % day_in_month(1:12) = &
      & (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /)
  case(cal_julian)
    calp % day_in_month(1:12) = &
      & (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /)
  case(cal_gregorian)
    calp % day_in_month(1:12) = &
      & (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /)
  case(cal_360day)
    calp % day_in_month(1:12) = &
      & (/ 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30 /)
  case default
  end select
 
  ! 終了処理, 例外処理
  ! Termination and Exception handling
  !
  calp % initialized = .true.
999 continue
  nullify( calp )
  call storeerror( stat, subname, err, cause_c )
  call endsub( subname )
end subroutine dccalcreate1
 
!> @en
!> @brief Create calendar with custom settings
!> @details
!> Set calendar.
!>
!> Specify number of days of a month, number of seconds of a day, etc.
!> to arguments. If Gregorian calendar, Julian calendar are needed,
!> see a foregoing homonymous subroutine.
!>
!> If an optional argument `cal` is omitted.
!> The calendar setting is stored to a "dc_calendar_types#DC_CAL"
!> variable that is saved in the "dc_calendar".
!> When `cal` is omitted in subsequent procedures, the internal calendar
!> is used.
!> If `cal` is not omitted, the settings is stored to the `cal`.
!> In order to use the calendar setting, use the "dc_calendar_types#DC_CAL"
!> variable to subsequent procedures.
!>
!> @param[in] month_in_year Months in a year
!> @param[in] day_in_month Days in months (array)
!> @param[in] hour_in_day Hours in a day
!> @param[in] min_in_hour Minutes in an hour
!> @param[in] sec_in_min Seconds in a minute
!> @param[out] cal An object that stores information of calendar
!> @param[out] err Exception handling flag
!> @enden
!>
!> @ja
!> @brief カスタム設定で暦を作成
!> @details
!> 暦の設定を行います.
!>
!> 1 ヶ月の日数, 1 日の秒数などを引数に指定して下さい.
!> グレゴリオ暦やユリウス暦などを利用する場合には
!> 上記の同名のサブルーチンを使用して下さい.
!>
!> 省略可能引数 `cal` が省略された場合には, dc_calendar 内部で
!> 保持される "dc_calendar_types#DC_CAL" 型の変数に暦が
!> 設定されます. その後の手続きで `cal` を省略した場合には
!> この暦が使用されます.
!> `cal` が省略されない場合にはその変数に暦が設定されます.
!> その暦を使用する場合, 手続きにその "dc_calendar_types#DC_CAL" 型の変数
!> を与えてください.
!>
!> @param[in] month_in_year 1年の月数
!> @param[in] day_in_month 1ヶ月の日数 (配列)
!> @param[in] hour_in_day 1日の時間数
!> @param[in] min_in_hour 1時間の分数
!> @param[in] sec_in_min 1分の秒数
!> @param[out] cal 暦情報を収めたオブジェクト
!> @param[out] err 例外処理用フラグ.
!>                 デフォルトでは, この手続き内でエラーが生じた場合,
!>                 プログラムは強制終了します.
!>                 引数 `err` が与えられる場合, プログラムは強制終了せず,
!>                 代わりに `err` に .true. が代入されます.
!> @endja
subroutine dccalcreate2( month_in_year, day_in_month, &
  &                      hour_in_day, min_in_hour, sec_in_min, &
  &                      cal, err )
 
  use dc_calendar_types, only: dc_cal, cal_user_defined
  use dc_calendar_internal, only: default_cal
  use dc_message, only: messagenotify
  use dc_types, only: dp
  use dc_trace, only: beginsub, endsub
  use dc_error, only: storeerror, dc_noerr, dc_ebadcaltype
  use dc_types, only: string
  implicit none
  integer, intent(in):: month_in_year
  integer, intent(in):: day_in_month(:)
  integer, intent(in):: hour_in_day
  integer, intent(in):: min_in_hour
  real(DP), intent(in):: sec_in_min
  type(dc_cal), intent(out), optional, target:: cal
  logical, intent(out), optional:: err
 
  ! 作業変数
  ! Work variables
  !
  type(dc_cal), pointer:: calp =>null()
  integer:: size_day_in_month
  integer:: stat
  character(STRING):: cause_c
  character(*), parameter:: version = &
    & '$Name:  $' // &
    & '$Id: dccalcreate.f90,v 1.4 2009-10-18 12:02:32 morikawa Exp $'
  character(*), parameter:: subname = 'DCCalCreate2'
continue
  call beginsub( subname, version )
  stat = dc_noerr
  cause_c = ''
 
  ! オブジェクトのポインタ割付
  ! Associate pointer of an object
  !
  if ( present( cal ) ) then
    calp => cal
  else
    calp => default_cal
  end if
 
  ! 月数の算出
  ! Evaluate number of months
  !
  size_day_in_month = size ( day_in_month )
 
  ! 引数の正当性のチェック
  ! Validate arguments
  !
  if ( .not. month_in_year == size_day_in_month ) then
    stat = dc_ebadcaltype
    call messagenotify('W', subname, &
      & 'month_in_year=<%d> is not equal to size of day_in_month=<%d>', &
      & i = (/ month_in_year, size_day_in_month /) )
    goto 999
  end if
 
  if ( month_in_year < 1 ) then
    stat = dc_ebadcaltype
    call messagenotify('W', subname, 'month_in_year=<%d> must be positive', &
      & i = (/ month_in_year /) )
    goto 999
  end if
 
  if ( hour_in_day < 1 ) then
    stat = dc_ebadcaltype
    call messagenotify('W', subname, 'hour_in_day=<%d> must be positive', &
      & i = (/ hour_in_day /) )
    goto 999
  end if
 
  if ( min_in_hour < 1 ) then
    stat = dc_ebadcaltype
    call messagenotify('W', subname, 'min_in_hour=<%d> must be positive', &
      & i = (/ min_in_hour /) )
    goto 999
  end if
 
  if ( .not. sec_in_min > 0.0_dp ) then
    stat = dc_ebadcaltype
    call messagenotify('W', subname, 'sec_in_min=<%f> must be positive', &
      & d = (/ sec_in_min /) )
    goto 999
  end if
 
  ! 各要素への値の設定
  ! Configure elements
  !
  calp % cal_type      = cal_user_defined
  calp % month_in_year = month_in_year
  allocate( calp % day_in_month(1:size_day_in_month) )
  calp % day_in_month  = day_in_month
  calp % hour_in_day   = hour_in_day
  calp % min_in_hour   = min_in_hour
  calp % sec_in_min    = sec_in_min
 
  ! 終了処理, 例外処理
  ! Termination and Exception handling
  !
  calp % initialized = .true.
999 continue
  nullify( calp )
  call storeerror( stat, subname, err, cause_c )
  call endsub( subname )
end subroutine dccalcreate2