#!/usr/bin/env ruby
# -*- f90 -*-
# vi: set sw=4 ts=8:
require("intrinsic_types")
require("optparse")
#
# "gt4_history.f90" Generator with Ruby.
#
opt = OptionParser.new
opt.on('--histput_dim=VAL') {|v| $histput_dim = v.to_i}
opt.on('--histget_dim=VAL') {|v| $histget_dim = v.to_i}
opt.parse!(ARGV)
$histput_dim = 7 unless $histput_dim
$histget_dim = 7 unless $histget_dim
print <<"__EndOfFortran90Code__"
!--
#{rb2f90_header_comment}!
!++
!
!= gtool4 netCDF データの入出力インターフェース
!= Interface of Input/Output of gtool4 netCDF data
!
! Authors:: Yasuhiro MORIKAWA, Eizi TOYODA
! Version:: $Id: gt4_history.rb2f90,v 1.52 2008-07-27 22:40:53 morikawa Exp $
! Tag Name:: $Name: gt4f90io-20080812 $
! Copyright:: Copyright (C) GFD Dennou Club, 2000-2005. All rights reserved.
! License:: See COPYRIGHT[link:../../COPYRIGHT]
!
module gt4_history
!
!= gtool4 netCDF データの入出力インターフェース
!= Interface of Input/Output of gtool4 netCDF data
!
! gt4_history モジュールは, 数値モデルの結果を
! {gtool4 netCDF 規約}[link:../xref.htm#label-6] に基づくデータ形式
! (以降, gtool4 データと呼びます) で出力するためのインターフェースです.
! 主に時間積分の結果を等時間間隔で出力することを念頭においてます.
! このモジュールを用いれば, Fortran90 で書かれたプログラムの計算結果を
! gtool4 データで出力することが簡単に実現できます.
!
! なお, Fortran77 用のインターフェースとして,
! HSPACK[link:files/hspack_rdoc.html]
! も用意しています.
!
!== Prepare
!
! 以下の use 文を Fortran 90 プログラムの先頭に書き込んでください.
! 本 gt4_history モジュール内の手続きと構造型変数が
! 利用できるようになります.
!
! use gt4_history
!
!== Procedures List
!
! 【出力用】
!
! HistoryCreate :: gtool4 データ出力用初期設定
! HistoryAddVariable :: 変数定義
! HistoryCopyVariable :: 変数定義 (別ファイルの変数コピー)
! HistoryPut :: データ出力
! HistoryAddAttr :: 変数に属性付加
! HistoryClose :: 終了処理
! HistorySetTime :: 時刻指定
!
! 【入力用】
!
! HistoryGet :: データ入力 (固定長配列用)
! HistoryGetPointer :: データ入力 (ポインタ配列用)
!
! 【その他】
!
! HistoryInquire :: GT_HISTORY 型変数への問い合わせ
! HistoryCopy :: GT_HISTORY 型変数のコピー
! HistoryPutLine :: GT_HISTORY 型変数の印字
! HistoryInitialized :: GT_HISTORY 型変数の初期設定をチェック
!
! * GT_HISTORY_AXIS 関連
!
! HistoryAxisCreate :: 作成 (初期設定)
! HistoryAxisCopy :: コピー
! HistoryAxisAddAttr :: 属性付加
! HistoryAxisInquire :: 問い合わせ
! HistoryAxisClear :: 終了処理
!
! * GT_HISTORY_VARINFO 関連
!
! HistoryVarinfoCreate :: 作成 (初期設定)
! HistoryVarinfoCopy :: コピー
! HistoryVarinfoAddAttr :: 属性付加
! HistoryVarinfoInquire :: 問い合わせ
! HistoryVarinfoClear :: 終了処理
! HistoryVarinfoInitialized :: 初期設定チェック
!
!== Derived types
!
! GT_HISTORY :: gtool4 データ出力用
! GT_HISTORY_AXIS :: gtool4 データ座標軸情報
! GT_HISTORY_VARINFO :: gtool4 データ変数情報
!
!
!== {gtool4 netCDF 規約}[link:../xref.htm#label-6]との対応
!
! バージョン gtool4_netCDF_version に対応しています。
!
!=== 生成系
!
! 出力するデータには以下の大域属性を必ず与えます。
!
! netCDF属性:: 与えられる値
! Conventions :: ユーザによる指定が無い限り gtool4_netCDF_Conventions
! が与えられます.
! gt_version :: ユーザによる指定が無い限り gtool4_netCDF_version
! が与えられます.
! title :: ユーザによって指定されます.
! source :: ユーザによって指定されます.
! institution :: ユーザによって指定されます.
! history :: "unknown 2005-08-05T21:48:37+09:00> gt4_history: HistoryCreate\\n"
! といった値が与えられます.
! "unknown" の部分には, 環境変数 USER から取得される
! ユーザ名が与えられます. その後ろにはファイルの生成を
! 開始した時刻が与えられます.
!
! 出力するデータの変数には以下の属性を必ず与えます.
!
! netCDF属性:: 与えられる値
! long_name :: ユーザによって指定されます.
! units :: ユーザによって指定されます.
!
! この他の属性に関して HistoryAddAttr などによって任意に与えることは
! 可能です. 禁止の属性に関しては警告を発するべきですが, 現在は
! チェックを行っていません.
!
!=== 解釈系
!
! 原則的に, 現在の gt4_history は全ての属性の解釈を行ないません.
! 本来ならば, HistoryGet は scale_factor, add_offset,
! valid_range などの属性を解釈すべきかも知れません. ただし,
! HistoryCopyVariable は変数コピーの際, 変数に属する全ての属性と
! その値を引き継ぎます.
!
!--
!
! This module is designed for output to gtool4 netCDF dataset
! sequentially along an axis (here after it will be called '+time+').
! The name indicates that the module is originally intended to serve as
! the '+history+' of atmospheric forecast models.
!
!== Dependency
!
!* module gtdata_types for internal data access
!* module dc_types for constants dc_types#STRING and dc_types#TOKEN
!* module dc_trace for error trace function
!
!++
use gtdata_types, only: GT_VARIABLE
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
private
public:: GT_HISTORY, GT_HISTORY_AXIS, GT_HISTORY_VARINFO
public:: HistoryInitialized
public:: Create, Copy, Inquire, Put_Attr !, New, Put
public:: HistoryCreate, HistoryClose, HistoryAxisClear, HistoryVarinfoClear
public:: HistoryAxisCreate !, HistoryAxisNew
public:: HistoryVarinfoCreate
public:: HistoryInquire, HistoryAxisInquire, HistoryVarinfoInquire
public:: HistoryCopy, HistoryAxisCopy, HistoryVarinfoCopy, HistoryVarinfoInitialized
public:: HistoryPutLine
public:: HistoryAddVariable, HistoryCopyVariable
public:: HistoryPut, HistoryPutEx
public:: HistoryAddAttr, HistoryAxisAddAttr, HistoryVarinfoAddAttr
public:: HistorySetTime
public:: HistoryGet, HistoryGetPointer
public:: lookup_variable_ord
!-----------------------------------------------
! 後方互換用
! For backward compatibility
public:: initialized
interface initialized
module procedure HistoryInitialized0
end interface
!!$ interface New
!!$ module procedure HistoryAxisNew1
!!$ end interface
!!$ interface HistoryAxisNew
!!$ module procedure HistoryAxisNew1
!!$ end interface
interface HistoryInitialized
module procedure HistoryInitialized0
end interface
interface Create
module procedure HistoryAxisCreate1
module procedure HistoryVarinfoCreate1
!!$ module procedure HistoryCreate1, HistoryCreate2
end interface
interface HistoryCreate
module procedure HistoryCreate1, HistoryCreate2
end interface
interface HistoryAxisCreate
module procedure HistoryAxisCreate1
end interface
interface HistoryVarinfoCreate
module procedure HistoryVarinfoCreate1
end interface
interface HistoryAddVariable
module procedure HistoryAddVariable1, HistoryAddVariable2
end interface
interface Copy
module procedure HistoryCopy1
module procedure HistoryAxisCopy1
module procedure HistoryVarinfoCopy1
end interface
interface HistoryCopy
module procedure HistoryCopy1
end interface
interface HistoryAxisCopy
module procedure HistoryAxisCopy1
end interface
interface HistoryVarinfoCopy
module procedure HistoryVarinfoCopy1
end interface
interface HistoryCopyVariable
module procedure HistoryCopyVariable1
end interface
interface Inquire
module procedure HistoryInquire1, HistoryInquire2
module procedure HistoryAxisInquire1
module procedure HistoryVarinfoInquire1
end interface
interface HistoryInquire
module procedure HistoryInquire1, HistoryInquire2
end interface
interface HistoryAxisInquire
module procedure HistoryAxisInquire1
end interface
interface HistoryVarinfoInquire
module procedure HistoryVarinfoInquire1
end interface
interface HistoryVarinfoClear
module procedure HistoryVarinfoClear0
end interface
interface HistoryVarinfoInitialized
module procedure HistoryVarinfoInitialized0
end interface
interface HistoryPutLine
module procedure HistoryPutLine
end interface
!!$ interface Put
#{foreach("\\$type\\$", "Double", "Real", %Q{
#{forloop("\\$num\\$", 1, $histput_dim, %Q{
!!$ module procedure HistoryPut$type$$num$
})}
!!$ module procedure HistoryPut$type$0
!!$ module procedure HistoryPut$type$Ex
})}
!!$ end interface
interface HistoryPut
#{foreach("\\$type\\$", "Double", "Real", "Int", %Q{
#{forloop("\\$num\\$", 1, $histput_dim, %Q{
module procedure HistoryPut$type$$num$
})}
module procedure HistoryPut$type$0
})}
end interface
interface HistoryPutEx
#{foreach("\\$type\\$", "Real", "Double", "Int", %Q{
module procedure HistoryPut$type$Ex
})}
end interface
interface Put_Attr
#{foreach("\\$type\\$", "Char", "Logical", %Q{
!!$ module procedure HistoryAddAttr$type$0
module procedure HistoryAxisAddAttr$type$0
module procedure HistoryVarinfoAddAttr$type$0
})}
#{foreach("\\$type\\$", "Int", "Real", "Double", %Q{
#{forloop("\\$num\\$", 0, 1, %Q{
!!$ module procedure HistoryAddAttr$type$$num$
module procedure HistoryAxisAddAttr$type$$num$
module procedure HistoryVarinfoAddAttr$type$$num$
})}})}
end interface
interface HistoryAddAttr
#{foreach("\\$type\\$", "Char", "Logical", %Q{
module procedure HistoryAddAttr$type$0
})}
#{foreach("\\$type\\$", "Int", "Real", "Double", %Q{
#{forloop("\\$num\\$", 0, 1, %Q{
module procedure HistoryAddAttr$type$$num$
})}})}
end interface
interface HistoryAxisAddAttr
#{foreach("\\$type\\$", "Char", "Logical", %Q{
module procedure HistoryAxisAddAttr$type$0
})}
#{foreach("\\$type\\$", "Int", "Real", "Double", %Q{
#{forloop("\\$num\\$", 0, 1, %Q{
module procedure HistoryAxisAddAttr$type$$num$
})}})}
end interface
interface HistoryVarinfoAddAttr
#{foreach("\\$type\\$", "Char", "Logical", %Q{
module procedure HistoryVarinfoAddAttr$type$0
})}
#{foreach("\\$type\\$", "Int", "Real", "Double", %Q{
#{forloop("\\$num\\$", 0, 1, %Q{
module procedure HistoryVarinfoAddAttr$type$$num$
})}})}
end interface
__EndOfFortran90Code__
timetypes = ["Double", "Real", "Int"]
types = ["Double", "Real", "Int"]
fixorptrs = ["", "Pointer"]
def timekind(timetype)
return "D" if timetype == "Double"
return "R" if timetype == "Real"
return "I" if timetype == "Int"
return ""
end
fixorptrs.each{ |fixorptr|
print <<"__EndOfFortran90Code__"
#{ifelse(fixorptr, "Pointer", %Q{
!--------------------------
! ポインタ配列用
! For pointer array
interface HistoryGetPointer
}, %Q{
!--------------------------
! 固定長配列用
! For fixed length array
interface HistoryGet
})}
__EndOfFortran90Code__
types.each{ |type|
for num in 0..$histget_dim
print <<"__EndOfFortran90Code__"
subroutine HistoryGet#{type}#{num}#{fixorptr}(file, varname, array, range, quiet, err)
use dc_types, only: DP
character(*), intent(in):: file, varname
character(*), intent(in), optional:: range
logical, intent(in), optional:: quiet
#{ifelse(fixorptr, "Pointer", %Q{
#{$type_intent_out[type]}, pointer:: array#{array_colon("#{num}")} ! (out)
}, %Q{
#{$type_intent_out[type]}, intent(out):: array#{array_colon("#{num}")}
})}
logical, intent(out), optional:: err
end subroutine HistoryGet#{type}#{num}#{fixorptr}
__EndOfFortran90Code__
timetypes.each{ |timetype|
print <<"__EndOfFortran90Code__"
subroutine HistoryGet#{type}#{num}#{fixorptr}Time#{timekind(timetype)}(file, varname, array, time, quiet, err)
use dc_types, only: DP
character(*), intent(in):: file, varname
#{$type_intent_in[timetype]}, intent(in):: time
logical, intent(in), optional:: quiet
#{ifelse(fixorptr, "Pointer", %Q{
#{$type_intent_out[type]}, pointer:: array#{array_colon("#{num}")} ! (out)
}, %Q{
#{$type_intent_out[type]}, intent(out):: array#{array_colon("#{num}")}
})}
logical, intent(out), optional:: err
end subroutine HistoryGet#{type}#{num}#{fixorptr}Time#{timekind(timetype)}
__EndOfFortran90Code__
} # end of timetypes.each
end # end of for num in 0..$histget_dim
} # end of types.each
print <<"__EndOfFortran90Code__"
end interface
__EndOfFortran90Code__
} # end of "fixorptrs.each"
undef timekind
print <<"__EndOfFortran90Code__"
character(len = STRING), parameter, public:: &
& gtool4_netCDF_Conventions = &
& "http://www.gfd-dennou.org/library/gtool4/conventions/"
! gtool4 netCDF 規約の URL
character(len = STRING), parameter, public:: &
& gtool4_netCDF_version = "4.3"
! gtool4 netCDF 規約のバージョン
type GT_HISTORY
!
!== gtool4 netCDF データの出力用構造体
!
! この型の変数は HistoryCreate によって初期設定される必要があります。
! 初期設定後、データ出力用の複数のサブルーチンによって利用されます。
! 最終的には HistoryClose によって終了処理してください。
!
! この構造体の内部の要素は非公開になっています。
! 問い合わせの際には HistoryInquire を利用してください。
!
!
! Data entity of this type represents a netCDF dataset
! controlled by gt4f90io library.
! It must be initialized by HistoryCreate ,
! then used in many subroutines, and must be finalized by
! HistoryClose .
! 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 HistoryCreate,
! 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.
private
logical:: initialized = .false.
! 初期設定フラグ.
! Initialization flag
integer:: unlimited_index
type(GT_VARIABLE), pointer:: dimvars(:) =>null()
! 次元変数 ID配列.
! it is index of dimvars(:),
! not that of vars(:).
logical, pointer:: dim_value_written(:) =>null()
! 各次元が記述済みかどうか
real:: origin, interval, newest, oldest
type(GT_VARIABLE), pointer:: vars(:) =>null()
! 変数 ID 配列
integer, pointer:: growable_indices(:) =>null()
! 無制限次元の添字
! (無制限次元が無い時は 0)
integer, pointer:: count(:) =>null()
! 各配列の無制限次元の配列長
integer, pointer:: var_avr_count(:) =>null()
! 各変数の時間平均値出力の際の積算回数.
! -1 の場合は出力データを平均化しない.
!
! Number of times of integral
! for time-averaged value output of each variable.
! -1 disables average value output
type(GT_HISTORY_AVRDATA), pointer:: var_avr_data(:) =>null()
! 時間平均値を出力するためのデータ一時保管用配列.
!
! Array for temporary keeping data for
! time-averaged value output
real(DP):: time_bnds(1:2)
! "time_bnds" 変数に出力されるデータ.
!
! Data that is to be output in "time_bnds"
! variable
integer:: time_bnds_output_count = 0
! "time_bnds" 変数に出力された回数.
!
! Number of output in "time_bnds" variable
end type GT_HISTORY
type GT_HISTORY_AVRDATA
!
! 時間方向の平均値を出力するためのデータ一時保管用配列.
!
! Array for temporary keeping data for time average value output
!
real(DP), pointer:: a_DataAvr(:) =>null()
integer:: length
end type GT_HISTORY_AVRDATA
type(GT_HISTORY), save, target:: default ! history が未指定の場合に使用
type GT_HISTORY_AXIS
!
!== 座標軸情報を格納する構造体
!
! この型の変数は HistoryAxisCreate, HistoryAxisCopy, HistoryInquire
! によって初期設定される必要があります。
! 初期設定後、HistoryCreate の *axes* に与えます。
!
! 問い合わせは HistoryAxisInquire によって行います。
! 属性の付加は HistoryAxisAddAttr によって行います。
! 初期化は HistoryAxisClear によって行います。
!
! This type may be used as a argument *axes* of HistoryCreate
! to define features of axes of a history dataset.
! Typically, a constant array of this type will be used for
! fixed specification.
!
private
character(TOKEN) :: name = "" ! 次元変数名
integer :: length = 0 ! 次元長 (配列サイズ)
character(STRING):: longname = "" ! 次元変数の記述的名称
character(STRING):: units = "" ! 次元変数の単位
character(TOKEN) :: xtype = "" ! 次元変数の型
type(GT_HISTORY_ATTR), pointer:: attrs(:) =>null() ! 属性情報群
end type GT_HISTORY_AXIS
type GT_HISTORY_VARINFO
!
!== 変数情報を格納する構造体
!
! この型の変数は HistoryVarinfoCreate, HistoryVarinfoCopy,
! HistoryInquire
! によって初期設定される必要があります。
! 初期設定後、HistoryAddVariable の *varinfo* に与えます。
!
! 問い合わせは HistoryVarinfoInquire によって行います。
! 属性の付加は HistoryVarinfoAddAttr によって行います。
! 初期化は HistoryVarinfoClear によって行います。
!
! This type may be used as a argument *varinfo* of
! HistoryAddVariable
! to define features of variable of a history dataset.
!
private
character(TOKEN) :: name = "" ! 変数名
character(TOKEN), pointer :: dims(:) =>null() ! 依存する次元
character(STRING) :: longname = "" ! 変数の記述的名称
character(STRING) :: units = "" ! 変数の単位
character(TOKEN) :: xtype = "" ! 変数の型
type(GT_HISTORY_ATTR), pointer:: attrs(:) =>null() ! 属性情報群
logical:: time_average = .false. ! 時間平均
logical:: initialized = .false.
! 初期設定フラグ.
! Initialization flag
end type GT_HISTORY_VARINFO
type GT_HISTORY_ATTR
!
! 変数の属性情報の構造体. 外部参照はさせず, GT_HISTORY_VARINFO
! および GT_HISTORY_AXIS に内包されて利用されることを
! 想定している. 直接的にこの構造体を変数にとる
! サブルーチンは HistoryAttrAdd および HistoryAttrCopy.
!
private
character(TOKEN) :: attrname ! 属性の名前
character(TOKEN) :: attrtype ! 属性の値の型
logical :: array = .false. ! 属性の値が配列かどうか
character(STRING) :: Charvalue ! 属性の値 (文字型変数)
integer :: Intvalue ! 属性の値 (整数型変数)
real :: Realvalue ! 属性の値 (単精度実数型変数)
real(DP) :: Doublevalue ! 属性の値 (倍精度実数型変数)
logical :: Logicalvalue ! 属性の値 (論理型変数)
integer ,pointer:: Intarray(:) =>null() ! 属性の値 (整数型配列)
real ,pointer:: Realarray(:) =>null() ! 属性の値 (単精度実数型配列)
real(DP) ,pointer:: Doublearray(:) =>null() ! 属性の値 (倍精度実数型配列)
end type GT_HISTORY_ATTR
character(*), parameter:: version = &
& '$Name: gt4f90io-20080812 $' // &
& '$Id: gt4_history.rb2f90,v 1.52 2008-07-27 22:40:53 morikawa Exp $'
contains
__EndOfFortran90Code__
print <<"__EndOfFortran90Code__"
logical function HistoryInitialized0( history ) result(result)
!
! *history* が初期設定されている場合には .true. が,
! 初期設定されていない場合には .false. が返ります.
!
! If *history* is initialized, .true. is returned.
! If *history* is not initialized, .false. is returned.
!
implicit none
type(GT_HISTORY), intent(in):: history
continue
result = history % initialized
end function HistoryInitialized0
subroutine HistoryPutLine( history, unit, indent, err )
!
! 引数 *history* に設定されている情報を印字します.
! デフォルトではメッセージは標準出力に出力されます.
! *unit* に装置番号を指定することで, 出力先を変更することが可能です.
!
! Print information of *history*.
! By default messages are output to standard output.
! Unit number for output can be changed by *unit* argument.
!
use dc_trace, only: BeginSub, EndSub
use dc_string, only: PutLine, Printf, Split, StrInclude, StoA, JoinChar
use dc_types, only: DP, STRING, TOKEN, STDOUT
use dc_error, only: StoreError, DC_NOERR, DC_ENOTINIT
use gtdata_generic, only: PutLine
implicit none
type(GT_HISTORY), intent(in), target, optional:: history
integer, intent(in), optional:: unit
! 出力先の装置番号.
! デフォルトの出力先は標準出力.
!
! Unit number for output.
! Default value is standard output.
character(*), intent(in), optional:: indent
! 表示されるメッセージの字下げ.
!
! Indent of displayed messages.
logical, intent(out), optional:: err
! 例外処理用フラグ.
! デフォルトでは, この手続き内でエラーが
! 生じた場合, プログラムは強制終了します.
! 引数 *err* が与えられる場合,
! プログラムは強制終了せず, 代わりに
! *err* に .true. が代入されます.
!
! Exception handling flag.
! By default, when error occur in
! this procedure, the program aborts.
! If this *err* argument is given,
! .true. is substituted to *err* and
! the program does not abort.
!-----------------------------------
! 作業変数
! Work variables
type(GT_HISTORY), pointer:: hst =>null()
integer:: i, max
integer:: stat
character(STRING):: cause_c
integer:: out_unit
integer:: indent_len
character(STRING):: indent_str
character(STRING):: file, title, source, institution
character(STRING):: conventions, gt_version
character(TOKEN), pointer:: dims(:) =>null()
integer, pointer:: dimsizes(:) =>null()
character(STRING), pointer:: longnames(:) =>null()
character(TOKEN), pointer:: units(:) =>null()
character(TOKEN), pointer:: xtypes(:) =>null()
character(*), parameter:: subname = 'HistoryPutLine'
continue
call BeginSub( subname )
stat = DC_NOERR
cause_c = ''
!-----------------------------------------------------------------
! 出力先装置番号と字下げの設定
! Configure output unit number and indents
!-----------------------------------------------------------------
if ( present(unit) ) then
out_unit = unit
else
out_unit = STDOUT
end if
indent_len = 0
indent_str = ''
if ( present(indent) ) then
if ( len(indent) /= 0 ) then
indent_len = len(indent)
indent_str(1:indent_len) = indent
end if
end if
if (present(history)) then
hst => history
else
hst => default
endif
!-----------------------------------------------------------------
! "GT_HISTORY" の設定の印字
! Print the settings for "GT_HISTORY"
!-----------------------------------------------------------------
if ( hst % initialized ) then
call Printf( out_unit, &
& indent_str(1:indent_len) // &
& '#' )
end if
if ( associated( hst % count ) ) then
max = size( hst % count )
call Printf( out_unit, &
& indent_str(1:indent_len) // &
& ' @count=%*d', &
& i = hst % count, n = (/max/) )
else
call Printf( out_unit, &
& indent_str(1:indent_len) // &
& ' @count=' )
end if
if ( associated( hst % dimvars ) ) then
call Printf( out_unit, &
& indent_str(1:indent_len) // &
& ' @dimvars=' )
max = size( hst % dimvars )
do i = 1, max
call PutLine( hst % dimvars(i), out_unit, &
& indent_str(1:indent_len) // ' ', err )
end do
else
call Printf( out_unit, &
& indent_str(1:indent_len) // &
& ' @dimvars=' )
end if
if ( associated( hst % vars ) ) then
call Printf( out_unit, &
& indent_str(1:indent_len) // &
& ' @vars=' )
max = size( hst % vars )
do i = 1, max
call PutLine( hst % vars(i), out_unit, &
& indent_str(1:indent_len) // ' ', err )
end do
else
call Printf( out_unit, &
& indent_str(1:indent_len) // &
& ' @vars=' )
end if
if ( associated( hst % var_avr_count ) ) then
max = size( hst % var_avr_count )
call Printf( out_unit, &
& indent_str(1:indent_len) // &
& ' @var_avr_count=%*d', &
& i = hst % var_avr_count, n = (/max/) )
else
call Printf( out_unit, &
& indent_str(1:indent_len) // &
& ' @var_avr_count=' )
end if
call Printf( out_unit, &
& indent_str(1:indent_len) // &
& ' @time_bnds=%*f, @time_bnds_output_count=%d', &
& i = (/hst % time_bnds_output_count/), &
& d = hst % time_bnds, &
& n = (/ size(hst % time_bnds) /) )
if ( associated( hst % var_avr_data ) ) then
call Printf( out_unit, &
& indent_str(1:indent_len) // &
& ' @var_avr_data=' )
max = size( hst % var_avr_data )
do i = 1, max
call Printf( out_unit, &
& indent_str(1:indent_len) // &
& ' #' )
end if
call Printf( out_unit, &
& indent_str(1:indent_len) // &
& '>' )
else
call Printf( out_unit, &
& indent_str(1:indent_len) // &
& '#', &
& l = (/hst % initialized/) )
end if
!-----------------------------------------------------------------
! 終了処理, 例外処理
! Termination and Exception handling
!-----------------------------------------------------------------
999 continue
call StoreError( stat, subname, err, cause_c )
call EndSub( subname )
end subroutine HistoryPutLine
__EndOfFortran90Code__
print <<"__EndOfFortran90Code__"
subroutine HistoryCreate2(file, title, source, institution, &
& axes, origin, interval, history, conventions, gt_version, &
& overwrite, quiet, err )
!
!== gtool4 データ出力用初期設定
!
! *HistoryCreate* というサブルーチン名は 2 つの別々の
! サブルーチンの総称名です。まずは HistoryCreate を参照ください。
!
! もう 1 つのサブルーチンと異なる点は、座標軸の情報を
! *dims*, *dimsizes*, *longnames*, *units*, and *xtypes* といった
! 個別の引数で与えるのではなく、構造体 GT_HISTORY_AXIS 型の
! 引数 *axes* で与える点にあります。
!
! GT_HISTORY_AXIS 型変数の生成 (constructer) は
! HistoryAxisCreate にて行います。
!
!
! Two specific subroutines shares common part:
!
! Both two ones initializes a dataset *file*.
! The result of type GT_HISTORY 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 type GT_HISTORY_AXIS,
! *axes*.
! Temporal definition is done without *origin*, *interval*.
!
implicit none
character(*), intent(in):: file
! HistoryCreate 参照
! (以下 axes を除く引数も同様)
!
character(*), intent(in):: title, source, institution
type(GT_HISTORY_AXIS), intent(in):: axes(:)
! 次元情報を格納した構造型変数
!
! GT_HISTORY_AXIS 型変数の生成
! (constructer) は
! HistoryAxisCreate にて行いま
! す。配列の大きさに制限は
! ありません。
!
real, intent(in), optional:: origin, interval
type(GT_HISTORY), intent(out), optional:: history
character(*), intent(in), optional:: conventions, gt_version
logical, intent(in), optional:: overwrite
logical, intent(in), optional:: quiet
! .true. を与えた場合,
! メッセージ出力が抑制されます.
! デフォルトは .false. です.
!
! If ".true." is given,
! messages are suppressed.
! Default value is ".false.".
!
logical, intent(out), optional:: err
! 例外処理用フラグ.
! デフォルトでは, この手続き内でエラーが
! 生じた場合, プログラムは強制終了します.
! 引数 *err* が与えられる場合,
! プログラムは強制終了せず, 代わりに
! *err* に .true. が代入されます.
!
! Exception handling flag.
! By default, when error occur in
! this procedure, the program aborts.
! If this *err* argument is given,
! .true. is substituted to *err* and
! the program does not abort.
! 構造体 GT_HISTORY_AXIS のデータ蓄積用
character(STRING), allocatable:: axes_name(:)
integer , allocatable:: axes_length(:)
character(STRING), allocatable:: axes_longname(:)
character(STRING), allocatable:: axes_units(:)
character(STRING), allocatable:: axes_xtype(:)
integer:: i, ndims
character(len = *), parameter:: subname = "HistoryCreate2"
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, overwrite=overwrite)
! 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 )
do i = 1, ndims
if (.not. associated( axes(i) % attrs ) ) cycle
call HistoryAttrAdd( axes(i) % name, axes(i) % attrs, history )
end do
call EndSub(subname)
end subroutine HistoryCreate2
subroutine HistoryCreate1( &
& file, title, source, institution, &
& dims, dimsizes, longnames, units, origin, interval, &
& xtypes, history, conventions, gt_version, overwrite, quiet, err )
!
!== gtool4 データ出力用初期設定
!
! このサブルーチンは、gtool4 データ出力の初期設定を行います。
! HistoryAddVariable、 HistoryCopyVariable、 HistoryPut、
! HistoryAddAttr、 HistoryClose、 HistorySetTime
! を用いるためには、HistoryCreate による初期設定が必要です。
!
! なお、プログラム内で HistoryCreate を呼び出した場合、
! プログラムを終了する前に必ず、 HistoryClose を呼び出して
! 終了処理を行なって下さい。
!
! *HistoryCreate* というサブルーチン名は 2 つの別々の
! サブルーチンの総称名です。上記のサブルーチンも参照ください。
!
!
! Two specific subroutines shares common part:
!
! Both two ones initializes a dataset *file*.
! The result of type GT_HISTORY 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 type GT_HISTORY_AXIS,
! *axes*.
! Temporal definition is done without *origin*, *interval*.
!
use gtdata_generic,only: Create, put_attr
use dc_error, only: StoreError, DC_NOERR, GT_EARGSIZEMISMATCH, DC_EALREADYINIT
use dc_string, only: JoinChar, toChar, StoA
use dc_url, only: UrlMerge
use dc_present, only: present_and_not_empty, present_and_false, present_and_true
use dc_types, only: STRING, TOKEN
use dc_message, only: MessageNotify
use sysdep, only: SysdepEnvGet
use dc_date_types, only: DC_DATETIME
use dc_date, only: DCDateTimeCreate, toChar
implicit none
character(*), intent(in):: file
! 出力するファイルの名前.
! Name of output file
character(*), intent(in):: title
! データ全体の表題.
! Title of entire data
character(*), intent(in):: source
! データを作成する際の手段.
! Source of data file
character(*), intent(in):: institution
! ファイルを最終的に変更した組織/個人.
! Institution or person that changes files for the last time
character(*), intent(in):: dims(:)
! 次元の名前.
!
! 配列の大きさに制限はありません.
! 個々の次元の文字数は dc_types#TOKEN まで.
! 配列内の文字数は
! 全て同じでなければなりません.
! 足りない文字分は空白で
! 補ってください.
!
! Names of dimensions.
!
! Length of array is unlimited.
! Limits of numbers of characters of each
! dimensions are "dc_types#TOKEN".
! Numbers of characters in this array
! must be same.
! Make up a deficit with blanks.
!
integer, intent(in):: dimsizes (:)
! dims で指定したそれぞれの次元大きさ.
!
! 配列の大きさは dims の大きさと等しい
! 必要があります. '0' (数字のゼロ) を指定
! するとその次元は 無制限次元 (unlimited
! dimension) となります. (gt4_history
! では時間の次元に対して無制限次元を
! 用いることを想定しています). ただし,
! 1 つの NetCDF ファイル (バージョン 3)
! は最大で 1 つの無制限次元しか持てないので,
! 2 ヶ所以上に '0' を指定しないでください.
! その場合, 正しく gtool4 データが出力されません.
!
! Lengths of dimensions specified with "dims".
!
! Length of this array must be same as
! length of "dim". If '0' (zero) is
! specified, the dimension is treated as
! unlimited dimension.
! (In "gt4_history", unlimited dimension is
! expected to be used as time).
! Note that one NetCDF file (version 3)
! can not have two or more unlimited
! dimensions, so that do not specify '0'
! to two or more places. In that case,
! gtoo4 data is not output currently
!
character(*), intent(in):: longnames (:)
! dims で指定したそれぞれの次元の名前.
!
! 配列の大きさは dims の大きさ
! と等しい必要があります. 文字数
! は dc_types#STRING まで.
! 配列内の文字数は
! 全て同じでなければなりません.
! 足りない文字分は空白で補います.
!
! Names of dimensions specified with "dims".
!
! Length of this array must be same as
! length of "dim".
! Limits of numbers of characters are
! "dc_types#STRING".
! Numbers of characters in this array
! must be same.
! Make up a deficit with blanks.
!
character(*), intent(in):: units(:)
! dims で指定したそれぞれの次元の単位.
!
! 配列の大きさは dims の大きさ
! と等しい必要があります. 文字数
! は dc_types#STRING まで.
! 配列内の文字数は
! 全て同じでなければなりません.
! 足りない文字分は空白で補います.
!
! Units of dimensions specified with "dims".
!
! Length of this array must be same as
! length of "dim".
! Limits of numbers of characters are
! "dc_types#STRING".
! Numbers of characters in this array
! must be same.
! Make up a deficit with blanks.
!
real, intent(in), optional:: origin
! 時間の原点.
!
! これは HistoryPut により変数を最初に
! 出力するときの時間となります.
!
! 省略した場合, 時間の原点には
! 自動的に 0.0 が設定されます.
!
! Origin of time.
!
! This time is used as time
! when first output is done by "HistoryPut".
!
! If this argument is omitted,
! 0.0 is specified automatically.
!
real, intent(in), optional:: interval
! 出力時間間隔.
!
! 同じ変数に対して HistoryPut が複数回
! 呼ばれた時に, 自動的に時間変数がこの値
! だけ増やされて出力されます. なお,
! 各々の出力ファイルにつき HistorySetTime
! を一度でも用いた場合, この値は無効に
! なるので注意してください.
!
! 省略した場合, 自動的に 1.0 が設定されます.
!
! Interval of output time.
!
! When "HistoryPut" is called two or
! more times for the same variable, time
! is increased as this value and
! output automatically.
! Note that this value becomes
! invalid when "HistorySetTime" is
! used for each output file even once.
!
! If this argument is omitted,
! 1.0 is specified automatically.
!
character(*), intent(in), optional:: xtypes(:)
! dims で指定したそれぞれの
! 次元のデータ型.
!
! デフォルトは float (単精度実数型)
! です. 有効なのは,
! double (倍精度実数型),
! int (整数型) です. 指定しない
! 場合や, 無効な型を指定した場合には,
! float となります. なお, 配列の大きさ
! は *dims* の大きさと等しい必要が
! あります. 配列内の文字数は全て
! 同じでなければなりません.
! 足りない文字分は空白で補います.
!
! Data types of dimensions specified
! with "dims".
!
! Default value is "float" (single precision).
! Other valid values are
! "double" (double precision),
! "int" (integer).
! If no value or invalid value is specified,
! "float" is applied.
! Length of this array must be same as
! length of "dim".
! Numbers of characters in this array
! must be same.
! Make up a deficit with blanks.
!
type(GT_HISTORY), intent(out), optional, target:: history
! 出力ファイルの設定に関する情報を
! 格納した構造体.
!
! 1 つのプログラムで複数のファイル
! に gtool データを出力する
! 場合に利用します.
! (単独のファイルに書き出す場合は
! 指定する必要はありません)
!
! Derived type that
! stores information about output files.
!
! If multiple gtool4 data files are
! output from one program, use this
! argument.
! (If onlye one file is output,
! this argument is not needed).
!
character(*), intent(in), optional:: conventions
! 出力するファイルの netCDF
! 規約
!
! 省略した場合,
! もしくは空文字を与えた場合,
! 出力する netCDF 規約の
! Conventions 属性に値
! gtool4_netCDF_Conventions
! が自動的に与えられます.
!
! NetCDF conventions of output file.
!
! If this argument is omitted or,
! blanks are given,
! gtool4_netCDF_Conventions is given to
! attribute "Conventions" of an output file
! automatically.
!
character(*), intent(in), optional:: gt_version
! gtool4 netCDF 規約のバージョン
!
! 省略した場合, gt_version 属性に
! 規約の最新版のバージョンナンバー
! gtool4_netCDF_version
! が与えられます.
! (ただし, 引数 conventions に
! gtool4_netCDF_Conventions
! 以外が与えられる場合は
! gt_version 属性を作成しません).
!
! Version of gtool4 netCDF Conventions.
!
! If this argument is omitted,
! latest version number of gtool4 netCDF
! Conventions is given to attribute
! "gt_version" of an output file
! (However, gtool4_netCDF_Conventions is
! not given to an argument "conventions",
! attribute "gt_version" is not created).
!
logical, intent(in), optional:: overwrite
! 上書き可否
!
! この引数に .false. を渡すと,
! 既存のファイルを上書きしません.
! デフォルトは上書きします.
!
! Whether or not to overwrite.
!
! If .false. is specified to this
! argument, an existing file is not
! overwritten.
! By default, existing file is overwritten.
!
logical, intent(in), optional:: quiet
! .true. を与えた場合,
! メッセージ出力が抑制されます.
! デフォルトは .false. です.
!
! If ".true." is given,
! messages are suppressed.
! Default value is ".false.".
!
logical, intent(out), optional:: err
! 例外処理用フラグ.
! デフォルトでは, この手続き内でエラーが
! 生じた場合, プログラムは強制終了します.
! 引数 *err* が与えられる場合,
! プログラムは強制終了せず, 代わりに
! *err* に .true. が代入されます.
!
! Exception handling flag.
! By default, when error occur in
! this procedure, the program aborts.
! If this *err* argument is given,
! .true. is substituted to *err* and
! the program does not abort.
integer:: numdims, i, stat
real:: origin_work
type(GT_HISTORY), pointer:: hst =>null()
character(TOKEN):: my_xtype, origin_str, interval_str
character(STRING):: url, x_inst, x_conv, x_gtver, nc_history
character(STRING):: cause_c
logical :: gtver_add, overwrite_required
character(token) :: username
type(DC_DATETIME) :: now_time
character(*), parameter:: subname = "HistoryCreate1"
continue
call BeginSub(subname, 'file=%c ndims=%d', &
& c1=trim(file), i=(/size(dims)/), &
& version=version)
stat = DC_NOERR
cause_c = ""
call DbgMessage( &
& 'dims(:)=%a, dimsizes(:)=%a, longnames(:)=%a, units(:)=%a', &
& ca=StoA(JoinChar(dims), toChar(dimsizes), &
& JoinChar(longnames), JoinChar(units)))
if (present(history)) then
hst => history
else
hst => default
endif
!-----------------------------------------------------------------
! 初期設定のチェック
! Check initialization
!-----------------------------------------------------------------
if ( hst % initialized ) then
stat = DC_EALREADYINIT
cause_c = 'GT_HISTORY'
goto 999
end if
numdims = size(dims)
if ( size(dimsizes) /= numdims ) then
cause_c = 'dimsizes, dims'
elseif ( size(longnames) /= numdims ) then
cause_c = 'longnames, dims'
elseif ( size(units) /= numdims ) then
cause_c = 'units, dims'
endif
if ( trim(cause_c) /= "" ) then
stat = GT_EARGSIZEMISMATCH
goto 999
end if
! 次元変数表作成
allocate(hst % dimvars(numdims))
allocate(hst % dim_value_written(numdims))
hst % dim_value_written(:) = .false.
hst % unlimited_index = 0
call SysdepEnvGet('USER', username)
if (trim(username) == '') username = 'unknown'
call DCDateTimeCreate(now_time)
nc_history = trim(toChar(now_time)) // ' ' // &
& trim(username) // &
& '> gt4_history: HistoryCreate' // &
& achar(10)
my_xtype = ""
do, i = 1, numdims
if ( present(xtypes) ) then
if ( size(xtypes) >= i ) then
my_xtype = xtypes(i)
end if
end if
url = UrlMerge(file=file, var=dims(i))
overwrite_required = .true.
if (present_and_false(overwrite)) overwrite_required = .false.
call Create( &
& hst % dimvars(i), trim(url), &
& dimsizes(i), xtype=trim(my_xtype), &
& overwrite=overwrite_required)
! conventions が存在しない場合はデフォルトの値を
! 属性 Conventions に付加。
if ( present_and_not_empty(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_and_not_empty(gt_version)) then
x_gtver = gt_version
gtver_add = .TRUE.
else
if (present_and_not_empty(conventions) .and. &
.not. x_conv == gtool4_netCDF_Conventions) then
gtver_add = .FALSE.
else
x_gtver = gtool4_netCDF_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)
! 時間カウンタ
if (present(interval)) then
hst % interval = interval
interval_str = toChar( hst % interval )
else
hst % interval = 1.0
interval_str = '1.0 (auto)'
!!$ call MessageNotify('M', subname, &
!!$ & 'interval=%r in output file <%c> (auto-setting)', &
!!$ & c1=trim(file), r=(/hst % interval/))
end if
if (present(origin)) then
origin_work = origin
origin_str = toChar( origin_work )
else
origin_work = 0.0
origin_str = '0. (auto)'
!!$ call MessageNotify('M', subname, &
!!$ & 'origin=%r in output file <%c> (auto-setting)', &
!!$ & c1=trim(file), r=(/origin_work/))
end if
hst % origin = origin_work
hst % newest = origin_work
hst % oldest = origin_work
!-----------------------------------------------------------------
! 時間平均値出力に関するデフォルト設定
! Default settings for time-averaged value output
!-----------------------------------------------------------------
hst % time_bnds = hst % origin
hst % time_bnds_output_count = 0
!-----------------------------------------------------------------
! メッセージ出力
! Output messages
!-----------------------------------------------------------------
if ( .not. present_and_true(quiet) ) then
call MessageNotify('M', subname, &
& '"%c" is created (origin=%c, interval=%c)', &
& c1 = trim( file ), &
& c2 = trim( origin_str ), &
& c3 = trim( interval_str ) )
end if
!-----------------------------------------------------------------
! 終了処理, 例外処理
! Termination and Exception handling
!-----------------------------------------------------------------
hst % initialized = .true.
999 continue
call StoreError(stat, subname, cause_c=cause_c)
call EndSub(subname, 'stat=%d', i = (/stat/) )
end subroutine HistoryCreate1
__EndOfFortran90Code__
print <<"__EndOfFortran90Code__"
!!$ type(GT_HISTORY_AXIS) function HistoryAxisNew1( &
!!$ & name, size, longname, units, xtype) result(result)
!!$ use dc_types, only: STRING, TOKEN, DP
!!$ use dc_trace, only: BeginSub, EndSub, DbgMessage
!!$ implicit none
!!$ character(*) , intent(in):: name ! 次元変数名
!!$ integer, intent(in):: size ! 次元長 (配列サイズ)
!!$ character(*) , intent(in):: longname ! 次元変数の記述的名称
!!$ character(*) , intent(in):: units ! 次元変数の単位
!!$ character(*) , intent(in):: xtype ! 次元変数の型
!!$ character(len = *), parameter:: subname = "HistoryAxisCreate1"
!!$ continue
!!$ call BeginSub(subname)
!!$ result % name = name
!!$ result % length = size
!!$ result % longname = longname
!!$ result % units = units
!!$ result % xtype = xtype
!!$ call EndSub(subname)
!!$ end function HistoryAxisNew1
subroutine HistoryAxisCreate1( axis, &
& name, size, longname, units, xtype)
!
!== GT_HISTORY_AXIS 型変数作成
!
! GT_HISTORY_AXIS 型変数を作成します。
! このサブルーチンによる設定の後、
! HistoryCreate の *axes* に与えます。
! さらに属性を付加する場合には HistoryAxisAddAttr
! を用いてください。
!
! Constructor of GT_HISTORY_AXIS
!
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
type(GT_HISTORY_AXIS),intent(out) :: axis
character(*) , intent(in):: name ! 次元変数名
integer, intent(in):: size ! 次元長 (配列サイズ)
character(*) , intent(in):: longname ! 次元変数の記述的名称
character(*) , intent(in):: units ! 次元変数の単位
character(*) , intent(in):: xtype ! 次元変数の型
character(len = *), parameter:: subname = "HistoryAxisCreate1"
continue
call BeginSub(subname)
axis % name = name
axis % length = size
axis % longname = longname
axis % units = units
axis % xtype = xtype
call EndSub(subname)
end subroutine HistoryAxisCreate1
subroutine HistoryVarinfoCreate1( varinfo, & ! (out)
& name, dims, longname, units, xtype, & ! (in)
& time_average, average, err & ! (in) optional
& )
!
!== GT_HISTORY_VARINFO 型変数作成
!
! GT_HISTORY_VARINFO 型変数を作成します。
! このサブルーチンによる設定の後、
! HistoryAddVariable の *varinfo* に与えます。
! さらに属性を付加する場合には HistoryVarinfoAddAttr
! を用いてください。
!
! Constructor of GT_HISTORY_VARINFO
!
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_message, only: MessageNotify
use dc_error, only: StoreError, DC_NOERR, DC_EALREADYINIT
implicit none
type(GT_HISTORY_VARINFO),intent(inout) :: varinfo
character(*), intent(in):: name ! 変数名
character(*), intent(in):: dims(:) ! 依存する次元
character(*), intent(in):: longname ! 変数の記述的名称
character(*), intent(in):: units ! 変数の単位
character(*), intent(in), optional:: xtype
! 変数の型
logical, intent(in), optional:: time_average
! 時間平均
logical, intent(in), optional:: average
! 時間平均 (後方互換用)
logical, intent(out), optional:: err
! 例外処理用フラグ.
! デフォルトでは, この手続き内でエラーが
! 生じた場合, プログラムは強制終了します.
! 引数 *err* が与えられる場合,
! プログラムは強制終了せず, 代わりに
! *err* に .true. が代入されます.
!
! Exception handling flag.
! By default, when error occur in
! this procedure, the program aborts.
! If this *err* argument is given,
! .true. is substituted to *err* and
! the program does not abort.
! Internal Work
integer:: i, numdims, stat
character(STRING):: cause_c
character(*), parameter:: subname = "HistoryVarinfoCreate1"
continue
call BeginSub(subname)
stat = DC_NOERR
cause_c = ''
if ( varinfo % initialized ) then
stat = DC_EALREADYINIT
cause_c = 'GT_HISTORY_VARINFO'
goto 999
end if
varinfo % name = name
varinfo % longname = longname
varinfo % units = units
if ( present(xtype) ) varinfo % xtype = xtype
if ( present(time_average) ) varinfo % time_average = time_average
if ( present(average) ) varinfo % time_average = average
numdims = size(dims)
allocate(varinfo % dims(numdims))
do i = 1, numdims
varinfo % dims(i) = dims(i)
if (len(trim(dims(i))) > TOKEN) then
call MessageNotify('W', subname, &
& 'dimension name <%c> is trancated to <%c>', &
& c1=trim(dims(i)), c2=trim(varinfo % dims(i)))
end if
end do
varinfo % initialized = .true.
999 continue
call StoreError( stat, subname, err, cause_c )
call EndSub(subname)
end subroutine HistoryVarinfoCreate1
__EndOfFortran90Code__
print <<"__EndOfFortran90Code__"
subroutine HistoryAxisInquire1( axis, &
& name, size, longname, units, xtype)
!
!== GT_HISTORY_AXIS 型変数への問い合わせ
!
! GT_HISTORY_AXIS 型の変数内の各情報を参照します。
!
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
type(GT_HISTORY_AXIS),intent(in) :: axis
character(*) , intent(out), optional:: name ! 次元変数名
integer, intent(out), optional:: size ! 次元長 (配列サイズ)
character(*) , intent(out), optional:: longname ! 次元変数の記述的名称
character(*) , intent(out), optional:: units ! 次元変数の単位
character(*) , intent(out), optional:: xtype ! 次元変数の型
character(len = *), parameter:: subname = "HistoryAxisInquire1"
continue
call BeginSub(subname)
if (present(name)) then
name = axis % name
end if
if (present(size)) then
size = axis % length
end if
if (present(longname)) then
longname = axis % longname
end if
if (present(units)) then
units = axis % units
end if
if (present(xtype)) then
xtype = axis % xtype
end if
call EndSub(subname)
end subroutine HistoryAxisInquire1
subroutine HistoryVarinfoInquire1( varinfo, & ! (in)
& name, dims, longname, units, xtype, & ! (out) optional
& time_average, average, err ) ! (out) optional
!
!== GT_HISTORY_VARINFO 型変数への問い合わせ
!
! GT_HISTORY_VARINFO 型の変数内の各情報を参照します。
!
! dims はポインタ配列です。空状態にして与えてください。
!
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_error, only: StoreError, DC_NOERR, DC_ENOTINIT
implicit none
type(GT_HISTORY_VARINFO),intent(in) :: varinfo
character(*), intent(out), optional:: name ! 変数名
character(*), pointer, optional:: dims(:) !(out) 依存する次元
character(*), intent(out), optional:: longname ! 変数の記述的名称
character(*), intent(out), optional:: units ! 変数の単位
character(*), intent(out), optional:: xtype ! 変数の型
logical, intent(out), optional:: time_average ! 時間平均
logical, intent(out), optional:: average ! 時間平均 (後方互換用)
logical, intent(out), optional:: err
! 例外処理用フラグ.
! デフォルトでは, この手続き内でエラーが
! 生じた場合, プログラムは強制終了します.
! 引数 *err* が与えられる場合,
! プログラムは強制終了せず, 代わりに
! *err* に .true. が代入されます.
!
! Exception handling flag.
! By default, when error occur in
! this procedure, the program aborts.
! If this *err* argument is given,
! .true. is substituted to *err* and
! the program does not abort.
! Internal Work
integer:: i, numdims, stat
character(STRING):: cause_c
character(*), parameter:: subname = "HistoryVarinfoInquire1"
continue
call BeginSub(subname)
stat = DC_NOERR
cause_c = ''
if ( .not. varinfo % initialized ) then
stat = DC_ENOTINIT
cause_c = 'GT_HISTORY_VARINFO'
goto 999
end if
if (present(name)) name = varinfo % name
if (present(dims)) then
numdims = size(varinfo % dims)
allocate(dims(numdims))
do i = 1, numdims
dims(i) = varinfo % dims(i)
end do
end if
if ( present(longname) ) longname = varinfo % longname
if ( present(units) ) units = varinfo % units
if ( present(xtype) ) xtype = varinfo % xtype
if ( present(time_average) ) time_average = varinfo % time_average
if ( present(average) ) average = varinfo % time_average
999 continue
call StoreError(stat, subname, err, cause_c=cause_c)
call EndSub(subname)
end subroutine HistoryVarinfoInquire1
__EndOfFortran90Code__
print <<"__EndOfFortran90Code__"
subroutine HistoryCopy1(hist_dest, file, hist_src, &
& title, source, institution, &
!!!$ & axes, addaxes, dims, dimsizes, longnames, units, xtypes, &
& origin, interval, &
!!!$ & xtypes, &
& conventions, gt_version)
!
! 引数 *hist_src* の内容にコピーし, *hist_dest* へ返します. *hist_src*
! が与えられない場合は, 引数 *history* を与えずに呼び出した
! HistoryCreate の設定内容が参照されます.
! HistoryCreate と同様に, 出力の初期設定を行います. *file*
! は必ず与えなければならず, *hist_src* と同じファイルへ出力
! しようとする場合はエラーを生じます.
! HistoryAddVariable で設定される内容に関してはコピーされません.
!
! それ以降の引数を与えることで, hist_src の設定を
! 上書きすることが可能です.
!
use gtdata_generic, only: Inquire, Get_Attr, Copy_Attr, Get, Put
! use dc_url, only:
use dc_error, only: StoreError, DC_NOERR, GT_EARGSIZEMISMATCH
! use dc_string, only:
use dc_present, only: present_select
use dc_types, only: string, token
implicit none
type(GT_HISTORY), intent(out), target :: hist_dest
character(*), intent(in) :: file
type(GT_HISTORY), intent(in), optional, target:: hist_src
character(*), intent(in), optional:: title, source, institution
!!!$ type(GT_HISTORY_AXIS), intent(in),optional :: axes(:)
!!!$ type(GT_HISTORY_AXIS), intent(in),optional :: addaxes(:)
!!!$ character(*), intent(in), optional:: dims(:)
!!!$ integer, intent(in), optional:: dimsizes(:)
!!!$ character(*), intent(in), optional:: longnames(:)
!!!$ character(*), intent(in), optional:: units(:)
real, intent(in), optional:: origin, interval
!!!$ character(*), intent(in), optional:: xtypes(:)
character(*), intent(in), optional:: conventions, gt_version
! Internal Work
type(GT_HISTORY), pointer:: src =>null()
character(STRING) :: title_src, source_src, institution_src
character(STRING) :: conventions_src, gt_version_src
character(STRING), pointer:: dims(:) => null()
integer , pointer:: dimsizes(:) => null()
character(STRING), pointer:: longnames(:) => null()
character(STRING), pointer:: units(:) => null()
character(STRING), pointer:: xtypes(:) => null()
integer :: i, numdims
logical :: err
real(DP),pointer :: dimvalue(:) => null()
character(len = *),parameter:: subname = "HistoryCopy1"
continue
call BeginSub(subname, 'file=<%c>', c1=trim(file))
if (present(hist_src)) then
src => hist_src
else
src => default
endif
numdims = size(src % dimvars)
call HistoryInquire1(history=src, title=title_src, &
& source=source_src, institution=institution_src, &
& dims=dims, dimsizes=dimsizes, longnames=longnames, &
& units=units, xtypes=xtypes, &
& conventions=conventions_src, gt_version=gt_version_src)
call HistoryCreate1(file=trim(file), &
& title=trim(present_select('', title_src, title)), &
& source=trim(present_select('', source_src, source)), &
& institution=trim(present_select('', institution_src, institution)), &
& dims=dims, dimsizes=dimsizes, longnames=longnames, units=units, &
& origin=present_select(.false., src % origin, origin), &
& interval=present_select(0.0, src % interval, interval), &
& xtypes=xtypes, &
& history=hist_dest, &
& conventions=trim(present_select('', conventions_src, conventions)), &
& gt_version=trim(present_select('', gt_version_src, gt_version)) )
!
! 次元変数が属性を持っている場合のことも考え, 最後に直接
! hist_dst % dimvars へ copy_attr (gtvarcopyattrall) をかける.
!
do i = 1, numdims
call Copy_Attr(hist_dest % dimvars(i), src % dimvars (i), global=.false.)
end do
! dimvars を Get してみて, 値を持っているようならデータを与えてしまう.
do i = 1, numdims
if (dimsizes(i) == 0) cycle
call Get(src % dimvars(i), dimvalue, err)
if (err) cycle
call HistoryPutDoubleEx(dims(i), dimvalue, size(dimvalue), hist_dest)
deallocate(dimvalue)
end do
deallocate(dims, dimsizes, longnames, units, xtypes)
call EndSub(subname)
end subroutine HistoryCopy1
subroutine HistoryAxisCopy1(axis_dest, axis_src, err, &
& name, length, longname, units, xtype)
!
!== GT_HISTORY_AXIS 型変数コピー
!
! GT_HISTORY_AXIS 型の変数 *axis_src* を
! *axis_dest* にコピーします。
! *axis_src* は HistoryAxisCreate によって初期設定されている必要が
! あります。
! さらに属性を付加する場合には HistoryAxisAddAttr
! を用いてください。
!
! *err* を与えておくと、コピーの際何らかの不具合が生じても
! 終了せずに err が真になって返ります。
!
! *err* 以降の引数は、コピーの際に上書きする値です。
!
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_present,only: present_select
implicit none
type(GT_HISTORY_AXIS),intent(out) :: axis_dest ! コピー先 GT_HISTORY_AXIS
type(GT_HISTORY_AXIS),intent(in) :: axis_src ! コピー元 GT_HISTORY_AXIS
logical, intent(out), optional :: err
character(*) , intent(in), optional:: name ! 次元変数名
integer, intent(in), optional:: length ! 次元長 (配列サイズ)
character(*) , intent(in), optional:: longname ! 次元変数の記述的名称
character(*) , intent(in), optional:: units ! 次元変数の単位
character(*) , intent(in), optional:: xtype ! 次元変数の型
character(STRING), parameter:: subname = "HistoryAxisCopy1"
continue
call BeginSub(subname)
axis_dest % name = present_select('', axis_src % name, name)
axis_dest % length = present_select(.false., axis_src % length, length)
axis_dest % longname = present_select('', axis_src % longname, longname)
axis_dest % units = present_select('', axis_src % units, units)
axis_dest % xtype = present_select('', axis_src % xtype, xtype)
if (associated( axis_src % attrs ) ) then
allocate( axis_dest % attrs( size( axis_src % attrs) ) )
call HistoryAttrCopy( from = axis_src % attrs, &
& to = axis_dest % attrs, err = err)
end if
call EndSub(subname)
end subroutine HistoryAxisCopy1
subroutine HistoryVarinfoCopy1(varinfo_dest, varinfo_src, err, &
& name, dims, longname, units, xtype )
!
!== GT_HISTORY_VARINFO 型変数コピー
!
! GT_HISTORY_VARINFO 型の変数 *varinfo_src* を
! *varinfo_dest* にコピーします。
! *varinfo_src* は HistoryVarinfoCreate によって初期設定されている必要が
! あります。
! さらに属性を付加する場合には HistoryVarinfoAddAttr
! を用いてください。
!
! *err* を与えておくと、コピーの際何らかの不具合が生じても
! 終了せずに err が真になって返ります。
!
! *err* 以降の引数は、コピーの際に上書きする値です。
!
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_present,only: present_select
use dc_string, only: JoinChar
use dc_error, only: StoreError, DC_NOERR, DC_ENOTINIT, DC_EALREADYINIT
implicit none
type(GT_HISTORY_VARINFO),intent(out) :: varinfo_dest
type(GT_HISTORY_VARINFO),intent(in) :: varinfo_src
logical, intent(out), optional :: err
character(*) , intent(in), optional:: name ! 次元変数名
character(*) , intent(in), optional, target:: dims(:) ! 依存する次元
character(*) , intent(in), optional:: longname ! 次元変数の記述的名称
character(*) , intent(in), optional:: units ! 次元変数の単位
character(*) , intent(in), optional:: xtype ! 次元変数の型
integer:: i, stat
character(STRING):: cause_c
character(TOKEN), pointer :: srcdims(:) =>null() ! 依存する次元
character(*), parameter:: subname = "HistoryVarinfoCopy1"
continue
call BeginSub(subname)
stat = DC_NOERR
cause_c = ''
if ( .not. varinfo_src % initialized ) then
stat = DC_ENOTINIT
cause_c = 'GT_HISTORY_VARINFO'
goto 999
end if
if ( varinfo_dest % initialized ) then
stat = DC_EALREADYINIT
cause_c = 'GT_HISTORY_VARINFO'
goto 999
end if
varinfo_dest % name = present_select('', varinfo_src % name, name)
varinfo_dest % longname = present_select('', varinfo_src % longname, longname)
varinfo_dest % units = present_select('', varinfo_src % units, units)
varinfo_dest % xtype = present_select('', varinfo_src % xtype, xtype)
if (present(dims)) then
srcdims => dims
else
srcdims => varinfo_src % dims
endif
call DbgMessage('srcdims=<%c>', &
& c1=trim(JoinChar(srcdims)))
allocate( varinfo_dest % dims( size( srcdims ) ) )
do i = 1, size(srcdims)
varinfo_dest % dims(i) = srcdims(i)
end do
call DbgMessage('varinfo_dest %% dims=<%c>', &
& c1=trim(JoinChar(varinfo_dest % dims)))
if (associated( varinfo_src % attrs ) ) then
allocate( varinfo_dest % attrs( size( varinfo_src % attrs) ) )
call HistoryAttrCopy( from = varinfo_src % attrs, &
& to = varinfo_dest % attrs, err = err)
end if
varinfo_dest % initialized = .true.
999 continue
call StoreError( stat, subname, err, cause_c )
call EndSub(subname)
end subroutine HistoryVarinfoCopy1
subroutine HistoryAttrCopy(from, to, err)
!
! GT_HISTORY_ATTR 変数をコピーするためのサブルーチン
! このモジュール内部で利用されることを想定している.
! from と to の配列サイズは同じであることが想定されている.
! err を与えると, コピーの際何らかの不具合が生じると
! 終了せずに err が真になって返る.
!
use dc_string,only: LChar, StrHead
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_error, only: StoreError, &
& GT_EARGSIZEMISMATCH, GT_EBADATTRNAME, DC_NOERR
implicit none
type(GT_HISTORY_ATTR), intent(in) :: from(:)
type(GT_HISTORY_ATTR), intent(out) :: to(:)
logical, intent(out), optional :: err
integer :: i, stat
character(STRING) :: cause_c
character(STRING), parameter:: subname = "HistoryAttrCopy"
continue
call BeginSub(subname)
stat = DC_NOERR
cause_c = ''
call DbgMessage('size(from)=<%d>, size(to)=<%d>, So copy <%d> times.', &
& i=(/ size(from), size(to), min(size(from),size(to)) /) )
if ( size(to) < size(from) ) then
stat = GT_EARGSIZEMISMATCH
cause_c = 'from is larger than to'
goto 999
end if
! from と to の小さい方に合わせてループ
do i = 1, min( size(from), size(to) )
! attrname と attrtype と array はまずコピー
to(i)%attrname = from(i)%attrname
to(i)%attrtype = from(i)%attrtype
to(i)%array = from(i)%array
! from(i)%attrtype の種別でコピーする変数を変える.
if ( StrHead( 'char', trim(LChar(from(i)%attrtype))) ) then
to(i)%Charvalue = from(i)%Charvalue
#{foreach("\\$type\\$", "Int", "Real", "Double", %Q{
elseif ( StrHead( &
& LChar('$type$'), trim(LChar(from(i)%attrtype)))) then
if ( from(i)%array ) then
allocate( to(i)%$type$array( size(from(i)%$type$array) ) )
to(i)%$type$array = from(i)%$type$array
else
to(i)%$type$value = from(i)%$type$value
endif
})}
elseif ( StrHead( 'logical', trim(LChar(from(i)%attrtype))) ) then
to(i)%Logicalvalue = from(i)%Logicalvalue
else
stat = GT_EBADATTRNAME
cause_c = from(i)%attrtype
goto 999
endif
enddo
999 continue
call StoreError(stat, subname, err, cause_c=cause_c)
call EndSub(subname)
end subroutine HistoryAttrCopy
__EndOfFortran90Code__
types = ["Char", "Logical", "Int", "Real", "Double"]
def toChar(type, value)
return "trim(#{value})" if type == "Char"
return "trim(toChar(#{value}))"
end
def Num2Array(type, value)
return value if type == "Char"
return value if type == "Logical"
return "(/#{value}/)"
end
types.each{ |type|
for num in 0..1
next if num == 1 && type == "Char"
next if num == 1 && type == "Logical"
print <<"__EndOfFortran90Code__"
subroutine HistoryAddAttr#{type}#{num}( &
& varname, attrname, value, history)
!
#{ifelse(type, "Char", %Q{
!
!== gtool4 データ内の変数への属性付加
!
! gtool4 データおよびそのデータ内の変数に属性を付加します。
! このサブルーチンを用いる前に、 HistoryCreate による初期設定が
! 必要です。
!
! 属性名 *attrname* の先頭にプラス "+" を付加する
! 場合は、gtool4 データ自体の属性 (大域属性) として属性が付加されます
! この場合、*varname* は無視されますが、その場合でも *varname* へは
! 引数の解説にもある通り有効な値を与えてください。
!
! *HistoryAddAttr* は複数のサブルーチンの総称名です。*value* には
! いくつかの型を与えることが可能です。
! 下記のサブルーチンを参照ください。
!
})}
!
use gtdata_generic, only: Put_Attr
use dc_string, only: toChar, JoinChar
use dc_url, only: GT_PLUS
use dc_error, only: DC_NOERR
implicit none
character(*), intent(in):: varname
#{ifelse(type, "Char", %Q{
! 変数の名前。
!
! ここで指定するものは、
! HistoryCreateの *dims* 、
! または HistoryAddVariable の
! *varname* で既に指定されてい
! なければなりません。
!
})}
character(*), intent(in):: attrname
#{ifelse(type, "Char", %Q{
! 変数またはファイル全体に付
! 加する属性の名前
!
! "+" (プラ
! ス) を属性名の先頭につける
! 場合には、ファイル全体に属
! 性を付加します。
! ファイル全体へ属性を付加
! する場合でも、 HistoryCreate
! の *dims* 、または
! HistoryAddVariable の
! *varname* で既に指定されてい
! る変数を *varname* に指定する
! 必要があります。
!
})}
#{$type_intent_in[type]}, intent(in):: value#{array_colon("#{num}")}
#{ifelse(type, "Char", %Q{
! 属性の値
!
})}
type(GT_HISTORY), intent(inout), target, optional:: history
#{ifelse(type, "Char", %Q{
! 出力ファイルの設定に関する情報を
! 格納した構造体
!
! ここに指定するものは、
! HistoryCreate によって初期設定
! されていなければなりません。
!
})}
type(GT_HISTORY), pointer:: hst =>null()
type(GT_VARIABLE):: var
integer:: v_ord
logical:: err
character(len = *), parameter:: subname = "HistoryAddAttr#{type}#{num}"
continue
call BeginSub(subname, &
& 'varname=<%c> attrname=<%c>, value=<%c>', &
& c1=trim(varname), c2=trim(attrname), c3=#{toChar(type, "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), GT_PLUS // attrname, #{Num2Array(type, "value")})
enddo
else
call lookup_var_or_dim(hst, varname, var, err)
if (.not. err) then
call Put_Attr(var, attrname, #{Num2Array(type, "value")})
endif
endif
call EndSub(subname)
end subroutine
__EndOfFortran90Code__
end
}
types.each{ |type|
for num in 0..1
next if num == 1 && type == "Char"
next if num == 1 && type == "Logical"
print <<"__EndOfFortran90Code__"
subroutine HistoryAxisAddAttr#{type}#{num}( &
& axis, attrname, value)
!
#{ifelse(type, "Char", %Q{
!
!== GT_HISTORY_AXIS 型変数への属性付加
!
! GT_HISTORY_AXIS 型の変数 *axis* へ属性を付加します。
!
! *HistoryAxisAddAttr* は複数のサブルーチンの総称名です。
! value には様々な型の引数を与えることが可能です。
! 下記のサブルーチンを参照ください。
!
})}
!
use gtdata_generic, only: Put_Attr
use dc_string , only: toChar, JoinChar
use dc_url , only: GT_PLUS
implicit none
type(GT_HISTORY_AXIS),intent(inout) :: axis
character(*), intent(in):: attrname ! 属性の名前
#{$type_intent_in[type]}, intent(in):: value#{array_colon("#{num}")}
#{ifelse(type, "Char", %Q{
! 属性に与えられる値
!
! 配列の場合でも、数値型以外
! では配列の 1 つ目の要素のみ
! 値として付加されます。
!
})}
type(GT_HISTORY_ATTR), pointer:: attrs_tmp(:)
integer:: attrs_num
character(STRING) :: name
character(*), parameter:: subname = "HistoryAxisAddAttr#{type}#{num}"
continue
call BeginSub(subname, &
& 'attrname=<%c>, value=<%c>', &
& c1=trim(attrname), c2=#{toChar(type, "value")})
call HistoryAxisInquire1( axis, name )
call DbgMessage('axis name=<%c>', c1=trim(name))
! これまでの属性を保持しつつ配列を1つ増やす
if ( .not. associated(axis % attrs) ) then
allocate( axis % attrs(1) )
attrs_num = 1
else
attrs_num = size( axis % attrs ) + 1
! 配列データの領域確保
allocate( attrs_tmp(attrs_num - 1) )
call HistoryAttrCopy( from = axis % attrs(1:attrs_num - 1), &
& to = attrs_tmp(1:attrs_num - 1))
deallocate( axis % attrs )
allocate( axis % attrs(attrs_num) )
call HistoryAttrCopy( from = attrs_tmp(1:attrs_num - 1), &
& to = axis % attrs(1:attrs_num - 1))
deallocate( attrs_tmp )
endif
axis % attrs(attrs_num) % attrname = attrname
axis % attrs(attrs_num) % attrtype = '#{type}'
#{ifelse(num, 0, %Q{
axis % attrs(attrs_num) % array = .false.
axis % attrs(attrs_num) % #{type}value = value
}, num, 1, %Q{
axis % attrs(attrs_num) % array = .true.
allocate( axis % attrs(attrs_num) % #{type}array( size(value) ) )
axis % attrs(attrs_num) % #{type}array = value
})}
call EndSub(subname)
end subroutine HistoryAxisAddAttr#{type}#{num}
__EndOfFortran90Code__
end
}
types.each{ |type|
for num in 0..1
next if num == 1 && type == "Char"
next if num == 1 && type == "Logical"
print <<"__EndOfFortran90Code__"
subroutine HistoryVarinfoAddAttr#{type}#{num}( &
& varinfo, attrname, value, err )
!
#{ifelse(type, "Char", %Q{
!
!== GT_HISTORY_VARINFO 型変数への属性付加
!
! GT_HISTORY_VARINFO 型の変数 *varinfo* へ属性を付加します。
!
! *HistoryVarinfoAddAttr* は複数のサブルーチンの総称名です。
! value には様々な型の引数を与えることが可能です。
! 下記のサブルーチンを参照ください。
!
})}
!
use gtdata_generic, only: Put_Attr
use dc_string , only: toChar, JoinChar
use dc_url , only: GT_PLUS
use dc_error, only: StoreError, DC_NOERR, DC_ENOTINIT
implicit none
type(GT_HISTORY_VARINFO),intent(inout) :: varinfo
character(*), intent(in):: attrname ! 属性の名前
#{$type_intent_in[type]}, intent(in):: value#{array_colon("#{num}")}
#{ifelse(type, "Char", %Q{
! 属性に与えられる値
!
! 配列の場合でも、数値型以外
! では配列の 1 つ目の要素のみ
! 値として付加されます。
!
})}
logical, intent(out), optional:: err
! 例外処理用フラグ.
! デフォルトでは, この手続き内でエラーが
! 生じた場合, プログラムは強制終了します.
! 引数 *err* が与えられる場合,
! プログラムは強制終了せず, 代わりに
! *err* に .true. が代入されます.
!
! Exception handling flag.
! By default, when error occur in
! this procedure, the program aborts.
! If this *err* argument is given,
! .true. is substituted to *err* and
! the program does not abort.
type(GT_HISTORY_ATTR), pointer:: attrs_tmp(:)
integer:: attrs_num, stat
character(STRING) :: name, cause_c
character(*), parameter:: subname = "HistoryVarinfoAddAttr#{type}#{num}"
continue
call BeginSub(subname, &
& 'attrname=<%c>, value=<%c>', &
& c1=trim(attrname), c2=#{toChar(type, "value")})
stat = DC_NOERR
cause_c = ''
if ( .not. varinfo % initialized ) then
stat = DC_ENOTINIT
cause_c = 'GT_HISTORY_VARINFO'
goto 999
end if
call HistoryVarinfoInquire1( varinfo, name )
call DbgMessage('varinfo name=<%c>', c1=trim(name))
! これまでの属性を保持しつつ配列を1つ増やす
if ( .not. associated(varinfo % attrs) ) then
allocate( varinfo % attrs(1) )
attrs_num = 1
else
attrs_num = size( varinfo % attrs ) + 1
! 配列データの領域確保
allocate( attrs_tmp(attrs_num - 1) )
call HistoryAttrCopy( from = varinfo % attrs(1:attrs_num - 1), &
& to = attrs_tmp(1:attrs_num - 1))
deallocate( varinfo % attrs )
allocate( varinfo % attrs(attrs_num) )
call HistoryAttrCopy( from = attrs_tmp(1:attrs_num - 1), &
& to = varinfo % attrs(1:attrs_num - 1))
deallocate( attrs_tmp )
endif
varinfo % attrs(attrs_num) % attrname = attrname
varinfo % attrs(attrs_num) % attrtype = '#{type}'
#{ifelse(num, 0, %Q{
varinfo % attrs(attrs_num) % array = .false.
varinfo % attrs(attrs_num) % #{type}value = value
}, num, 1, %Q{
varinfo % attrs(attrs_num) % array = .true.
allocate( varinfo % attrs(attrs_num) % #{type}array( size(value) ) )
varinfo % attrs(attrs_num) % #{type}array = value
})}
999 continue
call StoreError( stat, subname, err, cause_c )
call EndSub(subname)
end subroutine HistoryVarinfoAddAttr#{type}#{num}
__EndOfFortran90Code__
end
}
undef toChar
undef Num2Array
print <<"__EndOfFortran90Code__"
subroutine HistoryAttrAdd(varname, attrs, history)
!
! GT_HISTORY_ATTR 変数を history の varname 変数に
! 付加するためのサブルーチン. 公開用ではなく,
! HistoryCreate や HistoryAddVariable に GT_HISTORY_AXIS
! や GT_HISTORY_VARINFO が与えられた時に内部的に利用される.
!
use gtdata_generic, only: Put_Attr
use dc_string , only: StrHead, LChar, toChar
implicit none
character(*), intent(in):: varname
type(GT_HISTORY_ATTR), intent(in):: attrs(:)
type(GT_HISTORY), intent(inout), target, optional:: history
type(GT_HISTORY), pointer:: hst =>null()
integer :: i
character(*), parameter:: subname = "HistoryAttrAdd"
continue
call BeginSub(subname, 'varname=<%c>, size(attrs(:))=<%d>', &
& c1=trim(varname), i=(/size(attrs(:))/))
if (present(history)) then
hst => history
else
hst => default
endif
! attrs(:) のサイズ分だけループ
do i = 1, size( attrs(:) )
! attrs(i)%attrtype の種別で与える変数を変える
if ( StrHead( 'char', trim(LChar(attrs(i)%attrtype))) ) then
call HistoryAddAttr( &
& varname, attrs(i)%attrname, &
& trim(attrs(i)%Charvalue), hst )
elseif ( StrHead( 'int', trim(LChar(attrs(i)%attrtype))) ) then
if ( attrs(i)%array ) then
call DbgMessage('Intarray(:) is selected.')
call HistoryAddAttr( &
& varname, attrs(i)%attrname , &
& attrs(i)%Intarray, hst )
else
call DbgMessage('Intvalue is selected')
call HistoryAddAttr( &
& varname, attrs(i)%attrname , &
& attrs(i)%Intvalue, hst )
endif
elseif ( StrHead( 'real', trim(LChar(attrs(i)%attrtype))) ) then
if ( attrs(i)%array ) then
call DbgMessage('Realarray(:) is selected.')
call HistoryAddAttr( &
& varname, attrs(i)%attrname, attrs(i)%Realarray, hst)
else
call DbgMessage('Realvalue is selected')
call HistoryAddAttr( &
& varname, attrs(i)%attrname, attrs(i)%Realvalue, hst)
endif
elseif ( StrHead( 'double', trim(LChar(attrs(i)%attrtype))) ) then
if ( attrs(i)%array ) then
call DbgMessage('Doublearray(:) is selected.')
call HistoryAddAttr( &
& varname, attrs(i)%attrname, attrs(i)%Doublearray, hst)
else
call DbgMessage('Doublevalue is selected')
call HistoryAddAttr( &
& varname, attrs(i)%attrname, attrs(i)%Doublevalue, hst)
endif
elseif ( StrHead( 'logical', trim(LChar(attrs(i)%attrtype))) ) then
call HistoryAddAttr( &
& varname, attrs(i)%attrname, attrs(i)%Logicalvalue, hst)
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 HistoryAttrAdd
!-----------------------------------------------------------------
! 変数の追加
!-----------------------------------------------------------------
subroutine HistoryAddVariable2( &
& varinfo, history, err )
!
!== 変数定義
!
! gtool4 データ内の変数の定義を行います。このサブルーチンを
! 用いる前に、 HistoryCreate による初期設定が必要です。
!
! 既に gtool4 データが存在し、そのデータ内の変数と全く同じ
! 構造の変数を定義したい場合は HistoryCopyVariable を利用すると
! 便利です。
!
! *HistoryAddVariable* というサブルーチン名は 2 つの別々の
! サブルーチンの総称名です。下記のサブルーチンも参照ください。
!
use dc_string, only: JoinChar
implicit none
type(GT_HISTORY_VARINFO), intent(in) :: varinfo
! 変数情報を格納した構造体
!
! ここに指定するものは、
! HistoryVarinfoCreate によって
! 初期設定されていなければなりません。
!
type(GT_HISTORY), intent(inout), optional:: history
! 出力ファイルの設定に関する情報を
! 格納した構造体
!
! ここに指定するものは、
! HistoryCreate によって初期設定
! されていなければなりません。
!
logical, intent(out), optional:: err
! 例外処理用フラグ.
! デフォルトでは, この手続き内でエラーが
! 生じた場合, プログラムは強制終了します.
! 引数 *err* が与えられる場合,
! プログラムは強制終了せず, 代わりに
! *err* に .true. が代入されます.
!
! Exception handling flag.
! By default, when error occur in
! this procedure, the program aborts.
! If this *err* argument is given,
! .true. is substituted to *err* and
! the program does not abort.
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( &
& history = history, & ! (inout)
& varname = varinfo % name, & ! (in)
& dims = varinfo % dims, & ! (in)
& longname = varinfo % longname, & ! (in)
& units = varinfo % units, & ! (in)
& xtype = varinfo % xtype, & ! (in)
& time_average = varinfo % time_average, & ! (in) optional
& err = err ) ! (out) optional
if (associated( varinfo % attrs )) then
call HistoryAttrAdd( varinfo % name, varinfo % attrs, history )
end if
call EndSub(subname)
end subroutine HistoryAddVariable2
recursive subroutine HistoryAddVariable1( &
& varname, dims, longname, units, &
& xtype, time_average, average, history, err )
!
!== 変数定義
!
! gtool4 データ内の変数の定義を行います。このサブルーチンを
! 用いる前に、 HistoryCreate による初期設定が必要です。
!
! 既に gtool4 データが存在し、そのデータ内の変数と全く同じ
! 構造の変数を定義したい場合は HistoryCopyVariable を利用すると便利です。
!
! *HistoryAddVariable* というサブルーチン名は 2 つの別々の
! サブルーチンの総称名です。上記のサブルーチンも参照ください。
!
use netcdf_f77, only: NF_EBADDIM
use dc_error, only: StoreError, DC_NOERR, DC_ENOTINIT, HST_ENODEPENDTIME
use dc_string, only: CPrintf, JoinChar, StoA
use gtdata_generic, only: Inquire, Create, Slice, Put_Attr, Get_Attr, &
& Put, PutLine
use dc_url, only: GT_ATMARK, UrlResolve
use dc_present, only: present_and_true
use dc_types, only: STRING
implicit none
character(len = *), intent(in):: varname
! 定義する変数の名前
!
! 最大文字数は dc_type#TOKEN
!
character(len = *), intent(in):: dims(:)
! 変数が依存する次元の名前
!
! 時間の次元は配列の最後に指定
! しなければならない。
! ここで指定するものは、
! HistoryCreate にて dims で指定
! されていなければならない。
!
! もしもスカラー変数を作成
! する場合には, サイズが 1 で
! 中身が空の文字型配列,
! すなわち (/''/)
! を与えること.
!
character(len = *), intent(in):: longname
! 変数の記述的名称
!
! 最大文字数は dc_types#STRING
!
character(len = *), intent(in):: units
! 変数の単位
!
! 最大文字数は dc_types#STRING
!
character(len = *), intent(in), optional:: xtype
! 変数のデータ型
!
! デフォルトはfloat (単精度実数型)
! である。 有効なのは、
! double (倍精度実数型)、 int
! (整数型)である。 指定しない
! 場合や、無効な型を指定した
! 場合には、 float (単精度実数型)
! となる。
!
logical, intent(in), optional:: time_average
! 出力データを時間平均する場合には
! .true. を与えます。
! デフォルトは .false. です。
!
! If output data is averaged in time direction,
! specify ".true.".
! Default is ".false.".
!
logical, intent(in), optional:: average
! time_average の旧版.
! Old version of "time_average"
type(GT_HISTORY), intent(inout), optional, target:: history
! 出力ファイルの設定に関する情報を
! 格納した構造体
!
! ここに指定するものは、
! HistoryCreate によって初期設定
! されていなければなりません。
!
logical, intent(out), optional:: err
! 例外処理用フラグ.
! デフォルトでは, この手続き内でエラーが
! 生じた場合, プログラムは強制終了します.
! 引数 *err* が与えられる場合,
! プログラムは強制終了せず, 代わりに
! *err* に .true. が代入されます.
!
! Exception handling flag.
! By default, when error occur in
! this procedure, the program aborts.
! If this *err* argument is given,
! .true. is substituted to *err* and
! the program does not abort.
type(GT_HISTORY), pointer:: hst =>null()
type(GT_VARIABLE), pointer:: vwork(:) =>null(), dimvars(:) =>null()
character(STRING):: fullname, url, cause_c
integer, pointer:: count_work(:) =>null()
integer, pointer:: var_avr_count_work(:) =>null()
integer:: var_avr_length
type(GT_HISTORY_AVRDATA), pointer:: var_avr_data_work(:) =>null()
character(STRING):: time_name, time_xtype, time_url, time_units
type(GT_VARIABLE), pointer:: dimvars_work(:)
logical, pointer:: dim_value_written_work(:)
integer:: dimvars_size
logical:: nv_exist, bnds_exist
character(STRING):: nv_name_check, bnds_name_check
character(*), parameter:: nv_suffix = '_nv'
character(*), parameter:: bnds_suffix = '_bnds'
type(GT_VARIABLE), pointer:: timevar
integer:: nvars, numdims, i, dimord, stat
character(*), parameter:: subname = "HistoryAddVariable1"
continue
call BeginSub(subname, 'name=<%a>, dims=<%a>, longname=<%a>, units=<%a>', &
& ca=StoA(varname, JoinChar(dims), longname, units))
stat = DC_NOERR
cause_c = ''
!----- 操作対象決定 -----
if (present(history)) then
hst => history
else
hst => default
endif
!-----------------------------------------------------------------
! 初期設定のチェック
! Check initialization
!-----------------------------------------------------------------
if ( .not. hst % initialized ) then
stat = DC_ENOTINIT
cause_c = 'GT_HISTORY'
goto 999
end if
!----- 変数表拡張 -----
if (associated(hst % vars)) then
nvars = size(hst % vars(:))
vwork => hst % vars
count_work => hst % count
var_avr_count_work => hst % var_avr_count
nullify(hst % vars, hst % count, hst % var_avr_count)
allocate(hst % vars(nvars + 1), hst % count(nvars + 1), hst % var_avr_count(nvars + 1))
hst % vars(1:nvars) = vwork(1:nvars)
hst % count(1:nvars) = count_work(1:nvars)
hst % var_avr_count(1:nvars) = var_avr_count_work(1:nvars)
deallocate(vwork, count_work, var_avr_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)
!
! 平均値出力のための変数表コピー
! Copy table of variables for average value output
!
var_avr_data_work => hst % var_avr_data
nullify(hst % var_avr_data)
allocate(hst % var_avr_data(nvars + 1))
do i = 1, nvars
hst % var_avr_data(i) % length = var_avr_data_work(i) % length
allocate(hst % var_avr_data(i) % &
& a_DataAvr(var_avr_data_work(i) % length))
hst % var_avr_data(i) % a_DataAvr = var_avr_data_work(i) % a_DataAvr
end do
else
! トリッキーだが、ここで count だけ 2 要素確保するのは、
! HistorySetTime による巻き戻しに備えるため。
allocate(hst % vars(1), hst % count(2), hst % growable_indices(1))
allocate(hst % var_avr_count(1), hst % var_avr_data(1))
hst % count(2) = 0
endif
nvars = size(hst % vars(:))
hst % growable_indices(nvars) = 0
hst % count(nvars) = 0
! スカラー変数作成への対応
if (size(dims) == 1 .and. trim(dims(1)) == '') then
numdims = 0
allocate(dimvars(numdims))
else
numdims = size(dims)
allocate(dimvars(numdims))
end if
!----- 変数添字次元を決定 -----
do, i = 1, numdims
! hst 内で, 次元変数名 dim(i) に当たる次元変数の ID である
! hst % dimvar(i) を dimvars(i) に, 添字を dimord に
dimvars(i) = lookup_dimension( hst, dims(i), & ! (in)
& ord = dimord ) ! (out)
if (dimord == 0) then
stat = NF_EBADDIM
cause_c = CPrintf('"%c" dimension is not found.', c1=trim(dims(i)))
goto 999
end if
! 無制限次元の添字と一致する場合に,
! その添字を hst % growable_indices(nvars) に
if (dimord == hst % unlimited_index) then
hst % growable_indices(nvars) = i
endif
call Inquire(hst % dimvars(1), url=url)
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)
!-----------------------------------------------------------------
! 平均処理に関する情報管理
!-----------------------------------------------------------------
if ( present_and_true( time_average ) &
& .or. present_and_true( average ) ) then
hst % var_avr_count(nvars) = 0
!-------------------------
! 割り付け
call Inquire(hst % vars(nvars), size = var_avr_length )
hst % var_avr_data(nvars) % length = var_avr_length
allocate(hst % var_avr_data(nvars) % a_DataAvr(var_avr_length))
hst % var_avr_data(nvars) % a_DataAvr = 0.0_DP
!-----------------------
! 時間次元情報の取得
if ( hst % growable_indices(nvars) < 1 ) then
stat = HST_ENODEPENDTIME
cause_c = trim(varname)
goto 999
end if
timevar => hst % dimvars( hst % unlimited_index )
call Inquire( &
& var = timevar, & ! (in)
& name = time_name, url = time_url, & ! (out)
& xtype = time_xtype ) ! (out)
call Get_Attr( &
& var = timevar, & ! (in)
& name = 'units', default = '', & ! (in)
& value = time_units ) ! (out)
!-----------------------
! 時間次元への属性 "bounds" の追加
call Put_Attr( var = timevar, & ! (inout)
& name = 'bounds', & ! (in)
& value = trim(time_name) // bnds_suffix ) ! (in)
!-----------------------
! 変数 "varname" への属性 "cell_methods" の追加
call Put_Attr( var = hst % vars(nvars), & ! (inout)
& name = 'cell_methods', & ! (in)
& value = trim(time_name) // ': mean' ) ! (in)
!-----------------------
! "time_nv" 次元の作成 (既に作成されていたら何もしない)
dimvars_size = size( hst % dimvars )
nv_exist = .false.
do i = 1, dimvars_size
call Inquire( &
& var = hst % dimvars(i), & ! (in)
& name = nv_name_check ) ! (out)
if ( trim(time_name) // trim(nv_suffix) == trim(nv_name_check) ) then
nv_exist = .true.
exit
end if
end do
if ( .not. nv_exist ) then
dimvars_work => hst % dimvars
dim_value_written_work => hst % dim_value_written
nullify(hst % dimvars, hst % dim_value_written)
allocate(hst % dimvars(dimvars_size + 1))
allocate(hst % dim_value_written(dimvars_size + 1))
hst % dimvars(1:dimvars_size) = dimvars_work(1:dimvars_size)
hst % dim_value_written(1:dimvars_size) = dim_value_written_work(1:dimvars_size)
deallocate(dimvars_work)
deallocate(dim_value_written_work)
call Create( &
& var = hst % dimvars(dimvars_size + 1), & ! (out)
& url = trim(time_url) // trim(nv_suffix), & ! (in)
& length = 2, xtype = 'integer' ) ! (in)
call Put_Attr( var = hst % dimvars(dimvars_size + 1), & ! (inout)
& name = 'long_name', & ! (in)
& value = 'number of vertices of time') ! (in)
call Put_Attr( var = hst % dimvars(dimvars_size + 1), & ! (inout)
& name = 'units', value = '1' ) ! (in)
call Put( var = hst % dimvars(dimvars_size + 1), & ! (inout)
& value = (/1, 2/) ) ! (in)
hst % dim_value_written(dimvars_size + 1) = .true.
end if
!-----------------------
! "time_bnds" 変数の作成 (既に作成されていたら何もしない)
bnds_exist = .false.
do i = 1, nvars
call Inquire( &
& var = hst % vars(i), & ! (in)
& name = bnds_name_check ) ! (out)
if ( trim(time_name) // trim(bnds_suffix) == trim(bnds_name_check) ) then
bnds_exist = .true.
exit
end if
end do
if ( .not. bnds_exist ) then
call HistoryAddVariable( &
& history = hst, & ! (inout)
& varname = trim(time_name) // trim(bnds_suffix), &
& dims = StoA( trim(time_name) // trim(nv_suffix), &
& trim(time_name) ), & ! (in)
& longname = 'bounds of time', & ! (in)
& units = time_units, xtype = time_xtype ) ! (in)
end if
else
hst % var_avr_count(nvars) = -1
!-------------------------
! 割り付け
var_avr_length = 1
hst % var_avr_data(nvars) % length = var_avr_length
allocate(hst % var_avr_data(nvars) % a_DataAvr(var_avr_length))
hst % var_avr_data(nvars) % a_DataAvr = 0.0_DP
end if
!-----------------------------------------------------------------
! 終了処理, 例外処理
! Termination and Exception handling
!-----------------------------------------------------------------
999 continue
call StoreError(stat, subname, err, cause_c)
call EndSub(subname)
end subroutine HistoryAddVariable1
subroutine HistoryInquire1(history, err, file, title, source, &
& dims, dimsizes, longnames, units, xtypes, &
& institution, origin, interval, newest, oldest, &
& conventions, gt_version, &
& axes, varinfo )
!
!== GT_HISTORY 型変数への問い合わせ
!
! HistoryCreate や HistoryAddVariable などで設定した値の
! 参照を行います。
!
! file, title, source, institution, origin, interval,
! conventions, gt_version, dims, dimsizes, longnames, units,
! xtypes に関しては HistoryCreate を参照してください。
!
! title, source, institution, origin, interval, conventions, gt_version
! に関しては、値が得られなかった場合は "unknown" が返ります。
!
! dims, dimsizes, longnames, units, xtypes に関してはポインタに
! 値を返すため、必ずポインタを空状態にしてから与えてください。
!
! axes と varinfo にはそれぞれ座標軸情報と変数情報を返します。
! 将来的には全ての属性の値も一緒に返す予定ですが、現在は
! long_name, units, xtype のみが属性の値として返ります。
!
! *HistoryInquire* は 2 つのサブルーチンの総称名です。
! HistoryCreate で *history* を与えなかった場合の問い合わせに関しては
! 上記のサブルーチンを参照してください。
!
!=== エラー
!
! 以下の場合に、このサブルーチンはエラーを生じプログラムを終了させます。
! ただし、*err* 引数を与える場合、この引数に .true. を
! 返し、プログラムは続行します。
!
! - *history* が HistoryCreate によって初期設定されていない場合
! - HistoryAddVariable や HistoryCopyVariable 等による変数定義が
! 一度も行われていない GT_HISTORY 変数に対して引数 varinfo
! を渡した場合
!
use dc_error, only: StoreError, DC_NOERR, GT_EBADHISTORY, NF_ENOTVAR
use gtdata_generic, only: Inquire, Get_Attr, Open, Close
use dc_url, only: UrlSplit
implicit none
type(GT_HISTORY), intent(in):: history
logical, intent(out), optional :: err
character(*), intent(out), optional:: file, title, source, institution
real,intent(out), optional:: origin, interval
real,intent(out), optional:: newest ! 最新の時刻
real,intent(out), optional:: oldest ! 最初の時刻
character(*), intent(out), optional:: conventions, gt_version
character(*), pointer, optional:: dims(:) ! (out)
integer,pointer, optional:: dimsizes(:) ! (out)
character(*), pointer, optional:: longnames(:) ! (out)
character(*), pointer, optional:: units(:) ! (out)
character(*), pointer, optional:: xtypes(:) ! (out)
type(GT_HISTORY_AXIS), pointer, optional :: axes(:) ! (out)
type(GT_HISTORY_VARINFO), pointer, optional :: varinfo(:) ! (out)
! Internal Work
character(STRING) :: url, cause_c
character(TOKEN) :: unknown_mes = 'unknown'
integer :: i, j, numdims, numvars, alldims, stat
logical :: growable
type(GT_VARIABLE) :: dimvar
character(*), parameter:: subname = "HistoryInquire1"
continue
call BeginSub(subname)
stat = DC_NOERR
cause_c = ''
if (.not. associated(history % dimvars) .or. &
& size(history % dimvars) < 1) then
stat = GT_EBADHISTORY
goto 999
end if
if (present(file)) then
call Inquire(history % dimvars(1), url=url)
call UrlSplit(fullname=url, file=file)
end if
if (present(title)) then
call Get_Attr(history % dimvars(1), '+title', title, trim(unknown_mes))
end if
if (present(source)) then
call Get_Attr(history % dimvars(1), '+source', source, trim(unknown_mes))
end if
if (present(institution)) then
call Get_Attr(history % dimvars(1), '+institution', institution, trim(unknown_mes))
end if
if (present(origin)) then
origin = history % origin
end if
if (present(interval)) then
interval = history % interval
end if
if (present(newest)) then
newest = history % newest
end if
if (present(oldest)) then
oldest = history % oldest
end if
if (present(conventions)) then
call Get_Attr(history % dimvars(1), '+Conventions', conventions, trim(unknown_mes))
end if
if (present(gt_version)) then
call Get_Attr(history % dimvars(1), '+gt_version', gt_version, trim(unknown_mes))
end if
if (present(dims)) then
numdims = size(history % dimvars)
allocate(dims(numdims))
do i = 1, numdims
call Inquire(history % dimvars(i), name=dims(i))
end do
end if
if (present(dimsizes)) then
numdims = size(history % dimvars)
allocate(dimsizes(numdims))
do i = 1, numdims
call Inquire(history % dimvars(i), size=dimsizes(i), growable=growable)
if (growable) dimsizes(i) = 0
end do
end if
if (present(longnames)) then
numdims = size(history % dimvars)
allocate(longnames(numdims))
do i = 1, numdims
call Get_attr(history % dimvars(i), 'long_name', &
& longnames(i), 'unknown')
end do
end if
if (present(units)) then
numdims = size(history % dimvars)
allocate(units(numdims))
do i = 1, numdims
call Get_attr(history % dimvars(i), 'units', &
& units(i), 'unknown')
end do
end if
if (present(xtypes)) then
numdims = size(history % dimvars)
allocate(xtypes(numdims))
do i = 1, numdims
call Inquire(history % dimvars(i), xtype=xtypes(i))
end do
end if
if (present(axes)) then
numvars = size(history % dimvars)
allocate(axes(numvars))
do i = 1, numvars
call Inquire(history % dimvars(i), &
& allcount=axes(i) % length, &
& xtype=axes(i) % xtype, name=axes(i) % name)
call Get_Attr(history % dimvars(i), 'long_name', &
& axes(i) % longname, 'unknown')
call Get_Attr(history % dimvars(i), 'units', &
& axes(i) % units, 'unknown')
! 属性 GT_HISTORY_ATTR はまだ取得できない
!
! するためには, 属性名に対して様々な型が存在しうると
! 考えられるため, get_attr (gtdata_generic および an_generic)
! に err 属性を装備させ, 取得できない際にエラーを
! 返してもらわなければならないだろう.
end do
end if
if (present(varinfo)) then
if (.not. associated(history % vars) .or. &
& size(history % vars) < 1) then
stat = NF_ENOTVAR
goto 999
end if
numvars = size(history % vars)
allocate(varinfo(numvars))
do i = 1, numvars
call Inquire(history % vars(i), alldims=alldims, &
& xtype=varinfo(i) % xtype, name=varinfo(i) % name)
call Get_Attr(history % vars(i), 'long_name', &
& varinfo(i) % longname, 'unknown')
call Get_Attr(history % vars(i), 'units', &
& varinfo(i) % units, 'unknown')
! 属性 GT_HISTORY_ATTR はまだ取得できない
!
! するためには, 属性名に対して様々な型が存在しうると
! 考えられるため, get_attr (gtdata_generic および an_generic)
! に err 属性を装備させ, 取得できない際にエラーを
! 返してもらわなければならないだろう.
allocate(varinfo(i) % dims(alldims))
do j = 1, alldims
call Open(var=dimvar, source_var=history % vars(i), &
& dimord=j, count_compact=.true.)
call Inquire(dimvar, name=varinfo(i) % dims(j))
call Close(dimvar)
end do
varinfo(i) % initialized = .true.
end do
end if
999 continue
call StoreError(stat, subname, err, cause_c=cause_c)
call EndSub(subname)
end subroutine HistoryInquire1
subroutine HistoryInquire2(history, err, file, title, source, &
& dims, dimsizes, longnames, units, xtypes, &
& institution, origin, interval, newest, oldest, &
& conventions, gt_version, &
& axes, varinfo )
!
!== GT_HISTORY 型変数への問い合わせ
!
! HistoryCreate で *history* を指定しなかった場合はこちらの
! サブルーチンで問い合わせを行います。
! *history* には必ず "default" という文字列を与えてください。
!
! *HistoryInquire* は 2 つのサブルーチンの総称名です。
! 各引数の情報に関しては下記のサブルーチンを参照してください。
!
!--
! HistoryInquire1 と同機能だが, こちらは
! history に "default" という文字列を代入することで,
! デフォルトで出力されるファイル名 (HistoryCreate で
! history 引数を与えない場合のファイル名) が返る.
!++
!
use dc_error, only: StoreError, DC_NOERR, NF_EINVAL
implicit none
character(*), intent(in):: history
logical, intent(out), optional :: err
character(*), intent(out), optional:: file, title, source, institution
real,intent(out), optional:: origin, interval, newest, oldest
character(*), intent(out), optional:: conventions, gt_version
character(*), pointer, optional:: dims(:) ! (out)
integer,pointer, optional:: dimsizes(:) ! (out)
character(*), pointer, optional:: longnames(:) ! (out)
character(*), pointer, optional:: units(:) ! (out)
character(*), pointer, optional:: xtypes(:) ! (out)
type(GT_HISTORY_AXIS), pointer, optional :: axes(:) ! (out)
type(GT_HISTORY_VARINFO), pointer, optional :: varinfo(:) ! (out)
integer:: stat
character(STRING):: cause_c
character(*), parameter:: subname = "HistoryInquire2"
continue
call BeginSub(subname, "history=%c", c1=trim(history))
stat = DC_NOERR
cause_c = ''
if (trim(history) /= 'default') then
stat = NF_EINVAL
cause_c = 'history="' // trim(history) // '"'
goto 999
end if
call HistoryInquire1(default, err, file, title, source, &
& dims, dimsizes, longnames, units, xtypes, &
& institution, origin, interval, newest, oldest, &
& conventions, gt_version, &
& axes, varinfo )
999 continue
call StoreError(stat, subname, cause_c=cause_c)
call EndSub(subname)
end subroutine HistoryInquire2
!!$ !-----------------------------------------------------------------
!!$ ! 変数情報 GT_HISTORY_VARINFO の取得
!!$ !-----------------------------------------------------------------
!!$ subroutine HistoryInquireVariable1(file, variable, varinfo)
!!$ implicit none
!!$ character(len = *), intent(in) :: file ! ファイル名
!!$ character(len = *), intent(in) :: varname ! 変数名
!!$ type(GT_HISTORY_VARINFO), intent(out) :: varinfo
!!$
!!$ type(GT_VARIABLE) :: var
!!$ character(len = string) :: xtype
!!$ integer :: alldims
!!$ character(len = *), parameter:: subname = "HistoryInquireVariable1"
!!$ continue
!!$ call BeginSub(subname, 'file=<%c>, dims=<%c>', &
!!$ & c1=trim(file), c2=trim(variname) )
!!$ call Open(var, UrlMerge(file, varname), .false.)
!!$ call Inquire(var, xtype=xtype, alldims=alldims)
!!$
!!$ call Inquire(var, 'longname', )
!!$
!!$ call HistoryAddVariable1(trim(varinfo % name), &
!!$ & varinfo % dims, trim(varinfo % longname), &
!!$ & trim(varinfo % units), trim(varinfo % xtype), history)
!!$ call EndSub(subname)
!!$ end subroutine HistoryInquireVariable1
subroutine HistoryCopyVariable1(file, varname, history, overwrite)
!
!== 変数定義 (別ファイルの変数コピー)
!
! gtool4 データ内の変数の定義を行います。 他の gtool4 データの
! ファイル名とその中の変数名を指定することで、 自動的のその変数の
! 構造や属性をコピーして変数定義します。このサブルーチンを
! 用いる前に、 HistoryCreate による初期設定が必要です。
!
! 構造や属性を手動で設定する場合には HistoryAddVariable
! を用いて下さい。
!
use gtdata_generic, only: Create, Inquire, Open, Slice, Close
use dc_present, only: present_and_false
use dc_url, only: UrlMerge, GT_ATMARK, UrlResolve
use dc_types, only: STRING
implicit none
character(len = *), intent(in) :: file
! コピーしようとする変数が格納された
! netCDF ファイル名
!
character(len = *), intent(in) :: varname
! コピー元となる変数の名前
!
! 定義される変数名もこれと
! 同じになります。
! 最大文字数は dc_types#TOKEN 。
!
! 依存する次元が存在しない
! 場合は自動的にその次元に関する
! 変数情報も元のファイルから
! コピーします。
! この場合に「同じ次元」と見
! なされるのは、(1) 無制限次
! 元 (自動的に「時間」と認識
! される)、
! (2) サイズと単位が同じ次元、
! です。
!
type(GT_HISTORY), intent(inout), optional, target :: history
! 出力ファイルの設定に関する情報を
! 格納した構造体
!
! ここに指定するものは、
! HistoryCreate によって初期設定
! されていなければなりません。
!
logical, intent(in), optional:: overwrite
! 上書きの可否の設定
!
! この引数に .false. を渡すと、
! 既存のファイルを上書きしません。
! デフォルトは上書きします。
!
type(GT_HISTORY), pointer:: hst =>null()
type(GT_VARIABLE), pointer:: vwork(:) =>null(), dimvars(:) =>null()
type(GT_VARIABLE):: copyfrom
character(STRING):: fullname, url, copyurl
integer, pointer:: count_work(:) =>null()
integer, pointer:: var_avr_count_work(:) =>null()
integer:: var_avr_length
type(GT_HISTORY_AVRDATA), pointer:: var_avr_data_work(:) =>null()
integer:: nvars, numdims, i
logical:: growable, overwrite_required
character(*), parameter:: subname = "HistoryCopyVariable1"
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
var_avr_count_work => hst % var_avr_count
nullify(hst % vars, hst % count, hst % var_avr_count)
allocate(hst % vars(nvars + 1), hst % count(nvars + 1), hst % var_avr_count(nvars + 1))
hst % vars(1:nvars) = vwork(1:nvars)
hst % count(1:nvars) = count_work(1:nvars)
hst % var_avr_count(1:nvars) = var_avr_count_work(1:nvars)
deallocate(vwork, count_work, var_avr_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)
!
! 平均値出力のための変数表コピー
! Copy table of variables for average value output
!
var_avr_data_work => hst % var_avr_data
nullify(hst % var_avr_data)
allocate(hst % var_avr_data(nvars + 1))
do i = 1, nvars
hst % var_avr_data(i) % length = var_avr_data_work(i) % length
allocate(hst % var_avr_data(i) % &
& a_DataAvr(var_avr_data_work(i) % length))
hst % var_avr_data(i) % a_DataAvr = var_avr_data_work(i) % a_DataAvr
end do
else
! トリッキーだが、ここで count だけ 2 要素確保するのは、
! HistorySetTime による巻き戻しに備えるため。
allocate(hst % vars(1), hst % count(2), hst % growable_indices(1))
allocate(hst % var_avr_count(1), hst % var_avr_data(1))
hst % count(2) = 0
endif
nvars = size(hst % vars(:))
hst % growable_indices(nvars) = 0
hst % count(nvars) = 0
hst % var_avr_count(nvars) = -1
!----- コピー元ファイルの変数 ID 取得 -----
copyurl = UrlMerge(file, varname)
call Open(copyfrom, copyurl)
!----- 変数コピー -----
call Inquire(hst % dimvars(1), url=url)
fullname = UrlResolve((GT_ATMARK // trim(varname)), trim(url))
overwrite_required = .true.
if (present_and_false(overwrite)) overwrite_required = .false.
call Create(hst % vars(nvars), trim(fullname), copyfrom, &
& copyvalue=.FALSE., overwrite=overwrite_required)
!----- 無制限次元の添字を探査 -----
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 Inquire( hst % vars(nvars), size = var_avr_length )
allocate( hst % var_avr_data(nvars) % a_DataAvr(var_avr_length) )
hst % var_avr_data(nvars) % length = var_avr_length
hst % var_avr_data(nvars) % a_DataAvr = 0.0_DP
call Close(copyfrom)
call EndSub(subname)
end subroutine HistoryCopyVariable1
subroutine HistorySetTime(time, history)
!
!== 時刻指定
!
! 明示的に時刻指定を行なうためのサブルーチンです。
! このサブルーチンを用いる前に、HistoryCreate による初期設定が必要です。
! このサブルーチンを使用する事で HistoryCreate の *interval* が無効
! になるので注意してください。
!
!--
! 時刻を明示設定している状態で、巻き戻しを含めた時間設定。
! 前進している間は検索をしないようになっている。
!++
!
use gtdata_generic, only: Slice, Put, Get
implicit none
real, intent(in):: time
! 時刻
!
! ここで言う "時刻" とは、
! HistoryCreate の *dims* で "0"
! と指定されたものです。
! もしも時刻が定義されていな
! い場合は、 このサブルーチン
! は何の効果も及ぼしません。
!
type(GT_HISTORY), intent(inout), optional, target:: history
! 出力ファイルの設定に関する情報を
! 格納した構造体
!
! ここに指定するものは、
! HistoryCreate によって初期設定
! されていなければなりません。
!
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
subroutine TimeGoAhead( varname, var, head, history, err )
!
! *history* 内の (省略された場合は gt4_history 内に内包
! される GT_HISTORY 変数) の変数名 *varname* の時間を1つ分
! 進め、その最新の時間断面で切り取った変数 ID を *var* に返します。
!
!--
! そのデフォルトでは変数ごとにカウンタを設置し、呼んだ数だけ
! 「時刻」方向を進め、時刻データを入力する。
! これに対し、HistorySetTime で時刻の変数に一度でもスカラ値を投入
! すると、明示的にそれを設定したときにだけ時刻が進むようになる。
! このルーチンでは後退はできない。
!
! [詳細]
! 変数名 varname に対応する変数 ID var を探査し、その変数が
! 時間次元に依存する場合には hst % count の値を1つ増やす (時間を進める)。
! そして、hst % origin と hst % interval から時間次元データに値を与える。
!
! なお、HistorySetTime で既に値が設定され、hst % count の値が
! 増やされる場合には、こちらでは hst % count の値を変更しない。
! データも入力しない。
!++
use gtdata_generic, only: Slice, Get_Slice, Put, Get
use dc_types, only: STRING
use dc_error, only: StoreError, NF_ENOTVAR, DC_NOERR
character(len = *), intent(in) :: varname
type(GT_VARIABLE), intent(out) :: var
real, intent(in):: head
type(GT_HISTORY), intent(inout), optional, target:: history
logical, intent(out), optional :: err
!
type(GT_HISTORY), pointer:: hst =>null()
type(GT_VARIABLE) :: timevar
real, pointer:: time(:) =>null()
integer :: v_ord ! varname の history における次元添字番号
integer :: d_ord
integer :: timestart, rest
integer :: stat
logical :: get_err
character(STRING) :: cause_c
character(*), parameter :: subname = "TimeGoAhead"
continue
call BeginSub(subname, 'varname=%c head=%r', &
& c1=trim(varname), r=(/head/))
stat = DC_NOERR
cause_c = ''
if (present(history)) then
hst => history
else
hst => default
endif
! hst 内での変数 varname の変数 ID を var に、
! hst における変数添字を v_ord に取得
var = lookup_variable( hst, varname, & ! (in)
& ord = v_ord ) ! (out)
if (v_ord == 0) goto 1000
! 変数 v_ord に時間次元が無い場合は終了
if (hst % growable_indices(v_ord) == 0) then
goto 999
endif
if (hst % dim_value_written(hst % unlimited_index)) then
!-----------------------
! HistorySetTime を利用する場合
!
! 時間次元に既に値が書き込まれている場合は count を増やさない
!
call Slice(var, hst % growable_indices(v_ord), &
& start=hst % count(1), count=1)
else
!-----------------------
! HisotrySetTime を利用しない場合
!
! 時間次元に値が書き込まれていない場合, count を増やす
! (history % interval を利用する)
!
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 と時間次元変数の count を比較し,
! 変数の count が大きい場合, 時間次元変数の count も
! 同値になるようデータを出力する.
!
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, get_err)
call DbgMessage('time(%d)=<%*r>, err=<%b>', &
& i=(/size(time)/), r=(/time(:)/), &
& l=(/get_err/), n=(/size(time)/) )
if (get_err .or. hst % count(v_ord) == 1 .and. timestart == 1) then
!---------------------
! 時間次元のデータの初期値作成
!
! 時間次元のデータがまだ作成されていない場合、
! 初期値となるデータを作成
call Slice(timevar, 1, start=1, count=1)
call Put(timevar, (/hst % origin/), 1)
elseif (hst % count(v_ord) > timestart) then
!---------------------
! 時間次元のデータの初期値以外を作成
!
! 変数の count が時間次元の start より大きい場合、
! hst % interval でその間を埋める。
rest = timestart + 1
do
call Slice(timevar, 1, start=rest, count=1)
call Put(timevar, &
& (/hst % origin + hst % interval * (rest - 1) /), 1 )
rest = rest + 1
if ( rest > hst % count(v_ord) ) exit
enddo
endif
nullify(time)
endif
goto 999
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
cause_c = 'varname="' // trim(varname) // '" is not found'
goto 999
endif
hst % dim_value_written(d_ord) = .TRUE.
if (d_ord /= hst % unlimited_index) then
goto 999
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)
999 continue
call StoreError(stat, subname, err, cause_c)
call EndSub(subname)
end subroutine TimeGoAhead
__EndOfFortran90Code__
types = ["Real", "Double", "Int"]
types.each{ |type|
print <<"__EndOfFortran90Code__"
recursive subroutine HistoryPut#{type}Ex( &
& varname, array, arraysize, history, range, time, quiet, err )
!
!== データ出力
!
! こちらは配列サイズを指定する必要があるため、
! HistoryPut を利用してください。
!
use gtdata_generic, only: Put, GTVarSync, Slice, Inquire, &
& Get_Slice, Get, PutLine, Open, Close
use dc_string, only: StoA, Printf, toChar, JoinChar
use dc_present, only: present_and_not_empty, present_select, present_and_false
use dc_error, only: StoreError, DC_NOERR, DC_ENOTINIT, DC_EARGLACK, USR_ERRNO, GT_EARGSIZEMISMATCH
use dc_message, only: MessageNotify
use dc_url, only: UrlSplit, UrlMerge
character(*), intent(in):: varname
integer, intent(in):: arraysize
#{$type_intent_in[type]}, intent(in):: array(arraysize)
type(GT_HISTORY), intent(inout), target, optional:: history
character(*), intent(in), optional:: range
! gtool4 のコンマ記法による
! データの出力範囲指定
!
! このオプションを用いる
! 際には、必ず *HistorySetTime*
! によって明示的に時刻の設定
! を行ってください。
! また、*HistoryGet* と異なり、
! 時刻に関する範囲指定は
! 行なえません。
!
! 書式に関する詳細は
! {gtool4 netCDF 規約}[link:../xref.htm#label-6]
! の「5.4 コンマ記法」を参照して
! ください。
real, intent(in), optional:: time
!
! 時刻
!
! この引数を与える場合、
! 出力するかどうかをプログラムが
! 自動的に判断します。
! *time* に与えられた数値が
! HistoryCreate に与えた *interval*
! で割り切れる場合には出力が行われます。
!
! HistoryAddVariable で
! *average* に .true. を与えた場合には、
! この引数を与えない場合に、
! プログラムはエラーを発生させます。
!
! また、この引数と *range* は併用できません。
! 併用した場合には、
! プログラムはエラーを発生させます。
!
logical, intent(in), optional:: quiet
! .false. を与えた場合,
! このサブルーチンが呼ばれる毎に
! ファイル名と時刻が表示されます.
! デフォルトは .true. です.
!
! If ".false." is given,
! a filename and time is displayed
! when this subroutine is called.
! Default value is ".true.".
!
logical, intent(out), optional:: err
! 例外処理用フラグ.
! デフォルトでは, この手続き内でエラーが
! 生じた場合, プログラムは強制終了します.
! 引数 *err* が与えられる場合,
! プログラムは強制終了せず, 代わりに
! *err* に .true. が代入されます.
!
! Exception handling flag.
! By default, when error occur in
! this procedure, the program aborts.
! If this *err* argument is given,
! .true. is substituted to *err* and
! the program does not abort.
#{$type_intent_in[type]}:: array_work(arraysize)
type(GT_VARIABLE):: var, timevar
character(STRING):: url, file, time_str
real:: time_value(1:1)
type(GT_HISTORY), pointer:: hst =>null()
integer, allocatable:: start(:), count(:), stride(:)
integer :: i, dims, v_ord
character(STRING):: avr_msg
logical :: slice_err
character(STRING):: time_name
character(*), parameter:: bnds_suffix = '_bnds'
type(GT_VARIABLE):: bndsvar
integer:: bnds_ord, time_count, bnds_rank
integer:: stat
logical:: output_step
character(STRING):: cause_c
character(*), parameter:: subname = "HistoryPut#{type}Ex"
continue
call BeginSub(subname, 'varname=%a range=%a', &
& ca=StoA(varname, present_select('', '(no-range)', range)))
stat = DC_NOERR
cause_c = ""
if (present(history)) then
hst => history
else
hst => default
endif
!-----------------------------------------------------------------
! 初期設定のチェック
! Check initialization
!-----------------------------------------------------------------
if ( .not. hst % initialized ) then
stat = DC_ENOTINIT
cause_c = 'GT_HISTORY'
goto 999
end if
!-----------------------------------------------------------------
! time と range の同時使用の禁止
! Permit concurrent use of "time" and "range"
!-----------------------------------------------------------------
if ( present(time) .and. present_and_not_empty(range) ) then
call MessageNotify('W', subname, &
& '(varname=%c) "range" and "time" are not suppored at the same time', &
& c1 = trim(varname) )
stat = USR_ERRNO
cause_c = '"range" and "time" are not suppored at the same time'
goto 999
end if
!-----------------------------------------------------------------
! hst 内の varname 変数の変数番号を取得
! Get variable number of "varname" in "hst"
!-----------------------------------------------------------------
v_ord = lookup_variable_ord(hst, varname)
!-----------------------------------------------------------------
! 時間平均値のためのデータ格納
! Store data for time average value
!-----------------------------------------------------------------
if ( v_ord > 0 ) then
if ( hst % var_avr_count( v_ord ) > -1 ) then
if ( .not. present(time) ) then
call MessageNotify('W', subname, &
& '(varname=%c) argument "time" is needed when "argument=.true." is specified to "HistoryAddVariable"', &
& c1 = trim(varname) )
stat = DC_EARGLACK
cause_c = 'time'
goto 999
end if
if ( arraysize /= hst % var_avr_data( v_ord ) % length ) then
call MessageNotify('W', subname, &
& '(varname=%c) size of array should be (%d). size of array is (%d)', &
& i = (/hst % var_avr_data( v_ord ) % length, arraysize/), &
& c1 = trim(varname) )
stat = GT_EARGSIZEMISMATCH
cause_c = 'array'
goto 999
end if
hst % var_avr_data( v_ord ) % a_DataAvr = &
& hst % var_avr_data( v_ord ) % a_DataAvr + array
hst % var_avr_count( v_ord ) = &
& hst % var_avr_count( v_ord ) + 1
hst % time_bnds(2:2) = time
end if
end if
!-----------------------------------------------------------------
! 時刻の自動チェック
! Check time automatically
!-----------------------------------------------------------------
output_step = .true.
if ( present(time) ) then
output_step = .false.
if ( hst % interval == 0.0 ) then
output_step = .true.
else
if ( mod( time - hst % origin , hst % interval ) == 0.0 ) then
output_step = .true.
end if
end if
end if
!-------------------------
! 時間平均値出力のための情報処理
! Information processing for output time-averaged value
if ( .not. output_step ) then
goto 999
else
array_work = array
avr_msg = ''
v_ord = lookup_variable_ord(hst, varname)
if ( v_ord > 0 ) then
if ( hst % var_avr_count( v_ord ) > -1 ) then
avr_msg = '(time average of ' // trim( toChar(hst % var_avr_count( v_ord )) ) // ' step data)'
!-------------------
! 蓄えた値の時間平均化
! Average stored value in time direction
array_work = &
& ( hst % var_avr_data( v_ord ) % a_DataAvr ) / ( hst % var_avr_count( v_ord ) )
hst % var_avr_data( v_ord ) % a_DataAvr = 0.0
hst % var_avr_count( v_ord ) = 0
end if
end if
end if
!-----------------------------------------------------------------
! 時刻を1つ進めて GT_VARIABLE 変数取得
! Progress one time, and get GT_VARIABLE variable
!-----------------------------------------------------------------
call TimeGoAhead( &
& varname = varname, & ! (in)
& head = real(array_work(1)), & ! (in)
& var = var, & ! (out)
& history = history, & ! (inout)
& err = err ) ! (out)
call Inquire( var, & ! (in)
& alldims=dims ) ! (out)
if (present_and_not_empty(range) .and. (dims < 1)) then
call DbgMessage('varname=<%c> has no dimension. so range is ignoread.', &
& c1=trim(varname))
end if
if (.not. (present_and_not_empty(range) .and. (dims > 0))) then
! range 無しの普通の出力の場合
call Put(var, array_work, arraysize)
else
! range があり, 且つ varname がちゃんと次元を持っている場合
!
! 元々の start, count, stride を保持. データを与えた後に復元する.
allocate(start(dims), count(dims), stride(dims))
do i = 1, dims
call Get_Slice(var, i, start(i), count(i), stride(i))
end do
slice_err = .false. ! 不要だが Slice の引用仕様として必要なため
call Slice(var, range, slice_err)
call Put(var, array_work, arraysize)
! 復元
do i = 1, dims
call Slice(var, i, start(i), count(i), stride(i))
end do
deallocate(start, count, stride)
end if
call GTVarSync(var)
!-----------------------------------------------------------------
! "time_bnds" 変数への出力
! Output to "time_bnds" variable
!-----------------------------------------------------------------
v_ord = lookup_variable_ord(hst, varname)
if ( v_ord > 0 ) then
if ( hst % var_avr_count( v_ord ) > -1 ) then
!-------------------
! 時間次元の名前とファイル名を取得
! Get name of time dimension, and filename
timevar = hst % dimvars( hst % unlimited_index )
call Inquire( &
& var = timevar, & ! (in)
& url = url, & ! (out)
& name = time_name ) ! (out)
call UrlSplit( fullname = url, & ! (in)
& file = file ) ! (out)
!-------------------
! "time_bnds" 変数の取得
! Get "time_bnds" variable
call Open( var = bndsvar, &
& url = UrlMerge(file=file, var=trim(time_name) // bnds_suffix) )
bnds_ord = lookup_variable_ord( hst, trim(time_name) // bnds_suffix)
!-------------------
! "time_bnds" 変数への出力
! Output to "time_bnds" variable
call Inquire( &
& var = bndsvar, & ! (in)
& rank = bnds_rank ) ! (out)
time_count = 1
if ( bnds_rank > 1 ) then
call Inquire( &
& var = bndsvar, & ! (in)
& dimord = hst % growable_indices(bnds_ord), & ! (in)
& allcount = time_count ) ! (out)
end if
call Close( var = bndsvar ) ! (inout)
if ( (hst % time_bnds_output_count < 1) &
& .or. (hst % time_bnds_output_count < time_count) ) then
call HistoryPut( &
& history = hst, & ! (inout)
& varname = trim(time_name) // bnds_suffix, & ! (in)
& array = hst % time_bnds ) ! (in)
hst % time_bnds_output_count = hst % time_bnds_output_count + 1
end if
hst % time_bnds(1:1) = time
end if
end if
!-----------------------------------------------------------------
! メッセージ出力
! Output messages
!-----------------------------------------------------------------
if ( present_and_false(quiet) ) then
call Inquire( hst % dimvars(1), & ! (in)
& url = url ) ! (out)
call UrlSplit( fullname = url, & ! (in)
& file = file ) ! (out)
if ( hst % unlimited_index < 1 ) then
time_str = ''
else
timevar = hst % dimvars(hst % unlimited_index)
call Slice( timevar, & ! (in)
& 1, start = hst % count(v_ord), count = 1 ) ! (in)
call Get( timevar, & ! (inout)
& time_value, & ! (out)
& 1, & ! (in)
& err ) ! (out)
time_str = '(time=' // trim( toChar( time_value(1) )) // ')'
end if
call MessageNotify('M', 'HistoryPut', &
& '"%a" => "%a" %a %a', &
& ca = StoA( varname, file, time_str, avr_msg ) )
end if
!-----------------------------------------------------------------
! 終了処理, 例外処理
! Termination and Exception handling
!-----------------------------------------------------------------
999 continue
call StoreError( stat, subname, err, cause_c )
call EndSub(subname)
end subroutine HistoryPut#{type}Ex
__EndOfFortran90Code__
}
types = ["Real", "Double", "Int"]
def ValueOrArray(num)
return "value" if num == 0
return "array"
end
def ArgsToPutEx(num)
return "(/value/), 1" if num == 0
return "array, size(array)"
end
types.each{ |type|
for num in 0..$histput_dim
print <<"__EndOfFortran90Code__"
subroutine HistoryPut#{type}#{num}( varname, #{ValueOrArray(num)}, &
& history, range, time, quiet, err )
!
#{ifelse(num, 1, %Q{
#{ifelse(type, "Double", %Q{
!
!== データ出力
!
! gtool4 データ内の変数へデータの出力を行います。
! このサブルーチンを用いる前に、HistoryCreate
! による初期設定が必要です。
!
! *HistoryPut* は複数のサブルーチンの総称名です。*array* には
! 0 〜 #{$histput_dim} 次元のデータを与えることが可能です。
! (下記のサブルーチンを参照ください)。
! ただし、0 次元のデータを与える際の引数キーワードは
! *value* を用いてください。
!
! HistoryPut を最初に呼んだ時、時間次元の変数は HistoryCreate の
! origin の値に設定されます。
!
! ある変数 varname に対して HistoryPut を複数回呼ぶと、
! HistoryCreate の interval × HistoryPut を呼んだ回数、 の分だけ
! 時間次元の変数の値が増やされます。
!
! これらの時間次元の変数の値を明示的に設定したい場合は
! HistorySetTime を用いるか、HistoryPut 自身で時間次元の変数へ値
! を出力してください。
!
})}})}
!
character(*), intent(in):: varname
#{ifelse(num, 1, %Q{
#{ifelse(type, "Double", %Q{
! 変数の名前
!
! ただし、ここで指定するもの
! は、 HistoryCreateの *dims*
! または HistoryAddVariable や
! HistoryCopyVariable の
! *varname* で既に指定されてい
! なければなりません。
!
})}})}
#{$type_intent_in[type]}, intent(in):: #{ValueOrArray(num)}#{array_colon("#{num}")}
#{ifelse(num, 1, %Q{
#{ifelse(type, "Double", %Q{
! 変数が出力するデータ
!
! 型は単精度実数型でも
! 倍精度実数型でもよいですが、
! HistoryAddVariable の
! *xtype* で指定した
! データ型と異なる
! 型を渡した場合、xtype で
! 指定した型に変換されます。
!
})}})}
type(GT_HISTORY), intent(inout), optional, target:: history
#{ifelse(num, 1, %Q{
#{ifelse(type, "Double", %Q{
! 出力ファイルの設定に関する情報を
! 格納した構造体
!
! ここに指定するものは、
! HistoryCreate によって初期設定
! されていなければなりません。
!
})}})}
character(*), intent(in), optional:: range
#{ifelse(num, 1, %Q{
#{ifelse(type, "Double", %Q{
! gtool4 のコンマ記法による
! データの出力範囲指定
!
! このオプションを用いる
! 際には、必ず *HistorySetTime*
! によって明示的に時刻の設定
! を行ってください。
! また、*HistoryGet* と異なり、
! 時刻に関する範囲指定は
! 行なえません。
!
! 書式に関する詳細は
! {gtool4 netCDF 規約}[link:../xref.htm#label-6]
! の「5.4 コンマ記法」を参照して
! ください。
})}})}
real, intent(in), optional:: time
#{ifelse(num, 1, %Q{
#{ifelse(type, "Double", %Q{
!
! 時刻。
!
! この引数を与える場合、
! 出力するかどうかをプログラムが
! 自動的に判断します。
! *time* に与えられた数値が
! HistoryCreate に与えた *interval*
! で割り切れる場合には出力が行われます。
!
! HistoryAddVariable で
! *time_average* (または *average*)
! に .true. を与えた場合には、
! この引数を与えない場合に、
! プログラムはエラーを発生させます。
!
! また、この引数と *range* は併用できません。
! 併用した場合には、
! プログラムはエラーを発生させます。
!
})}})}
logical, intent(in), optional:: quiet
#{ifelse(num, 1, %Q{
#{ifelse(type, "Double", %Q{
! .true. を与えた場合,
! メッセージ出力が抑制されます.
!
! If ".true." is given,
! messages are suppressed.
!
})}})}
logical, intent(out), optional:: err
#{ifelse(num, 1, %Q{
#{ifelse(type, "Double", %Q{
! 例外処理用フラグ.
! デフォルトでは, この手続き内でエラーが
! 生じた場合, プログラムは強制終了します.
! 引数 *err* が与えられる場合,
! プログラムは強制終了せず, 代わりに
! *err* に .true. が代入されます.
!
! Exception handling flag.
! By default, when error occur in
! this procedure, the program aborts.
! If this *err* argument is given,
! .true. is substituted to *err* and
! the program does not abort.
})}})}
character(*), parameter:: subname = "HistoryPut#{type}#{num}"
continue
call BeginSub(subname)
call HistoryPut#{type}Ex( &
& varname, & ! (in)
& #{ArgsToPutEx(num)}, & ! (in)
& history = history, & ! (inout)
& range = range, & ! (in)
& time = time, & ! (in)
& quiet = quiet, & ! (in)
& err = err ) ! (out)
call EndSub(subname)
end subroutine
__EndOfFortran90Code__
end
}
undef ValueOrArray
undef ArgsToPutEx
print <<"__EndOfFortran90Code__"
subroutine HistoryClose( history, quiet, err )
!
!== gtool4 データの終了処理
!
! HistoryCreate で始まったデータ出力の終了処理をおこなうものです.
! プログラム内で HistoryCreate を用いた場合, プログラムを終了する
! 前に必ずこのサブルーチンを呼んで下さい.
!
use gtdata_generic, only: Close, Inquire
use dc_message, only: MessageNotify
use dc_url, only: UrlSplit
use dc_present, only: present_and_true
use dc_error, only: StoreError, DC_NOERR, DC_ENOTINIT
type(GT_HISTORY), intent(inout), optional, target:: history
! 出力ファイルの設定に関する情報を
! 格納した構造体
!
! ここに指定するものは,
! HistoryCreate によって初期設定
! されていなければなりません.
!
logical, intent(in), optional:: quiet
! .true. を与えた場合,
! メッセージ出力が抑制されます.
!
! If ".true." is given,
! messages are suppressed.
!
logical, intent(out), optional:: err
! 例外処理用フラグ.
! デフォルトでは, この手続き内でエラーが
! 生じた場合, プログラムは強制終了します.
! 引数 *err* が与えられる場合,
! プログラムは強制終了せず, 代わりに
! *err* に .true. が代入されます.
!
! Exception handling flag.
! By default, when error occur in
! this procedure, the program aborts.
! If this *err* argument is given,
! .true. is substituted to *err* and
! the program does not abort.
type(GT_HISTORY), pointer:: hst =>null()
character(STRING):: url, file
integer:: i, v_size
integer:: stat
character(STRING):: cause_c
character(len = *), parameter:: subname = "HistoryClose"
continue
call BeginSub(subname)
stat = DC_NOERR
cause_c = ""
if (present(history)) then
hst => history
else
hst => default
endif
!-----------------------------------------------------------------
! 初期設定のチェック
! Check initialization
!-----------------------------------------------------------------
if ( .not. hst % initialized ) then
stat = DC_ENOTINIT
cause_c = 'GT_HISTORY'
goto 999
end if
!-----------------------------------------------------------------
! メッセージ出力用にファイル名取得
! Get filename for output messages
!-----------------------------------------------------------------
if ( .not. present_and_true(quiet) ) then
call Inquire( hst % dimvars(1), & ! (in)
& url = url ) ! (out)
call UrlSplit( fullname = url, & ! (in)
& file = file ) ! (out)
end if
v_size = size(hst % dimvars)
do, i = 1, v_size
if (.not. hst % dim_value_written(i)) &
call set_fake_dim_value(hst, i)
call Close(hst % dimvars(i))
enddo
deallocate(hst % dimvars)
v_size = size(hst % vars)
do, i = 1, v_size
call Close(hst % vars(i))
enddo
if (associated(hst % vars)) deallocate(hst % vars)
if (associated(hst % count)) deallocate(hst % count)
if (associated(hst % var_avr_count)) deallocate(hst % var_avr_count)
do, i = 1, v_size
if (associated(hst % var_avr_data(i) % a_DataAvr)) deallocate(hst % var_avr_data(i) % a_DataAvr)
enddo
if (associated(hst % var_avr_data)) deallocate(hst % var_avr_data)
!-----------------------------------------------------------------
! メッセージ出力
! Output messages
!-----------------------------------------------------------------
if ( .not. present_and_true(quiet) ) then
call MessageNotify('M', subname, &
& '"%c" is closed', &
& c1 = trim( file ) )
end if
!-----------------------------------------------------------------
! 終了処理, 例外処理
! Termination and Exception handling
!-----------------------------------------------------------------
hst % initialized = .false.
999 continue
call StoreError( stat, subname, err, cause_c )
call EndSub( subname )
end subroutine HistoryClose
subroutine HistoryAxisClear(axis)
!
!== GT_HISTORY_AXIS 型変数初期化
!
! *axis* で与えられた変数を HistoryAxisCreate による初期設定よりも
! さらに前の状態に初期化します。
!
! Destructor of GT_HISTORY_AXIS
!
implicit none
type(GT_HISTORY_AXIS),intent(inout) :: axis
character(len = *), parameter:: subname = "HistoryAxisClear1"
call BeginSub(subname)
axis % name = ""
axis % length = 0
axis % longname = ""
axis % units = ""
axis % xtype = ""
if (associated(axis % attrs)) then
deallocate(axis % attrs)
end if
call EndSub(subname)
end subroutine HistoryAxisClear
subroutine HistoryVarinfoClear0(varinfo, err)
!
!== GT_HISTORY_VARINFO 型変数初期化
!
! *varinfo* で与えられた変数を HistoryVarinfoCreate による初期設定よりも
! さらに前の状態に初期化します。
!
! Destructor of GT_HISTORY_VARINFO
!
use dc_error, only: StoreError, DC_NOERR, DC_ENOTINIT
implicit none
type(GT_HISTORY_VARINFO),intent(inout) :: varinfo
logical, intent(out), optional:: err
! 例外処理用フラグ.
! デフォルトでは, この手続き内でエラーが
! 生じた場合, プログラムは強制終了します.
! 引数 *err* が与えられる場合,
! プログラムは強制終了せず, 代わりに
! *err* に .true. が代入されます.
!
! Exception handling flag.
! By default, when error occur in
! this procedure, the program aborts.
! If this *err* argument is given,
! .true. is substituted to *err* and
! the program does not abort.
integer:: stat
character(STRING):: cause_c
character(len = *), parameter:: subname = "HistoryVarinfoClear1"
continue
call BeginSub(subname)
stat = DC_NOERR
cause_c = ''
if ( .not. varinfo % initialized ) then
stat = DC_ENOTINIT
cause_c = 'GT_HISTORY_VARINFO'
goto 999
end if
varinfo % name = ""
varinfo % longname = ""
varinfo % units = ""
varinfo % xtype = ""
if (associated(varinfo % attrs)) then
deallocate(varinfo % attrs)
end if
varinfo % initialized = .false.
999 continue
call StoreError( stat, subname, err, cause_c )
call EndSub(subname)
end subroutine HistoryVarinfoClear0
logical function HistoryVarinfoInitialized0( varinfo ) result(result)
!
! *varinfo* が初期設定されている場合には .true. が,
! 初期設定されていない場合には .false. が返ります.
!
! If *varinfo* is initialized, .true. is returned.
! If *varinfo* is not initialized, .false. is returned.
!
implicit none
type(GT_HISTORY_VARINFO),intent(in) :: varinfo
continue
result = varinfo % initialized
end function HistoryVarinfoInitialized0
subroutine set_fake_dim_value(history, dimord)
!
! 次元 history % dimvars(dimord) に値が設定されていない場合、
! 「とりあえず」値を設定する。ただし、無制限次元 (時間次元)
! に関しては history % origin, history % interval, history % count
! から「まっとうな」値が設定される。
!
use gtdata_generic, only: Inquire, Slice, Put
use dc_error, only: DumpError
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 set_fake_dim_value
integer function lookup_variable_ord(history, varname) result(result)
!
! history 内の varname 変数の変数番号を返す.
! 現在, 明示的に history 変数を与えない場合の変数番号の
! 検索は出来ない.
!
use dc_types, only: string
use gtdata_generic, only: inquire
type(GT_HISTORY), intent(in):: history
character(len = *), intent(in):: 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
type(GT_VARIABLE) function lookup_variable(history, varname, ord) result(result)
!
! history 内での変数 varname の ID を取得
! ID を取得できた場合, 返り値 result と ord にそれぞれ
! その ID が返される。
! ID を取得できない場合、ord が渡されていなければその場で終了
! ord が渡されている場合は ord に 0 が返される。
!
use dc_types, only: STRING
use dc_error, only: StoreError, NF_ENOTVAR, DC_NOERR
type(GT_HISTORY), intent(in):: history
character(len = *), intent(in):: varname
character(len = STRING) :: cause_c
integer, intent(out), optional:: ord
integer:: ordwork
integer:: i, stat
character(len = *), parameter:: subname = 'lookup_variable'
continue
call BeginSub(subname, '%c', c1=trim(varname))
stat = DC_NOERR
cause_c = ''
if (present(ord)) ord = 0
ordwork = 0
i = lookup_variable_ord(history, varname)
if (i > 0) then
result = history % vars(i)
if (present(ord)) ord = i
goto 999
endif
if (present(ord)) then
ord = 0
else
stat = NF_ENOTVAR
cause_c = varname
i = 0
endif
999 continue
call StoreError(stat, subname, cause_c=cause_c)
if (present(ord)) ordwork = ord
call EndSub(subname, "ord=%d (0: not found)", i=(/ordwork/))
end function
type(GT_VARIABLE) function lookup_dimension(history, dimname, ord) result(result)
!
! history 内の dimname という変数名を持つ次元の GT_VARIABLE
! 変数を返す. dimname 末尾の空白は無視される.
!
use gtdata_generic, only: Inquire
use dc_types, only: STRING
use dc_error, only: StoreError, GT_EBADDIMNAME, DC_NOERR
type(GT_HISTORY), intent(in):: history
character(len = *), intent(in):: dimname
integer, intent(out), optional:: ord
integer:: ordwork
character(len = STRING):: name, cause_c
integer:: i, stat
character(len = *), parameter:: subname = 'lookup_dimension'
continue
call BeginSub(subname, 'dimname=%c', c1=trim(dimname))
stat = DC_NOERR
if (present(ord)) ord = 0
ordwork = 0
if (associated(history % dimvars)) then
do, i = 1, size(history % dimvars)
call Inquire(history % dimvars(i), name=name)
if (name == trim(dimname)) then
result = history % dimvars(i)
if (present(ord)) ord = i
stat = DC_NOERR
cause_c = ""
goto 999
endif
enddo
endif
if (present(ord)) then
ord = 0
else
stat = GT_EBADDIMNAME
cause_c = dimname
endif
999 continue
call StoreError(stat, subname, cause_c=cause_c)
if (present(ord)) ordwork = ord
call EndSub(subname, 'ord=%d (0:not found)', i=(/ordwork/))
end function
subroutine lookup_var_or_dim(history, name, var, err)
!
! history 内から, name という名前の次元または変数を探査し,
! var に GT_VARIABLE 変数を返す. 見つかって正常に
! var が返る場合は stat には DC_NOERR が返り,
! history 内から name が発見されない場合には, stat に
! NF_ENOTVAR が返る.
!
use dc_error, only: StoreError, DC_NOERR, NF_ENOTVAR
use dc_types, only: STRING
type(GT_HISTORY), intent(in):: history
character(len = *), intent(in):: name
type(GT_VARIABLE), intent(out):: var
logical, intent(out):: err
integer:: stat, ord
character(STRING) :: cause_c
character(len = *), parameter:: subname = 'lookup_var_or_dim'
continue
call BeginSub(subname, 'name=<%c>', c1=trim(name))
cause_c = ""
stat = DC_NOERR
var = lookup_variable(history, name, ord)
if (ord /= 0) then
stat = DC_NOERR
goto 999
endif
var = lookup_dimension(history, name, ord)
if (ord /= 0) then
stat = DC_NOERR
goto 999
endif
stat = NF_ENOTVAR
cause_c = "Any vars and dims are not found"
999 continue
call StoreError(stat, subname, err, cause_c)
call EndSub(subname, 'ord=%d (0:not found)', i=(/ord/))
end subroutine lookup_var_or_dim
end module gt4_history
__EndOfFortran90Code__
print <<"__EndOfFooter__"
!--
! vi:set readonly sw=4 ts=8:
!
#{rb2f90_emacs_readonly}!
!++
__EndOfFooter__