gtool_history_internal.f90

Go to the documentation of this file.

!--
! *** Caution!! ***
!
! This file is generated from "gtool_history_internal.rb2f90" by Ruby 2.3.3.
! Please do not edit this file directly.
!
! [JAPANESE]
!
! ※※※ 注意!!! ※※※
!
! このファイルは "gtool_history_internal.rb2f90" から Ruby 2.3.3
! によって自動生成されたファイルです.
! このファイルを直接編集しませんようお願い致します.
!
!
!++
!
!
!= デフォルトの GT_HISTORY 変数および GT_HISTORY 操作用内部手続き
!= A default GT_HISTORY variable and internal procedures for handling of GT_HISTORY
!
! Authors::   Yasuhiro MORIKAWA, Eizi TOYODA
! Version::   $Id: gtool_history_internal.rb2f90,v 1.3 2009-10-12 04:03:45 morikawa Exp $
! Tag Name::  $Name:  $
! Copyright:: Copyright (C) GFD Dennou Club, 2000-2005. All rights reserved.
! License::   See COPYRIGHT[link:../../../COPYRIGHT]
!
module gtool_history_internal
  !
  ! このモジュールは, 各サブルーチンにおいて, history 引数が
  ! 未指定の場合に使用されるデフォルトの GT_HISTORY 変数を
  ! 保管するとともに, GT_HISTORY 変数内の情報を編集するための
  ! gtool_history モジュール内部で使用する手続きについても提供します.
  ! 内部向けなので, gtool5 ライブラリの外部から呼び出さないでください.
  !
  ! A default "GT_HISTORY" variable
  ! that is used when "history" argument
  ! of each subroutine is not specified is stored in this module.
  ! In addition, procedures that handle information in GT_HISTORY variables
  ! are provided.
  ! This variable is prepared for internal use,
  ! so do not refer this variable from outside of gtool5
  !
  use dc_types, only: string
  use gtool_history_types, only: gt_history
  use gtdata_types, only: gt_variable
  implicit none
  private
  type(gt_history), save, target, public:: default
                              ! 各サブルーチンにおいて, history 引数が
                              ! 未指定の場合に使用される
                              ! デフォルトの GT_HISTORY 変数.
                              !
                              ! A default "GT_HISTORY" variable
                              ! that is used when "history" argument
                              ! of each subroutine is not specified.
  character(STRING), parameter, public:: &
    & gtool4_netCDF_Conventions = &
    &     "http://www.gfd-dennou.org/library/gtool4/conventions/"
    ! gtool4 netCDF 規約の URL
  character(STRING), parameter, public:: &
    & gtool4_netCDF_version = "4.3"
    ! gtool4 netCDF 規約のバージョン
  public:: append_attrs, copy_attrs
  public:: set_fake_dim_value
  public:: lookup_variable_ord, lookup_variable
  public:: lookup_dimension, lookup_var_or_dim
  interface append_attrs
    module procedure append_attrs
  end interface
  interface copy_attrs
    module procedure copy_attrs
  end interface
  interface set_fake_dim_value
    module procedure set_fake_dim_value
  end interface
  interface lookup_variable_ord
    module procedure lookup_variable_ord
  end interface
  interface lookup_variable
    module procedure lookup_variable
  end interface
  interface lookup_dimension
    module procedure lookup_dimension
  end interface
  interface lookup_var_or_dim
    module procedure lookup_var_or_dim
  end interface
