! != 数値型属性の入力 ! ! Authors:: Eizi TOYODA, Yasuhiro MORIKAWA ! Version:: $Id: gtvargetattr.f90,v 1.3 2006/01/15 07:10:30 morikawa Exp $ ! Tag Name:: $Name: gt4f90io-20060121 $ ! Copyright:: Copyright (C) GFD Dennou Club, 2000-2005. All rights reserved. ! License:: See COPYRIGHT[link:../../COPYRIGHT] ! ! 以下のサブルーチン, 関数は gtdata_generic から提供されます。 ! !-- ! 引数の型に応じていろいろあるが、どうせ下部構造では同じモノを使っている。 ! ! スカラで受け取るのが一番簡単。解釈可能な値がとられ、残りは捨てられる。 !++ subroutine GTVarGetAttrI(var, attrname, value, default) ! !== 属性の入力 ! ! 変数 *var* に付加されている属性 *name* の値を返します。 ! *Get_Attr* は複数のサブルーチンの総称名なので、 ! *value* には様々な型の変数 (ポインタも可能) ! を与えることが可能です。 ! 以下のサブルーチンを参照してください。 ! ! 属性の値が正常に取得できず、且つ *default* が与えられて ! いた場合、その値が返ります。 ! *default* が与えられない場合のデフォルトの値はそれぞれ以下の ! 通りです。 ! ! character :: "" (空文字) ! real :: netcdf_f77#NF_FILL_REAL ! real(DP) :: netcdf_f77#NF_FILL_REAL ! integer :: netcdf_f77#NF_FILL_INT ! ! *value* がポインタの場合は、型に依らず空状態が返ります。 ! ! *value* にポインタを与えた場合、属性の値に応じて自動的に ! 割り付けが行われます。そのため、必ず空状態にしてから与えてください。 ! ! *value* に固定長配列を用意する場合 *default* が必須になりますが、 ! これは Fortran の言語仕様上ポインタ方式と引用仕様が同じであっては ! ならないからです。 ! use gtdata_types, only: GT_VARIABLE use gt_map, only: var_class, vtb_class_netcdf, vtb_class_memory use an_generic, only: get_attr, an_variable use gt_mem, only: get_attr, mem_variable use netcdf_f77, only: NF_FILL_INT use dc_string, only: VSTRING, assignment(=), stoi use dc_error, only: GT_ENOTVAR, StoreError implicit none type(GT_VARIABLE), intent(in):: var character(len = *), intent(in):: attrname integer, intent(out):: value integer, intent(in), optional:: default integer:: stat, buffer(1), class, cid type(VSTRING):: cbuffer logical:: err continue call var_class(var, class, cid) if (class == vtb_class_netcdf) then call get_attr(an_variable(cid), attrname, buffer, stat, default) value = buffer(1) if (stat >= 1) return else if (class == vtb_class_memory) then call get_attr(mem_variable(cid), attrname, cbuffer, err) if (.not. err) then value = stoi(cbuffer) return endif else call StoreError(GT_ENOTVAR, "GTVarGetAttrI") endif value = NF_FILL_INT if (present(default)) value = default end subroutine GTVarGetAttrI subroutine GTVarGetAttrR(var, attrname, value, default) use gtdata_types, only: GT_VARIABLE use an_generic, only: get_attr, an_variable use gt_mem, only: get_attr, mem_variable use gt_map, only: var_class, vtb_class_netcdf, vtb_class_memory use dc_error, only: GT_EBADVAR, StoreError use dc_string, only: VSTRING, assignment(=), stod use netcdf_f77, only: NF_FILL_REAL implicit none type(GT_VARIABLE), intent(in):: var character(len = *), intent(in):: attrname real, intent(out):: value real, intent(in), optional:: default integer:: stat real:: buffer(1) type(VSTRING):: cbuffer integer:: class, cid logical:: err continue call var_class(var, class, cid) if (class == vtb_class_netcdf) then call get_attr(an_variable(cid), attrname, value=buffer, & & stat=stat, default=default) if (stat >= 1) then value = buffer(1) return endif else if (class == vtb_class_memory) then call get_attr(mem_variable(cid), attrname, cbuffer, err) if (.not. err) then value = stod(cbuffer) return endif else call StoreError(GT_EBADVAR, "GTVarGetAttrR") endif if (present(default)) then value = default else value = NF_FILL_REAL endif end subroutine GTVarGetAttrR subroutine GTVarGetAttrD(var, attrname, value, default) use gtdata_types, only: GT_VARIABLE use gt_map, only: var_class, vtb_class_netcdf, vtb_class_memory use an_generic, only: get_attr, an_variable use gt_mem, only: get_attr, mem_variable use dc_string, only: VSTRING, assignment(=), stod use dc_error, only: GT_ENOTVAR, StoreError use dc_types, only: DP use netcdf_f77, only: NF_FILL_REAL implicit none type(GT_VARIABLE), intent(in):: var character(len = *), intent(in):: attrname real(DP), intent(out):: value real(DP), intent(in), optional:: default integer:: stat real(DP):: buffer(1) type(VSTRING):: cbuffer integer:: class, cid logical:: err continue call var_class(var, class, cid) select case(class) case (vtb_class_netcdf) call get_attr(an_variable(cid), attrname, value=buffer, & & stat=stat, default=default) value = buffer(1) if (stat >= 1) return case (vtb_class_memory) call get_attr(mem_variable(cid), attrname, cbuffer, err) if (.not. err) then value = stod(cbuffer) return endif case default call StoreError(GT_ENOTVAR, "GTVarGetAttrR") end select value = NF_FILL_REAL if (present(default)) value = default end subroutine ! ! ポインタ配列を使って受け取る場合は解釈可能な数だけ実体が割り付けられる。 ! subroutine GTVarGetAttrIP(var, name, value) use gtdata_types, only: GT_VARIABLE use gt_map, only: var_class, vtb_class_netcdf, vtb_class_memory use an_generic, only: get_attr, an_variable use gt_mem, only: get_attr, mem_variable use dc_error, only: GT_ENOTVAR, StoreError use dc_string, only: VSTRING, get_array, assignment(=) implicit none type(GT_VARIABLE), intent(in):: var character(len = *), intent(in):: name integer, pointer:: value(:) !(out) integer:: stat, class, cid type(VSTRING):: cbuffer logical:: err continue call var_class(var, class, cid) if (class == vtb_class_netcdf) then allocate(value(1)) call get_attr(an_variable(cid), name, value(1:0), stat) deallocate(value) if (stat < 1) return allocate(value(stat)) call get_attr(an_variable(cid), name, value, stat) if (stat < 1) deallocate(value) else if (class == vtb_class_memory) then call get_attr(mem_variable(cid), name, cbuffer, err) if (err) then nullify(value) return endif call get_array(value, cbuffer) cbuffer = "" else call StoreError(GT_ENOTVAR, "GTVarGetAttrIP") endif end subroutine GTVarGetAttrIP subroutine GTVarGetAttrRP(var, name, value) use gtdata_types, only: GT_VARIABLE use gt_map, only: var_class, vtb_class_netcdf, vtb_class_memory use an_generic, only: get_attr, an_variable use gt_mem, only: get_attr, mem_variable use dc_string, only: VSTRING, assignment(=), get_array use dc_error, only: GT_ENOTVAR, StoreError implicit none type(GT_VARIABLE), intent(in):: var character(len = *), intent(in):: name real, pointer:: value(:) !(out) integer:: stat, class, cid type(VSTRING):: cbuffer logical:: err continue call var_class(var, class, cid) if (class == vtb_class_netcdf) then allocate(value(1)) call get_attr(an_variable(cid), name, value(1:0), stat) deallocate(value) if (stat < 1) return allocate(value(stat)) call get_attr(an_variable(cid), name, value, stat) if (stat < 1) deallocate(value) else if (class == vtb_class_memory) then call get_attr(mem_variable(cid), name, cbuffer, err) if (err) then nullify(value) return endif call get_array(value, cbuffer) cbuffer = "" else nullify(value) call StoreError(GT_ENOTVAR, "GTVarGetAttrRP") endif end subroutine GTVarGetAttrRP subroutine GTVarGetAttrDP(var, name, value) use gtdata_types, only: GT_VARIABLE use gt_map, only: var_class, vtb_class_netcdf, vtb_class_memory use an_generic, only: get_attr, an_variable use gt_mem, only: get_attr, mem_variable use dc_types, only: DP use dc_error, only: GT_ENOTVAR, StoreError use dc_string, only: VSTRING, get_array, assignment(=) implicit none type(GT_VARIABLE), intent(in):: var character(len = *), intent(in):: name real(DP), pointer:: value(:) !(out) integer:: stat, class, cid type(VSTRING):: cbuffer logical:: err continue call var_class(var, class, cid) if (class == vtb_class_netcdf) then allocate(value(1)) call get_attr(an_variable(cid), name, value(1:0), stat) deallocate(value) if (stat < 1) return allocate(value(stat)) call get_attr(an_variable(cid), name, value, stat) if (stat < 1) deallocate(value) else if (class == vtb_class_memory) then call get_attr(mem_variable(cid), name, cbuffer, err) if (err) then nullify(value) return endif call get_array(value, cbuffer) cbuffer = "" else call StoreError(GT_ENOTVAR, "GTVarGetAttrRP") endif end subroutine GTVarGetAttrDP ! integer 配列, real 配列として受け取る ! 場合は属性長があまっている場合には切り捨てられ、 ! 属性長が足りない場合は default 値 (ポインタと違い必須) を埋める。 subroutine GTVarGetAttrIA(var, name, value, stat, default) use gtdata_types, only: GT_VARIABLE use gtdata_generic, only: friend => get_attr use gt_map, only: var_class, vtb_class_netcdf, vtb_class_memory use an_generic, only: get_attr, an_variable use dc_error, only: GT_ENOTVAR, StoreError implicit none type(GT_VARIABLE), intent(in):: var character(len = *), intent(in):: name integer, intent(out):: value(:) integer, intent(in):: default integer, pointer:: ptr(:) integer:: n, stat, class, cid continue call var_class(var, class, cid) if (class == vtb_class_netcdf) then call get_attr(an_variable(cid), name, value, stat, default) else if (class == vtb_class_memory) then call friend(var, name, ptr) if (.not. associated(ptr)) then value(:) = default else n = min(size(ptr), size(value)) value(1:n) = ptr(1:n) if (n < size(ptr)) value(n+1: ) = default deallocate(ptr) endif else call StoreError(GT_ENOTVAR, "GTVarGetAttrIA") endif end subroutine GTVarGetAttrIA subroutine GTVarGetAttrRA(var, name, value, default) use gtdata_types, only: GT_VARIABLE use gtdata_generic, only: friend => get_attr use gt_map, only: var_class, vtb_class_netcdf, vtb_class_memory use an_generic, only: get_attr, an_variable use dc_error, only: GT_ENOTVAR, StoreError implicit none type(GT_VARIABLE), intent(in):: var character(len = *), intent(in):: name real, intent(out):: value(:) real, intent(in):: default real, pointer:: ptr(:) integer:: n, class, cid, stat continue call var_class(var, class, cid) if (class == vtb_class_netcdf) then call get_attr(an_variable(cid), name, value, stat, default) else if (class == vtb_class_memory) then call friend(var, name, ptr) if (.not. associated(ptr)) then value(:) = default else n = min(size(ptr), size(value)) value(1:n) = ptr(1:n) if (n < size(ptr)) value(n+1: ) = default deallocate(ptr) endif else call StoreError(GT_ENOTVAR, "GTVarGetAttrRA") endif end subroutine GTVarGetAttrRA subroutine GTVarGetAttrDA(var, name, value, default) use gtdata_types, only: GT_VARIABLE use gtdata_generic, only: friend => get_attr use gt_map, only: var_class, vtb_class_netcdf, vtb_class_memory use an_generic, only: get_attr, an_variable use dc_types, only: DP use dc_error, only: GT_ENOTVAR, StoreError implicit none type(GT_VARIABLE), intent(in):: var character(len = *), intent(in):: name real(DP), intent(out):: value(:) real(DP), intent(in):: default real(DP), pointer:: ptr(:) integer:: n, stat, class, cid continue call var_class(var, class, cid) if (class == vtb_class_netcdf) then call get_attr(an_variable(cid), name, value, stat, default) else if (class == vtb_class_memory) then call friend(var, name, ptr) if (.not. associated(ptr)) then value(:) = default else n = min(size(ptr), size(value)) value(1:n) = ptr(1:n) if (n < size(ptr)) value(n+1: ) = default deallocate(ptr) endif else call StoreError(GT_ENOTVAR, "GTVarGetAttrRA") endif end subroutine GTVarGetAttrDA