subroutine GTVarInquire(var, growable, rank, alldims, allcount, size, xtype, name, url)
!
!== 変数に関する問い合わせ
!
! 変数 *var* に関する問い合わせを行います。
!
! 返り値となる引数の文字型の実引数の長さが足りないと、
! 結果が損なわれます。引数の文字列の長さとして dc_types#STRING
! を用いることを推奨します。
!
! *Inquire* は複数のサブルーチンの総称名であり、
! 問い合わせ方法は複数用意されています。
! 下記のサブルーチンも参照してください。
!
! 他にも変数に関する問い合わせのための手続きとして
! Get_Slice, Dimname_to_Dimord があります。
!
!
use gtdata_types, only: GT_VARIABLE
use gt_map, only: var_class, vtb_class_netcdf, vtb_class_memory
use an_generic, only: inquire, an_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
! 変数が次元変数である場合、
! 自動拡張可能か否かを返します。
! 次元変数でない場合は不定となります。
!
integer:: class, cid
continue
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(an_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(an_variable(cid), growable=growable)
call DbgMessage('growable=%y', L=(/growable/))
endif
case(vtb_class_memory)
call DbgMessage('vtb_class_memory not implemented: skipped')
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 gt_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 gt_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 gt_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 gt_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 = 1
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