gtvarinquire.f90

Go to the documentation of this file.

 
 
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
 
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
 
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
 
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