dccaldatecreate.f90

Go to the documentation of this file.

! -*- mode: f90; coding: utf-8 -*-
!-----------------------------------------------------------------------
! Copyright (c) 2000-2026 Gtool Development Group. All rights reserved.
!-----------------------------------------------------------------------
 
subroutine dccaldatecreate1( year, month, day, hour, min, sec, date, zone, err )
 
  use dc_calendar_types, only: dc_cal_date
  use dc_calendar_internal, only: default_date
  use dc_regex, only: match
  use dc_message, only: messagenotify
  use dc_string, only: lchar
  use dc_trace, only: beginsub, endsub
  use dc_error, only: storeerror, dc_noerr, dc_ebaddate
  use dc_types, only: string, dp
  implicit none
  integer, intent(in):: year
  integer, intent(in):: month
  integer, intent(in):: day
  integer, intent(in):: hour
  integer, intent(in):: min
  real(DP), intent(in):: sec
  type(dc_cal_date), intent(out), optional, target:: date
  character(*), intent(in), optional:: zone
  logical, intent(out), optional:: err
 
  ! 作業変数
  ! Work variables
  !
  type(dc_cal_date), pointer:: datep =>null()
  integer:: start, length
  integer:: stat
  character(STRING):: cause_c
  character(*), parameter:: version = &
    & '$Name:  $' // &
    & '$Id: dccaldatecreate.f90,v 1.3 2010-09-24 07:07:31 morikawa Exp $'
  character(*), parameter:: subname = 'DCCalDateCreate1'
continue
  call beginsub( subname, version )
  stat = dc_noerr
  cause_c = ''
 
  ! オブジェクトのポインタ割付
  ! Associate pointer of an object
  !
  if ( present( date ) ) then
    datep => date
  else
    datep => default_date
  end if
 
!!$  ! 初期設定のチェック
!!$  ! Check initialization
!!$  !
!!$  if ( datep % initialized ) then
!!$    stat = DC_EALREADYINIT
!!$    cause_c = 'DC_CAL_DATE'
!!$    goto 999
!!$  end if
 
  ! 日時の正当性のチェック
  ! Validate date and time
  !
!!$  if ( year < 1 ) then
!!$    stat = DC_EBADDATE
!!$    call MessageNotify('W', subname, 'year=<%d> must be natural number', &
!!$      & i = (/ year /) )
!!$    goto 999
!!$  end if
 
  if ( month < 1 ) then
    stat = dc_ebaddate
    call messagenotify('W', subname, 'month=<%d> must be natural number', &
      & i = (/ month /) )
    goto 999
  end if
 
  if ( day < 1 ) then
    stat = dc_ebaddate
    call messagenotify('W', subname, 'day=<%d> must be natural number', &
      & i = (/ day /) )
    goto 999
  end if
 
  if ( hour < 0 ) then
    stat = dc_ebaddate
    call messagenotify('W', subname, 'hour=<%d> must not be negative', &
      & i = (/ hour /) )
    goto 999
  end if
 
  if ( min < 0 ) then
    stat = dc_ebaddate
    call messagenotify('W', subname, 'min=<%d> must not be negative', &
      & i = (/ min /) )
    goto 999
  end if
 
  if ( sec < 0.0_dp ) then
    stat = dc_ebaddate
    call messagenotify('W', subname, 'sec=<%f> must not be negative', &
      & d = (/ sec /) )
    goto 999
  end if
 
  call match( '^[#+-]#d+:#d+$', zone, & ! (in)
    &         start, length )           ! (out)
  if ( length > 0 ) then
    datep % zone = zone
  else
    datep % zone = ''
  end if
 
  ! 各要素への値の設定
  ! Configure elements
  !
  datep % year  = year
  datep % month = month
  datep % day   = day
  datep % hour  = hour
  datep % min   = min
  datep % sec   = sec
 
  ! 終了処理, 例外処理
  ! Termination and Exception handling
  !
  datep % initialized = .true.
999 continue
  nullify( datep )
  call storeerror( stat, subname, err, cause_c )
  call endsub( subname )
end subroutine dccaldatecreate1
 
subroutine dccaldatecreate2( date_str, date, err )
  use dc_calendar_generic, only: dccaldateparsestr, dccaldatecreate
  use dc_calendar_types, only: dc_cal_date
  use dc_calendar_internal, only: default_date
  use dc_message, only: messagenotify
  use dc_types, only: dp, token
  use dc_trace, only: beginsub, endsub
  use dc_error, only: storeerror, dc_noerr, dc_ebaddate
  use dc_types, only: string
  implicit none
  character(*), intent(in):: date_str
  type(dc_cal_date), intent(out), optional, target:: date
  logical, intent(out), optional:: err
 
  ! 作業変数
  ! Work variables
  !
  type(dc_cal_date), pointer:: datep =>null()
  integer:: year
  integer:: month
  integer:: day
  integer:: hour
  integer:: min
  real(DP):: sec
  character(TOKEN):: zone
  integer:: stat
  character(STRING):: cause_c
  character(*), parameter:: version = &
    & '$Name:  $' // &
    & '$Id: dccaldatecreate.f90,v 1.3 2010-09-24 07:07:31 morikawa Exp $'
  character(*), parameter:: subname = 'DCCalDateCreate2'
continue
  call beginsub( subname, version )
  stat = dc_noerr
  cause_c = ''
 
  ! オブジェクトのポインタ割付
  ! Associate pointer of an object
  !
  if ( present( date ) ) then
    datep => date
  else
    datep => default_date
  end if
 
!!$  ! 初期設定のチェック
!!$  ! Check initialization
!!$  !
!!$  if ( datep % initialized ) then
!!$    stat = DC_EALREADYINIT
!!$    cause_c = 'DC_CAL_DATE'
!!$    goto 999
!!$  end if
 
  ! 日時を表現した文字列の解釈
  ! Parse strings that express date and time
  !
  call dccaldateparsestr( date_str, &           ! (in)
    & year, month, day, hour, min, sec, zone, & ! (out)
    & err = err )                               ! (out) optional
  if ( present(err) ) then
    if ( err ) then
      stat = dc_ebaddate
      goto 999
    end if
  end if
 
  ! オブジェクトの作成
  ! Create an object
  !
  call dccaldatecreate( &
    & year, month, day, hour, min, sec, & ! (in)
    & datep, zone, err = err )            ! (out) optional
  if ( present(err) ) then
    if ( err ) then
      stat = dc_ebaddate
      goto 999
    end if
  end if
 
  ! 終了処理, 例外処理
  ! Termination and Exception handling
  !
999 continue
  nullify( datep )
  call storeerror( stat, subname, err, cause_c )
  call endsub( subname )
end subroutine dccaldatecreate2