gdncattrgetnum.f90

Go to the documentation of this file.

! -*- coding: utf-8; mode: f90 -*-
!-------------------------------------------------------------------------------------
! Copyright (c) 2000-2016 Gtool Development Group. All rights reserved.
!-------------------------------------------------------------------------------------
! ** Important**
!
! This file is generated from gdncattrgetnum.erb by ERB included Ruby 2.3.3.
! Please do not edit this file directly. @see "gdncattrgetnum.erb"
!-------------------------------------------------------------------------------------
!
!
!= Get GD_NC_VARIABLES
!
! Authors::   Eizi TOYODA, Yasuhiro MORIKAWA
! Version::   $Id: gdncattrgetnum.rb2f90,v 1.2 2009-05-25 09:51:59 morikawa Exp $
! Tag Name::  $Name:  $
! Copyright:: Copyright (C) GFD Dennou Club, 2000-2009. All rights reserved.
! License::   See COPYRIGHT[link:../../COPYRIGHT]
!
! お客様向きではないけれど、情報落ちのないインターフェイスということで....
!
! stat < 0                :: エラー、あるいはその属性は存在しなかった
! stat = 0 ... size(value):: その属性を全部読み取った。サイズは stat 個
! stat > size(value)      :: 配列長不足のため属性が全部読み取れなかった。
!                            サイズは stat 個必要
!
! * バグ:
!   * 属性が文字型で STRING 文字を越える場合、GT_ECHARSHORT が返る
!
!
subroutine gdncattrgetint(var, name, value, stat, default)
  use gtdata_netcdf_types,   only: gd_nc_variable, gd_nc_variable_entry
  use gtdata_netcdf_internal,only: vtable_lookup
  use netcdf, only: &
    & nf90_noerr, &
    & nf90_global, &
    & nf90_char, &
    & nf90_enomem, &
    & nf90_inquire_attribute, &
    & nf90_get_att
  use dc_url,     only: gt_plus
  use gtdata_netcdf_generic, only: get_attr
  use dc_types,   only: string
  use dc_string
  implicit none
  type(gd_nc_variable),       intent(in) :: var
  character(len = *),      intent(in) :: name
  integer,            intent(out):: stat
  integer, intent(out):: value(:)
  integer,  intent(in), optional:: default
  integer,  allocatable:: rbuffer(:)
  character(STRING)      :: cbuffer
  character(STRING), pointer :: lbuffer(:)
  integer           :: attrlen, xtype, i, xferend, iname, varid
  type(gd_nc_variable_entry):: ent
  continue
  stat = vtable_lookup(var, ent)
  if (stat /= nf90_noerr) then
    if (present(default)) value(:) = default
    return
  endif
  ! 型と長さを取得
  if (name(1:1) == gt_plus) then
    iname = 2
    varid = nf90_global
  else
    iname = 1
    varid = ent%varid
  endif
  stat = nf90_inquire_attribute(ent%fileid, varid, &
    name = name(iname:), xtype = xtype, len = attrlen)
  if (stat /= nf90_noerr) then
    if (present(default)) value(:) = default
    return
  endif
  ! 文字型の場合は長さをコンマで分解した語数と読み替える
  if (xtype == nf90_char) then
    call get_attr(var, name, cbuffer, "", stat)
    if (stat /= 0) return
    call split(cbuffer, lbuffer, ", ")
    attrlen = size(lbuffer)
  endif
  ! 結果を入れるところがなければ長さだけを伝え終了
  if (size(value) == 0) then
    if (xtype == nf90_char) deallocate(lbuffer)
    stat = attrlen
    return
  endif
  ! 型に応じて要求されただけ値を転送
  xferend = min(size(value), attrlen)
  if (present(default)) value(xferend+1: ) = default
  if (xtype == nf90_char) then
    do, i = 1, xferend
      value(i) = stod(lbuffer(i))
    enddo
    deallocate(lbuffer)
    stat = attrlen
    return
  else
    allocate(rbuffer(attrlen), stat=stat)
    if (stat /= 0) then
      stat = nf90_enomem
      return
    endif
    stat = nf90_get_att(ent%fileid, varid, name(iname:), rbuffer)
    if (stat == nf90_noerr) then
      value(1:xferend) = rbuffer(1:xferend)
      stat = attrlen
    endif
    deallocate(rbuffer)
    return
  endif
end subroutine gdncattrgetint