contains
  subroutine append_attrs(varname, attrs, history)
    !
    ! GT_HISTORY_ATTR 変数を history の varname 変数に
    ! 付加するためのサブルーチン. 公開用ではなく,
    ! HistoryCreate や HistoryAddVariable に GT_HISTORY_AXIS
    ! や GT_HISTORY_VARINFO が与えられた時に内部的に利用される.
    !
    use gtool_history_generic, only: historyaddattr
    use gtdata_generic, only: put_attr
    use dc_trace, only: beginsub, endsub, dbgmessage
    use dc_string     , only: strhead, lchar, tochar
    use gtool_history_types, only: gt_history, gt_history_axis, gt_history_varinfo, gt_history_attr
    implicit none
    character(*),     intent(in):: varname
    type(gt_history_attr),  intent(in):: attrs(:)
    type(gt_history), intent(inout), target, optional:: history
    type(gt_history), pointer:: hst =>null()
    integer                      :: i
    character(*), parameter:: subname = "append_attrs"
  continue
    call beginsub(subname, 'varname=<%c>, size(attrs(:))=<%d>', &
      &        c1=trim(varname), i=(/size(attrs(:))/))
    if (present(history)) then
      hst => history
    else
      hst => default
    endif
    ! attrs(:) のサイズ分だけループ
    do i = 1, size( attrs(:) )
      ! attrs(i)%attrtype の種別で与える変数を変える
      if ( strhead( 'char', trim(lchar(attrs(i)%attrtype))) ) then
        call historyaddattr( &
          & varname, attrs(i)%attrname, &
          & trim(attrs(i)%Charvalue), hst )
      elseif ( strhead( 'int', trim(lchar(attrs(i)%attrtype))) ) then
        if ( attrs(i)%array ) then
          call dbgmessage('Intarray(:) is selected.')
          call historyaddattr( &
            & varname, attrs(i)%attrname , &
            & attrs(i)%Intarray, hst       )
        else
          call dbgmessage('Intvalue is selected')
          call historyaddattr( &
            & varname, attrs(i)%attrname , &
            & attrs(i)%Intvalue, hst      )
        endif
      elseif ( strhead( 'real', trim(lchar(attrs(i)%attrtype))) ) then
        if ( attrs(i)%array ) then
          call dbgmessage('Realarray(:) is selected.')
          call historyaddattr( &
            & varname, attrs(i)%attrname, attrs(i)%Realarray, hst)
        else
          call dbgmessage('Realvalue is selected')
          call historyaddattr( &
            & varname, attrs(i)%attrname, attrs(i)%Realvalue, hst)
        endif
      elseif ( strhead( 'double', trim(lchar(attrs(i)%attrtype))) ) then
        if ( attrs(i)%array ) then
          call dbgmessage('Doublearray(:) is selected.')
          call historyaddattr( &
            & varname, attrs(i)%attrname, attrs(i)%Doublearray, hst)
        else
          call dbgmessage('Doublevalue is selected')
          call historyaddattr( &
            & varname, attrs(i)%attrname, attrs(i)%Doublevalue, hst)
        endif
      elseif ( strhead( 'logical', trim(lchar(attrs(i)%attrtype))) ) then
        call historyaddattr( &
          & varname, attrs(i)%attrname, attrs(i)%Logicalvalue, hst)
      else
        call dbgmessage('attrtype=<%c>=<%c>is Invalid.'   , &
          &      c1=trim(attrs(i)%attrtype)         , &
          &      c2=trim(lchar(attrs(i)%attrtype))      )
      endif
    enddo
    call endsub(subname)
  end subroutine append_attrs
  subroutine copy_attrs(from, to, err)
    !
    ! GT_HISTORY_ATTR 変数をコピーするためのサブルーチン
    ! このモジュール内部で利用されることを想定している.
    ! from と to の配列サイズは同じであることが想定されている.
    ! err を与えると, コピーの際何らかの不具合が生じると
    ! 終了せずに err が真になって返る.
    !
    use dc_string,only: lchar, strhead
    use dc_trace, only: beginsub, endsub, dbgmessage
    use dc_error, only: storeerror, &
      &  gt_eargsizemismatch, gt_ebadattrname, dc_noerr
    use dc_types, only: string, token
    use gtool_history_types, only: gt_history, gt_history_axis, gt_history_varinfo, gt_history_attr
    implicit none
    type(gt_history_attr), intent(in)  :: from(:)
    type(gt_history_attr), intent(out) :: to(:)
    logical,               intent(out), optional :: err
    integer     :: i, stat
    character(STRING) :: cause_c
    character(STRING), parameter:: subname = "copy_attrs"
  continue
    call beginsub(subname)
    stat = dc_noerr
    cause_c = ''
    call dbgmessage('size(from)=<%d>, size(to)=<%d>, So copy <%d> times.', &
      &       i=(/ size(from), size(to), min(size(from),size(to)) /) )
    if ( size(to) < size(from) ) then
      stat = gt_eargsizemismatch
      cause_c = 'from is larger than to'
      goto 999
    end if
    ! from と to の小さい方に合わせてループ
    do i = 1, min( size(from), size(to) )
      ! attrname と attrtype と array はまずコピー
      to(i)%attrname       = from(i)%attrname
      to(i)%attrtype       = from(i)%attrtype
      to(i)%array          = from(i)%array
      ! from(i)%attrtype の種別でコピーする変数を変える.
      if ( strhead( 'char', trim(lchar(from(i)%attrtype))) ) then
        to(i)%Charvalue      = from(i)%Charvalue
                          elseif ( strhead( &
        &   lchar('Int'), trim(lchar(from(i)%attrtype)))) then
        if ( from(i)%array ) then
          allocate(  to(i)%Intarray( size(from(i)%Intarray) )  )
          to(i)%Intarray = from(i)%Intarray
        else
          to(i)%Intvalue = from(i)%Intvalue
        endif
      elseif ( strhead( &
        &   lchar('Real'), trim(lchar(from(i)%attrtype)))) then
        if ( from(i)%array ) then
          allocate(  to(i)%Realarray( size(from(i)%Realarray) )  )
          to(i)%Realarray = from(i)%Realarray
        else
          to(i)%Realvalue = from(i)%Realvalue
        endif
      elseif ( strhead( &
        &   lchar('Double'), trim(lchar(from(i)%attrtype)))) then
        if ( from(i)%array ) then
          allocate(  to(i)%Doublearray( size(from(i)%Doublearray) )  )
          to(i)%Doublearray = from(i)%Doublearray
        else
          to(i)%Doublevalue = from(i)%Doublevalue
        endif
      elseif ( strhead( 'logical', trim(lchar(from(i)%attrtype))) ) then
        to(i)%Logicalvalue = from(i)%Logicalvalue
      else
        stat = gt_ebadattrname
        cause_c = from(i)%attrtype
        goto 999
      endif
    enddo
