gtvarinquire.f90

Go to the documentation of this file.

!> @file gtvarinquire.f90
!>
!> @author Eizi TOYODA, Yasuhiro MORIKAWA
!> @copyright Copyright (C) GFD Dennou Club, 2000-2026. All rights reserved. <br/>
!>            License is BSD-2-Clause. See [COPYRIGHT](@ref COPYRIGHT) in detail
!>
!> @en
!> @brief Variable or attribute inquiry
!>
!> These subroutines are provided as gtdata_generic#Inquire
!> through gtdata_generic.
!> @enden
!>
!> @ja
!> @brief 変数または属性に関する問い合わせ
!>
!> これらのサブルーチンは gtdata_generic から gtdata_generic#Inquire
!> として提供されます。
!> @endja
!>
 
!>
!> @en
!> @brief Inquire about variable properties
!>
!> Inquires about variable var. This subroutine is modeled after
!> the INQUIRE statement.
!>
!> If the character argument length is insufficient, results may be
!> truncated. Using dc_types#STRING for argument string lengths is
!> recommended.
!>
!> Inquire is a generic name for multiple subroutines with various
!> inquiry methods. See also Get_Slice and Dimname_to_Dimord.
!> @param[in]  var      Variable handle
!> @param[out] growable Whether variable can auto-extend (optional)
!> @param[out] rank     Number of non-compact dimensions (optional)
!> @param[out] alldims  Total number of dimensions including degenerate (optional)
!> @param[out] allcount Total count for dimension variable (optional)
!> @param[out] size     Size of I/O region (optional)
!> @param[out] xtype    External type name (optional)
!> @param[out] name     Variable name (optional)
!> @param[out] url      Full URL of variable (optional)
!> @param[out] err      Error flag (optional)
!> @enden
!>
!> @ja
!> @brief 変数の属性に関する問い合わせ
!>
!> 変数 var に関する問い合わせを行います。
!> このサブルーチンは INQUIRE 文を模して作られたものです。
!>
!> 返り値となる引数の文字型の実引数の長さが足りないと、
!> 結果が損なわれます。引数の文字列の長さとして dc_types#STRING
!> を用いることを推奨します。
!>
!> Inquire は複数のサブルーチンの総称名であり、
!> 問い合わせ方法は複数用意されています。
!> Get_Slice, Dimname_to_Dimord も参照してください。
!> @param[in]  var      変数ハンドル
!> @param[out] growable 自動拡張可能か否か (省略可能)
!> @param[out] rank     コンパクト次元を数えない次元の数 (省略可能)
!> @param[out] alldims  縮退次元を含む全次元数 (省略可能)
!> @param[out] allcount 次元変数の総数 (省略可能)
!> @param[out] size     入出力領域の大きさ (省略可能)
!> @param[out] xtype    外部型の名前 (省略可能)
!> @param[out] name     変数名 (省略可能)
!> @param[out] url      変数のフルURL (省略可能)
!> @param[out] err      エラーフラグ (省略可能)
!> @endja
!>
subroutine gtvarinquire(var, growable, rank, alldims, allcount, &
  & size, xtype, name, url, err )
  use gtdata_types, only: gt_variable
  use gtdata_internal_map, only: var_class, vtb_class_netcdf
  use gtdata_netcdf_generic, only: inquire
  use gtdata_netcdf_types, only: gd_nc_variable
  use dc_trace, only: beginsub, endsub, dbgmessage
  implicit none
  type(gt_variable), intent(in):: var
  character(len=*), intent(out), optional:: xtype
                                        ! 外部型の名前
  character(len=*), intent(out), optional:: name
                                        ! name は変数名の最小の単位を返します。
                                        ! ファイル名を含まないため
                                        ! プログラム内での一意性は
                                        ! 保証されません。
                                        !
  character(len=*), intent(out), optional:: url
                                        ! url はファイル名のついた変数名
                                        ! を返します。
                                        ! プログラム内で一意です。
                                        !
  integer, intent(out), optional:: rank
                                        ! コンパクト(縮退)次元を数えない、
                                        ! 次元の数
                                        !
  integer, intent(out), optional:: alldims
                                        ! 縮退次元を含む全次元数。
                                        ! dimord には基本的にこちらを
                                        ! 使います。
                                        !
  integer, intent(out), optional:: allcount
                                        ! 変数が次元変数である場合、
                                        ! 総数を返します。
                                        ! エラーの場合はゼロを返します。
                                        !
  integer, intent(out), optional:: size
                                        ! 変数の入出力領域の大きさ。
                                        ! (変数が依存する各次元の長
                                        ! [格子点数]の積)
                                        !
  logical, intent(out), optional:: growable
                                        ! 変数が次元変数である場合、
                                        ! 自動拡張可能か否かを返します。
                                        ! 次元変数でない場合は不定となります。
                                        !
  logical, intent(out), optional:: err
                                        ! 例外処理用フラグ.
                                        ! デフォルトでは, この手続き内でエラーが
                                        ! 生じた場合, プログラムは強制終了します.
                                        ! 引数 *err* が与えられる場合,
                                        ! プログラムは強制終了せず, 代わりに
                                        ! *err* に .true. が代入されます.
                                        !
                                        ! Exception handling flag.
                                        ! By default, when error occur in
                                        ! this procedure, the program aborts.
                                        ! If this *err* argument is given,
                                        ! .true. is substituted to *err* and
                                        ! the program does not abort.
            integer:: class, cid
