! gtool_history.f90 - traditional interface for `history' output ! vi: set sw=4 ts=8: ! Copyright (C) GFD Dennou Club, 2000. All rights reserved. !=begin != module gtool_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 gtool_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, message implicit none private public:: GT_HISTORY public:: HistoryCreate, HistoryAddVariable, HistoryClose public:: HistoryPutEx, HistoryPut, HistoryAddAttr, GT_HISTORY_AXIS public:: HistorySetTime, GT_HISTORY_VARINFO interface HistoryCreate module procedure HistoryCreate1, HistoryCreate2 end interface interface HistoryAddVariable module procedure HistoryAddVariable1, HistoryAddVariable2 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, HistoryAddAttrS module procedure HistoryAddAttrL module procedure HistoryAddAttrR, HistoryAddAttrRA module procedure HistoryAddAttrD, HistoryAddAttrDA module procedure HistoryAddAttrI, HistoryAddAttrIA end interface !=begin !== Derived Types !=== type GT_HISTORY !Data entity of this type represents a netCDF dataset controlled by !gtool4 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(:) logical, pointer:: dim_value_written(:) ! ! NOTE: it is index of dimvars(:), not that of vars(:). integer:: unlimited_index real:: origin, interval, newest, oldest type(GT_VARIABLE), pointer:: vars(:) integer, pointer:: growable_indices(:) integer, pointer:: count(:) end type type(GT_HISTORY), save, target:: default !=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, 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 type GT_HISTORY_VARINFO character(len = token):: name character(len = token), pointer:: dims(:) character(len = string):: longname, units character(len = token):: xtype end type 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) 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 !=end continue 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) end subroutine !=begin subroutine HistoryCreate1(file, title, source, institution, & & dims, dimsizes, longnames, units, origin, interval, & & xtypes, history) 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 !=end integer:: numdims, i type(GT_HISTORY), pointer:: hst character(len = token):: my_xtype character(len = string):: merged, x_inst, nc_history continue call beginsub('history-create', 'file=%c ndims=%d', & & c1=trim(file), i=(/size(dims)/)) 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, "HistoryCreate") call endsub('history-create', '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> gtool_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.) 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 gtool_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('history-create', 'std') end subroutine ! ! --- 属性の設定 --- ! subroutine HistoryAddAttrC(varname, attrname, value, history) use gtdata_generic, only: Put_Attr 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 type(GT_VARIABLE):: var integer:: v_ord, stat character(len = *), parameter:: subname = "HistoryAddAttrC" 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 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 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 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 type(GT_VARIABLE):: var integer:: v_ord, stat character(len = *), parameter:: subname = "HistoryAddAttrL" 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 HistoryAddAttrR(varname, attrname, value, history) use gtdata_generic, only: Put_Attr 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 type(GT_VARIABLE):: var integer:: v_ord, stat character(len = *), parameter:: subname = "HistoryAddAttrR" 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 HistoryAddAttrRA(varname, attrname, value, history) use gtdata_generic, only: Put_Attr 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 type(GT_VARIABLE):: var integer:: v_ord, stat continue ! 操作対象決定 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 end subroutine subroutine HistoryAddAttrD(varname, attrname, value, history) use gtdata_generic, only: Put_Attr implicit none character(len = *), intent(in):: varname character(len = *), intent(in):: attrname double precision, intent(in):: value type(GT_HISTORY), target, optional:: history type(GT_HISTORY), pointer:: hst type(GT_VARIABLE):: var integer:: v_ord, stat continue ! 操作対象決定 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 end subroutine subroutine HistoryAddAttrDA(varname, attrname, value, history) use gtdata_generic, only: Put_Attr implicit none character(len = *), intent(in):: varname character(len = *), intent(in):: attrname double precision, intent(in):: value(:) type(GT_HISTORY), target, optional:: history type(GT_HISTORY), pointer:: hst type(GT_VARIABLE):: var integer:: v_ord, stat continue ! 操作対象決定 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 end subroutine subroutine HistoryAddAttrI(varname, attrname, value, history) use gtdata_generic, only: Put_Attr 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 type(GT_VARIABLE):: var integer:: v_ord, stat continue ! 操作対象決定 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 end subroutine subroutine HistoryAddAttrIA(varname, attrname, value, history) use gtdata_generic, only: Put_Attr 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 type(GT_VARIABLE):: var integer:: stat, v_ord continue ! 操作対象決定 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 end subroutine ! ! --- 変数の追加 --- ! subroutine HistoryAddVariable2(varinfo, history) type(GT_HISTORY_VARINFO), intent(in):: varinfo type(GT_HISTORY), intent(inout), optional:: history continue call HistoryAddVariable1(trim(varinfo%name), & & varinfo%dims, trim(varinfo%longname), & & trim(varinfo%units), trim(varinfo%xtype), history) end subroutine 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 type(GT_VARIABLE), pointer:: vwork(:), dimvars(:) character(len = STRING):: fullname, url integer, pointer:: count_work(:) integer:: nvars, numdims, i, dimord continue ! 操作対象決定 if (present(history)) then hst => history else hst => default endif call beginsub('history-add-variable', '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 dimvars(i) = lookup_dimension(hst, dims(i), ord=dimord) if (dimord == hst%unlimited_index) then hst%growable_indices(nvars) = i endif enddo ! 変数作成 call Inquire(hst%dimvars(1), url=url) fullname = UrlResolve(('@' // 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('history-add-variable') 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 type(GT_VARIABLE):: var real, pointer:: buffer(:) 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 ! デフォルトでは変数ごとにカウンタを設置し、呼んだ数だけ「時刻」 ! 方向を進める。 ! これに対し、時刻の変数に一度でもスカラ値を投入すると、 ! 明示的にそれを設定したときにだけ時刻が進むようになる。 ! このルーチンでは後退はできない。 subroutine TimeGoAhead(varname, var, head, history) use gtdata_generic character(len = *), intent(in):: varname type(GT_VARIABLE), intent(out):: var real, intent(in):: head type(GT_HISTORY), intent(inout), optional, target:: history type(GT_HISTORY), pointer:: hst integer, pointer:: time integer:: v_ord, d_ord continue if (present(history)) then hst => history else hst => default endif var = lookup_variable(hst, varname, ord=v_ord) if (v_ord == 0) goto 1000 if (hst%growable_indices(v_ord) == 0) return if (hst%dim_value_written(hst%unlimited_index)) then time => hst%count(1) call Slice(var, hst%growable_indices(v_ord), & & start=time, count=1) else time => hst%count(v_ord) time = time + 1 call Slice(var, hst%growable_indices(v_ord), & & start=time, count=1) endif return 1000 continue var = lookup_dimension(hst, varname, ord=d_ord) hst%dim_value_written(d_ord) = .TRUE. if (d_ord /= hst%unlimited_index) return ! ややトリッキーだが、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) return end subroutine subroutine HistoryPutEx(varname, array, arraysize, history) use gtdata_generic 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 logical:: err character(*), parameter:: subname = "HistoryPutEx" continue call beginsub(subname, '%c', c1=trim(varname)) call TimeGoAhead(varname, var, array(1), history) 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 character(len = *), intent(in):: varname integer, intent(in):: arraysize double precision, intent(in):: array(arraysize) type(GT_HISTORY), intent(inout), optional, target:: history type(GT_VARIABLE):: var logical:: err character(len = *), parameter:: subname = "HistoryPutExDouble" continue call beginsub(subname, '%c', c1=trim(varname)) call TimeGoAhead(varname, var, real(array(1)), history) 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 double precision, 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 double precision, 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 double precision, 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 double precision, 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 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 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 message('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 type(GT_VARIABLE) & function lookup_variable(history, varname, ord) result(result) use gtdata_generic type(GT_HISTORY), intent(in):: history character(len = *):: varname integer, intent(out), optional:: ord integer:: i 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 print *, 'gtool_history: var lookup for ', varname, ' failed' stop 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 type(GT_HISTORY), intent(in):: history character(len = *), intent(in):: dimname integer, intent(out), optional:: ord character(len = STRING):: name integer:: i 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 print *, 'gtool_history: dim lookup for ', dimname, ' failed' stop 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 end module