999 continue
    call storeerror(stat, subname, err, cause_c=cause_c)
    call endsub(subname)
  end subroutine copy_attrs
  subroutine set_fake_dim_value(history, dimord)
    !
    ! 次元 history % dimvars(dimord) に値が設定されていない場合、
    ! 「とりあえず」値を設定する。ただし、無制限次元 (時間次元)
    ! に関しては history % origin, history % interval, history % count
    ! から「まっとうな」値が設定される。
    !
    use gtdata_generic, only: inquire, slice, put
    use dc_error, only: dumperror
!    use dc_calendar, only: DCCalConvertByUnit
!    use dc_date, only: EvalByUnit
    type(gt_history), intent(inout):: history
    integer, intent(in):: dimord
    integer:: length, i
    real, allocatable:: value(:)
    logical:: err
  continue
    if (dimord == history % unlimited_index) then
      if (.not. associated(history % count)) return
      length = maxval(history % count(:))
    else
      call inquire(history % dimvars(dimord), size=length)
    endif
    if (length == 0) return
    allocate(value(length))
    if (dimord == history % unlimited_index) then
      value(:) = (/(real(i), i = 1, length)/)
      value(:) =   &
        &   history % origin &
        & + (value(:) - 1.0) * history % interval
!!$      value(:) =   &
!!$        &   EvalByUnit( history % origin, '', history % unlimited_units_symbol ) &
!!$        & + (value(:) - 1.0) &
!!$        &   * EvalByUnit( history % interval, '', history % unlimited_units_symbol )
      call slice(history % dimvars(dimord), 1, start=1, count=length)
    else
      value(:) = (/(real(i), i = 1, length)/)
    endif
    call put(history % dimvars(dimord), value, size(value), err)
    if (err) call dumperror
    deallocate(value)
  end subroutine set_fake_dim_value
  integer function lookup_variable_ord(history, varname) result(result)
    !
    ! history 内の varname 変数の変数番号を返す.
    ! 現在, 明示的に history 変数を与えない場合の変数番号の
    ! 検索は出来ない.
    !
    use dc_types, only: string
    use gtdata_generic, only: inquire
    use dc_trace, only: beginsub, endsub, dbgmessage
    implicit none
    type(gt_history), intent(in):: history
    character(len = *), intent(in):: varname
    character(len = string):: name
    character(len = *), parameter:: subname = 'lookup_variable_ord'
  continue
    call beginsub(subname, 'var=%c', c1 = trim(varname))
    if (associated(history % vars)) then
      do, result = 1, size(history % vars)
        call inquire(history % vars(result), name=name)
        if (name == varname) goto 999
        call dbgmessage('no match <%c> <%c>', c1=trim(name), c2=trim(varname))
      enddo
    endif
    result = 0