continue
  if (present(err)) err = .false.
  call beginsub('gtvarinquire', 'var.mapid=%d', i=(/var%mapid/))
  call var_class(var, class, cid)
  select case(class)
  case(vtb_class_netcdf)
    if (present(xtype) .or. present(name) .or. present(url)) then
      call inquire(gd_nc_variable(cid), xtype=xtype, name=name, url=url)
      if (present(xtype)) call dbgmessage('xtype=%c', c1=trim(xtype))
      if (present(name)) call dbgmessage('name=%c', c1=trim(name))
      if (present(url)) call dbgmessage('url=%c', c1=trim(url))
    endif
    if (present(growable)) then
      call inquire(gd_nc_variable(cid), growable=growable)
      call dbgmessage('growable=%y', l=(/growable/))
    endif
  end select
  if (present(alldims)) alldims = internal_get_alldims(var)
  if (present(allcount)) allcount = internal_get_allcount(var)
  if (present(size)) size = internal_get_size(var)
  if (present(rank)) rank = internal_get_rank(var)
  call endsub('gtvarinquire')
  return
contains
 
  integer function internal_get_alldims(var) result(result)
    use gtdata_internal_map, only: map_lookup
    implicit none
    type(gt_variable), intent(in):: var
    call map_lookup(var, ndims=result)
    call dbgmessage('alldims=%d', i=(/result/))
  end function internal_get_alldims
 
  integer function internal_get_allcount(var) result(result)
    use gtdata_internal_map, only: gt_dimmap, map_lookup
    implicit none
    type(gt_variable), intent(in):: var
    type(gt_dimmap), allocatable:: map(:)
    integer:: nd
    call map_lookup(var, ndims=nd)
    if (nd <= 0) then
      call dbgmessage('internal_get_allcount: no map')
      result = 1
      return
    endif
    allocate(map(nd))
    call map_lookup(var, map=map)
    result = product(map(1:nd)%allcount)
    call dbgmessage('internal_get_allcount: %d map.size=%d', &
      & i=(/result, nd/))
    deallocate(map)
  end function internal_get_allcount
 
  integer function internal_get_size(var) result(result)
    use gtdata_internal_map, only: gt_dimmap, map_lookup
    implicit none
    type(gt_variable), intent(in):: var
    type(gt_dimmap), allocatable:: map(:)
    integer:: nd
    call map_lookup(var, ndims=nd)
    if (nd <= 0) then
      call dbgmessage('internal_get_size: no map')
      result = 1
      return
    endif
    allocate(map(nd))
    call map_lookup(var, map=map)
    result = product(map(1:nd)%count)
    call dbgmessage('internal_get_size: %d map.size=%d', &
      & i=(/result, nd/))
    deallocate(map)
  end function internal_get_size
 
  integer function internal_get_rank(var) result(result)
    use gtdata_internal_map, only: gt_dimmap, map_lookup
    implicit none
    type(gt_variable), intent(in):: var
    type(gt_dimmap), allocatable:: map(:)
    integer:: nd
 
    call map_lookup(var, ndims=nd)
    if (nd <= 0) then
      call dbgmessage('internal_get_rank: no map')
      result = 0
      return
    endif
    allocate(map(nd))
    call map_lookup(var, map=map)
    result = count(map(1:nd)%count > 1)
    call dbgmessage('internal_get_rank: %d', i=(/result/))
    deallocate(map)
  end function internal_get_rank
 
end subroutine gtvarinquire
 
