| Path: | gt4_historyauto.f90 |
| Last Update: | Fri Jun 16 15:17:03 JST 2006 |
module gt4_history のアプリケーション.
変数毎に時・空間に自由にサンプリングを設定できる.
長くなりそうな出力の時分割や並列化に対応.
その他の特徴
* 一つの変数を切り方や時間間隔を変えて複数出すこともできる。
* 並列化対応は、単にプロセス固有のサフィックスをファイル名に付けられる
だけという単純なものである。MPIなどを使う際に、各ノードが自分の
受け持ちの領域をそれぞれ独立なファイルに出すことを想定している。
* 時間積分ループ内でデータを出力するためのコーディングを楽にする工夫
* 出力する変数に関する諸々の情報はモジュール内部に取っておき、
外部からは名前で指定する。生の gt4f90io の場合、出力初期化でできた
GT_HISTORY 構造体を実際の出力場所に渡さなければない。そうすると
時間積分のループの内と外をどうやって繋ぐかという悩みが発生するが、
ここではその悩みから解放される。
* 出力するタイミングも内部で管理されるため時間積分ループ内で毎回出力
命令を呼んで構わない。なお、出力のためだけに特別に計算する物理量を
無駄に計算しないための工夫もある(関数((<HistoryAutoWhetherPutNow>)))
* 地図投影座標のように、多次元の座標（補助）変数を出力したい場合も考慮さ
れている(((<HistoryAutoCreate>))のオプション引数 ancilcrdvars)。
* 任意の属性が簡単に追加できる(((<HistoryAutoCreate>))のオプション引数 attrs)。
2004/11/??-19 堀之内 武 作成 2005/02/17 堀之内 武 ドキュメントちょこっと修正
* 長さ (*) の配列は本当に必要か？ 実は (:) にしたいんだけど、 長さチェック実装を面倒がって当座 (*) にしたんでは？？ もしそれだけの問題なら、長さチェックをするようにして、まずければ 例外が発生するようにすべき。 * 現在は内部データの保持は単なる linked list を使っているが、 登録変数が多くても高速に検索できるようにするため、2分探索出来る ように変えるべき。 * gt4f90io に上位モジュールとして取り込んで貰う * gt4f90io に整合的なドキュメンテーション （あるいは dcpam的に？）
—subroutine HistoryAutoCreate( name, aryshape, &
& longname, units, slfst, sllst, slstp, &
& file, title, source, institution, &
& dims, axlongnames, axunits, axxtypes, &
& time_to_start, put_interval, dt, &
& conventions, gt_version, &
& proc, newfile_interval, spcoordvars, &
& ancilcrdvars, attrs )
ヒストリファイル初期化情報の設定。実際のファイル初期化は
必要に応じて HistoryAutoPut が行う（時分割するときは適宜
クローズと初期化を繰り返さないとならないので、そういう
構造になる）。なお、一つのファイルへの出力に対して
このサブルーチンを２回以上呼んではならない。複数の
変数を一つのファイルに出したい場合は、HistoryAutoCopyCreate
を利用せよ。
時・空間に自由にサンプリングを設定できる。
但し、いずれも等間隔。長い時間積分によって、ファイルが
大きくなり過ぎることに対応するため、一定の時間間隔で
分割することが可能。また、並列化を念頭に各ノードを特定する
文字列を挿入することができる。
—subroutine HistoryAutoCopyCreate( name, longname, units [, file] )
直前の HistoryAutoCreate を使って、格子及び出力の空間・時間
サンプリングが同じ出力を定義する。fileを省略すれば
同じファイルを使う。
—subroutine HistoryAutoPut(name, vals, time)
変数の出力を行う。タイミングは内部で制御するので、全タイム
ステップで呼べば良い。なお、下記の HistoryAutoWhetherPutNow
を使って呼ぶタイミングを制御しても良い。
—logical function HistoryAutoWhetherPutNow( name, time )
name の名を持つ出力項目に関し、現在がファイルに出力するタイミ
ングかどうかを返す。同名で複数の出力をする場合、どれか一つでも
出力するタイミングなら .true. を返す。出力のために特別に計算を
を要するようなケースに使うと良い。（ほとんどのステップで無駄に
なる計算をするのを避けられる）
—GT4_ATTRIBUTE
属性を名前と値の組で入れる
—GT4_ATTRIBUTE function init_gt4_attribute(name,rval,ival,cval)
ATTRIBUTEのコンストラクター.
名前 ＆ （実数配列 or 整数配列 or 文字列） を与える
—GT4_REAL1D
配列の配列をつくるための型（実数）
—GT4_REAL1D function init_gt4_real1d(ary)
REAL1Dのコンストラクター.
—GT4_NAMED_REALARY
名前、次元名、longname, units を持つ実数配列. 配列データは1次元で保持
—GT4_NAMED_REALARY function init_gt4_named_realary(name,rank,dims,length,ary,longname,units)
GT4_NAMED_REALARYのコンストラクター.
| Subroutine : | |
| hst : | type(HIST_EACHVAR),intent(inout) |
| hst : | type(HIST_EACHVAR),intent(inout) |
| hst : | type(HIST_EACHVAR),pointer |
| hst : | type(HIST_EACHVAR),pointer |
| var : | type(GT4_NAMED_REALARY),intent(in) |
| var : | type(GT4_NAMED_REALARY),intent(in) |
subroutine add_ancilcrdvar(hst, var)
implicit none
type(HIST_EACHVAR),intent(inout) :: hst
type(GT4_NAMED_REALARY),intent(in) :: var
!
integer :: rank
!
rank = var%rank
call HistoryAddVariable(var%name, var%dims(1:rank), end subroutine add_ancilcrdvar
subroutine put_ancilcrdvar(hst, var)
use dc_error, only: GT_ENOMATCHDIM, StoreError
implicit none
type(HIST_EACHVAR),intent(inout) :: hst
type(GT4_NAMED_REALARY),intent(in) :: var
!
integer :: rank,i,j
integer,allocatable :: idx(:)
real,pointer :: subset(:)
character(len=*), parameter :: subname = 'put_ancilcrdvar'
!
call BeginSub(subname)
rank = var%rank
allocate(idx(rank))
loopi: do i=1,rank
do j=1,hst%sprank
if ( var%dims(i) == hst%dims(j) ) then
idx(i)=j
cycle loopi
endif
enddo
call StoreError(GT_ENOMATCHDIM, subname)
enddo loopi
subset => make_slice(var%ary, rank, (/hst%aryshape(idx)/), (/hst%slfst(idx)/), (/hst%sllst(idx)/), (/hst%slstp(idx)/))
if (associated(subset)) then
call HistoryPut(var%name, subset, hst%h%hs)
else
call HistoryPut(var%name, var%ary, hst%h%hs)
endif
deallocate(idx)
call EndSub(subname)
end subroutine put_ancilcrdvar
subroutine HistoryAutoPut(name, vals, time)
implicit none
character(len=*), intent(in) :: name
real :: vals(*)
real :: time
!
type(HIST_EACHVAR),pointer :: hst
integer :: ith, j, rank
character(len=STRING) :: file_actual
real :: eps=3e-7, newest
type(GT_HISTORY),pointer :: hist
logical :: put_now
integer :: arysize
real,pointer :: subset(:)
character(len = *), parameter:: subname = 'HistoryAutoPut'
!
call BeginSub(subname, 'name=<%c>, time=<%r>', c1=trim(name), r=(/time/))
ith = 1
do while( histpl_find(HISTPOOL, name, ith, hst) )
put_now = whether_to_put_now( time, hst%time_last, if ( put_now ) then
if ( associated(hst%h%hs) ) then
call HistoryInquire(hst%h%hs, newest=newest)
if ( hst%newfile_interval > 0 .and. hst%time_to_start = hst%time_to_start + hst%newfile_interval
call HistoryClose(hst%h%hs)
nullify(hst%h%hs)
endif
endif
if (.not.associated(hst%h%hs)) then
if (hst%newfile_interval > 0) then
file_actual = merge_file_proc_time(hst%file,hst%proc, else
file_actual = merge_file_proc_time(hst%file,hst%proc)
endif
rank = hst%sprank + 1
allocate(hist) ! always new allocataion
call HistoryCreate( file_actual, trim(hst%title), hst%h%hs => hist
call HistoryAddVariable(name, hst%dims(1:rank), trim(hst%longname), trim(hst%units), if (associated(hst%attrs)) then
do j=1,size(hst%attrs)
call add_gt4_attribute(hst, hst%attrs(j))
enddo
endif
if (associated(hst%ancilcrdvars)) then
do j=1,size(hst%ancilcrdvars)
call add_ancilcrdvar(hst, hst%ancilcrdvars(j))
enddo
endif
do j=1,hst%sprank
subset => make_slice(hst%spcoordvars(j)%ary, 1, (/hst%aryshape(j)/), (/hst%slfst(j)/), (/hst%sllst(j)/), (/hst%slstp(j)/) )
if (associated(subset)) then
call HistoryPut(hst%dims(j), else
call HistoryPut(hst%dims(j), endif
enddo
if (associated(hst%ancilcrdvars)) then
do j=1,size(hst%ancilcrdvars)
call put_ancilcrdvar(hst, hst%ancilcrdvars(j))
enddo
endif
call HistorySetTime(time, hst%h%hs)
else
rank = hst%sprank + 1
if ( .not. HistoryHasVariable(hst%h%hs, name) ) then
call HistoryAddVariable(name, hst%dims(1:rank), trim(hst%longname), trim(hst%units), !" ここで HistorySetTime すると問題が起きるので前回に従う
if (associated(hst%attrs)) then
do j=1,size(hst%attrs)
call add_gt4_attribute(hst, hst%attrs(j))
enddo
endif
else
call HistorySetTime(time, hst%h%hs)
endif
endif
arysize = product(hst%aryshape(1:hst%sprank))
subset => make_slice(vals(1:arysize), hst%sprank, (/hst%aryshape/), (/hst%slfst/), (/hst%sllst/), (/hst%slstp/))
if (associated(subset)) then
call HistoryPut(name, subset, hst%h%hs)
else
call HistoryPut(name, vals(1:hst%size), hst%h%hs)
endif
hst%time_last = time
endif
enddo
call EndSub(subname)
end subroutine HistoryAutoPut
function HistoryAutoWhetherPutNow( name, time ) result(result)
implicit none
logical :: result
character(len=*), intent(in) :: name
real, intent(in) :: time
!
integer :: ith
type(HIST_EACHVAR),pointer :: hst
character(len = *), parameter:: subname = 'HistoryAutoWhetherPutNow'
logical :: put_now
!
call BeginSub(subname)
result = .false.
ith = 1
do while( histpl_find(HISTPOOL, name, ith, hst) )
put_now = whether_to_put_now( time, hst%time_last, if (put_now) then
result = .true.
exit
endif
enddo
call EndSub(subname)
end function HistoryAutoWhetherPutNow
function whether_to_put_now( time_now, time_last, time_to_start, put_interval, dt ) result(result)
implicit none
logical :: result
real, intent(in) :: time_now
real, intent(in) :: time_last
real, intent(in) :: time_to_start
real, intent(in) :: put_interval
real, intent(in) :: dt
!
real :: next_put_time
real :: eps
character(len = *), parameter:: subname = 'whether_to_put_now'
call BeginSub(subname)
eps = dt * 1e-3 ! allowable error in time in float
if (time_now < time_to_start - eps) then
result = .false.
return
end if
next_put_time = time_last + put_interval ! initially very small because
! of the init val of time_last
if ( time_now >= (next_put_time - eps) ) then
result = .true.
else
result = .false.
endif
call EndSub(subname)
end function whether_to_put_now
subroutine HistoryAutoCopyCreate( name, longname, units, file )
! use the result of the latest call of HistoryAutoCreate
character(len=*), intent(in) :: name
character(len=*), intent(in) :: longname
character(len=*), intent(in) :: units
character(len=*), intent(in),optional :: file
!
type(HIST_EACHVAR) :: hist
type(HIST_EACHVAR),pointer :: histpt
character(len = *), parameter:: subname = 'HistoryAutoCopyCreate'
!
call BeginSub(subname)
histpt => histpl_last(HISTPOOL)
hist = histpt ! copy the contents
if(present_and_not_empty(file)) then
hist%file = file
allocate(hist%h) ! always new allocation
nullify(hist%h%hs)
else
hist%h => histpt%h
endif
hist%name = name
hist%longname = longname
hist%units = units
call histpl_push(HISTPOOL, hist)
call EndSub(subname)
end subroutine HistoryAutoCopyCreate
subroutine HistoryAutoSetRunInfo( conventions, gt_version )
use dc_error, only: USR_EINT, StoreError
implicit none
character(len=*), intent(in), optional :: title, source, institution
character(len=*), intent(in), optional :: proc
character(len=*), intent(in), optional :: conventions, gt_version
!
character(len = *),parameter :: subname = "HistoryAutoSetRunInfo"
continue
call BeginSub(subname)
if (present(title)) com_title = title
if (present(source)) com_source = source
if (present(institution)) com_institution = institution
if (present(proc)) com_proc = proc
if (present(conventions)) com_conventions = conventions
if (present(gt_version)) com_gt_version = gt_version
call EndSub(subname)
end subroutine HistoryAutoSetRunInfo
subroutine HistoryAutoSetGrid( grid_label, aryshape, dims, axlongnames, axunits, axxtypes, use dc_error, only: USR_EINT, StoreError
implicit none
character(len=*), intent(in) :: grid_label
integer, intent(in) :: aryshape(:) ! size <= 3 (--> sprank)
character(len=*), intent(in) :: dims(:) !size == sprank+1
character(len=*), intent(in) :: axlongnames(:) !size == sprank+1
character(len=*), intent(in) :: axunits(:) !size == sprank+1
character(len=*), intent(in) :: axxtypes(:)
real, intent(in),optional :: coord1(:) ! must present if sprank>=1
real, intent(in),optional :: coord2(:) ! must present if sprank>=2
real, intent(in),optional :: coord3(:) ! must present if sprank>=3
type(GT4_NAMED_REALARY),intent(in),optional :: ancilcrdvars(:)
!
type(HIST_EACHVAR) :: hist
integer :: sprank
character(len = *),parameter :: subname = "HistoryAutoSetGrid"
continue
call BeginSub(subname)
sprank = min( size(aryshape), 3 )
hist%sprank = sprank
hist%name = grid_label
hist%aryshape(1:sprank) = aryshape(1:sprank)
hist%dims(1:sprank+1) = dims(1:sprank+1)
hist%axlongnames(1:sprank+1) = axlongnames(1:sprank+1)
hist%axunits(1:sprank+1) = axunits(1:sprank+1)
hist%axxtypes(1:sprank+1) = axxtypes(1:sprank+1)
if (sprank >= 1) hist%spcoordvars(1) = init_gt4_real1d( coord1 )
if (sprank >= 2) hist%spcoordvars(2) = init_gt4_real1d( coord2 )
if (sprank >= 3) hist%spcoordvars(3) = init_gt4_real1d( coord3 )
if(.not. present(ancilcrdvars)) then
nullify(hist%ancilcrdvars)
else if ( size(ancilcrdvars)==0 )then
nullify(hist%ancilcrdvars)
else
allocate(hist%ancilcrdvars(size(ancilcrdvars))) ! always new alloc
hist%ancilcrdvars = ancilcrdvars
endif
call histpl_push(HISTGRIDPOOL, hist)
call EndSub(subname)
end subroutine HistoryAutoSetGrid
| Subroutine : | |
| hst : | type(HIST_EACHVAR),intent(inout) |
| attr : | type(GT4_ATTRIBUTE),intent(in) |
subroutine add_gt4_attribute(hst, attr)
implicit none
type(HIST_EACHVAR),intent(inout) :: hst
type(GT4_ATTRIBUTE),intent(in) :: attr
!
if( hst%name /= "" ) then
if(associated(attr%rval)) then
call HistoryAddAttr(hst%name, attr%name, attr%rval, hst%h%hs)
else if(associated(attr%rval)) then
call HistoryAddAttr(hst%name, attr%name, attr%ival, hst%h%hs)
else
call HistoryAddAttr(hst%name, attr%name, trim(attr%cval), hst%h%hs)
endif
endif
end subroutine add_gt4_attribute
| Function : | |||
| result : | logical
| ||
| histpl : | type(HIST_LINK),pointer
| ||
| name : | character(len=*), intent(in) | ||
| ith : | integer, intent(inout)
| ||
| hist : | type(HIST_EACHVAR),pointer |
function histpl_find(histpl, name,ith,hist) result(result)
implicit none
logical :: result ! .true. if found
type(HIST_LINK),pointer :: histpl ! intent(in)
character(len=*), intent(in) :: name
integer, intent(inout) :: ith ! ith+=1 when return (to iterate)
type(HIST_EACHVAR),pointer :: hist
!
type(HIST_LINK),pointer,save :: hp
integer,save :: cnt=1
character(len=TOKEN),save :: name_save = ''
!
if(name/=name_save .or. ith<cnt) then
cnt = 1
hp => histpl
endif
do while (associated(hp))
!!print *,trim(name),ith,cnt,trim(hp%name)
if (hp%name == name) then
if(cnt==ith) then
!!print *,' ...found'
hist => hp%hist
result = .true. ! found
name_save = name ! save the name found
ith = ith+1 ! stepped forward for the next search
cnt = cnt + 1 ! stepped forward for the next search
hp => hp%next ! stepped forward for the next search
return
endif
cnt = cnt + 1
endif
hp => hp%next
end do
!!print *,' ...not found'
result = .false. ! not found
name_save = '' ! initialize
cnt = 1 ! initialize
end function histpl_find
| Function : | |||
| result : | type(HIST_EACHVAR),pointer | ||
| histpl : | type(HIST_LINK),pointer
|
function histpl_last(histpl) result(result)
implicit none
type(HIST_EACHVAR),pointer :: result
type(HIST_LINK),pointer :: histpl ! intent(in)
!
type(HIST_LINK),pointer :: hp
hp => histpl_to_the_end(histpl)
result => hp%hist
end function histpl_last
| Subroutine : | |||
| histpl : | type(HIST_LINK),pointer
| ||
| hist : | type(HIST_EACHVAR),intent(in) |
subroutine histpl_push(histpl, hist)
implicit none
type(HIST_LINK),pointer :: histpl ! intent(in)
type(HIST_EACHVAR),intent(in) :: hist
!
type(HIST_LINK),pointer :: hp, nxt
hp => histpl_to_the_end(histpl)
if ( .not. associated(hp) ) then
! must be the first time
allocate(hp) ! always new allocation
histpl => hp
else
allocate(nxt)
hp%next => nxt
hp => nxt
endif
hp%hist = hist
hp%name = hist%name
end subroutine histpl_push
| Function : | |||
| result : | type(HIST_LINK),pointer | ||
| histpl : | type(HIST_LINK),pointer
|
function histpl_to_the_end(histpl) result(result)
type(HIST_LINK),pointer :: result
type(HIST_LINK),pointer :: histpl ! intent(in)
result => histpl
do while (associated(result))
if (associated(result%next)) then
result => result%next
else
exit
endif
end do
end function histpl_to_the_end
| Function : | |
| result : | character(len=STRING) |
| file : | character(len=*), intent(in) |
| proc : | character(len=*), intent(in) |
| time : | real, intent(in), optional |
function merge_file_proc_time(file,proc,time) result(result)
implicit none
character(len=STRING) :: result
character(len=*), intent(in) :: file
character(len=*), intent(in) :: proc
real, intent(in), optional :: time
!
integer :: idx
character(len=TOKEN) :: ctime
character(len=10) :: fmt
!
if(.not.present(time)) then
ctime = ""
else
if (aint(time) == time) then
fmt = "(I)"
write(ctime,fmt=fmt) nint(time)
idx = index(ctime, '.')
if (idx>0) ctime = ctime(1:idx-1)
else
write(ctime,*) time
endif
ctime = '_t'//adjustl(ctime)//'-'
endif
!
if (proc == "") then
result = file
else
idx = index(file, '.nc', .true.) ! tru -> search the right-most match
if (idx == 0) then
result = trim(file) // trim(adjustl(proc))
else if (idx /= 1) then
result = file(1:idx-1) // trim(adjustl(proc)) // '.nc'
else
result = trim(adjustl(proc)) // '.nc'
endif
endif
if (ctime == "") then
! do nothing
else
idx = index(result, '.nc', .true.) !tru-> search the right-most match
if (idx == 0) then
result = trim(result) // trim(adjustl(ctime))
else if (idx /= 1) then
result = result(1:idx-1) // trim(adjustl(ctime)) // '.nc'
else
result = trim(adjustl(ctime)) // '.nc'
endif
endif
end function merge_file_proc_time
| Function : | |
| result : | logical |
| arg : | character(len=*),intent(in),optional |
function present_and_not_empty(arg) result(result)
logical :: result
character(len=*),intent(in),optional :: arg
if(present(arg)) then
if(arg/="") then
result=.true.
else
result=.false.
endif
else
result=.false.
endif
end function present_and_not_empty