999 continue
    call endsub(subname, "result=%d", i=(/result/))
  end function
  type(gt_variable) function lookup_variable(history, varname, ord) result(result)
    !
    !  history 内での変数 varname の ID を取得
    !    ID を取得できた場合, 返り値 result と ord にそれぞれ
    !    その ID が返される。
    !    ID を取得できない場合、ord が渡されていなければその場で終了
    !    ord が渡されている場合は ord に 0 が返される。
    !
    use dc_types, only: string
    use dc_error, only: storeerror, nf90_enotvar, dc_noerr
    use dc_trace, only: beginsub, endsub, dbgmessage
    implicit none
    type(gt_history), intent(in):: history
    character(len = *), intent(in):: varname
    character(len = STRING) :: cause_c
    integer, intent(out), optional:: ord
    integer:: ordwork
    integer:: i, stat
    character(len = *), parameter:: subname = 'lookup_variable'
  continue
    call beginsub(subname, '%c', c1=trim(varname))
    stat = dc_noerr
    cause_c = ''
    if (present(ord)) ord = 0
    ordwork = 0
    i = lookup_variable_ord(history, varname)
    if (i > 0) then
      result = history % vars(i)
      if (present(ord)) ord = i
      goto 999
    endif
    if (present(ord)) then
      ord = 0
    else
      stat = nf90_enotvar
      cause_c = varname
      i = 0
    endif
999 continue
    call storeerror(stat, subname, cause_c=cause_c)
    if (present(ord)) ordwork = ord
    call endsub(subname, "ord=%d (0: not found)", i=(/ordwork/))
  end function
  type(gt_variable) function lookup_dimension(history, dimname, ord) result(result)
    !
    ! history 内の dimname という変数名を持つ次元の GT_VARIABLE
    ! 変数を返す. dimname 末尾の空白は無視される.
    !
    use gtdata_generic, only: inquire
    use dc_types, only: string
    use dc_error, only: storeerror, gt_ebaddimname, dc_noerr
    use dc_trace, only: beginsub, endsub, dbgmessage
    implicit none
    type(gt_history), intent(in):: history
    character(len = *), intent(in):: dimname
    integer, intent(out), optional:: ord
    integer:: ordwork
    character(len = STRING):: name, cause_c
    integer:: i, stat
    character(len = *), parameter:: subname = 'lookup_dimension'
  continue
    call beginsub(subname, 'dimname=%c', c1=trim(dimname))
    stat = dc_noerr
    if (present(ord)) ord = 0
    ordwork = 0
    if (associated(history % dimvars)) then
      do, i = 1, size(history % dimvars)
        call inquire(history % dimvars(i), name=name)
        if (name == trim(dimname)) then
          result = history % dimvars(i)
          if (present(ord)) ord = i
          stat = dc_noerr
          cause_c = ""
          goto 999
        endif
      enddo
    endif
    if (present(ord)) then
      ord = 0
    else
      stat = gt_ebaddimname
      cause_c = dimname
    endif
999 continue
    call storeerror(stat, subname, cause_c=cause_c)
    if (present(ord)) ordwork = ord
    call endsub(subname, 'ord=%d (0:not found)', i=(/ordwork/))
  end function
  subroutine lookup_var_or_dim(history, name, var, err)
    !
    ! history 内から, name という名前の次元または変数を探査し,
    ! var に GT_VARIABLE 変数を返す. 見つかって正常に
    ! var が返る場合は stat には DC_NOERR が返り,
    ! history 内から name が発見されない場合には, stat に
    ! NF90_ENOTVAR が返る.
    !
    use dc_error, only: storeerror, dc_noerr, nf90_enotvar
    use dc_types, only: string
    use dc_trace, only: beginsub, endsub, dbgmessage
    implicit none
    type(gt_history), intent(in):: history
    character(len = *), intent(in):: name
    type(gt_variable), intent(out):: var
    logical, intent(out):: err
    integer:: stat, ord
    character(STRING) :: cause_c
    character(len = *), parameter:: subname = 'lookup_var_or_dim'
  continue
    call beginsub(subname, 'name=<%c>', c1=trim(name))
    cause_c = ""
    stat = dc_noerr
    var = lookup_variable(history, name, ord)
    if (ord /= 0) then
      stat = dc_noerr
      goto 999
    endif
    var = lookup_dimension(history, name, ord)
    if (ord /= 0) then
      stat = dc_noerr
      goto 999
    endif
    stat = nf90_enotvar
    cause_c = "Any vars and dims are not found"
999 continue
    call storeerror(stat, subname, err, cause_c)
    call endsub(subname, 'ord=%d (0:not found)', i=(/ord/))
  end subroutine lookup_var_or_dim
end module gtool_history_internal
!--
! vi:set readonly sw=4 ts=8:
!
!Local Variables:
!mode: f90
!buffer-read-only: t
!End:
!
!++