!> @en
!> @brief Inquire total counts for all dimensions of a variable
!>
!> Returns the total count for each dimension that variable var depends on.
!> The allcount array size must be at least the number of dependent dimensions.
!> Use Inquire with alldims to determine the number of dimensions.
!> @param[in]  var      Variable handle
!> @param[out] allcount Total count for each dimension
!> @enden
!> @ja
!> @brief 変数の依存する次元 (複数) の総数の問い合わせ
!>
!> 変数 var が依存する各次元の総数を返します。
!> allcount の配列のサイズは依存する次元の数だけ必要です。
!> 依存する次元の数は Inquire の alldims で調べることができます。
!> @param[in]  var      変数ハンドル
!> @param[out] allcount 各次元の総数
!> @endja
subroutine gtvarinquire2(var, allcount)
  use gtdata_types, only: gt_variable
  use gtdata_generic, only: inquire, open, close
  use dc_trace, only: beginsub, endsub
  type(gt_variable), intent(in):: var
  integer, intent(out):: allcount(:) ! alldims 個必要
  integer:: i, n
  type(gt_variable):: v
  call beginsub('gtvarinquire2')
  call inquire(var, alldims=n)
  do, i = 1, n
    call open(v, var, i, count_compact=.true.)
    call inquire(var, allcount=allcount(i))
    call close(v)
  enddo
  call endsub('gtvarinquire2')
end subroutine
 
!> @en
!> @brief Inquire attribute type of a variable
!>
!> Returns the type of attribute attrname of variable var in xtype.
!> @param[in]  var      Variable handle
!> @param[in]  attrname Attribute name
!> @param[out] xtype    Attribute type (optional)
!> @enden
!> @ja
!> @brief 変数の属性の型の問い合わせ
!>
!> 変数 var の属性 attrname の値の型を xtype に返します。
!> @param[in]  var      変数ハンドル
!> @param[in]  attrname 属性名
!> @param[out] xtype    属性の型 (省略可能)
!> @endja
subroutine gtvarinquirea(var, attrname, xtype)
  use gtdata_types, only: gt_variable
  use gtdata_internal_map, only: var_class, vtb_class_netcdf
  use dc_trace, only: beginsub, endsub
  use gtdata_netcdf_generic, only: inquire
  use gtdata_netcdf_types, only: gd_nc_variable
  type(gt_variable), intent(in):: var
  character(len=*), intent(in):: attrname
  character(len=*), intent(out), optional:: xtype
  integer:: class, cid
  character(len = *), parameter:: subnam = "gtvarinquireA"
continue
  call beginsub(subnam, "%c", c1=trim(attrname))
  call var_class(var, class, cid)
  select case(class)
  case(vtb_class_netcdf)
    call inquire(gd_nc_variable(cid), attrname=attrname, xtype=xtype)
  end select
  call endsub(subnam)
end subroutine gtvarinquirea
 
!> @en
!> @brief Inquire about a dimension of a variable
!>
!> Returns the URL and total count for the dimension at order number
!> dimord of variable var.
!> @param[in]  var      Variable handle
!> @param[in]  dimord   Dimension order number
!> @param[out] url      Dimension URL (optional)
!> @param[out] allcount Total count (optional)
!> @param[out] err      Error flag (optional)
!> @enden
!> @ja
!> @brief 変数の次元に関する問い合わせ
!>
!> 変数 var の次元順序番号 dimord に対応する次元の
!> URL url と総数 allcount を返します。
!> @param[in]  var      変数ハンドル
!> @param[in]  dimord   次元順序番号
!> @param[out] url      次元URL (省略可能)
!> @param[out] allcount 総数 (省略可能)
!> @param[out] err      エラーフラグ (省略可能)
!> @endja
subroutine gtvarinquired(var, dimord, url, allcount, err)
  use gtdata_types, only: gt_variable
  use gtdata_generic, only: open, close, inquire
  use dc_trace, only: beginsub, endsub
  implicit none
  type(gt_variable), intent(in):: var
  integer, intent(in):: dimord
  character(len=*), intent(out), optional:: url
  integer, intent(out), optional:: allcount
  logical, intent(out), optional:: err
  type(gt_variable):: dimvar
  character(len = *), parameter:: subnam = "gtvarinquireD"
continue
  call beginsub(subnam, "%d", i=(/dimord/))
  call open(dimvar, source_var=var, dimord=dimord, err=err)
  if (present(url)) call inquire(dimvar, url=url)
  if (present(allcount)) call inquire(dimvar, allcount=allcount)
  call close(dimvar)
  call endsub(subnam)
end subroutine gtvarinquired