subroutine gdncattrgetreal(var, name, value, stat, default)
  use gtdata_netcdf_types,   only: gd_nc_variable, gd_nc_variable_entry
  use gtdata_netcdf_internal,only: vtable_lookup
  use netcdf, only: &
    & nf90_noerr, &
    & nf90_global, &
    & nf90_char, &
    & nf90_enomem, &
    & nf90_inquire_attribute, &
    & nf90_get_att
  use dc_url,     only: gt_plus
  use gtdata_netcdf_generic, only: get_attr
  use dc_types,   only: string, sp
  use dc_string
  implicit none
  type(gd_nc_variable),       intent(in) :: var
  character(len = *),      intent(in) :: name
  integer,            intent(out):: stat
  real(SP), intent(out):: value(:)
  real(SP),  intent(in), optional:: default
  real(SP),  allocatable:: rbuffer(:)
  character(STRING)      :: cbuffer
  character(STRING), pointer :: lbuffer(:)
  integer           :: attrlen, xtype, i, xferend, iname, varid
  type(gd_nc_variable_entry):: ent
  continue
  stat = vtable_lookup(var, ent)
  if (stat /= nf90_noerr) then
    if (present(default)) value(:) = default
    return
  endif
  ! 型と長さを取得
  if (name(1:1) == gt_plus) then
    iname = 2
    varid = nf90_global
  else
    iname = 1
    varid = ent%varid
  endif
  stat = nf90_inquire_attribute(ent%fileid, varid, &
    name = name(iname:), xtype = xtype, len = attrlen)
  if (stat /= nf90_noerr) then
    if (present(default)) value(:) = default
    return
  endif
  ! 文字型の場合は長さをコンマで分解した語数と読み替える
  if (xtype == nf90_char) then
    call get_attr(var, name, cbuffer, "", stat)
    if (stat /= 0) return
    call split(cbuffer, lbuffer, ", ")
    attrlen = size(lbuffer)
  endif
  ! 結果を入れるところがなければ長さだけを伝え終了
  if (size(value) == 0) then
    if (xtype == nf90_char) deallocate(lbuffer)
    stat = attrlen
    return
  endif
  ! 型に応じて要求されただけ値を転送
  xferend = min(size(value), attrlen)
  if (present(default)) value(xferend+1: ) = default
  if (xtype == nf90_char) then
    do, i = 1, xferend
      value(i) = stod(lbuffer(i))
    enddo
    deallocate(lbuffer)
    stat = attrlen
    return
  else
    allocate(rbuffer(attrlen), stat=stat)
    if (stat /= 0) then
      stat = nf90_enomem
      return
    endif
    stat = nf90_get_att(ent%fileid, varid, name(iname:), rbuffer)
    if (stat == nf90_noerr) then
      value(1:xferend) = rbuffer(1:xferend)
      stat = attrlen
    endif
    deallocate(rbuffer)
    return
  endif
end subroutine gdncattrgetreal

subroutine gdncattrgetdouble(var, name, value, stat, default)
  use gtdata_netcdf_types,   only: gd_nc_variable, gd_nc_variable_entry
  use gtdata_netcdf_internal,only: vtable_lookup
  use netcdf, only: &
    & nf90_noerr, &
    & nf90_global, &
    & nf90_char, &
    & nf90_enomem, &
    & nf90_inquire_attribute, &
    & nf90_get_att
  use dc_url,     only: gt_plus
  use gtdata_netcdf_generic, only: get_attr
  use dc_types,   only: string, dp
  use dc_string
  implicit none
  type(gd_nc_variable),       intent(in) :: var
  character(len = *),      intent(in) :: name
  integer,            intent(out):: stat
  real(DP), intent(out):: value(:)
  real(DP),  intent(in), optional:: default
  real(DP),  allocatable:: rbuffer(:)
  character(STRING)      :: cbuffer
  character(STRING), pointer :: lbuffer(:)
  integer           :: attrlen, xtype, i, xferend, iname, varid
  type(gd_nc_variable_entry):: ent
  continue
  stat = vtable_lookup(var, ent)
  if (stat /= nf90_noerr) then
    if (present(default)) value(:) = default
    return
  endif
  ! 型と長さを取得
  if (name(1:1) == gt_plus) then
    iname = 2
    varid = nf90_global
  else
    iname = 1
    varid = ent%varid
  endif
  stat = nf90_inquire_attribute(ent%fileid, varid, &
    name = name(iname:), xtype = xtype, len = attrlen)
  if (stat /= nf90_noerr) then
    if (present(default)) value(:) = default
    return
  endif
  ! 文字型の場合は長さをコンマで分解した語数と読み替える
  if (xtype == nf90_char) then
    call get_attr(var, name, cbuffer, "", stat)
    if (stat /= 0) return
    call split(cbuffer, lbuffer, ", ")
    attrlen = size(lbuffer)
  endif
  ! 結果を入れるところがなければ長さだけを伝え終了
  if (size(value) == 0) then
    if (xtype == nf90_char) deallocate(lbuffer)
    stat = attrlen
    return
  endif
  ! 型に応じて要求されただけ値を転送
  xferend = min(size(value), attrlen)
  if (present(default)) value(xferend+1: ) = default
  if (xtype == nf90_char) then
    do, i = 1, xferend
      value(i) = stod(lbuffer(i))
    enddo
    deallocate(lbuffer)
    stat = attrlen
    return
  else
    allocate(rbuffer(attrlen), stat=stat)
    if (stat /= 0) then
      stat = nf90_enomem
      return
    endif
    stat = nf90_get_att(ent%fileid, varid, name(iname:), rbuffer)
    if (stat == nf90_noerr) then
      value(1:xferend) = rbuffer(1:xferend)
      stat = attrlen
    endif
    deallocate(rbuffer)
    return
  endif
end subroutine gdncattrgetdouble