! gt4_history.f90 - traditional interface for `history' output ! vi: set sw=4 ts=8: ! Copyright (C) GFD Dennou Club, 2004. All rights reserved. !=begin != module gt4_history !a sequential output interface for gtool4 netCDF dataset. ! !== Description !This module is designed for output to gtool4 netCDF dataset !sequentially along an axis (hereafter it will be called 'time'). !The name indicates that the module is originally intended to serve as !the 'history' of atmospheric forecast models. !=end module gt4_history !=begin !== Dependency !* (()) for internal data access !* (()) for constants STRING and TOKEN !* (()) for error trace function !=end use gtdata_types use dc_types, only: string, token use dc_trace, only: BeginSub, EndSub, DbgMessage implicit none private public:: GT_HISTORY, GT_HISTORY_AXIS, GT_HISTORY_VARINFO public:: GT_HISTORY_ATTR public:: HistoryCreate, HistoryClose public:: HistoryAddVariable, HistoryCopyVariable public:: HistoryPutEx, HistoryPut, HistoryAddAttr public:: HistorySetTime public:: HistoryGet, HistoryGetPointer interface HistoryCreate module procedure HistoryCreate1, HistoryCreate2 end interface interface HistoryAddVariable module procedure HistoryAddVariable1, HistoryAddVariable2 end interface interface HistoryCopyVariable module procedure HistoryCopyVariable1 end interface interface HistoryPut module procedure HistoryPut1, HistoryPut2, HistoryPut3, HistoryPut0 module procedure HistoryPutDouble1, HistoryPutDouble2 module procedure HistoryPutDouble3, HistoryPutDouble0 end interface interface HistoryAddAttr module procedure HistoryAddAttrC !!$ module procedure HistoryAddAttrS module procedure HistoryAddAttrL module procedure HistoryAddAttrR, HistoryAddAttrRA module procedure HistoryAddAttrD, HistoryAddAttrDA module procedure HistoryAddAttrI, HistoryAddAttrIA module procedure HistoryAddAttr2 end interface !----- ポインタ配列用 ----- ! ※ ifc と frt ではポインタ配列用と引用仕様がかぶるため, ! ポインタ用のものを HistoryGetPointer とする。2004/11/20 morikawa interface HistoryGetPointer module procedure HistoryGet0Pointer module procedure HistoryGet0PointerTimeR, HistoryGet0PointerTimeD module procedure HistoryGet1Pointer module procedure HistoryGet1PointerTimeR, HistoryGet1PointerTimeD module procedure HistoryGet2Pointer module procedure HistoryGet2PointerTimeR, HistoryGet2PointerTimeD module procedure HistoryGet3Pointer module procedure HistoryGet3PointerTimeR, HistoryGet3PointerTimeD module procedure HistoryGetDouble0Pointer module procedure HistoryGetDouble0PointerTimeR module procedure HistoryGetDouble0PointerTimeD module procedure HistoryGetDouble1Pointer module procedure HistoryGetDouble1PointerTimeR module procedure HistoryGetDouble1PointerTimeD module procedure HistoryGetDouble2Pointer module procedure HistoryGetDouble2PointerTimeR module procedure HistoryGetDouble2PointerTimeD module procedure HistoryGetDouble3Pointer module procedure HistoryGetDouble3PointerTimeR module procedure HistoryGetDouble3PointerTimeD end interface interface HistoryGet !----- 固定長配列用 ----- ! ※ ifc と frt ではポインタ配列用と引用仕様がかぶるため, ! 同じ総称名称のものとしては定義できない. 2004/08/08 morikawa module procedure HistoryGet0 module procedure HistoryGet0TimeR, HistoryGet0TimeD module procedure HistoryGet1 module procedure HistoryGet1TimeR, HistoryGet1TimeD module procedure HistoryGet2 module procedure HistoryGet2TimeR, HistoryGet2TimeD module procedure HistoryGet3 module procedure HistoryGet3TimeR, HistoryGet3TimeD module procedure HistoryGetDouble0 module procedure HistoryGetDouble0TimeR, HistoryGetDouble0TimeD module procedure HistoryGetDouble1 module procedure HistoryGetDouble1TimeR, HistoryGetDouble1TimeD module procedure HistoryGetDouble2 module procedure HistoryGetDouble2TimeR, HistoryGetDouble2TimeD module procedure HistoryGetDouble3 module procedure HistoryGetDouble3TimeR, HistoryGetDouble3TimeD end interface !=begin !== Derived Types !=== type GT_HISTORY !Data entity of this type represents a netCDF dataset controlled by !gt4f90io library. !It must be initialized by (()), !then used in many subroutines, and must be finalized by (()). !Note that the resultant file is undefined if you forget to finalize it. ! !Users are recommended to retain the object of this type !returned by (()), !to use it as the last argument (called ((|history|))) for !all following subroutine calls. !However, it is not mandatory. !When you are going to write ((*ONLY*)) one dataset, !argument ((|history|)) of all subroutine calls can be omitted, and !the history entity will be internally managed within this module. !=end type GT_HISTORY type(GT_VARIABLE) & & , pointer:: dimvars(:) =>null() ! 次元変数 ID配列 ! it is index of dimvars(:), ! not that of vars(:). logical, pointer:: & & dim_value_written(:) =>null() ! 各次元が記述済みかどうか integer :: unlimited_index ! 無制限次元の添字 real :: origin, interval, newest, oldest type(GT_VARIABLE) & & , pointer:: vars(:) =>null() ! 変数 ID 配列 integer, pointer:: & & growable_indices(:) =>null() ! 無制限次元の添字 ! (無制限次元が無い時は 0) integer, pointer:: count(:) =>null() ! 各配列の無制限次元の配列長 end type type(GT_HISTORY), save, target:: default ! history が未指定の場合に使用 !=begin !=== type GT_HISTORY_AXIS !This type may be used as a argument ((|axes|)) of (()) !to define features of axes of a history dataset. !Typically, a constant array of this type will be used for !fixed specification. !=end !=begin type GT_HISTORY_AXIS character(len = token) :: name ! 次元変数名 integer :: length ! 次元長 (配列サイズ) character(len = string):: longname ! 次元変数の記述的名称 character(len = string):: units ! 次元変数の単位 character(len = token) :: xtype ! 次元変数の型 end type !=end !=begin !=== type GT_HISTORY_VARINFO !This type may be used as a argument ((|varinfo|)) of (()) !to define features of variable of a history dataset. !=end ! ! 変数が持つ最低限情報の構造体 (HistoryAddVariable にて使用) ! type GT_HISTORY_VARINFO character(len = token) :: name ! 変数名 character(len = token), pointer :: dims(:) =>null() ! 依存する次元 character(len = string) :: longname ! 変数の記述的名称 character(len = string) :: units ! 変数の単位 character(len = token) :: xtype ! 変数の型 end type GT_HISTORY_VARINFO ! ! 変数の属性情報の構造体 (HistoryAddAttr2 にて使用) ! type GT_HISTORY_ATTR character(token) :: attrname ! 属性の名前 character(token) :: attrtype ! 属性の値の型 logical :: array = .false. ! 属性の値が配列かどうか character(string) :: cvalue ! 属性の値 (文字型変数) integer :: ivalue ! 属性の値 (整数型変数) real :: rvalue ! 属性の値 (単精度実数型変数) real(8) :: dvalue ! 属性の値 (倍精度実数型変数) logical :: lvalue ! 属性の値 (論理型変数) integer ,pointer:: iarray(:) =>null() ! 属性の値 (整数型配列) real ,pointer:: rarray(:) =>null() ! 属性の値 (単精度実数型配列) real(8) ,pointer:: darray(:) =>null() ! 属性の値 (倍精度実数型配列) end type GT_HISTORY_ATTR contains !=begin !== Procedure Interface !=end !=begin !=== HistoryCreate subroutines !Two specific subroutines shares common part: ! !(({call HistoryCreate(}))((|file|)), ((|title|)), ((|source|)), !((|institution|)), ..., ((|origin|)), ((|interval|)), ![((|history|))](({)})) ! !Both two ones initializes a dataset ((|file|)). !The result of (()) will be returned by ((|history|)) !or managed internally if omitted. !Mandatory global attributes are defined by arguments !((|title|)), ((|source|)), and ((|institution|)); !they are all declared as (({character(len = *)})). !Spatial axis definitions have two different forms: !a primitive one uses several arrays of various types: !((|dims|)), ((|dimsizes|)), ((|longnames|)), ((|units|)), and ((|xtypes|)). !Another sophisticated one has only array of (()), !((|axes|)). !Temporal definition is done without ((|origin|)), ((|interval|)). !=end !=begin subroutine HistoryCreate2(file, title, source, institution, & & axes, origin, interval, history, conventions, gt_version) use dc_string implicit none character(len=*), intent(in) :: file character(len=*), intent(in) :: title, source, institution type(GT_HISTORY_AXIS), intent(in) :: axes(:) real, intent(in) :: origin, interval type(GT_HISTORY), intent(out), optional:: history character(len=*), intent(in), optional:: conventions, gt_version ! 構造体 GT_HISTORY_AXIS のデータ蓄積用 character(len=string), allocatable :: axes_name(:) integer , allocatable :: axes_length(:) character(len=string), allocatable :: axes_longname(:) character(len=string), allocatable :: axes_units(:) character(len=string), allocatable :: axes_xtype(:) integer :: i, ndims character(len = *), parameter:: subname = "HistoryCreate2" !=end continue call BeginSub(subname, 'file=%c ndims=%d', & & c1=trim(file), i=(/size(axes)/) ) ! 構造体 GT_HISTORY_AXIS の axes からのデータ取得 ! (Fujitsu Fortran などなら axes(:)%name という表記で配列 ! データをそのまま引き渡せるが、Intel Fortran 8 などだと ! その表記をまともに解釈してくれないので、美しくないけど ! いったん他の配列に情報を引き渡す)。2004/11/27 morikawa ndims = size( axes(:) ) allocate( axes_name(ndims) ) allocate( axes_length(ndims) ) allocate( axes_longname(ndims) ) allocate( axes_units(ndims) ) allocate( axes_xtype(ndims) ) do i = 1, ndims axes_name(i) = axes(i)%name axes_length(i) = axes(i)%length axes_longname(i) = axes(i)%longname axes_units(i) = axes(i)%units axes_xtype(i) = axes(i)%xtype call DbgMessage('axes(%d):name=<%c>, length=<%d>, ' // & & 'longname=<%c>, units=<%c>' , & & i=(/i, axes(i)%length/) , & & c1=( trim(axes(i)%name) ) , & & c2=( trim(axes(i)%longname) ) , & & c3=( trim(axes(i)%units) ) ) enddo call HistoryCreate1(file, title, source, institution, & & dims=axes_name(:), dimsizes=axes_length(:), & & longnames=axes_longname(:), units=axes_units(:), & & xtypes=axes_xtype(:), & & origin=origin, interval=interval, & & history=history, conventions=conventions, & & gt_version=gt_version) ! Fujitsu Fortran や Intel Fortran 7 、 SunStudio 8 などなら ! 可能な方法。Intel 8 に対応するため、上記のように ! 書き換えてみた。 2004/11/27 morikawa ! call HistoryCreate1(file, title, source, institution, & ! & dims=axes(:)%name, dimsizes=axes(:)%length, & ! & longnames=axes(:)%longname, units=axes(:)%units, & ! & xtypes=axes(:)%xtype, & ! & origin=origin, interval=interval, & ! & history=history, conventions=conventions, & ! & gt_version=gt_version) deallocate( axes_name ) deallocate( axes_length ) deallocate( axes_longname ) deallocate( axes_units ) deallocate( axes_xtype ) call EndSub(subname) end subroutine !=begin subroutine HistoryCreate1(file, title, source, institution, & & dims, dimsizes, longnames, units, origin, interval, & & xtypes, history, conventions, gt_version) use gtdata_generic use dc_url use dc_error use dc_string use dc_types, only: string, token implicit none character(len=*), intent(in) :: file character(len=*), intent(in) :: title, source, institution character(len=*), intent(in) :: dims(:) integer, intent(in) :: dimsizes(:) character(len=*), intent(in) :: longnames(:) character(len=*), intent(in) :: units(:) real, intent(in) :: origin, interval character(len=*), intent(in), optional :: xtypes(:) type(GT_HISTORY), intent(out), optional, target:: history character(len=*), intent(in), optional:: conventions, gt_version !=end integer:: numdims, i type(GT_HISTORY), pointer:: hst =>null() character(len = token):: my_xtype character(len = string):: merged, x_inst, x_conv, x_gtver, nc_history ! gtool4 netCDF 規約の URL と最新バージョン (更新されたらここを変更) character(len = string), parameter:: & & gtool4_netCDF_Conventions = & & "http://www.gfd-dennou.org/arch/gtool4/conventions/" character(len = string), parameter:: newest_version = "4.2" logical :: gtver_add character(len = *), parameter:: subname = "HistoryCreate1" continue call BeginSub(subname, 'file=%c ndims=%d, %c', & & c1=trim(file), i=(/size(dims)/), & & c2='dims(:)=<' // trim(JoinChar(dims(:), ','))// '>, ' // & & 'dimsizes(:)=<' // trim(toChar(dimsizes(:))) // '>, ' // & & 'longnames(:)=<'// trim(JoinChar(longnames(:), '| ')) // '>, ' // & & 'units(:)=<' // trim(JoinChar(units(:), '; '))// '>, ' ) if (present(history)) then hst => history else hst => default endif numdims = size(dims) if (size(dimsizes) /= numdims .or. size(longnames) /= numdims .or. & & size(units) /= numdims) then call StoreError(GT_EARGSIZEMISMATCH, subname) call EndSub(subname, 'err') return endif ! 次元変数表作成 allocate(hst%dimvars(numdims), hst%dim_value_written(numdims)) hst%dim_value_written(:) = .FALSE. hst%unlimited_index = 0 nc_history = 'unknown unknown> gt4_history: HistoryCreate' & & // achar(10) my_xtype = "" do, i = 1, numdims if (present(xtypes)) my_xtype = xtypes(i) merged = UrlMerge(file=file, var=dims(i)) call Create(hst%dimvars(i), & & trim(merged) , & & dimsizes(i), xtype=trim(my_xtype), overwrite=.TRUE.) ! conventions が存在しない場合はデフォルトの値を ! 属性 Conventions に付加。 if (present(conventions)) then x_conv = conventions else x_conv = gtool4_netCDF_Conventions endif ! 1) gt_version がある場合、それを gt_version 属性に渡す。 ! 2) gt_version が無い場合、conventions も無いか、または ! gtool4 netCDF 規約が入っていれば最新版を gt_version ! に与える。そうでない場合は gt_version 属性を与えない。 if (present(gt_version)) then x_gtver = gt_version gtver_add = .TRUE. else if (present(conventions) .and. & .not. x_conv == gtool4_netCDF_Conventions) then gtver_add = .FALSE. else x_gtver = newest_version gtver_add = .TRUE. endif endif call put_attr(hst%dimvars(i), '+Conventions', trim(x_conv)) if (gtver_add) then call put_attr(hst%dimvars(i), '+gt_version', trim(x_gtver)) endif ! title, source, institution, history, long_name, units 属性の付加 call put_attr(hst%dimvars(i), '+title', title) call put_attr(hst%dimvars(i), '+source', source) if (institution /= "") then x_inst = institution else x_inst = "a gt4_history (by GFD Dennou Club) user" endif call put_attr(hst%dimvars(i), '+institution', trim(x_inst)) call put_attr(hst%dimvars(i), '+history', trim(nc_history)) call put_attr(hst%dimvars(i), 'long_name', trim(longnames(i))) call put_attr(hst%dimvars(i), 'units', trim(units(i))) if (dimsizes(i) == 0) hst%unlimited_index = i enddo ! 変数表 nullify(hst%vars, hst%growable_indices, hst%count) ! 時間カウンタ hst%origin = origin hst%interval = interval hst%newest = origin hst%oldest = origin call EndSub(subname, 'std') end subroutine ! ! --- 属性の設定 --- ! subroutine HistoryAddAttrC(varname, attrname, value, history) use gtdata_generic, only: Put_Attr use dc_string , only: toChar implicit none character(len = *), intent(in):: varname character(len = *), intent(in):: attrname character(len = *), intent(in):: value type(GT_HISTORY), target, optional:: history type(GT_HISTORY), pointer:: hst =>null() type(GT_VARIABLE):: var integer:: v_ord, stat character(len = *), parameter:: subname = "HistoryAddAttrC" continue call BeginSub(subname, 'varname=<%c> attrname=<%c>, value=<%c>', & & c1=trim(varname), c2=trim(attrname), c3=trim(value)) ! 操作対象決定 if (present(history)) then hst => history else hst => default endif if (varname == "") then ! "+" に大域属性の意味が期待できない場合はループ必要 do, v_ord = 1, size(hst%vars) call Put_Attr(hst%vars(v_ord), "+" // attrname, value) enddo else call lookup_var_or_dim(hst, varname, var, stat) if (stat == 0) then call Put_Attr(var, attrname, value) endif endif call EndSub(subname) end subroutine !!$ subroutine HistoryAddAttrS(varname, attrname, value, history) !!$ use dc_string, only: VSTRING !!$ use gtdata_generic, only: Put_Attr !!$ implicit none !!$ character(len = *), intent(in):: varname !!$ character(len = *), intent(in):: attrname !!$ type(VSTRING), intent(in):: value !!$ type(GT_HISTORY), target, optional:: history !!$ type(GT_HISTORY), pointer:: hst =>null() !!$ type(GT_VARIABLE):: var !!$ integer:: v_ord, stat !!$ character(len = *), parameter:: subname = "HistoryAddAttrS" !!$ continue !!$ call BeginSub(subname) !!$ ! 操作対象決定 !!$ if (present(history)) then !!$ hst => history !!$ else !!$ hst => default !!$ endif !!$ if (varname == "") then !!$ ! とりあえず無駄だが大域属性を何度もつける !!$ do, v_ord = 1, size(hst%vars) !!$ call Put_Attr(hst%vars(v_ord), "+" // attrname, value) !!$ enddo !!$ else !!$ call lookup_var_or_dim(hst, varname, var, stat) !!$ if (stat == 0) then !!$ call Put_Attr(var, attrname, value) !!$ endif !!$ endif !!$ call EndSub(subname) !!$ end subroutine subroutine HistoryAddAttrL(varname, attrname, value, history) use gtdata_generic, only: Put_Attr use dc_string , only: toChar implicit none character(len = *), intent(in):: varname character(len = *), intent(in):: attrname logical, intent(in):: value type(GT_HISTORY), target, optional:: history type(GT_HISTORY), pointer:: hst =>null() type(GT_VARIABLE):: var integer:: v_ord, stat character(len = *), parameter:: subname = "HistoryAddAttrL" continue call BeginSub(subname, 'varname=<%c> attrname=<%c>, value=<%b>', & & c1=trim(varname), c2=trim(attrname), l=(/value/)) ! 操作対象決定 if (present(history)) then hst => history else hst => default endif if (varname == "") then ! とりあえず無駄だが大域属性を何度もつける do, v_ord = 1, size(hst%vars) call Put_Attr(hst%vars(v_ord), "+" // attrname, value) enddo else call lookup_var_or_dim(hst, varname, var, stat) if (stat == 0) then call Put_Attr(var, attrname, value) endif endif call EndSub(subname) end subroutine subroutine HistoryAddAttrR(varname, attrname, value, history) use gtdata_generic, only: Put_Attr use dc_string , only: toChar implicit none character(len = *), intent(in):: varname character(len = *), intent(in):: attrname real, intent(in):: value type(GT_HISTORY), target, optional:: history type(GT_HISTORY), pointer:: hst =>null() type(GT_VARIABLE):: var integer:: v_ord, stat character(len = *), parameter:: subname = "HistoryAddAttrR" continue call BeginSub(subname, 'varname=<%c> attrname=<%c>, value=<%c>', & & c1=trim(varname), c2=trim(attrname), c3=trim(toChar(value))) ! 操作対象決定 if (present(history)) then hst => history else hst => default endif if (varname == "") then ! とりあえず無駄だが大域属性を何度もつける do, v_ord = 1, size(hst%vars) call Put_Attr(hst%vars(v_ord), "+" // attrname, (/value/)) enddo else call lookup_var_or_dim(hst, varname, var, stat) if (stat == 0) then call Put_Attr(var, attrname, (/value/)) endif endif call EndSub(subname) end subroutine subroutine HistoryAddAttrRA(varname, attrname, value, history) use gtdata_generic, only: Put_Attr use dc_string , only: toChar implicit none character(len = *), intent(in):: varname character(len = *), intent(in):: attrname real, intent(in):: value(:) type(GT_HISTORY), target, optional:: history type(GT_HISTORY), pointer:: hst =>null() type(GT_VARIABLE):: var integer:: v_ord, stat character(len = *), parameter:: subname = "HistoryAddAttrRA" continue call BeginSub(subname, 'varname=<%c> attrname=<%c>, value=<%c>', & & c1=trim(varname), c2=trim(attrname), c3=trim(toChar(value))) ! 操作対象決定 if (present(history)) then hst => history else hst => default endif if (varname == "") then ! とりあえず無駄だが大域属性を何度もつける do, v_ord = 1, size(hst%vars) call Put_Attr(hst%vars(v_ord), "+" // attrname, value) enddo else call lookup_var_or_dim(hst, varname, var, stat) if (stat == 0) then call Put_Attr(var, attrname, value) endif endif call EndSub(subname) end subroutine subroutine HistoryAddAttrD(varname, attrname, value, history) use gtdata_generic, only: Put_Attr use dc_string , only: toChar implicit none character(len = *), intent(in):: varname character(len = *), intent(in):: attrname real(8) , intent(in):: value type(GT_HISTORY), target, optional:: history type(GT_HISTORY), pointer:: hst =>null() type(GT_VARIABLE):: var integer:: v_ord, stat character(len = *), parameter:: subname = "HistoryAddAttrD" continue call BeginSub(subname, 'varname=<%c> attrname=<%c>, value=<%c>', & & c1=trim(varname), c2=trim(attrname), c3=trim(toChar(value))) ! 操作対象決定 if (present(history)) then hst => history else hst => default endif if (varname == "") then ! とりあえず無駄だが大域属性を何度もつける do, v_ord = 1, size(hst%vars) call Put_Attr(hst%vars(v_ord), "+" // attrname, (/value/)) enddo else call lookup_var_or_dim(hst, varname, var, stat) if (stat == 0) then call Put_Attr(var, attrname, (/value/)) endif endif call EndSub(subname) end subroutine subroutine HistoryAddAttrDA(varname, attrname, value, history) use gtdata_generic, only: Put_Attr use dc_string , only: toChar implicit none character(len = *), intent(in):: varname character(len = *), intent(in):: attrname real(8) , intent(in):: value(:) type(GT_HISTORY), target, optional:: history type(GT_HISTORY), pointer:: hst =>null() type(GT_VARIABLE):: var integer:: v_ord, stat character(len = *), parameter:: subname = "HistoryAddAttrDA" continue call BeginSub(subname, 'varname=<%c> attrname=<%c>, value=<%c>', & & c1=trim(varname), c2=trim(attrname), c3=trim(toChar(value))) ! 操作対象決定 if (present(history)) then hst => history else hst => default endif if (varname == "") then ! とりあえず無駄だが大域属性を何度もつける do, v_ord = 1, size(hst%vars) call Put_Attr(hst%vars(v_ord), "+" // attrname, value) enddo else call lookup_var_or_dim(hst, varname, var, stat) if (stat == 0) then call Put_Attr(var, attrname, value) endif endif call EndSub(subname) end subroutine subroutine HistoryAddAttrI(varname, attrname, value, history) use gtdata_generic, only: Put_Attr use dc_string , only: toChar implicit none character(len = *), intent(in):: varname character(len = *), intent(in):: attrname integer, intent(in):: value type(GT_HISTORY), target, optional:: history type(GT_HISTORY), pointer:: hst =>null() type(GT_VARIABLE):: var integer:: v_ord, stat character(len = *), parameter:: subname = "HistoryAddAttrI" continue call BeginSub(subname, 'varname=<%c> attrname=<%c>, value=<%c>', & & c1=trim(varname), c2=trim(attrname), c3=trim(toChar(value))) ! 操作対象決定 if (present(history)) then hst => history else hst => default endif if (varname == "") then ! とりあえず無駄だが大域属性を何度もつける do, v_ord = 1, size(hst%vars) call Put_Attr(hst%vars(v_ord), "+" // attrname, (/value/)) enddo else call lookup_var_or_dim(hst, varname, var, stat) if (stat == 0) then call Put_Attr(var, attrname, (/value/)) endif endif call EndSub(subname) end subroutine subroutine HistoryAddAttrIA(varname, attrname, value, history) use gtdata_generic, only: Put_Attr use dc_string , only: toChar implicit none character(len = *), intent(in) :: varname character(len = *), intent(in) :: attrname integer , intent(in) :: value(:) type(GT_HISTORY) , target, optional:: history type(GT_HISTORY) , pointer :: hst =>null() type(GT_VARIABLE):: var integer:: stat, v_ord character(len = *), parameter:: subname = "HistoryAddAttrIA" continue call BeginSub(subname, 'varname=<%c> attrname=<%c>, value=<%c>', & & c1=trim(varname), c2=trim(attrname), c3=trim(toChar(value))) ! 操作対象決定 if (present(history)) then hst => history else hst => default endif if (varname == "") then ! とりあえず無駄だが大域属性を何度もつける do, v_ord = 1, size(hst%vars) call Put_Attr(hst%vars(v_ord), "+" // attrname, value) enddo else call lookup_var_or_dim(hst, varname, var, stat) if (stat == 0) then call Put_Attr(var, attrname, value) endif endif call EndSub(subname) end subroutine subroutine HistoryAddAttr2(varname, attrs, history) use gtdata_generic, only: Put_Attr use dc_string , only: StrHead, LChar, toChar implicit none character(len = *), intent(in):: varname type(GT_HISTORY_ATTR), intent(in):: attrs(:) type(GT_HISTORY), target, optional:: history integer :: i character(len = *), parameter:: subname = "HistoryAddAttr2" continue call BeginSub(subname, 'varname=<%c>, size(attrs(:))=<%d>', & & c1=trim(varname), i=(/size(attrs(:))/)) ! attrs(:) のサイズ分だけループ do i = 1, size( attrs(:) ) ! attrs(i)%attrtype の種別で与える変数を変える if ( StrHead( 'character', trim(LChar(attrs(i)%attrtype))) ) then call HistoryAddAttr( & & varname, attrs(i)%attrname, & & trim(attrs(i)%cvalue), history ) elseif ( StrHead( 'integer', trim(LChar(attrs(i)%attrtype))) ) then if ( attrs(i)%array ) then call DbgMessage('iarray(:) is selected.') call HistoryAddAttr( & & varname, attrs(i)%attrname , & & attrs(i)%iarray, history ) else call DbgMessage('ivalue is selected') call HistoryAddAttr( & & varname, attrs(i)%attrname , & & attrs(i)%ivalue, history ) endif elseif ( StrHead( 'float', trim(LChar(attrs(i)%attrtype))) .or. & & StrHead( 'real', trim(LChar(attrs(i)%attrtype))) ) then if ( attrs(i)%array ) then call DbgMessage('rarray(:) is selected.') call HistoryAddAttr( & & varname, attrs(i)%attrname, attrs(i)%rarray, history) else call DbgMessage('rvalue is selected') call HistoryAddAttr( & & varname, attrs(i)%attrname, attrs(i)%rvalue, history) endif elseif ( StrHead( 'double', trim(LChar(attrs(i)%attrtype))) .or. & & StrHead( 'dble', trim(LChar(attrs(i)%attrtype))) ) then if ( attrs(i)%array ) then call DbgMessage('darray(:) is selected.') call HistoryAddAttr( & & varname, attrs(i)%attrname, attrs(i)%darray, history) else call DbgMessage('dvalue is selected') call HistoryAddAttr( & & varname, attrs(i)%attrname, attrs(i)%dvalue, history) endif elseif ( StrHead( 'logical', trim(LChar(attrs(i)%attrtype))) ) then call HistoryAddAttr( & & varname, attrs(i)%attrname, attrs(i)%lvalue, history) else call DbgMessage('attrtype=<%c>=<%c>is Invalid.' , & & c1=trim(attrs(i)%attrtype) , & & c2=trim(LChar(attrs(i)%attrtype)) ) endif enddo call EndSub(subname) end subroutine !----------------------------------------------------------------- ! 変数の追加 !----------------------------------------------------------------- ! ! 各情報が格納された構造体 GT_HISTORY_VARINFO 変数を引数としてとる ! HistoryAddVariable ! subroutine HistoryAddVariable2(varinfo, history) use dc_string implicit none type(GT_HISTORY_VARINFO), intent(in) :: varinfo type(GT_HISTORY), intent(inout), optional:: history character(len = *), parameter:: subname = "HistoryAddVariable2" continue call BeginSub(subname, 'varname=<%c>, dims=<%c>, longname=<%c>', & & c1=trim(varinfo%name), c2=trim(JoinChar(varinfo%dims)), & & c3=trim(varinfo%longname) ) call HistoryAddVariable1(trim(varinfo%name), & & varinfo%dims, trim(varinfo%longname), & & trim(varinfo%units), trim(varinfo%xtype), history) call EndSub(subname) end subroutine ! ! 各情報を直接引数として与える HistoryAddVariable ! subroutine HistoryAddVariable1(varname, dims, longname, units, & & xtype, history) use dc_string use gtdata_generic use dc_url use dc_types, only: STRING implicit none character(len = *), intent(in):: varname character(len = *), intent(in):: dims(:) character(len = *), intent(in):: longname, units character(len = *), intent(in), optional:: xtype type(GT_HISTORY), intent(inout), optional, target:: history type(GT_HISTORY), pointer:: hst =>null() type(GT_VARIABLE), pointer:: vwork(:) =>null(), dimvars(:) =>null() character(len = STRING):: fullname, url integer, pointer:: count_work(:) =>null() integer:: nvars, numdims, i, dimord character(len = *), parameter:: subname = "HistoryAddVariable1" continue !----- 操作対象決定 ----- if (present(history)) then hst => history else hst => default endif call BeginSub(subname, 'name=%c', c1=varname) !----- 変数表拡張 ----- if (associated(hst%vars)) then nvars = size(hst%vars(:)) vwork => hst%vars count_work => hst%count nullify(hst%vars, hst%count) allocate(hst%vars(nvars + 1), hst%count(nvars + 1)) hst%vars(1:nvars) = vwork(1:nvars) hst%count(1:nvars) = count_work(1:nvars) deallocate(vwork, count_work) count_work => hst%growable_indices nullify(hst%growable_indices) allocate(hst%growable_indices(nvars + 1)) hst%growable_indices(1:nvars) = count_work(1:nvars) deallocate(count_work) else ! トリッキーだが、ここで count だけ 2 要素確保するのは、 ! HistorySetTime による巻き戻しに備えるため。 allocate(hst%vars(1), hst%count(2), hst%growable_indices(1)) hst%count(2) = 0 endif nvars = size(hst%vars(:)) hst%growable_indices(nvars) = 0 hst%count(nvars) = 0 !----- 変数添字次元を決定 ----- numdims = size(dims(:)) allocate(dimvars(numdims)) do, i = 1, numdims ! hst 内で, 次元変数名 dim(i) に当たる次元変数の ID である ! hst%dimvar(i) を dimvars(i) に, 添字を dimord に dimvars(i) = lookup_dimension(hst, dims(i), ord=dimord) ! 無制限次元の添字と一致する場合に, ! その添字を hst%growable_indices(nvars) に if (dimord == hst%unlimited_index) then hst%growable_indices(nvars) = i endif enddo !----- 変数作成 ----- call Inquire(hst%dimvars(1), url=url) fullname = UrlResolve((gt_atmark // trim(varname)), trim(url)) call Create(hst%vars(nvars), trim(fullname), dimvars, xtype=xtype) ! 拡張可能次元があったらそれをサイズ 1 に拡張しておく if (hst%growable_indices(nvars) /= 0) then call Slice(hst%vars(nvars), hst%growable_indices(nvars), & & start=1, count=1, stride=1) endif call put_attr(hst%vars(nvars), 'long_name', longname) call put_attr(hst%vars(nvars), 'units', units) deallocate(dimvars) call EndSub(subname) end subroutine !----------------------------------------------------------------- ! 変数のコピー ! (基本的に HistoryAddVariables と一緒) !----------------------------------------------------------------- subroutine HistoryCopyVariable1(file, varname, history) use dc_string use gtdata_generic use dc_url use dc_types, only: STRING implicit none character(len = *), intent(in) :: file ! ファイル名 character(len = *), intent(in) :: varname ! 変数名 (元と先で共有) type(GT_HISTORY), intent(inout), optional, target :: history ! 出力先 ! 作業変数 type(GT_HISTORY), pointer :: hst =>null() type(GT_VARIABLE), pointer :: vwork(:) =>null(), dimvars(:) =>null() type(GT_VARIABLE) :: copyfrom character(len = STRING) :: fullname, url, copyurl integer, pointer :: count_work(:) =>null() integer :: nvars, numdims, i logical :: growable character(*), parameter :: subname = "HistoryCopyVariable" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) !----- 操作対象決定 ----- if (present(history)) then hst => history else hst => default endif !----- 変数表拡張 ----- if (associated(hst%vars)) then nvars = size(hst%vars(:)) vwork => hst%vars count_work => hst%count nullify(hst%vars, hst%count) allocate(hst%vars(nvars + 1), hst%count(nvars + 1)) hst%vars(1:nvars) = vwork(1:nvars) hst%count(1:nvars) = count_work(1:nvars) deallocate(vwork, count_work) count_work => hst%growable_indices nullify(hst%growable_indices) allocate(hst%growable_indices(nvars + 1)) hst%growable_indices(1:nvars) = count_work(1:nvars) deallocate(count_work) else ! トリッキーだが、ここで count だけ 2 要素確保するのは、 ! HistorySetTime による巻き戻しに備えるため。 allocate(hst%vars(1), hst%count(2), hst%growable_indices(1)) hst%count(2) = 0 endif nvars = size(hst%vars(:)) hst%growable_indices(nvars) = 0 hst%count(nvars) = 0 !----- コピー元ファイルの変数 ID 取得 ----- copyurl = UrlMerge(file, varname) call Open(copyfrom, copyurl) !----- 変数コピー ----- call Inquire(hst%dimvars(1), url=url) fullname = UrlResolve((gt_atmark // trim(varname)), trim(url)) call Create(hst%vars(nvars), trim(fullname), copyfrom, & & copyvalue=.FALSE., overwrite=.TRUE.) !----- 無制限次元の添字を探査 ----- call Inquire(hst%vars(nvars), alldims=numdims) allocate(dimvars(numdims)) ! 各次元毎に情報を取得し, growable == .TRUE. のもの (つまりは時間) ! の添字番号を取得する do, i = 1, numdims call Open(var=dimvars(i), source_var=hst%vars(nvars), & & dimord=i, count_compact=.TRUE.) ! 各次元変数の growable を調べる call Inquire(var=dimvars(i), growable=growable) if (growable) then hst%growable_indices(nvars) = i endif enddo !----- 拡張可能次元があったらそれをサイズ 1 に拡張しておく ----- if (hst%growable_indices(nvars) /= 0) then call Slice(hst%vars(nvars), hst%growable_indices(nvars), & & start=1, count=1, stride=1) endif deallocate(dimvars) call Close(copyfrom) call EndSub(subname) end subroutine ! 時刻を明示設定している状態で、巻き戻しを含めた時間設定。 ! 前進している間は検索をしないようになっている。 subroutine HistorySetTime(time, history) use gtdata_generic implicit none real, intent(in):: time type(GT_HISTORY), intent(inout), optional, target:: history type(GT_HISTORY), pointer:: hst =>null() type(GT_VARIABLE):: var real, pointer:: buffer(:) =>null() logical:: err continue if (present(history)) then hst => history else hst => default endif if (hst%unlimited_index == 0) then return endif var = hst%dimvars(hst%unlimited_index) hst%dim_value_written(hst%unlimited_index) = .TRUE. if (time < hst%oldest .or. time > hst%newest .or. hst%count(2) == 0) then hst%count(:) = maxval(hst%count(:)) + 1 hst%newest = max(hst%newest, time) hst%oldest = min(hst%oldest, time) call Slice(var, 1, start=hst%count(1), count=1) call Put(var, (/time/), 1, err) if (err) call DumpError() return endif call Slice(var, 1, start=1, count=hst%count(2)) nullify(buffer) call Get(var, buffer, err) hst%count(1:1) = minloc(abs(buffer - time)) end subroutine ! そのデフォルトでは変数ごとにカウンタを設置し、呼んだ数だけ ! 「時刻」方向を進め、時刻データを入力する。 ! これに対し、HistorySetTime で時刻の変数に一度でもスカラ値を投入 ! すると、明示的にそれを設定したときにだけ時刻が進むようになる。 ! このルーチンでは後退はできない。 ! ! [詳細] ! 変数名 varname に対応する変数 ID var を探査し、その変数が ! 時間次元に依存する場合には hst%count の値を1つ増やす (時間を進める)。 ! そして、hst%origin と hst%interval から時間次元データに値を与える。 ! ! なお、HistorySetTime で既に値が設定され、hst%count の値が ! 増やされる場合には、こちらでは hst%count の値を変更しない。 ! データも入力しない。 subroutine TimeGoAhead(varname, var, head, history, stat) use gtdata_generic use dc_error, only: NF_ENOTVAR character(len = *), intent(in) :: varname type(GT_VARIABLE), intent(out) :: var integer, intent(out), optional :: stat ! real, intent(in):: head type(GT_HISTORY), intent(inout), optional, target:: history type(GT_HISTORY), pointer:: hst =>null() type(GT_VARIABLE) :: timevar real, pointer:: time(:) =>null() integer :: v_ord, d_ord integer :: timestart, rest logical :: err character(*), parameter :: subname = "TimeGoAhead" continue call BeginSub(subname, 'varname=%c head=%r', & & c1=trim(varname), r=(/head/)) stat = 0 if (present(history)) then hst => history else hst => default endif ! hst 内での変数 varname の変数 ID を var に、 ! hst における変数添字を v_ord に取得 var = lookup_variable(hst, varname, ord=v_ord) if (v_ord == 0) goto 1000 ! 変数 v_ord に時間次元が無い場合は終了 if (hst%growable_indices(v_ord) == 0) then call EndSub(subname, "stat=%d", i=(/stat/)) return endif !------------------------------------------------------------- ! 時間次元に値が書き込まれている場合は count を増やさない ! (HistorySetTime を利用する場合を想定) !------------------------------------------------------------- if (hst%dim_value_written(hst%unlimited_index)) then call Slice(var, hst%growable_indices(v_ord), & & start=hst%count(1), count=1) !------------------------------------------------------------- ! 値が書き込まれていない場合は count を増やす ! (history%interval を利用する場合を想定) !------------------------------------------------------------- else hst%count(v_ord) = hst%count(v_ord) + 1 call Slice(var, hst%growable_indices(v_ord), & & start=hst%count(v_ord), count=1) !--------------------------------------------------------- ! 変数の count にあたる時間次元のデータが未設定の ! 場合、データを設定する。 morikawa 2004/12/16 !--------------------------------------------------------- timevar = hst%dimvars(hst%unlimited_index) call Get_Slice(timevar, 1, start=timestart) call DbgMessage('map(timevar)start is <%d>. map(%c)start is <%d>', & & i=(/timestart, hst%count(v_ord)/), & & c1=trim(varname) ) call Get(timevar, time, err) call DbgMessage('time(%d)=<%*r>, err=<%b>', & & i=(/size(time)/), r=(/time(:)/), & & l=(/err/), n=(/size(time)/) ) ! 時間次元自体が存在していない場合、1から作成。 if (err) then call Slice(timevar, 1, start=1, count=1) call Put(timevar, (/hst%origin + hst%interval/), 1, err) if (err) call DumpError ! 変数の count が時間次元の start より大きい場合、 ! hst%interval でその間を埋める。 elseif (hst%count(v_ord) > timestart) then rest = timestart + 1 do call Slice(timevar, 1, start=rest, count=1) call Put(timevar, & & (/time(1) & & + hst%interval * (rest - timestart) & & /), 1, err ) if (err) call DumpError rest = rest + 1 if ( rest > hst%count(v_ord) ) exit enddo endif nullify(time) endif call EndSub(subname, "stat=%d", i=(/stat/)) return 1000 continue !----- hst 内に次元以外の変数 ID が見つからない場合は ----- !----- 次元 ID を探査 ----- var = lookup_dimension(hst, varname, ord=d_ord) ! 次元も含めた変数の中に varname が無い場合は stat に ! NF_ENOTVAR (Variable not Found) を返す. ! (上のサブルーチンが停止させることを想定) if (d_ord == 0) then stat = NF_ENOTVAR call EndSub(subname, "stat=%d", i=(/stat/)) return endif hst%dim_value_written(d_ord) = .TRUE. if (d_ord /= hst%unlimited_index) then call EndSub(subname, "stat=%d", i=(/stat/)) return endif ! ややトリッキーだが、count の2番目以降の要素にも時刻を入れて ! おくことで、HistorySetTime による巻き戻し後にも値を保持する。 hst%count(:) = maxval(hst%count(:)) + 1 hst%newest = max(hst%newest, head) hst%oldest = min(hst%oldest, head) call Slice(var, 1, start=hst%count(1), count=1) call EndSub(subname) return end subroutine subroutine HistoryPutEx(varname, array, arraysize, history) use gtdata_generic use dc_error, only: StoreError character(len = *), intent(in):: varname integer, intent(in):: arraysize real, intent(in):: array(arraysize) type(GT_HISTORY), intent(inout), optional:: history ! type(GT_VARIABLE):: var integer :: stat logical :: err character(*), parameter:: subname = "HistoryPutEx" continue call BeginSub(subname, '%c', c1=trim(varname)) call TimeGoAhead(varname, var, array(1), history, stat) call StoreError(stat, subname, cause_c=varname) call Put(var, array, arraysize, err) if (err) call DumpError() call GTVarSync(var) call EndSub(subname) end subroutine subroutine HistoryPut0(varname, value, history) character(len = *), intent(in):: varname real, intent(in):: value type(GT_HISTORY), intent(inout), optional:: history character(len = *), parameter:: subname = "HistoryPut0" continue call BeginSub(subname) call HistoryPutEx(varname, (/value/), 1, history) call EndSub(subname) end subroutine subroutine HistoryPut1(varname, array, history) character(len = *), intent(in):: varname real, intent(in):: array(:) type(GT_HISTORY), intent(inout), optional:: history character(len = *), parameter:: subname = "HistoryPut1" continue call BeginSub(subname) call HistoryPutEx(varname, array, size(array), history) call EndSub(subname) end subroutine subroutine HistoryPut2(varname, array, history) character(len = *), intent(in):: varname real, intent(in):: array(:, :) type(GT_HISTORY), intent(inout), optional:: history character(len = *), parameter:: subname = "HistoryPut2" continue call BeginSub(subname) call HistoryPutEx(varname, array, size(array), history) call EndSub(subname) end subroutine subroutine HistoryPut3(varname, array, history) character(len = *), intent(in):: varname real, intent(in):: array(:, :, :) type(GT_HISTORY), intent(inout), optional, target:: history character(len = *), parameter:: subname = "HistoryPut3" continue call BeginSub(subname) call HistoryPutEx(varname, array, size(array), history) call EndSub(subname) end subroutine subroutine HistoryPutExDouble(varname, array, arraysize, history) use gtdata_generic use dc_error, only: StoreError character(len = *), intent(in):: varname integer, intent(in):: arraysize real(8) , intent(in):: array(arraysize) type(GT_HISTORY), intent(inout), optional, target:: history ! type(GT_VARIABLE):: var integer :: stat logical :: err character(len = *), parameter:: subname = "HistoryPutExDouble" continue call BeginSub(subname, '%c', c1=trim(varname)) call TimeGoAhead(varname, var, real(array(1)), history, stat) call StoreError(stat, subname, cause_c=varname) call Put(var, array, arraysize, err) if (err) call DumpError() call GTVarSync(var) call EndSub(subname) end subroutine subroutine HistoryPutDouble0(varname, value, history) character(len = *), intent(in):: varname real(8) , intent(in):: value type(GT_HISTORY), intent(inout), optional:: history character(len = *), parameter:: subname = "HistoryPutDouble0" continue call BeginSub(subname) call HistoryPutExDouble(varname, (/value/), 1, history) call EndSub(subname) end subroutine subroutine HistoryPutDouble1(varname, array, history) character(len = *), intent(in):: varname real(8) , intent(in):: array(:) type(GT_HISTORY), intent(inout), optional, target:: history character(len = *), parameter:: subname = "HistoryPutDouble1" continue call BeginSub(subname) call HistoryPutExDouble(varname, array, size(array), history) call EndSub(subname) end subroutine subroutine HistoryPutDouble2(varname, array, history) character(len = *), intent(in):: varname real(8) , intent(in):: array(:, :) type(GT_HISTORY), intent(inout), optional, target:: history character(len = *), parameter:: subname = "HistoryPutDouble2" continue call BeginSub(subname) call HistoryPutExDouble(varname, array, size(array), history) call EndSub(subname) end subroutine subroutine HistoryPutDouble3(varname, array, history) character(len = *), intent(in):: varname real(8) , intent(in):: array(:, :, :) type(GT_HISTORY), intent(inout), optional, target:: history character(len = *), parameter:: subname = "HistoryPutDouble3" continue call BeginSub(subname) call HistoryPutExDouble(varname, array, size(array), history) call EndSub(subname) end subroutine subroutine HistoryClose(history) use gtdata_generic type(GT_HISTORY), intent(inout), optional, target:: history type(GT_HISTORY), pointer:: hst =>null() integer:: i character(len = *), parameter:: subname = "HistoryClose" continue call BeginSub(subname) if (present(history)) then hst => history else hst => default endif do, i = 1, size(hst%dimvars) if (.not. hst%dim_value_written(i)) & call set_fake_dim_value(hst, i) call Close(hst%dimvars(i)) enddo deallocate(hst%dimvars) do, i = 1, size(hst%vars) call Close(hst%vars(i)) enddo if (associated(hst%vars)) deallocate(hst%vars) if (associated(hst%count)) deallocate(hst%count) call EndSub(subname) end subroutine ! ! 次元 history%dimvars(dimord) に値が設定されていない場合、 ! 「とりあえず」値を設定する。ただし、無制限次元 (時間次元) ! に関しては history%origin, history%interval, history%count ! から「まっとうな」値が設定される。 ! subroutine set_fake_dim_value(history, dimord) use gtdata_generic use dc_error type(GT_HISTORY), intent(inout):: history integer, intent(in):: dimord integer:: length, i real, allocatable:: value(:) logical:: err continue if (dimord == history%unlimited_index) then if (.not. associated(history%count)) return length = maxval(history%count(:)) else call Inquire(history%dimvars(dimord), size=length) endif if (length == 0) return allocate(value(length)) if (dimord == history%unlimited_index) then value(:) = (/(real(i), i = 1, length)/) value(:) = history%origin + (value(:) - 1.0) * history%interval call Slice(history%dimvars(dimord), 1, start=1, count=length) else value(:) = (/(real(i), i = 1, length)/) endif call Put(history%dimvars(dimord), value, size(value), err) if (err) call DumpError deallocate(value) end subroutine integer & function lookup_variable_ord(history, varname) result(result) use dc_types, only: string use gtdata_generic, only: inquire type(GT_HISTORY), intent(in):: history character(len = *):: varname character(len = string):: name character(len = *), parameter:: subname = 'lookup_variable_ord' continue call BeginSub(subname) if (associated(history%vars)) then do, result = 1, size(history%vars) call Inquire(history%vars(result), name=name) if (name == varname) goto 999 call DbgMessage('no match <%c> <%c>', c1=trim(name), c2=trim(varname)) enddo endif result = 0 999 continue call EndSub(subname, "result=%d", i=(/result/)) end function !----------------------------------------------------------------- ! history 内での変数 varname の ID を取得 ! ID を取得できた場合, 返り値 result と ord にそれぞれ ! その ID が返される。 ! ID を取得できない場合、ord が渡されていなければその場で終了 ! ord が渡されている場合は ord に 0 が返される。 !----------------------------------------------------------------- type(GT_VARIABLE) & function lookup_variable(history, varname, ord) result(result) use gtdata_generic use dc_error, only: StoreError, NF_ENOTVAR type(GT_HISTORY), intent(in):: history character(len = *):: varname integer, intent(out), optional:: ord integer:: i, stat character(len = *), parameter:: subname = 'lookup_variable' continue call BeginSub(subname, '%c', c1=trim(varname)) i = lookup_variable_ord(history, varname) if (i > 0) then result = history%vars(i) if (present(ord)) ord = i call EndSub(subname, "ord=%d", i=(/i/)) return endif if (present(ord)) then ord = 0 else stat = NF_ENOTVAR call StoreError(stat, subname, cause_c=varname) endif call EndSub(subname) end function type(GT_VARIABLE) & function lookup_dimension(history, dimname, ord) result(result) use gtdata_generic use dc_string use dc_types, only: STRING use dc_error, only: StoreError, GT_EBADDIMNAME type(GT_HISTORY), intent(in):: history character(len = *), intent(in):: dimname integer, intent(out), optional:: ord character(len = STRING):: name integer:: i, stat character(len = *), parameter:: subname = 'lookup_dimension' continue call BeginSub(subname) if (associated(history%dimvars)) then do, i = 1, size(history%dimvars) call Inquire(history%dimvars(i), name=name) if (name == dimname) then result = history%dimvars(i) if (present(ord)) ord = i call EndSub(subname, "ord=%d", i=(/i/)) return endif enddo endif if (present(ord)) then ord = 0 else stat = GT_EBADDIMNAME call StoreError(stat, subname, cause_c=dimname) endif call EndSub(subname, 'ord=0 (not found)') end function subroutine lookup_var_or_dim(history, name, var, stat) type(GT_HISTORY), intent(in):: history character(len = *), intent(in):: name type(GT_VARIABLE), intent(out):: var integer, intent(out):: stat integer:: ord continue var = lookup_variable(history, name, ord) if (ord /= 0) then stat = 0 return endif var = lookup_dimension(history, name, ord) if (ord /= 0) then stat = 0 return endif stat = 1 end subroutine !================================================================= ! ! 入力用最下層サブルーチン (単精度, 固定長配列用) ! !================================================================= subroutine HistoryGetEx(file, varname, array, time) use gtdata_generic use dc_string, only: toChar use dc_error ! ファイル名 character(len = *), intent(in):: file ! 変数名 character(len = *), intent(in):: varname ! 時間 (無い場合には最後の時間のものになる) character(len = *), intent(in), optional:: time ! 返る配列 real, intent(out) :: array(*) type(GT_VARIABLE) :: var character(len = string) :: url integer:: domain ! 変数の入出力領域の大きさ ! (= 変数が依存する各次元サイズの積) character(*), parameter :: subname = "HistoryGetEx" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif ! 必要な情報を gtool 変数化 call lookup_growable_url(file, varname, time=time, url=url) ! いよいよデータ取得 call Open(var, url) call Inquire(var=var, size=domain) call Get(var, array, domain) call Close(var) call EndSub(subname) end subroutine !----------------------------------------------------------------- ! 単精度, 変数用インターフェース ! subroutine HistoryGet0(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname character(len = *), intent(in), optional:: time real, intent(out) :: array real :: array_tmp(1) character(*), parameter :: subname = "HistoryGet0" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif if (present(time)) then call HistoryGetEx(file=file, varname=varname, & & array=array_tmp, time=time) else call HistoryGetEx(file=file, varname=varname, array=array_tmp) endif array = array_tmp(1) call EndSub(subname) end subroutine ! ! 単精度, 変数用 [実数(単)で時間指定版] ! subroutine HistoryGet0TimeR(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname real, intent(in) :: time real, intent(out) :: array real :: array_tmp(1) character(*), parameter :: subname = "HistoryGet0TimeR" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetEx(file=file, varname=varname, & & array=array_tmp, time=toChar(time)) call EndSub(subname) array = array_tmp(1) end subroutine ! ! 単精度, 変数用 [実数(倍)で時間指定版] ! subroutine HistoryGet0TimeD(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname real(8) , intent(in) :: time real, intent(out) :: array real :: array_tmp(1) character(*), parameter :: subname = "HistoryGet0TimeD" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetEx(file=file, varname=varname, & & array=array_tmp, time=toChar(time)) call EndSub(subname) array = array_tmp(1) end subroutine !----------------------------------------------------------------- ! 単精度, 1 次元配列用インターフェース ! subroutine HistoryGet1(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname character(len = *), intent(in), optional:: time real, intent(out) :: array(:) character(*), parameter :: subname = "HistoryGet1" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif if (present(time)) then call HistoryGetEx(file=file, varname=varname, & & array=array, time=time) else call HistoryGetEx(file=file, varname=varname, array=array) endif call EndSub(subname) end subroutine ! ! 単精度, 1 次元配列用 [実数(単)で時間指定版] ! subroutine HistoryGet1TimeR(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname real, intent(in) :: time real, intent(out) :: array(:) character(*), parameter :: subname = "HistoryGet1TimeR" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetEx(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine ! ! 単精度, 1 次元配列用 [実数(倍)で時間指定版] ! subroutine HistoryGet1TimeD(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname real(8) , intent(in) :: time real, intent(out) :: array(:) character(*), parameter :: subname = "HistoryGet1TimeD" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetEx(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine !----------------------------------------------------------------- ! 単精度, 2 次元配列用インターフェース ! subroutine HistoryGet2(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname character(len = *), intent(in), optional:: time real, intent(out) :: array(:,:) character(*), parameter :: subname = "HistoryGet2" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif if (present(time)) then call HistoryGetEx(file=file, varname=varname, & & array=array, time=time) else call HistoryGetEx(file=file, varname=varname, array=array) endif call EndSub(subname) end subroutine ! ! 単精度, 2 次元配列用 [実数(単)で時間指定版] ! subroutine HistoryGet2TimeR(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname real, intent(in) :: time real, intent(out) :: array(:,:) character(*), parameter :: subname = "HistoryGet2TimeR" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetEx(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine ! ! 単精度, 2 次元配列用 [実数(倍)で時間指定版] ! subroutine HistoryGet2TimeD(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname real(8) , intent(in) :: time real, intent(out) :: array(:,:) character(*), parameter :: subname = "HistoryGet2TimeD" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetEx(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine !----------------------------------------------------------------- ! 単精度, 3 次元配列用インターフェース ! subroutine HistoryGet3(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname character(len = *), intent(in), optional:: time real, intent(out) :: array(:,:,:) character(*), parameter :: subname = "HistoryGet3" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif if (present(time)) then call HistoryGetEx(file=file, varname=varname, & & array=array, time=time) else call HistoryGetEx(file=file, varname=varname, array=array) endif call EndSub(subname) end subroutine ! ! 単精度, 3 次元配列用 [実数(単)で時間指定版] ! subroutine HistoryGet3TimeR(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname real, intent(in) :: time real, intent(out) :: array(:,:,:) character(*), parameter :: subname = "HistoryGet3TimeR" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetEx(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine ! ! 単精度, 3 次元配列用 [実数(倍)で時間指定版] ! subroutine HistoryGet3TimeD(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname real(8) , intent(in) :: time real, intent(out) :: array(:,:,:) character(*), parameter :: subname = "HistoryGet3TimeD" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetEx(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine !================================================================= ! ! 入力用最下層サブルーチン (倍精度, 固定長配列用) ! !================================================================= subroutine HistoryGetExDouble(file, varname, array, time) use gtdata_generic use dc_string, only: toChar use dc_error ! ファイル名 character(len = *), intent(in):: file ! 変数名 character(len = *), intent(in):: varname ! 時間 (無い場合には最後の時間のものになる) character(len = *), intent(in), optional:: time ! 返る配列 real(8) , intent(out) :: array(*) type(GT_VARIABLE) :: var character(len = string) :: url integer:: domain ! 変数の入出力領域の大きさ ! (= 変数が依存する各次元サイズの積) character(*), parameter :: subname = "HistoryGetExDouble" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif ! 必要な情報を gtool 変数化 call lookup_growable_url(file, varname, time=time, url=url) ! いよいよデータ取得 call Open(var, url) call Inquire(var=var, size=domain) call Get(var, array, domain) call Close(var) call EndSub(subname) end subroutine !----------------------------------------------------------------- ! 倍精度, 変数用インターフェース ! subroutine HistoryGetDouble0(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname character(len = *), intent(in), optional:: time real(8) , intent(out) :: array real(8) :: array_tmp(1) character(*), parameter :: subname = "HistoryGetDouble0" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif if (present(time)) then call HistoryGetExDouble(file=file, varname=varname, & & array=array_tmp, time=time) else call HistoryGetExDouble(file=file, varname=varname, array=array_tmp) endif array = array_tmp(1) call EndSub(subname) end subroutine ! ! 倍精度, 変数用 [実数(単)で時間指定版] ! subroutine HistoryGetDouble0TimeR(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname real, intent(in) :: time real(8) , intent(out) :: array real(8) :: array_tmp(1) character(*), parameter :: subname = "HistoryGetDouble0TimeR" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetExDouble(file=file, varname=varname, & & array=array_tmp, time=toChar(time)) call EndSub(subname) array = array_tmp(1) end subroutine ! ! 倍精度, 変数用 [実数(倍)で時間指定版] ! subroutine HistoryGetDouble0TimeD(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname real(8) , intent(in) :: time real(8) , intent(out) :: array real(8) :: array_tmp(1) character(*), parameter :: subname = "HistoryGetDouble0TimeD" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetExDouble(file=file, varname=varname, & & array=array_tmp, time=toChar(time)) call EndSub(subname) array = array_tmp(1) end subroutine !----------------------------------------------------------------- ! 倍精度, 1 次元配列用インターフェース ! subroutine HistoryGetDouble1(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname character(len = *), intent(in), optional:: time real(8) , intent(out) :: array(:) character(*), parameter :: subname = "HistoryGetDouble1" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif if (present(time)) then call HistoryGetExDouble(file=file, varname=varname, & & array=array, time=time) else call HistoryGetExDouble(file=file, varname=varname, array=array) endif call EndSub(subname) end subroutine ! ! 倍精度, 1 次元配列用 [実数(単)で時間指定版] ! subroutine HistoryGetDouble1TimeR(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname real, intent(in) :: time real(8) , intent(out) :: array(:) character(*), parameter :: subname = "HistoryGetDouble1TimeR" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetExDouble(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine ! ! 倍精度, 1 次元配列用 [実数(倍)で時間指定版] ! subroutine HistoryGetDouble1TimeD(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname real(8) , intent(in) :: time real(8) , intent(out) :: array(:) character(*), parameter :: subname = "HistoryGetDouble1TimeD" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetExDouble(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine !----------------------------------------------------------------- ! 倍精度, 2 次元配列用インターフェース ! subroutine HistoryGetDouble2(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname character(len = *), intent(in), optional:: time real(8) , intent(out) :: array(:,:) character(*), parameter :: subname = "HistoryGetDouble2" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif if (present(time)) then call HistoryGetExDouble(file=file, varname=varname, & & array=array, time=time) else call HistoryGetExDouble(file=file, varname=varname, array=array) endif call EndSub(subname) end subroutine ! ! 倍精度, 2 次元配列用 [実数(単)で時間指定版] ! subroutine HistoryGetDouble2TimeR(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname real, intent(in) :: time real(8) , intent(out) :: array(:,:) character(*), parameter :: subname = "HistoryGetDouble2TimeR" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetExDouble(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine ! ! 倍精度, 2 次元配列用 [実数(倍)で時間指定版] ! subroutine HistoryGetDouble2TimeD(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname real(8) , intent(in) :: time real(8) , intent(out) :: array(:,:) character(*), parameter :: subname = "HistoryGetDouble2TimeD" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetExDouble(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine !----------------------------------------------------------------- ! 倍精度, 3 次元配列用インターフェース ! subroutine HistoryGetDouble3(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname character(len = *), intent(in), optional:: time real(8) , intent(out) :: array(:,:,:) character(*), parameter :: subname = "HistoryGetDouble3" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif if (present(time)) then call HistoryGetExDouble(file=file, varname=varname, & & array=array, time=time) else call HistoryGetExDouble(file=file, varname=varname, array=array) endif call EndSub(subname) end subroutine ! ! 倍精度, 3 次元配列用 [実数(単)で時間指定版] ! subroutine HistoryGetDouble3TimeR(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname real, intent(in) :: time real(8) , intent(out) :: array(:,:,:) character(*), parameter :: subname = "HistoryGetDouble3TimeR" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetExDouble(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine ! ! 倍精度, 3 次元配列用 [実数(倍)で時間指定版] ! subroutine HistoryGetDouble3TimeD(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in):: file, varname real(8) , intent(in) :: time real(8) , intent(out) :: array(:,:,:) character(*), parameter :: subname = "HistoryGetDouble3TimeD" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetExDouble(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine !================================================================= ! ! 入力用サブルーチン (単精度, ポインタ配列用) ! !================================================================= !----------------------------------------------------------------- ! 単精度, ポインタ 0 次元配列 (変数) 用インターフェース ! (他のポインタ1次元配列用インターフェースの下請けも兼ねる) ! subroutine HistoryGet0Pointer(file, varname, array, time) use gtdata_generic use dc_string, only: toChar use dc_error character(len = *), intent(in) :: file, varname character(len = *), intent(in), optional :: time real, pointer :: array ! type(GT_VARIABLE) :: var character(len = string) :: url real, target :: array_tmp(1) integer:: domain ! 変数の入出力領域の大きさ ! (= 変数が依存する各次元サイズの積) character(*), parameter :: subname = "HistoryGet0Pointer" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif ! 必要な情報を gtool 変数化 call lookup_growable_url(file, varname, time=time, url=url) ! 0 次元配列 (変数) の下請けサブルーチン GTVarGetReal は ! ポインタを引数として取らないので, ここで allocate ! (本当は associated で確認して nullify などを行なうべき ! だが、Intel Fortran 8 の associated 関数が阿呆で ! allocate されていないポインタに対して .true. を返すので ! nullify してから allocate する) ! if (.not. associated(array)) then ! allocate(array) ! call DbgMessage('allocate array') ! else ! call DbgMessage('array=<%r> is already allocated', r=(/array/)) ! endif nullify(array) allocate(array) call DbgMessage('Reallocate array') ! いよいよデータ取得 call Open(var, url) call Inquire(var=var, size=domain) call Get(var, array_tmp, domain) call Close(var) array = array_tmp(1) ! GTVarGetReal は数値を出力しないのでここで出力 call DbgMessage('value=%r', r=(/array/)) call EndSub(subname) end subroutine ! ! 単精度, ポインタ 0 次元配列 (変数) 用 [実数(単)で時間指定版] ! subroutine HistoryGet0PointerTimeR(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in) :: file, varname real, intent(in) :: time real, pointer :: array character(*), parameter :: subname = "HistoryGet0PointerTimeR" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGet0Pointer(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine ! ! 単精度, ポインタ 0 次元配列 (変数) 用 [実数(倍)で時間指定版] ! subroutine HistoryGet0PointerTimeD(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in) :: file, varname real(8) , intent(in) :: time real, pointer :: array character(*), parameter :: subname = "HistoryGet0PointerTimeD" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGet0Pointer(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine !----------------------------------------------------------------- ! 単精度, ポインタ 1 次元配列用インターフェース ! (他のポインタ1次元配列用インターフェースの下請けも兼ねる) ! subroutine HistoryGet1Pointer(file, varname, array, time) use gtdata_generic use dc_string, only: toChar use dc_error character(len = *), intent(in) :: file, varname character(len = *), intent(in), optional :: time real, pointer :: array(:) ! type(GT_VARIABLE) :: var character(len = string) :: url character(*), parameter :: subname = "HistoryGet1Pointer" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif ! 必要な情報を gtool 変数化 call lookup_growable_url(file, varname, time=time, url=url) call DbgMessage('@ url =%c', c1=trim(url)) ! いよいよデータ取得 call Open(var, url) call Get(var, array) call Close(var) call EndSub(subname) end subroutine ! ! 単精度, ポインタ 1 次元配列用 [実数(単)で時間指定版] ! subroutine HistoryGet1PointerTimeR(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in) :: file, varname real, intent(in) :: time real, pointer :: array(:) character(*), parameter :: subname = "HistoryGet1PointerTimeR" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGet1Pointer(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine ! ! 単精度, ポインタ 1 次元配列用 [実数(倍)で時間指定版] ! subroutine HistoryGet1PointerTimeD(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in) :: file, varname real(8) , intent(in) :: time real, pointer :: array(:) character(*), parameter :: subname = "HistoryGet1PointerTimeD" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGet1Pointer(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine !----------------------------------------------------------------- ! 単精度, ポインタ 2 次元配列用インターフェース ! (他のポインタ2 次元配列用インターフェースの下請けも兼ねる) ! subroutine HistoryGet2Pointer(file, varname, array, time) use gtdata_generic use dc_string, only: toChar use dc_error character(len = *), intent(in) :: file, varname character(len = *), intent(in), optional :: time real, pointer :: array(:,:) ! type(GT_VARIABLE) :: var character(len = string) :: url character(*), parameter :: subname = "HistoryGet2Pointer" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif ! 必要な情報を gtool 変数化 call lookup_growable_url(file, varname, time=time, url=url) ! いよいよデータ取得 call Open(var, url) call Get(var, array) call Close(var) call EndSub(subname) end subroutine ! ! 単精度, ポインタ 2 次元配列用 [実数(単)で時間指定版] ! subroutine HistoryGet2PointerTimeR(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in) :: file, varname real, intent(in) :: time real, pointer :: array(:,:) character(*), parameter :: subname = "HistoryGet2PointerTimeR" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGet2Pointer(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine ! ! 単精度, ポインタ 2 次元配列用 [実数(倍)で時間指定版] ! subroutine HistoryGet2PointerTimeD(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in) :: file, varname real(8) , intent(in) :: time real, pointer :: array(:,:) character(*), parameter :: subname = "HistoryGet2PointerTimeD" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGet2Pointer(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine !----------------------------------------------------------------- ! 単精度, ポインタ 3 次元配列用インターフェース ! (他のポインタ3 次元配列用インターフェースの下請けも兼ねる) ! subroutine HistoryGet3Pointer(file, varname, array, time) use gtdata_generic use dc_string, only: toChar use dc_error character(len = *), intent(in) :: file, varname character(len = *), intent(in), optional :: time real, pointer :: array(:,:,:) ! type(GT_VARIABLE) :: var character(len = string) :: url character(*), parameter :: subname = "HistoryGet3Pointer" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif ! 必要な情報を gtool 変数化 call lookup_growable_url(file, varname, time=time, url=url) ! いよいよデータ取得 call Open(var, url) call Get(var, array) call Close(var) call EndSub(subname) end subroutine ! ! 単精度, ポインタ 3 次元配列用 [実数(単)で時間指定版] ! subroutine HistoryGet3PointerTimeR(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in) :: file, varname real, intent(in) :: time real, pointer :: array(:,:,:) character(*), parameter :: subname = "HistoryGet3PointerTimeR" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGet3Pointer(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine ! ! 単精度, ポインタ 3 次元配列用 [実数(倍)で時間指定版] ! subroutine HistoryGet3PointerTimeD(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in) :: file, varname real(8) , intent(in) :: time real, pointer :: array(:,:,:) character(*), parameter :: subname = "HistoryGet3PointerTimeD" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGet3Pointer(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine !================================================================= ! ! 入力用サブルーチン (倍精度, ポインタ配列用) ! !================================================================= !----------------------------------------------------------------- ! 倍精度, ポインタ 0 次元配列 (変数)用インターフェース ! (他のポインタ0 次元配列 (変数)用インターフェースの下請けも兼ねる) ! subroutine HistoryGetDouble0Pointer(file, varname, array, time) use gtdata_generic use dc_string, only: toChar use dc_error character(len = *), intent(in) :: file, varname character(len = *), intent(in), optional :: time real(8) , pointer :: array ! type(GT_VARIABLE) :: var character(len = string) :: url real(8) , target :: array_tmp(1) integer:: domain ! 変数の入出力領域の大きさ ! (= 変数が依存する各次元サイズの積) character(*), parameter :: subname = "HistoryGetDouble0Pointer" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif ! 必要な情報を gtool 変数化 call lookup_growable_url(file, varname, time=time, url=url) ! 0 次元配列 (変数) の下請けサブルーチン GTVarGetReal は ! ポインタを引数として取らないので, ここで allocate ! (本当は associated で確認して nullify などを行なうべき ! だが、Intel Fortran 8 の associated 関数が阿呆で ! allocate されていないポインタに対して .true. を返すので ! nullify してから allocate する) ! if (.not. associated(array)) then ! allocate(array) ! call DbgMessage('allocate array') ! else ! call DbgMessage('array=<%r> is already allocated', r=(/array/)) ! endif nullify(array) allocate(array) call DbgMessage('Reallocate array') ! いよいよデータ取得 call Open(var, url) call Inquire(var=var, size=domain) call Get(var, array_tmp, domain) call Close(var) array = array_tmp(1) ! GTVarGetDouble は数値を出力しないのでここで出力 call DbgMessage('value=%f', d=(/array/)) call EndSub(subname) end subroutine ! ! 倍精度, ポインタ 0 次元配列 (変数)用 [実数(単)で時間指定版] ! subroutine HistoryGetDouble0PointerTimeR(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in) :: file, varname real, intent(in) :: time real(8) , pointer :: array character(*), parameter :: subname = "HistoryGetDouble0PointerTimeR" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetDouble0Pointer(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine ! ! 倍精度, ポインタ 0 次元配列 (変数)用 [実数(倍)で時間指定版] ! subroutine HistoryGetDouble0PointerTimeD(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in) :: file, varname real(8) , intent(in) :: time real(8) , pointer :: array character(*), parameter :: subname = "HistoryGetDouble0PointerTimeD" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetDouble0Pointer(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine !----------------------------------------------------------------- ! 倍精度, ポインタ 1 次元配列用インターフェース ! (他のポインタ1 次元配列用インターフェースの下請けも兼ねる) ! subroutine HistoryGetDouble1Pointer(file, varname, array, time) use gtdata_generic use dc_string, only: toChar use dc_error character(len = *), intent(in) :: file, varname character(len = *), intent(in), optional :: time real(8) , pointer :: array(:) ! type(GT_VARIABLE) :: var character(len = string) :: url character(*), parameter :: subname = "HistoryGetDouble1Pointer" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif ! 必要な情報を gtool 変数化 call lookup_growable_url(file, varname, time=time, url=url) ! いよいよデータ取得 call Open(var, url) call Get(var, array) call Close(var) call EndSub(subname) end subroutine ! ! 倍精度, ポインタ 1 次元配列用 [実数(単)で時間指定版] ! subroutine HistoryGetDouble1PointerTimeR(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in) :: file, varname real, intent(in) :: time real(8) , pointer :: array(:) character(*), parameter :: subname = "HistoryGetDouble1PointerTimeR" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetDouble1Pointer(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine ! ! 倍精度, ポインタ 1 次元配列用 [実数(倍)で時間指定版] ! subroutine HistoryGetDouble1PointerTimeD(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in) :: file, varname real(8) , intent(in) :: time real(8) , pointer :: array(:) character(*), parameter :: subname = "HistoryGetDouble1PointerTimeD" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetDouble1Pointer(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine !----------------------------------------------------------------- ! 倍精度, ポインタ 2 次元配列用インターフェース ! (他のポインタ2 次元配列用インターフェースの下請けも兼ねる) ! subroutine HistoryGetDouble2Pointer(file, varname, array, time) use gtdata_generic use dc_string, only: toChar use dc_error character(len = *), intent(in) :: file, varname character(len = *), intent(in), optional :: time real(8) , pointer :: array(:,:) ! type(GT_VARIABLE) :: var character(len = string) :: url character(*), parameter :: subname = "HistoryGetDouble2Pointer" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif ! 必要な情報を gtool 変数化 call lookup_growable_url(file, varname, time=time, url=url) ! いよいよデータ取得 call Open(var, url) call Get(var, array) call Close(var) call EndSub(subname) end subroutine ! ! 倍精度, ポインタ 2 次元配列用 [実数(単)で時間指定版] ! subroutine HistoryGetDouble2PointerTimeR(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in) :: file, varname real, intent(in) :: time real(8) , pointer :: array(:,:) character(*), parameter :: subname = "HistoryGetDouble2PointerTimeR" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetDouble2Pointer(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine ! ! 倍精度, ポインタ 2 次元配列用 [実数(倍)で時間指定版] ! subroutine HistoryGetDouble2PointerTimeD(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in) :: file, varname real(8) , intent(in) :: time real(8) , pointer :: array(:,:) character(*), parameter :: subname = "HistoryGetDouble2PointerTimeD" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetDouble2Pointer(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine !----------------------------------------------------------------- ! 倍精度, ポインタ 3 次元配列用インターフェース ! (他のポインタ3 次元配列用インターフェースの下請けも兼ねる) ! subroutine HistoryGetDouble3Pointer(file, varname, array, time) use gtdata_generic use dc_string, only: toChar use dc_error character(len = *), intent(in) :: file, varname character(len = *), intent(in), optional :: time real(8) , pointer :: array(:,:,:) ! type(GT_VARIABLE) :: var character(len = string) :: url character(*), parameter :: subname = "HistoryGetDouble3Pointer" continue call BeginSub(subname, 'file=%c varname=%c', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif ! 必要な情報を gtool 変数化 call lookup_growable_url(file, varname, time=time, url=url) ! いよいよデータ取得 call Open(var, url) call Get(var, array) call Close(var) call EndSub(subname) end subroutine ! ! 倍精度, ポインタ 3 次元配列用 [実数(単)で時間指定版] ! subroutine HistoryGetDouble3PointerTimeR(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in) :: file, varname real, intent(in) :: time real(8) , pointer :: array(:,:,:) character(*), parameter :: subname = "HistoryGetDouble3PointerTimeR" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetDouble3Pointer(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine ! ! 倍精度, ポインタ 3 次元配列用 [実数(倍)で時間指定版] ! subroutine HistoryGetDouble3PointerTimeD(file, varname, array, time) use dc_string, only: toChar character(len = *), intent(in) :: file, varname real(8) , intent(in) :: time real(8) , pointer :: array(:,:,:) character(*), parameter :: subname = "HistoryGetDouble3PointerTimeD" continue call BeginSub(subname, 'file=%c varname=%c time=%c', & & c1=trim(file), c2=trim(varname), c3=toChar(time)) call HistoryGetDouble3Pointer(file=file, varname=varname, & & array=array, time=toChar(time)) call EndSub(subname) end subroutine !----------------------------------------------------------------- ! file の変数 varname が依存する次元の内, ! 時間の次元 (growable == .TRUE. のもの) の以下の情報を取得し, ! - 変数名 ! - 時間の次元 (無制限次元) の最後の値を取得 ! - (time が渡されない場合) ! gtool変数化 (「file@varname,time=10.5」みたいな) して返す. ! もしも varname が次元変数である場合は「time=」を付けずに返す. !----------------------------------------------------------------- subroutine lookup_growable_url(file, varname, time, url) use gtdata_generic use dc_string, only: toChar use dc_error use dc_url, only: gt_circumflex, gt_atmark, gt_comma, gt_equal, UrlSplit ! ファイル名 character(len = *), intent(in) :: file ! 変数名 character(len = *), intent(in) :: varname ! 時間 (無い場合は自動判別) character(len = *), intent(in), optional:: time ! gtool変数化した文字列 character(len = *), intent(out) :: url ! type(GT_VARIABLE) :: var type(GT_VARIABLE), allocatable :: dimvar(:) character(len = string) :: var_url, time_url, time_name, time_index logical:: growable, nounlimited, err integer:: allcount, timecount, nd, i, stat character(*), parameter :: subname = "lookup_growable_url" call BeginSub(subname, '', & & c1=trim(file), c2=trim(varname)) if (present(time)) then call DbgMessage('@ time=%c', c1=trim(time)) else call DbgMessage('@ time is undefined (auto defined later)') endif ! 探査のために varname を open (まだデータを取得しない) var_url = trim(adjustl(file))// gt_atmark //trim(adjustl(varname)) call Open(var, var_url) ! 次元の数を取得 call Inquire(var=var, alldims=nd) call DbgMessage('@ alldims = %d', i=(/nd/)) allocate(dimvar(nd)) ! 無制限次元があれば, dc_noerr に stat = GT_ENOUNLIMITDIM ! ! 各次元毎に情報を取得し, growable == .TRUE. のもの (つまりは時間) ! の変数名 (time_name) を取得する. call DbgMessage('[%c: growable-dim-search]', c1=trim(subname)) do, i = 1, nd call Open(var=dimvar(i), source_var=var, dimord=i, & & count_compact=.TRUE., err=err) ! まずは url に変数入り gtool4 変数を time_url に取得 call Inquire(var=dimvar(i), growable=growable, & & allcount=allcount, url=time_url) call DbgMessage(' [dim=<%d>: growable=<%y>: url=<%c>]', & & i=(/i/), L=(/growable/), c1=trim(time_url)) ! 総数 = 最後の数, なので... if (growable) then ! 変数部分だけ分離 call UrlSplit(fullname=time_url, var=time_name) if (.not. present(time)) timecount = allcount stat = dc_noerr endif call Close(dimvar(i)) ! 一応エラー処理 end do ! ! 変数が無制限変数を持たない場合にも取得するようにする。 ! * 無制限次元が無く ! nounlimited = .FALSE. if (stat == GT_ENOUNLIMITDIM) then stat = dc_noerr nounlimited = .TRUE. endif ! 一旦閉じる call StoreError(stat, subname) call Close(var) ! 時間自動設定の場合は, 引き出す時間の格子番号の前に「^」を付加 if (present(time)) then time_index = time ! 次元変数は必要ないので与えない。 else if (nounlimited) then time_index = '' call DbgMessage('@ %c@%c is dimension (not depend time)', & & c1=trim(file), c2=trim(varname)) else time_index = gt_circumflex // adjustl(toChar(timecount)) call DbgMessage('@ time=%c %c', & & c1=trim(time_index), c2="(auto mode)") endif ! file, varname, time_name を gtool変数化 ! (「file@varname,time=10.5」のように) ! 無制限次元が無い場合は後ろに「time=」をつけない。 if (nounlimited) then url = trim(adjustl(file))// gt_atmark // & & trim(adjustl(varname)) else url = trim(adjustl(file))// gt_atmark // & & trim(adjustl(varname))// gt_comma // trim(time_name) // & & gt_equal // trim(adjustl(time_index)) endif call EndSub(subname, '', c1=trim(url)) end subroutine lookup_growable_url end module