| Path: | gtool/gtool_history/historyput.F90 |
| Last Update: | Tue Jun 02 00:17:20 +0900 2009 |
| Authors: | Yasuhiro MORIKAWA, Eizi TOYODA |
| Version: | $Id: historyput.F90,v 1.4 2009-06-01 15:17:20 morikawa Exp $ |
| Tag Name: | $Name: gtool5-20090602 $ |
| Copyright: | Copyright (C) GFD Dennou Club, 2000-2009. All rights reserved. |
| License: | See COPYRIGHT |
以下のサブルーチン, 関数は gtool_history から gtool_history_generic#HistoryPut もしくは gtool_history_generic#HistoryPutPointer として提供されます.
Following subroutines and functions are provided as gtool_history_generic#HistoryPut or gtool_history_generic#HistoryPutPointer from gtool_history.
| Subroutine : | |||
| varname : | character(*), intent(in)
| ||
| array(:) : | real(DP), intent(in)
| ||
| history : | type(GT_HISTORY), intent(inout), optional, target
| ||
| err : | logical, intent(out), optional
|
MPI 使用時に, 各々のノード上のデータを単一ファイルに 集約して出力する場合には, このサブルーチンに領域全体の座標データを与えてください. また, HistoryCreate のオプショナル論理型引数 flag_mpi_gather に .true. を与えてください.
HistoryPut よりも後に使用してください HistoryAddVariable, HistoryAddAttr よりも前に使用してください.
When MPI is used, if data on each node is integrated and output to one file, give data of axes in whole area to this subroutine. And give .true. to optional logical argument flag_mpi_gather in "HistoryCreate".
Use this subroutine after "HistoryPut", and before "HistoryAddVariable", "HistoryAddAttr".
subroutine HistoryPutAxisMPIDouble( varname, array, history, err )
!
! MPI 使用時に, 各々のノード上のデータを単一ファイルに
! 集約して出力する場合には,
! このサブルーチンに領域全体の座標データを与えてください.
! また, HistoryCreate のオプショナル論理型引数 *flag_mpi_gather*
! に .true. を与えてください.
!
! HistoryPut よりも後に使用してください
! HistoryAddVariable, HistoryAddAttr よりも前に使用してください.
!
! When MPI is used, if data on each node is integrated and
! output to one file, give data of axes in whole area to
! this subroutine.
! And give .true. to optional logical argument *flag_mpi_gather*
! in "HistoryCreate".
!
! Use this subroutine after "HistoryPut", and
! before "HistoryAddVariable", "HistoryAddAttr".
!
use gtool_history_generic, only: HistoryAxisInquire
use gtdata_generic, only: Create, Put_Attr, Put
use gtdata_types, only: GT_VARIABLE
use dc_error, only: StoreError, DC_NOERR, DC_ENOTINIT, GT_EBADDIMNAME
use dc_url, only: UrlMerge
use dc_date_generic, only: EvalByUnit
use dc_date_types, only: DC_DIFFTIME
use dc_string, only: toChar, LChar, StrHead
use dc_message, only: MessageNotify
use gtool_history_types, only: GT_HISTORY, GT_HISTORY_AXIS, GT_HISTORY_VARINFO, GT_HISTORY_ATTR
use gtool_history_internal, only: default
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_types, only: STRING, TOKEN, DP
implicit none
character(*), intent(in):: varname
! 座標変数の名称.
!
! ここで指定するものは, HistoryCreate の
! 引数 *dims* で既に指定されてい
! なければなりません.
!
! Name of dimensional variable.
!
! This name must be specified by
! an argument *dims* in "HistoryCreate".
!
real(DP), intent(in):: array(:)
! 座標データ.
!
! Data of axes.
type(GT_HISTORY), intent(inout), optional, target:: history
! 出力ファイルの設定に関する情報を
! 格納した GT_HISTORY 型変数
!
! ここに指定するものは,
! HistoryCreate によって初期設定
! されていなければなりません.
!
! A "GT_HISTORY" type variable that
! stores information about configuration of
! an output file
!
! This must be initialized by
! "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.
#ifdef LIB_MPI
type(GT_HISTORY), pointer:: hst =>null()
integer:: dimord, dimsize, numdims, i, j, attr_size
type(GT_HISTORY_ATTR), pointer:: attrs(:) =>null()
type(GT_VARIABLE):: dimvar
character(STRING):: dimname
character(STRING):: name, longname, units, xtype, origin_str, url
real(DP):: origin_work
#endif
integer:: stat
character(STRING):: cause_c
character(*), parameter:: subname = "HistoryPutAxisMPIDouble"
continue
call BeginSub(subname, 'varname=%c', c1 = trim(varname) )
stat = DC_NOERR
cause_c = ""
#ifndef LIB_MPI
call DbgMessage('This library is not built with MPI library')
goto 999
#else
if (present(history)) then
hst => history
else
hst => default
endif
if ( .not. hst % initialized ) then
stat = DC_ENOTINIT
cause_c = 'GT_HISTORY'
goto 999
end if
call DbgMessage( 'mpi_gather=<%b>', l = (/ hst % mpi_gather /) )
if ( .not. hst % mpi_gather ) then
goto 999
else
numdims = size( hst % dimvars )
dimord = -1
do i = 1, numdims
call HistoryAxisInquire( hst % mpi_fileinfo % axes(i), name = dimname ) ! (out)
if ( trim(varname) == trim(dimname) ) then
dimord = i
exit
end if
end do
if ( dimord < 1 ) then
stat = GT_EBADDIMNAME
cause_c = varname
goto 999
end if
dimsize = size( array )
if ( associated( hst % mpi_dimdata_all( dimord ) % a_Axis ) ) then
deallocate( hst % mpi_dimdata_all( dimord ) % a_Axis )
end if
allocate( hst % mpi_dimdata_all( dimord ) % a_Axis(dimsize) )
hst % mpi_dimdata_all( dimord ) % a_Axis = array
hst % mpi_dimdata_all( dimord ) % length = dimsize
end if
! 全ての (時刻以外の) 座標データが登録されたらファイル出力
! Output file if data of all axes (excluding time) are registered
!
numdims = size( hst % dimvars )
do i = 1, numdims
if ( hst % unlimited_index == i ) cycle
if ( hst % time_nv_index == i ) cycle
if ( hst % mpi_dimdata_all( i ) % length < 1 ) goto 999
end do
if ( hst % mpi_myrank /= 0 ) goto 2000
if ( hst % mpi_fileinfo % already_output ) goto 999
do i = 1, numdims
call HistoryAxisInquire( hst % mpi_fileinfo % axes(i), name, dimsize, longname, units, xtype ) ! (out)
url = UrlMerge(file = hst % mpi_fileinfo % file, var = name)
! 座標の長さを, このサブルーチンで取得したものに修正
! Length of axes is modified to one that is gotten by this subroutine
!
if ( hst % unlimited_index /= i ) then
dimsize = hst % mpi_dimdata_all( i ) % length
end if
! ファイル作成
! Create file
!
call Create( hst % dimvars(i), trim(url), dimsize, xtype = xtype, overwrite = hst % mpi_fileinfo % overwrite )
! 属性の付加
! Add attributes
!
call Put_Attr(hst % dimvars(i), '+Conventions', trim(hst % mpi_fileinfo % conventions ))
if ( hst % mpi_fileinfo % gtver_add ) then
call Put_Attr(hst % dimvars(i), '+gt_version', trim(hst % mpi_fileinfo % gt_version ))
endif
! title, source, institution, history, long_name, units 属性の付加
call Put_Attr(hst % dimvars(i), '+title', hst % mpi_fileinfo % title)
call Put_Attr(hst % dimvars(i), '+source', hst % mpi_fileinfo % source)
call Put_Attr(hst % dimvars(i), '+institution', trim(hst % mpi_fileinfo % institution))
call Put_Attr(hst % dimvars(i), '+history', trim(hst % mpi_fileinfo % nc_history))
call Put_Attr(hst % dimvars(i), 'long_name', longname)
call Put_Attr(hst % dimvars(i), 'units', units)
origin_work = EvalByUnit( hst % origin, '', hst % unlimited_units_symbol )
origin_str = trim( toChar( origin_work ) ) // ' [' // trim( hst % unlimited_units ) // ']'
! 座標データの出力
! Output data of axes
!
if ( hst % unlimited_index /= i ) then
call Put(hst % dimvars(i), hst % mpi_dimdata_all( i ) % a_Axis, dimsize )
hst % dim_value_written(i) = .true.
end if
! 座標の属性の付加
! Add attributes of axes
!
attrs => hst % mpi_dimdata_all(i) % attrs
if ( associated( attrs ) ) then
attr_size = size( attrs )
do j = 1, attr_size
if ( StrHead( 'char', trim(LChar(attrs(j)%attrtype))) ) then
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, trim( attrs(j) % Charvalue ) )
elseif ( StrHead( 'int', trim(LChar(attrs(j)%attrtype))) ) then
if ( attrs(j)%array ) then
call DbgMessage('Intarray(:) is selected.')
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, attrs(j) % Intarray )
else
call DbgMessage('Intvalue is selected')
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, (/attrs(j) % Intvalue/) )
endif
elseif ( StrHead( 'real', trim(LChar(attrs(j)%attrtype))) ) then
if ( attrs(j)%array ) then
call DbgMessage('Realarray(:) is selected.')
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, attrs(j) % Realarray )
else
call DbgMessage('Realvalue is selected')
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, (/attrs(j) % Realvalue/) )
endif
elseif ( StrHead( 'double', trim(LChar(attrs(j)%attrtype))) ) then
if ( attrs(j)%array ) then
call DbgMessage('Doublearray(:) is selected.')
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, attrs(j) % Doublearray )
else
call DbgMessage('Doublevalue is selected')
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, (/attrs(j) % Doublevalue/) )
endif
elseif ( StrHead( 'logical', trim(LChar(attrs(j)%attrtype))) ) then
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, attrs(j) % Logicalvalue )
else
call DbgMessage('attrtype=<%c>=<%c>is Invalid.' , c1=trim(attrs(j)%attrtype) , c2=trim(LChar(attrs(j)%attrtype)) )
endif
end do
end if
end do
if ( .not. hst % mpi_fileinfo % quiet ) then
call MessageNotify('M', subname, '"%c" is created (origin=%c)', c1 = trim( hst % mpi_fileinfo % file ), c2 = trim( origin_str ) )
end if
2000 continue
hst % mpi_fileinfo % already_output = .true.
#endif
! 終了処理, 例外処理
! Termination and Exception handling
!
999 continue
call StoreError( stat, subname, err, cause_c )
call EndSub(subname)
end subroutine HistoryPutAxisMPIDouble
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:) : | integer, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| err : | logical, intent(out), optional |
MPI 使用時に, 各々のノード上のデータを単一ファイルに 集約して出力する場合には, このサブルーチンに領域全体の座標データを与えてください. また, HistoryCreate のオプショナル論理型引数 flag_mpi_gather に .true. を与えてください.
HistoryPut よりも後に使用してください HistoryAddVariable, HistoryAddAttr よりも前に使用してください.
When MPI is used, if data on each node is integrated and output to one file, give data of axes in whole area to this subroutine. And give .true. to optional logical argument flag_mpi_gather in "HistoryCreate".
Use this subroutine after "HistoryPut", and before "HistoryAddVariable", "HistoryAddAttr".
subroutine HistoryPutAxisMPIInt( varname, array, history, err )
!
! MPI 使用時に, 各々のノード上のデータを単一ファイルに
! 集約して出力する場合には,
! このサブルーチンに領域全体の座標データを与えてください.
! また, HistoryCreate のオプショナル論理型引数 *flag_mpi_gather*
! に .true. を与えてください.
!
! HistoryPut よりも後に使用してください
! HistoryAddVariable, HistoryAddAttr よりも前に使用してください.
!
! When MPI is used, if data on each node is integrated and
! output to one file, give data of axes in whole area to
! this subroutine.
! And give .true. to optional logical argument *flag_mpi_gather*
! in "HistoryCreate".
!
! Use this subroutine after "HistoryPut", and
! before "HistoryAddVariable", "HistoryAddAttr".
!
use gtool_history_generic, only: HistoryAxisInquire
use gtdata_generic, only: Create, Put_Attr, Put
use gtdata_types, only: GT_VARIABLE
use dc_error, only: StoreError, DC_NOERR, DC_ENOTINIT, GT_EBADDIMNAME
use dc_url, only: UrlMerge
use dc_date_generic, only: EvalByUnit
use dc_date_types, only: DC_DIFFTIME
use dc_string, only: toChar, LChar, StrHead
use dc_message, only: MessageNotify
use gtool_history_types, only: GT_HISTORY, GT_HISTORY_AXIS, GT_HISTORY_VARINFO, GT_HISTORY_ATTR
use gtool_history_internal, only: default
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_types, only: STRING, TOKEN, DP
implicit none
character(*), intent(in):: varname
integer, intent(in):: array(:)
type(GT_HISTORY), intent(inout), optional, target:: history
logical, intent(out), optional:: err
#ifdef LIB_MPI
type(GT_HISTORY), pointer:: hst =>null()
integer:: dimord, dimsize, numdims, i, j, attr_size
type(GT_HISTORY_ATTR), pointer:: attrs(:) =>null()
type(GT_VARIABLE):: dimvar
character(STRING):: dimname
character(STRING):: name, longname, units, xtype, origin_str, url
real(DP):: origin_work
#endif
integer:: stat
character(STRING):: cause_c
character(*), parameter:: subname = "HistoryPutAxisMPIInt"
continue
call BeginSub(subname, 'varname=%c', c1 = trim(varname) )
stat = DC_NOERR
cause_c = ""
#ifndef LIB_MPI
call DbgMessage('This library is not built with MPI library')
goto 999
#else
if (present(history)) then
hst => history
else
hst => default
endif
if ( .not. hst % initialized ) then
stat = DC_ENOTINIT
cause_c = 'GT_HISTORY'
goto 999
end if
call DbgMessage( 'mpi_gather=<%b>', l = (/ hst % mpi_gather /) )
if ( .not. hst % mpi_gather ) then
goto 999
else
numdims = size( hst % dimvars )
dimord = -1
do i = 1, numdims
call HistoryAxisInquire( hst % mpi_fileinfo % axes(i), name = dimname ) ! (out)
if ( trim(varname) == trim(dimname) ) then
dimord = i
exit
end if
end do
if ( dimord < 1 ) then
stat = GT_EBADDIMNAME
cause_c = varname
goto 999
end if
dimsize = size( array )
if ( associated( hst % mpi_dimdata_all( dimord ) % a_Axis ) ) then
deallocate( hst % mpi_dimdata_all( dimord ) % a_Axis )
end if
allocate( hst % mpi_dimdata_all( dimord ) % a_Axis(dimsize) )
hst % mpi_dimdata_all( dimord ) % a_Axis = array
hst % mpi_dimdata_all( dimord ) % length = dimsize
end if
! 全ての (時刻以外の) 座標データが登録されたらファイル出力
! Output file if data of all axes (excluding time) are registered
!
numdims = size( hst % dimvars )
do i = 1, numdims
if ( hst % unlimited_index == i ) cycle
if ( hst % time_nv_index == i ) cycle
if ( hst % mpi_dimdata_all( i ) % length < 1 ) goto 999
end do
if ( hst % mpi_myrank /= 0 ) goto 2000
if ( hst % mpi_fileinfo % already_output ) goto 999
do i = 1, numdims
call HistoryAxisInquire( hst % mpi_fileinfo % axes(i), name, dimsize, longname, units, xtype ) ! (out)
url = UrlMerge(file = hst % mpi_fileinfo % file, var = name)
! 座標の長さを, このサブルーチンで取得したものに修正
! Length of axes is modified to one that is gotten by this subroutine
!
if ( hst % unlimited_index /= i ) then
dimsize = hst % mpi_dimdata_all( i ) % length
end if
! ファイル作成
! Create file
!
call Create( hst % dimvars(i), trim(url), dimsize, xtype = xtype, overwrite = hst % mpi_fileinfo % overwrite )
! 属性の付加
! Add attributes
!
call Put_Attr(hst % dimvars(i), '+Conventions', trim(hst % mpi_fileinfo % conventions ))
if ( hst % mpi_fileinfo % gtver_add ) then
call Put_Attr(hst % dimvars(i), '+gt_version', trim(hst % mpi_fileinfo % gt_version ))
endif
! title, source, institution, history, long_name, units 属性の付加
call Put_Attr(hst % dimvars(i), '+title', hst % mpi_fileinfo % title)
call Put_Attr(hst % dimvars(i), '+source', hst % mpi_fileinfo % source)
call Put_Attr(hst % dimvars(i), '+institution', trim(hst % mpi_fileinfo % institution))
call Put_Attr(hst % dimvars(i), '+history', trim(hst % mpi_fileinfo % nc_history))
call Put_Attr(hst % dimvars(i), 'long_name', longname)
call Put_Attr(hst % dimvars(i), 'units', units)
origin_work = EvalByUnit( hst % origin, '', hst % unlimited_units_symbol )
origin_str = trim( toChar( origin_work ) ) // ' [' // trim( hst % unlimited_units ) // ']'
! 座標データの出力
! Output data of axes
!
if ( hst % unlimited_index /= i ) then
call Put(hst % dimvars(i), hst % mpi_dimdata_all( i ) % a_Axis, dimsize )
hst % dim_value_written(i) = .true.
end if
! 座標の属性の付加
! Add attributes of axes
!
attrs => hst % mpi_dimdata_all(i) % attrs
if ( associated( attrs ) ) then
attr_size = size( attrs )
do j = 1, attr_size
if ( StrHead( 'char', trim(LChar(attrs(j)%attrtype))) ) then
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, trim( attrs(j) % Charvalue ) )
elseif ( StrHead( 'int', trim(LChar(attrs(j)%attrtype))) ) then
if ( attrs(j)%array ) then
call DbgMessage('Intarray(:) is selected.')
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, attrs(j) % Intarray )
else
call DbgMessage('Intvalue is selected')
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, (/attrs(j) % Intvalue/) )
endif
elseif ( StrHead( 'real', trim(LChar(attrs(j)%attrtype))) ) then
if ( attrs(j)%array ) then
call DbgMessage('Realarray(:) is selected.')
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, attrs(j) % Realarray )
else
call DbgMessage('Realvalue is selected')
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, (/attrs(j) % Realvalue/) )
endif
elseif ( StrHead( 'double', trim(LChar(attrs(j)%attrtype))) ) then
if ( attrs(j)%array ) then
call DbgMessage('Doublearray(:) is selected.')
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, attrs(j) % Doublearray )
else
call DbgMessage('Doublevalue is selected')
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, (/attrs(j) % Doublevalue/) )
endif
elseif ( StrHead( 'logical', trim(LChar(attrs(j)%attrtype))) ) then
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, attrs(j) % Logicalvalue )
else
call DbgMessage('attrtype=<%c>=<%c>is Invalid.' , c1=trim(attrs(j)%attrtype) , c2=trim(LChar(attrs(j)%attrtype)) )
endif
end do
end if
end do
if ( .not. hst % mpi_fileinfo % quiet ) then
call MessageNotify('M', subname, '"%c" is created (origin=%c)', c1 = trim( hst % mpi_fileinfo % file ), c2 = trim( origin_str ) )
end if
2000 continue
hst % mpi_fileinfo % already_output = .true.
#endif
! 終了処理, 例外処理
! Termination and Exception handling
!
999 continue
call StoreError( stat, subname, err, cause_c )
call EndSub(subname)
end subroutine HistoryPutAxisMPIInt
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:) : | real, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| err : | logical, intent(out), optional |
MPI 使用時に, 各々のノード上のデータを単一ファイルに 集約して出力する場合には, このサブルーチンに領域全体の座標データを与えてください. また, HistoryCreate のオプショナル論理型引数 flag_mpi_gather に .true. を与えてください.
HistoryPut よりも後に使用してください HistoryAddVariable, HistoryAddAttr よりも前に使用してください.
When MPI is used, if data on each node is integrated and output to one file, give data of axes in whole area to this subroutine. And give .true. to optional logical argument flag_mpi_gather in "HistoryCreate".
Use this subroutine after "HistoryPut", and before "HistoryAddVariable", "HistoryAddAttr".
subroutine HistoryPutAxisMPIReal( varname, array, history, err )
!
! MPI 使用時に, 各々のノード上のデータを単一ファイルに
! 集約して出力する場合には,
! このサブルーチンに領域全体の座標データを与えてください.
! また, HistoryCreate のオプショナル論理型引数 *flag_mpi_gather*
! に .true. を与えてください.
!
! HistoryPut よりも後に使用してください
! HistoryAddVariable, HistoryAddAttr よりも前に使用してください.
!
! When MPI is used, if data on each node is integrated and
! output to one file, give data of axes in whole area to
! this subroutine.
! And give .true. to optional logical argument *flag_mpi_gather*
! in "HistoryCreate".
!
! Use this subroutine after "HistoryPut", and
! before "HistoryAddVariable", "HistoryAddAttr".
!
use gtool_history_generic, only: HistoryAxisInquire
use gtdata_generic, only: Create, Put_Attr, Put
use gtdata_types, only: GT_VARIABLE
use dc_error, only: StoreError, DC_NOERR, DC_ENOTINIT, GT_EBADDIMNAME
use dc_url, only: UrlMerge
use dc_date_generic, only: EvalByUnit
use dc_date_types, only: DC_DIFFTIME
use dc_string, only: toChar, LChar, StrHead
use dc_message, only: MessageNotify
use gtool_history_types, only: GT_HISTORY, GT_HISTORY_AXIS, GT_HISTORY_VARINFO, GT_HISTORY_ATTR
use gtool_history_internal, only: default
use dc_trace, only: BeginSub, EndSub, DbgMessage
use dc_types, only: STRING, TOKEN, DP
implicit none
character(*), intent(in):: varname
real, intent(in):: array(:)
type(GT_HISTORY), intent(inout), optional, target:: history
logical, intent(out), optional:: err
#ifdef LIB_MPI
type(GT_HISTORY), pointer:: hst =>null()
integer:: dimord, dimsize, numdims, i, j, attr_size
type(GT_HISTORY_ATTR), pointer:: attrs(:) =>null()
type(GT_VARIABLE):: dimvar
character(STRING):: dimname
character(STRING):: name, longname, units, xtype, origin_str, url
real(DP):: origin_work
#endif
integer:: stat
character(STRING):: cause_c
character(*), parameter:: subname = "HistoryPutAxisMPIReal"
continue
call BeginSub(subname, 'varname=%c', c1 = trim(varname) )
stat = DC_NOERR
cause_c = ""
#ifndef LIB_MPI
call DbgMessage('This library is not built with MPI library')
goto 999
#else
if (present(history)) then
hst => history
else
hst => default
endif
if ( .not. hst % initialized ) then
stat = DC_ENOTINIT
cause_c = 'GT_HISTORY'
goto 999
end if
call DbgMessage( 'mpi_gather=<%b>', l = (/ hst % mpi_gather /) )
if ( .not. hst % mpi_gather ) then
goto 999
else
numdims = size( hst % dimvars )
dimord = -1
do i = 1, numdims
call HistoryAxisInquire( hst % mpi_fileinfo % axes(i), name = dimname ) ! (out)
if ( trim(varname) == trim(dimname) ) then
dimord = i
exit
end if
end do
if ( dimord < 1 ) then
stat = GT_EBADDIMNAME
cause_c = varname
goto 999
end if
dimsize = size( array )
if ( associated( hst % mpi_dimdata_all( dimord ) % a_Axis ) ) then
deallocate( hst % mpi_dimdata_all( dimord ) % a_Axis )
end if
allocate( hst % mpi_dimdata_all( dimord ) % a_Axis(dimsize) )
hst % mpi_dimdata_all( dimord ) % a_Axis = array
hst % mpi_dimdata_all( dimord ) % length = dimsize
end if
! 全ての (時刻以外の) 座標データが登録されたらファイル出力
! Output file if data of all axes (excluding time) are registered
!
numdims = size( hst % dimvars )
do i = 1, numdims
if ( hst % unlimited_index == i ) cycle
if ( hst % time_nv_index == i ) cycle
if ( hst % mpi_dimdata_all( i ) % length < 1 ) goto 999
end do
if ( hst % mpi_myrank /= 0 ) goto 2000
if ( hst % mpi_fileinfo % already_output ) goto 999
do i = 1, numdims
call HistoryAxisInquire( hst % mpi_fileinfo % axes(i), name, dimsize, longname, units, xtype ) ! (out)
url = UrlMerge(file = hst % mpi_fileinfo % file, var = name)
! 座標の長さを, このサブルーチンで取得したものに修正
! Length of axes is modified to one that is gotten by this subroutine
!
if ( hst % unlimited_index /= i ) then
dimsize = hst % mpi_dimdata_all( i ) % length
end if
! ファイル作成
! Create file
!
call Create( hst % dimvars(i), trim(url), dimsize, xtype = xtype, overwrite = hst % mpi_fileinfo % overwrite )
! 属性の付加
! Add attributes
!
call Put_Attr(hst % dimvars(i), '+Conventions', trim(hst % mpi_fileinfo % conventions ))
if ( hst % mpi_fileinfo % gtver_add ) then
call Put_Attr(hst % dimvars(i), '+gt_version', trim(hst % mpi_fileinfo % gt_version ))
endif
! title, source, institution, history, long_name, units 属性の付加
call Put_Attr(hst % dimvars(i), '+title', hst % mpi_fileinfo % title)
call Put_Attr(hst % dimvars(i), '+source', hst % mpi_fileinfo % source)
call Put_Attr(hst % dimvars(i), '+institution', trim(hst % mpi_fileinfo % institution))
call Put_Attr(hst % dimvars(i), '+history', trim(hst % mpi_fileinfo % nc_history))
call Put_Attr(hst % dimvars(i), 'long_name', longname)
call Put_Attr(hst % dimvars(i), 'units', units)
origin_work = EvalByUnit( hst % origin, '', hst % unlimited_units_symbol )
origin_str = trim( toChar( origin_work ) ) // ' [' // trim( hst % unlimited_units ) // ']'
! 座標データの出力
! Output data of axes
!
if ( hst % unlimited_index /= i ) then
call Put(hst % dimvars(i), hst % mpi_dimdata_all( i ) % a_Axis, dimsize )
hst % dim_value_written(i) = .true.
end if
! 座標の属性の付加
! Add attributes of axes
!
attrs => hst % mpi_dimdata_all(i) % attrs
if ( associated( attrs ) ) then
attr_size = size( attrs )
do j = 1, attr_size
if ( StrHead( 'char', trim(LChar(attrs(j)%attrtype))) ) then
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, trim( attrs(j) % Charvalue ) )
elseif ( StrHead( 'int', trim(LChar(attrs(j)%attrtype))) ) then
if ( attrs(j)%array ) then
call DbgMessage('Intarray(:) is selected.')
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, attrs(j) % Intarray )
else
call DbgMessage('Intvalue is selected')
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, (/attrs(j) % Intvalue/) )
endif
elseif ( StrHead( 'real', trim(LChar(attrs(j)%attrtype))) ) then
if ( attrs(j)%array ) then
call DbgMessage('Realarray(:) is selected.')
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, attrs(j) % Realarray )
else
call DbgMessage('Realvalue is selected')
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, (/attrs(j) % Realvalue/) )
endif
elseif ( StrHead( 'double', trim(LChar(attrs(j)%attrtype))) ) then
if ( attrs(j)%array ) then
call DbgMessage('Doublearray(:) is selected.')
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, attrs(j) % Doublearray )
else
call DbgMessage('Doublevalue is selected')
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, (/attrs(j) % Doublevalue/) )
endif
elseif ( StrHead( 'logical', trim(LChar(attrs(j)%attrtype))) ) then
call Put_Attr(hst % dimvars(i), attrs(j) % attrname, attrs(j) % Logicalvalue )
else
call DbgMessage('attrtype=<%c>=<%c>is Invalid.' , c1=trim(attrs(j)%attrtype) , c2=trim(LChar(attrs(j)%attrtype)) )
endif
end do
end if
end do
if ( .not. hst % mpi_fileinfo % quiet ) then
call MessageNotify('M', subname, '"%c" is created (origin=%c)', c1 = trim( hst % mpi_fileinfo % file ), c2 = trim( origin_str ) )
end if
2000 continue
hst % mpi_fileinfo % already_output = .true.
#endif
! 終了処理, 例外処理
! Termination and Exception handling
!
999 continue
call StoreError( stat, subname, err, cause_c )
call EndSub(subname)
end subroutine HistoryPutAxisMPIReal
| Subroutine : | |
| varname : | character(*), intent(in) |
| value : | real(DP), intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutDouble0( varname, value, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
real(DP), intent(in):: value
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutDouble0"
continue
call BeginSub(subname)
call HistoryPutDoubleEx( varname, (/value/), 1, history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |||
| varname : | character(*), intent(in)
| ||
| array(:) : | real(DP), intent(in)
| ||
| history : | type(GT_HISTORY), intent(inout), optional, target
| ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
gtool4 データ内の変数へデータの出力を行います。 このサブルーチンを用いる前に、HistoryCreate による初期設定が必要です。
HistoryPut は複数のサブルーチンの総称名です。array には 0 〜 7 次元のデータを与えることが可能です。 (下記のサブルーチンを参照ください)。 ただし、0 次元のデータを与える際の引数キーワードは value を用いてください。
HistoryPut を最初に呼んだ時、時間次元の変数は HistoryCreate の origin の値に設定されます。
ある変数 varname に対して HistoryPut を複数回呼ぶと、 HistoryCreate の interval × HistoryPut を呼んだ回数、 の分だけ 時間次元の変数の値が増やされます。
これらの時間次元の変数の値を明示的に設定したい場合は HistorySetTime を用いるか、HistoryPut 自身で時間次元の変数へ値 を出力してください。
subroutine HistoryPutDouble1( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
!== データ出力
!
! gtool4 データ内の変数へデータの出力を行います。
! このサブルーチンを用いる前に、HistoryCreate
! による初期設定が必要です。
!
! *HistoryPut* は複数のサブルーチンの総称名です。*array* には
! 0 〜 7 次元のデータを与えることが可能です。
! (下記のサブルーチンを参照ください)。
! ただし、0 次元のデータを与える際の引数キーワードは
! *value* を用いてください。
!
! HistoryPut を最初に呼んだ時、時間次元の変数は HistoryCreate の
! origin の値に設定されます。
!
! ある変数 varname に対して HistoryPut を複数回呼ぶと、
! HistoryCreate の interval × HistoryPut を呼んだ回数、 の分だけ
! 時間次元の変数の値が増やされます。
!
! これらの時間次元の変数の値を明示的に設定したい場合は
! HistorySetTime を用いるか、HistoryPut 自身で時間次元の変数へ値
! を出力してください。
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
! 変数の名前
!
! ただし、ここで指定するもの
! は、 HistoryCreateの *dims*
! または HistoryAddVariable や
! HistoryCopyVariable の
! *varname* で既に指定されてい
! なければなりません。
!
real(DP), intent(in):: array(:)
! 変数が出力するデータ
!
! 型は単精度実数型でも
! 倍精度実数型でもよいですが、
! HistoryAddVariable の
! *xtype* で指定した
! データ型と異なる
! 型を渡した場合、xtype で
! 指定した型に変換されます。
!
type(GT_HISTORY), intent(inout), optional, target:: history
! 出力ファイルの設定に関する情報を
! 格納した構造体
!
! ここに指定するものは、
! HistoryCreate によって初期設定
! されていなければなりません。
!
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 で
! *time_average* (または *average*)
! に .true. を与えた場合には,
! *time*, *difftime*
! のどちらの引数も与えない場合に,
! プログラムはエラーを発生させます.
!
! この引数と *difftime*, *time_average_store*
! が同時に与えられた場合,
! *time_average_store* が優先されます.
!
! また, この引数と *range* は併用できません.
! 併用した場合には,
! プログラムはエラーを発生させます.
!
logical, intent(in), optional:: quiet
! .true. を与えた場合,
! メッセージ出力が抑制されます.
!
! If ".true." is given,
! messages are suppressed.
!
type(DC_DIFFTIME), intent(in), optional:: difftime
!
! 時刻 (dc_date_types#DC_DIFFTIME 型)
!
! この引数を与える場合,
! 出力するかどうかをプログラムが
! 自動的に判断します.
! *difftime* に与えられた時刻が
! HistoryCreate に与えた *interval*
! で割り切れる場合には出力が行われます.
!
! HistoryAddVariable で
! *time_average* (または *average*)
! に .true. を与えた場合には,
! *time*, *difftime*
! のどちらの引数も与えない場合に,
! プログラムはエラーを発生させます.
!
! この引数と *time* が与えられた場合,
! *difftime* が優先されます.
!
! この引数と *range* は併用できません.
! 併用した場合には,
! プログラムはエラーを発生させます.
!
logical, intent(in), optional:: time_average_store
!
! 平均値の出力フラグ.
! この値に .true. を与えた場合には,
! 出力せずに与えられた値を一旦蓄えます.
! .false. を与えた場合には,
! *time* もしくは *difftime* と
! HistoryCreate に与えた *interval* に
! 関わらず出力を行います.
!
! HistoryAddVariable で
! *time_average* (または *average*)
! に .true. を与えない場合は無効です.
!
! *time* と *difftime*
! のどちらかを同時に与える必要があります.
!
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(*), parameter:: subname = "HistoryPutDouble1"
continue
call BeginSub(subname)
call HistoryPutDoubleEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:,:) : | real(DP), intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutDouble2( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
real(DP), intent(in):: array(:,:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutDouble2"
continue
call BeginSub(subname)
call HistoryPutDoubleEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:,:,:) : | real(DP), intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutDouble3( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
real(DP), intent(in):: array(:,:,:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutDouble3"
continue
call BeginSub(subname)
call HistoryPutDoubleEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:,:,:,:) : | real(DP), intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutDouble4( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
real(DP), intent(in):: array(:,:,:,:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutDouble4"
continue
call BeginSub(subname)
call HistoryPutDoubleEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:,:,:,:,:) : | real(DP), intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutDouble5( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
real(DP), intent(in):: array(:,:,:,:,:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutDouble5"
continue
call BeginSub(subname)
call HistoryPutDoubleEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:,:,:,:,:,:) : | real(DP), intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutDouble6( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
real(DP), intent(in):: array(:,:,:,:,:,:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutDouble6"
continue
call BeginSub(subname)
call HistoryPutDoubleEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:,:,:,:,:,:,:) : | real(DP), intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutDouble7( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
real(DP), intent(in):: array(:,:,:,:,:,:,:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutDouble7"
continue
call BeginSub(subname)
call HistoryPutDoubleEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | real(DP), intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
recursive subroutine HistoryPutDoubleEx( varname, array, arraysize, history, range, time, quiet, difftime, time_average_store, err )
!
!== データ出力
!
! こちらは配列サイズを指定する必要があるため、
! HistoryPut を利用してください。
!
use gtool_history_types, only: GT_HISTORY
use gtool_history_generic, only: HistoryAxisInquire
use gtool_history_internal, only: default, lookup_variable_ord
#ifdef LIB_MPI
use gtool_history_internal, only: gtmpi_axis_register, gtmpi_vars_mkindex
#endif
use gtdata_generic, only: Put, GTVarSync, Slice, Inquire, Get_Slice, Get, PutLine, Open, Close
use gtdata_types, only: GT_VARIABLE
use dc_types, only: STRING, DP
use dc_string, only: StoA, Printf, toChar, JoinChar
use dc_present, only: present_and_not_empty, present_select, present_and_false, present_and_true
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
use dc_date_types, only: DC_DIFFTIME
use dc_date_generic, only: operator(==), DCDiffTimeCreate, mod, operator(-), EvalByUnit, operator(/), toChar
use dc_trace, only: BeginSub, EndSub, DbgMessage
#ifdef LIB_MPI
use mpi
#endif
implicit none
character(*), intent(in):: varname
integer, intent(in):: arraysize
real(DP), 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 で
! *time_average* (または *average*)
! に .true. を与えた場合には,
! *time*, *difftime*
! のどちらの引数も与えない場合に,
! プログラムはエラーを発生させます.
!
! また, この引数と *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.".
!
type(DC_DIFFTIME), intent(in), optional:: difftime
!
! 時刻 (dc_date_types#DC_DIFFTIME 型)
!
! この引数を与える場合,
! 出力するかどうかをプログラムが
! 自動的に判断します.
! *difftime* に与えられた時刻が
! HistoryCreate に与えた *interval*
! で割り切れる場合には出力が行われます.
!
! HistoryAddVariable で
! *time_average* (または *average*)
! に .true. を与えた場合には,
! *time*, *difftime*
! のどちらの引数も与えない場合に,
! プログラムはエラーを発生させます.
!
! この引数と *time* が与えられた場合,
! *difftime* が優先されます.
!
! この引数と *range* は併用できません.
! 併用した場合には,
! プログラムはエラーを発生させます.
!
logical, intent(in), optional:: time_average_store
!
! 平均値の出力フラグ.
! この値に .true. を与えた場合には,
! 出力せずに与えられた値を一旦蓄えます.
! .false. を与えた場合には,
! *time* もしくは *difftime* と
! HistoryCreate に与えた *interval* に
! 関わらず出力を行います.
!
! HistoryAddVariable で
! *time_average* (または *average*)
! に .true. を与えない場合は無効です.
!
! *time* と *difftime*
! のどちらかを同時に与える必要があります.
!
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.
real(DP), target:: array_work(arraysize)
real(DP), pointer:: array_work2(:) =>null()
integer:: arraysize_work2
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
type(DC_DIFFTIME):: difftimew
real(DP):: avr_coef
#ifdef LIB_MPI
integer, allocatable:: array_overwrap(:)
integer:: new_index
type(GT_VARIABLE):: dimvar
integer:: numdims, dimord, dimsize, dimsize_max, allcount, ra
character(STRING):: dimname
integer:: err_mpi, st_mpi(MPI_STATUS_SIZE)
real(DP), allocatable:: array_mpi_tmp(:)
real(DP), allocatable:: array_mpi_all(:,:)
#endif
character(STRING):: cause_c
character(*), parameter:: subname = "HistoryPutDoubleEx"
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) .or. present(difftime) ) .and. present_and_not_empty(range) ) then
call MessageNotify('W', subname, '(varname=%c) "range" and "time" or "difftime" are not suppored at the same time', c1 = trim(varname) )
stat = USR_ERRNO
cause_c = '"range" and "time" or "difftime" are not suppored at the same time'
goto 999
end if
!-----------------------------------------------------------------
! hst 内の varname 変数の変数番号を取得
! Get variable number of "varname" in "hst"
!-----------------------------------------------------------------
#ifndef LIB_MPI
v_ord = lookup_variable_ord(hst, varname)
#else
if ( .not. hst % mpi_gather ) then
v_ord = lookup_variable_ord(hst, varname)
else
if ( hst % mpi_myrank == 0 ) then
v_ord = lookup_variable_ord(hst, varname)
end if
call MPI_Bcast( v_ord, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, err_mpi )
end if
#endif
!-----------------------------------------------------------------
! 時間平均値のためのデータ格納
! Store data for time average value
!-----------------------------------------------------------------
if ( v_ord > 0 ) then
if ( hst % var_avr_count( v_ord ) > -1 ) then
if ( .not. present(time) .and. .not. present(difftime) ) then
call MessageNotify('W', subname, '(varname=%c) arguments "time" or "difftime" are needed ' // 'when "time_average=.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
if ( .not. present(difftime) ) then
call DCDiffTimeCreate( difftimew, time, '', hst % unlimited_units_symbol ) ! (in)
else
difftimew = difftime
end if
if ( hst % var_avr_firstput( v_ord ) ) then
if ( hst % var_avr_count( v_ord ) == 0 ) then
avr_coef = 1.0_DP
hst % var_avr_prevtime( v_ord ) = difftimew
else
hst % var_avr_baseint( v_ord ) = difftimew - hst % var_avr_prevtime( v_ord )
avr_coef = 1.0_DP
hst % var_avr_prevtime( v_ord ) = difftimew
hst % var_avr_firstput( v_ord ) = .false.
end if
else
if ( hst % var_avr_count( v_ord ) == 0 ) then
hst % var_avr_baseint( v_ord ) = difftimew - hst % var_avr_prevtime( v_ord )
avr_coef = 1.0_DP
hst % var_avr_prevtime( v_ord ) = difftimew
else
avr_coef = ( difftimew - hst % var_avr_prevtime( v_ord ) ) / hst % var_avr_baseint( v_ord )
hst % var_avr_prevtime( v_ord ) = difftimew
end if
end if
hst % var_avr_data( v_ord ) % a_DataAvr = hst % var_avr_data( v_ord ) % a_DataAvr + array * avr_coef
hst % var_avr_count( v_ord ) = hst % var_avr_count( v_ord ) + 1
hst % var_avr_coefsum( v_ord ) = hst % var_avr_coefsum( v_ord ) + avr_coef
if ( present(difftime) ) then
hst % time_bnds(2:2) = EvalByUnit( difftime, '', hst % unlimited_units_symbol )
else
hst % time_bnds(2:2) = time
end if
end if
end if
!-----------------------------------------------------------------
! 初期時刻の設定
! Configure initial time
!-----------------------------------------------------------------
if ( .not. hst % origin_setting ) then
if ( present(difftime) ) then
hst % origin = difftime
hst % time_bnds = EvalByUnit( difftime, '', hst % unlimited_units_symbol )
hst % origin_setting = .true.
elseif ( present(time) ) then
call DCDiffTimeCreate( hst % origin, time, '', hst % unlimited_units_symbol ) ! (in)
hst % time_bnds = time
hst % origin_setting = .true.
end if
end if
!-----------------------------------------------------------------
! 時刻の自動チェック
! Check time automatically
!-----------------------------------------------------------------
output_step = .true.
if ( present_and_false(time_average_store) ) then
output_step = .true.
elseif ( present_and_true(time_average_store) ) then
output_step = .false.
elseif ( present(difftime) .or. present(time) ) then
output_step = .false.
if ( hst % interval == 0 ) then
output_step = .true.
else
if ( .not. present(difftime) ) then
call DCDiffTimeCreate( difftimew, time, '', hst % unlimited_units_symbol ) ! (in)
else
difftimew = difftime
end if
if ( mod( difftimew - hst % origin, hst % interval ) == 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 = ''
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_coefsum( v_ord ) )
hst % var_avr_data( v_ord ) % a_DataAvr = 0.0
hst % var_avr_count( v_ord ) = 0
hst % var_avr_coefsum( v_ord ) = 0.0_DP
hst % var_avr_firstput( v_ord ) = .false.
end if
end if
end if
#ifndef LIB_MPI
array_work2 => array_work
arraysize_work2 = arraysize
#else
if ( .not. hst % mpi_gather ) then
array_work2 => array_work
arraysize_work2 = arraysize
else
!-----------------------------------------------------------------
! MPI 使用時に, 座標軸のデータが与えられた場合には, そのデータを保管.
! If data of axis is given, the data is stored when MPI is used
!-----------------------------------------------------------------
numdims = size( hst % mpi_fileinfo % axes )
if ( hst % mpi_myrank == 0 ) then
dimord = 0
do i = 1, numdims
call HistoryAxisInquire( hst % mpi_fileinfo % axes(i), name = dimname ) ! (out)
if ( trim(varname) == trim(dimname) ) then
dimord = i
exit
end if
end do
call MPI_Bcast( dimord, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, err_mpi )
else
call MPI_Bcast( dimord, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, err_mpi )
end if
if ( dimord > 0 ) then
call HistoryAxisInquire( hst % mpi_fileinfo % axes(dimord), size = dimsize_max ) ! (out)
dimsize = size( array )
if ( dimsize > dimsize_max .and. hst % unlimited_index /= dimord ) then
call MessageNotify('W', subname, 'dim=<%c> data size (%d) exceeds size of the dim (%d) by HistoryCreate. ' // 'the data will be trancated. ', i = (/ dimsize, dimsize_max /), c1 = trim(varname) )
dimsize = dimsize_max
end if
if ( associated( hst % mpi_dimdata_each( dimord ) % a_Axis ) ) then
deallocate( hst % mpi_dimdata_each( dimord ) % a_Axis )
end if
allocate( hst % mpi_dimdata_each( dimord ) % a_Axis(dimsize) )
hst % mpi_dimdata_each( dimord ) % a_Axis = array(1:dimsize)
hst % mpi_dimdata_each( dimord ) % length = dimsize
end if
!-----------------------------------------------------------------
! MPI 使用時に, 従属変数のデータが与えられた場合, データ集約の情報を整理.
! If data of dependent variables is given,
! information for integration is arranged when MPI is used
!-----------------------------------------------------------------
if ( v_ord > 0 ) then
if ( .not. associated( hst % mpi_gthr_info ) ) then
call gtmpi_axis_register( hst, err ) ! (inout)
end if
if ( present_and_true( err ) ) goto 999
if ( .not. associated( hst % mpi_vars_index( v_ord ) % allcount ) ) then
call gtmpi_vars_mkindex( hst, v_ord, err ) ! (inout)
end if
if ( present_and_true( err ) ) goto 999
end if
!-----------------------------------------------------------------
! MPI 使用時は, 各ノードのデータを rank == 0 へ集約する.
! Data on each node is integrated when MPI is used
!-----------------------------------------------------------------
if ( v_ord > 0 ) then
arraysize_work2 = hst % mpi_vars_index(v_ord) % allcount_all
if ( arraysize_work2 < 1 ) arraysize_work2 = 1
if ( hst % mpi_myrank == 0 ) then
do ra = 1, hst % mpi_nprocs - 1
allcount = hst % mpi_vars_index(v_ord) % allcount(ra)
call MPI_Send( allcount, 1, MPI_INTEGER, ra, 0, MPI_COMM_WORLD, err_mpi )
end do
else
call MPI_Recv( allcount, 1, MPI_INTEGER, 0, 0, MPI_COMM_WORLD, st_mpi, err_mpi )
end if
if ( hst % mpi_myrank /= 0 ) then
call MPI_Send( array_work, allcount, MPI_DOUBLE_PRECISION, 0, 0, MPI_COMM_WORLD, err_mpi )
else
allocate( array_mpi_all(0: hst % mpi_nprocs - 1, arraysize_work2 ) )
allocate( array_mpi_tmp( arraysize_work2 ) )
array_mpi_all(:,:) = 0.0_DP
array_mpi_tmp(:) = 0.0_DP
allcount = hst % mpi_vars_index(v_ord) % allcount(0)
array_mpi_all(0,1:allcount) = array_work
do ra = 1, hst % mpi_nprocs - 1
allcount = hst % mpi_vars_index(v_ord) % allcount(ra)
call MPI_Recv( array_mpi_tmp(1:allcount), allcount, MPI_DOUBLE_PRECISION, ra, 0, MPI_COMM_WORLD, st_mpi, err_mpi )
array_mpi_all(ra,1:allcount) = array_mpi_tmp(1:allcount)
end do
allocate( array_work2( arraysize_work2 ) )
allocate( array_overwrap( arraysize_work2 ) )
array_work2 = 0.0_DP
array_overwrap(:) = 0
do ra = 0, hst % mpi_nprocs - 1
do i = 1, hst % mpi_vars_index(v_ord) % allcount(ra)
new_index = hst % mpi_vars_index(v_ord) % each2all(ra, i)
array_work2( new_index ) = array_work2( new_index ) + array_mpi_all( ra, i )
array_overwrap( new_index ) = array_overwrap( new_index ) + 1
end do
end do
where ( array_overwrap == 0 )
array_overwrap = 1
end where
array_work2(:) = array_work2(:) / array_overwrap(:)
deallocate( array_mpi_all, array_mpi_tmp, array_overwrap )
! array_work2 はデータ出力の後に割り付け解除される.
end if
else
array_work2 => array_work
arraysize_work2 = arraysize
end if
end if
#endif
!-----------------------------------------------------------------
! 時刻を1つ進めて, データ出力
! Progress one time, and output data
!-----------------------------------------------------------------
#ifdef LIB_MPI
if ( .not. hst % mpi_gather .or. ( hst % mpi_gather .and. hst % mpi_myrank == 0 .and. hst % mpi_fileinfo % already_output) ) then
#endif
call TimeGoAhead( varname = varname, head = real(array_work2(1)), var = var, history = history, err = err ) ! (out)
call Inquire( var, 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_work2, arraysize_work2)
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_work2, arraysize_work2)
! 復元
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)
if ( hst % mpi_gather .and. v_ord > 0 ) then
deallocate( array_work2 )
end if
#ifdef LIB_MPI
end if
#endif
!-----------------------------------------------------------------
! "time_bnds" 変数への出力
! Output to "time_bnds" variable
!-----------------------------------------------------------------
#ifdef LIB_MPI
if ( .not. hst % mpi_gather .or. ( hst % mpi_gather .and. hst % mpi_myrank == 0 .and. hst % mpi_fileinfo % already_output ) ) then
#endif
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, url = url, name = time_name ) ! (out)
call UrlSplit( fullname = url, 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, rank = bnds_rank ) ! (out)
time_count = 1
if ( bnds_rank > 1 ) then
call Inquire( var = bndsvar, dimord = hst % growable_indices(bnds_ord), allcount = time_count ) ! (out)
end if
if ( (hst % time_bnds_output_count < 1) .or. (hst % time_bnds_output_count < time_count) ) then
call Slice(bndsvar, hst % growable_indices(bnds_ord), start=hst % time_bnds_output_count+1, count=1) ! (in)
call Put(bndsvar, hst % time_bnds, 2)
hst % time_bnds_output_count = hst % time_bnds_output_count + 1
end if
call Close( var = bndsvar ) ! (inout)
if ( present(difftime) ) then
hst % time_bnds(1:1) = EvalByUnit( difftime, '', hst % unlimited_units_symbol )
else
hst % time_bnds(1:1) = time
end if
end if
end if
#ifdef LIB_MPI
end if
#endif
!-----------------------------------------------------------------
! メッセージ出力
! Output messages
!-----------------------------------------------------------------
#ifdef LIB_MPI
if ( .not. hst % mpi_gather .or. ( hst % mpi_gather .and. hst % mpi_myrank == 0 .and. hst % mpi_fileinfo % already_output ) ) then
#endif
if ( present_and_false(quiet) ) then
call Inquire( hst % dimvars(1), url = url ) ! (out)
call UrlSplit( fullname = url, file = file ) ! (out)
if ( hst % unlimited_index < 1 ) then
time_str = ''
else
timevar = hst % dimvars(hst % unlimited_index)
call Slice( timevar, 1, start = hst % count(v_ord), count = 1 ) ! (in)
call Get( timevar, time_value, 1, 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
#ifdef LIB_MPI
end if
#endif
!-----------------------------------------------------------------
! 終了処理, 例外処理
! Termination and Exception handling
!-----------------------------------------------------------------
999 continue
call StoreError( stat, subname, err, cause_c )
call EndSub(subname)
end subroutine HistoryPutDoubleEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | real(DP), intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutDoubleEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | real(DP), intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutDoubleEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | real(DP), intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutDoubleEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | real(DP), intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutDoubleEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | real(DP), intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutDoubleEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | real(DP), intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutDoubleEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | real(DP), intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutDoubleEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | real(DP), intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutDoubleEx
| Subroutine : | |
| varname : | character(*), intent(in) |
| value : | integer, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutInt0( varname, value, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
integer, intent(in):: value
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutInt0"
continue
call BeginSub(subname)
call HistoryPutIntEx( varname, (/value/), 1, history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:) : | integer, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutInt1( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
integer, intent(in):: array(:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutInt1"
continue
call BeginSub(subname)
call HistoryPutIntEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:,:) : | integer, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutInt2( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
integer, intent(in):: array(:,:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutInt2"
continue
call BeginSub(subname)
call HistoryPutIntEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:,:,:) : | integer, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutInt3( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
integer, intent(in):: array(:,:,:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutInt3"
continue
call BeginSub(subname)
call HistoryPutIntEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:,:,:,:) : | integer, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutInt4( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
integer, intent(in):: array(:,:,:,:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutInt4"
continue
call BeginSub(subname)
call HistoryPutIntEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:,:,:,:,:) : | integer, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutInt5( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
integer, intent(in):: array(:,:,:,:,:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutInt5"
continue
call BeginSub(subname)
call HistoryPutIntEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:,:,:,:,:,:) : | integer, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutInt6( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
integer, intent(in):: array(:,:,:,:,:,:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutInt6"
continue
call BeginSub(subname)
call HistoryPutIntEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:,:,:,:,:,:,:) : | integer, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutInt7( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
integer, intent(in):: array(:,:,:,:,:,:,:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutInt7"
continue
call BeginSub(subname)
call HistoryPutIntEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | integer, intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
recursive subroutine HistoryPutIntEx( varname, array, arraysize, history, range, time, quiet, difftime, time_average_store, err )
!
!== データ出力
!
! こちらは配列サイズを指定する必要があるため、
! HistoryPut を利用してください。
!
use gtool_history_types, only: GT_HISTORY
use gtool_history_generic, only: HistoryAxisInquire
use gtool_history_internal, only: default, lookup_variable_ord
#ifdef LIB_MPI
use gtool_history_internal, only: gtmpi_axis_register, gtmpi_vars_mkindex
#endif
use gtdata_generic, only: Put, GTVarSync, Slice, Inquire, Get_Slice, Get, PutLine, Open, Close
use gtdata_types, only: GT_VARIABLE
use dc_types, only: STRING, DP
use dc_string, only: StoA, Printf, toChar, JoinChar
use dc_present, only: present_and_not_empty, present_select, present_and_false, present_and_true
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
use dc_date_types, only: DC_DIFFTIME
use dc_date_generic, only: operator(==), DCDiffTimeCreate, mod, operator(-), EvalByUnit, operator(/), toChar
use dc_trace, only: BeginSub, EndSub, DbgMessage
#ifdef LIB_MPI
use mpi
#endif
implicit none
character(*), intent(in):: varname
integer, intent(in):: arraysize
integer, 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 で
! *time_average* (または *average*)
! に .true. を与えた場合には,
! *time*, *difftime*
! のどちらの引数も与えない場合に,
! プログラムはエラーを発生させます.
!
! また, この引数と *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.".
!
type(DC_DIFFTIME), intent(in), optional:: difftime
!
! 時刻 (dc_date_types#DC_DIFFTIME 型)
!
! この引数を与える場合,
! 出力するかどうかをプログラムが
! 自動的に判断します.
! *difftime* に与えられた時刻が
! HistoryCreate に与えた *interval*
! で割り切れる場合には出力が行われます.
!
! HistoryAddVariable で
! *time_average* (または *average*)
! に .true. を与えた場合には,
! *time*, *difftime*
! のどちらの引数も与えない場合に,
! プログラムはエラーを発生させます.
!
! この引数と *time* が与えられた場合,
! *difftime* が優先されます.
!
! この引数と *range* は併用できません.
! 併用した場合には,
! プログラムはエラーを発生させます.
!
logical, intent(in), optional:: time_average_store
!
! 平均値の出力フラグ.
! この値に .true. を与えた場合には,
! 出力せずに与えられた値を一旦蓄えます.
! .false. を与えた場合には,
! *time* もしくは *difftime* と
! HistoryCreate に与えた *interval* に
! 関わらず出力を行います.
!
! HistoryAddVariable で
! *time_average* (または *average*)
! に .true. を与えない場合は無効です.
!
! *time* と *difftime*
! のどちらかを同時に与える必要があります.
!
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, target:: array_work(arraysize)
integer, pointer:: array_work2(:) =>null()
integer:: arraysize_work2
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
type(DC_DIFFTIME):: difftimew
real(DP):: avr_coef
#ifdef LIB_MPI
integer, allocatable:: array_overwrap(:)
integer:: new_index
type(GT_VARIABLE):: dimvar
integer:: numdims, dimord, dimsize, dimsize_max, allcount, ra
character(STRING):: dimname
integer:: err_mpi, st_mpi(MPI_STATUS_SIZE)
integer, allocatable:: array_mpi_tmp(:)
integer, allocatable:: array_mpi_all(:,:)
#endif
character(STRING):: cause_c
character(*), parameter:: subname = "HistoryPutIntEx"
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) .or. present(difftime) ) .and. present_and_not_empty(range) ) then
call MessageNotify('W', subname, '(varname=%c) "range" and "time" or "difftime" are not suppored at the same time', c1 = trim(varname) )
stat = USR_ERRNO
cause_c = '"range" and "time" or "difftime" are not suppored at the same time'
goto 999
end if
!-----------------------------------------------------------------
! hst 内の varname 変数の変数番号を取得
! Get variable number of "varname" in "hst"
!-----------------------------------------------------------------
#ifndef LIB_MPI
v_ord = lookup_variable_ord(hst, varname)
#else
if ( .not. hst % mpi_gather ) then
v_ord = lookup_variable_ord(hst, varname)
else
if ( hst % mpi_myrank == 0 ) then
v_ord = lookup_variable_ord(hst, varname)
end if
call MPI_Bcast( v_ord, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, err_mpi )
end if
#endif
!-----------------------------------------------------------------
! 時間平均値のためのデータ格納
! Store data for time average value
!-----------------------------------------------------------------
if ( v_ord > 0 ) then
if ( hst % var_avr_count( v_ord ) > -1 ) then
if ( .not. present(time) .and. .not. present(difftime) ) then
call MessageNotify('W', subname, '(varname=%c) arguments "time" or "difftime" are needed ' // 'when "time_average=.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
if ( .not. present(difftime) ) then
call DCDiffTimeCreate( difftimew, time, '', hst % unlimited_units_symbol ) ! (in)
else
difftimew = difftime
end if
if ( hst % var_avr_firstput( v_ord ) ) then
if ( hst % var_avr_count( v_ord ) == 0 ) then
avr_coef = 1.0_DP
hst % var_avr_prevtime( v_ord ) = difftimew
else
hst % var_avr_baseint( v_ord ) = difftimew - hst % var_avr_prevtime( v_ord )
avr_coef = 1.0_DP
hst % var_avr_prevtime( v_ord ) = difftimew
hst % var_avr_firstput( v_ord ) = .false.
end if
else
if ( hst % var_avr_count( v_ord ) == 0 ) then
hst % var_avr_baseint( v_ord ) = difftimew - hst % var_avr_prevtime( v_ord )
avr_coef = 1.0_DP
hst % var_avr_prevtime( v_ord ) = difftimew
else
avr_coef = ( difftimew - hst % var_avr_prevtime( v_ord ) ) / hst % var_avr_baseint( v_ord )
hst % var_avr_prevtime( v_ord ) = difftimew
end if
end if
hst % var_avr_data( v_ord ) % a_DataAvr = hst % var_avr_data( v_ord ) % a_DataAvr + array * avr_coef
hst % var_avr_count( v_ord ) = hst % var_avr_count( v_ord ) + 1
hst % var_avr_coefsum( v_ord ) = hst % var_avr_coefsum( v_ord ) + avr_coef
if ( present(difftime) ) then
hst % time_bnds(2:2) = EvalByUnit( difftime, '', hst % unlimited_units_symbol )
else
hst % time_bnds(2:2) = time
end if
end if
end if
!-----------------------------------------------------------------
! 初期時刻の設定
! Configure initial time
!-----------------------------------------------------------------
if ( .not. hst % origin_setting ) then
if ( present(difftime) ) then
hst % origin = difftime
hst % time_bnds = EvalByUnit( difftime, '', hst % unlimited_units_symbol )
hst % origin_setting = .true.
elseif ( present(time) ) then
call DCDiffTimeCreate( hst % origin, time, '', hst % unlimited_units_symbol ) ! (in)
hst % time_bnds = time
hst % origin_setting = .true.
end if
end if
!-----------------------------------------------------------------
! 時刻の自動チェック
! Check time automatically
!-----------------------------------------------------------------
output_step = .true.
if ( present_and_false(time_average_store) ) then
output_step = .true.
elseif ( present_and_true(time_average_store) ) then
output_step = .false.
elseif ( present(difftime) .or. present(time) ) then
output_step = .false.
if ( hst % interval == 0 ) then
output_step = .true.
else
if ( .not. present(difftime) ) then
call DCDiffTimeCreate( difftimew, time, '', hst % unlimited_units_symbol ) ! (in)
else
difftimew = difftime
end if
if ( mod( difftimew - hst % origin, hst % interval ) == 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 = ''
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_coefsum( v_ord ) )
hst % var_avr_data( v_ord ) % a_DataAvr = 0.0
hst % var_avr_count( v_ord ) = 0
hst % var_avr_coefsum( v_ord ) = 0.0_DP
hst % var_avr_firstput( v_ord ) = .false.
end if
end if
end if
#ifndef LIB_MPI
array_work2 => array_work
arraysize_work2 = arraysize
#else
if ( .not. hst % mpi_gather ) then
array_work2 => array_work
arraysize_work2 = arraysize
else
!-----------------------------------------------------------------
! MPI 使用時に, 座標軸のデータが与えられた場合には, そのデータを保管.
! If data of axis is given, the data is stored when MPI is used
!-----------------------------------------------------------------
numdims = size( hst % mpi_fileinfo % axes )
if ( hst % mpi_myrank == 0 ) then
dimord = 0
do i = 1, numdims
call HistoryAxisInquire( hst % mpi_fileinfo % axes(i), name = dimname ) ! (out)
if ( trim(varname) == trim(dimname) ) then
dimord = i
exit
end if
end do
call MPI_Bcast( dimord, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, err_mpi )
else
call MPI_Bcast( dimord, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, err_mpi )
end if
if ( dimord > 0 ) then
call HistoryAxisInquire( hst % mpi_fileinfo % axes(dimord), size = dimsize_max ) ! (out)
dimsize = size( array )
if ( dimsize > dimsize_max .and. hst % unlimited_index /= dimord ) then
call MessageNotify('W', subname, 'dim=<%c> data size (%d) exceeds size of the dim (%d) by HistoryCreate. ' // 'the data will be trancated. ', i = (/ dimsize, dimsize_max /), c1 = trim(varname) )
dimsize = dimsize_max
end if
if ( associated( hst % mpi_dimdata_each( dimord ) % a_Axis ) ) then
deallocate( hst % mpi_dimdata_each( dimord ) % a_Axis )
end if
allocate( hst % mpi_dimdata_each( dimord ) % a_Axis(dimsize) )
hst % mpi_dimdata_each( dimord ) % a_Axis = array(1:dimsize)
hst % mpi_dimdata_each( dimord ) % length = dimsize
end if
!-----------------------------------------------------------------
! MPI 使用時に, 従属変数のデータが与えられた場合, データ集約の情報を整理.
! If data of dependent variables is given,
! information for integration is arranged when MPI is used
!-----------------------------------------------------------------
if ( v_ord > 0 ) then
if ( .not. associated( hst % mpi_gthr_info ) ) then
call gtmpi_axis_register( hst, err ) ! (inout)
end if
if ( present_and_true( err ) ) goto 999
if ( .not. associated( hst % mpi_vars_index( v_ord ) % allcount ) ) then
call gtmpi_vars_mkindex( hst, v_ord, err ) ! (inout)
end if
if ( present_and_true( err ) ) goto 999
end if
!-----------------------------------------------------------------
! MPI 使用時は, 各ノードのデータを rank == 0 へ集約する.
! Data on each node is integrated when MPI is used
!-----------------------------------------------------------------
if ( v_ord > 0 ) then
arraysize_work2 = hst % mpi_vars_index(v_ord) % allcount_all
if ( arraysize_work2 < 1 ) arraysize_work2 = 1
if ( hst % mpi_myrank == 0 ) then
do ra = 1, hst % mpi_nprocs - 1
allcount = hst % mpi_vars_index(v_ord) % allcount(ra)
call MPI_Send( allcount, 1, MPI_INTEGER, ra, 0, MPI_COMM_WORLD, err_mpi )
end do
else
call MPI_Recv( allcount, 1, MPI_INTEGER, 0, 0, MPI_COMM_WORLD, st_mpi, err_mpi )
end if
if ( hst % mpi_myrank /= 0 ) then
call MPI_Send( array_work, allcount, MPI_INTEGER, 0, 0, MPI_COMM_WORLD, err_mpi )
else
allocate( array_mpi_all(0: hst % mpi_nprocs - 1, arraysize_work2 ) )
allocate( array_mpi_tmp( arraysize_work2 ) )
array_mpi_all(:,:) = 0
array_mpi_tmp(:) = 0
allcount = hst % mpi_vars_index(v_ord) % allcount(0)
array_mpi_all(0,1:allcount) = array_work
do ra = 1, hst % mpi_nprocs - 1
allcount = hst % mpi_vars_index(v_ord) % allcount(ra)
call MPI_Recv( array_mpi_tmp(1:allcount), allcount, MPI_INTEGER, ra, 0, MPI_COMM_WORLD, st_mpi, err_mpi )
array_mpi_all(ra,1:allcount) = array_mpi_tmp(1:allcount)
end do
allocate( array_work2( arraysize_work2 ) )
allocate( array_overwrap( arraysize_work2 ) )
array_work2 = 0
array_overwrap(:) = 0
do ra = 0, hst % mpi_nprocs - 1
do i = 1, hst % mpi_vars_index(v_ord) % allcount(ra)
new_index = hst % mpi_vars_index(v_ord) % each2all(ra, i)
array_work2( new_index ) = array_work2( new_index ) + array_mpi_all( ra, i )
array_overwrap( new_index ) = array_overwrap( new_index ) + 1
end do
end do
where ( array_overwrap == 0 )
array_overwrap = 1
end where
array_work2(:) = array_work2(:) / array_overwrap(:)
deallocate( array_mpi_all, array_mpi_tmp, array_overwrap )
! array_work2 はデータ出力の後に割り付け解除される.
end if
else
array_work2 => array_work
arraysize_work2 = arraysize
end if
end if
#endif
!-----------------------------------------------------------------
! 時刻を1つ進めて, データ出力
! Progress one time, and output data
!-----------------------------------------------------------------
#ifdef LIB_MPI
if ( .not. hst % mpi_gather .or. ( hst % mpi_gather .and. hst % mpi_myrank == 0 .and. hst % mpi_fileinfo % already_output) ) then
#endif
call TimeGoAhead( varname = varname, head = real(array_work2(1)), var = var, history = history, err = err ) ! (out)
call Inquire( var, 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_work2, arraysize_work2)
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_work2, arraysize_work2)
! 復元
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)
if ( hst % mpi_gather .and. v_ord > 0 ) then
deallocate( array_work2 )
end if
#ifdef LIB_MPI
end if
#endif
!-----------------------------------------------------------------
! "time_bnds" 変数への出力
! Output to "time_bnds" variable
!-----------------------------------------------------------------
#ifdef LIB_MPI
if ( .not. hst % mpi_gather .or. ( hst % mpi_gather .and. hst % mpi_myrank == 0 .and. hst % mpi_fileinfo % already_output ) ) then
#endif
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, url = url, name = time_name ) ! (out)
call UrlSplit( fullname = url, 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, rank = bnds_rank ) ! (out)
time_count = 1
if ( bnds_rank > 1 ) then
call Inquire( var = bndsvar, dimord = hst % growable_indices(bnds_ord), allcount = time_count ) ! (out)
end if
if ( (hst % time_bnds_output_count < 1) .or. (hst % time_bnds_output_count < time_count) ) then
call Slice(bndsvar, hst % growable_indices(bnds_ord), start=hst % time_bnds_output_count+1, count=1) ! (in)
call Put(bndsvar, hst % time_bnds, 2)
hst % time_bnds_output_count = hst % time_bnds_output_count + 1
end if
call Close( var = bndsvar ) ! (inout)
if ( present(difftime) ) then
hst % time_bnds(1:1) = EvalByUnit( difftime, '', hst % unlimited_units_symbol )
else
hst % time_bnds(1:1) = time
end if
end if
end if
#ifdef LIB_MPI
end if
#endif
!-----------------------------------------------------------------
! メッセージ出力
! Output messages
!-----------------------------------------------------------------
#ifdef LIB_MPI
if ( .not. hst % mpi_gather .or. ( hst % mpi_gather .and. hst % mpi_myrank == 0 .and. hst % mpi_fileinfo % already_output ) ) then
#endif
if ( present_and_false(quiet) ) then
call Inquire( hst % dimvars(1), url = url ) ! (out)
call UrlSplit( fullname = url, file = file ) ! (out)
if ( hst % unlimited_index < 1 ) then
time_str = ''
else
timevar = hst % dimvars(hst % unlimited_index)
call Slice( timevar, 1, start = hst % count(v_ord), count = 1 ) ! (in)
call Get( timevar, time_value, 1, 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
#ifdef LIB_MPI
end if
#endif
!-----------------------------------------------------------------
! 終了処理, 例外処理
! Termination and Exception handling
!-----------------------------------------------------------------
999 continue
call StoreError( stat, subname, err, cause_c )
call EndSub(subname)
end subroutine HistoryPutIntEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | integer, intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutIntEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | integer, intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutIntEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | integer, intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutIntEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | integer, intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutIntEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | integer, intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutIntEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | integer, intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutIntEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | integer, intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutIntEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | integer, intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutIntEx
| Subroutine : | |
| varname : | character(*), intent(in) |
| value : | real, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutReal0( varname, value, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
real, intent(in):: value
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutReal0"
continue
call BeginSub(subname)
call HistoryPutRealEx( varname, (/value/), 1, history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:) : | real, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutReal1( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
real, intent(in):: array(:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutReal1"
continue
call BeginSub(subname)
call HistoryPutRealEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:,:) : | real, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutReal2( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
real, intent(in):: array(:,:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutReal2"
continue
call BeginSub(subname)
call HistoryPutRealEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:,:,:) : | real, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutReal3( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
real, intent(in):: array(:,:,:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutReal3"
continue
call BeginSub(subname)
call HistoryPutRealEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:,:,:,:) : | real, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutReal4( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
real, intent(in):: array(:,:,:,:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutReal4"
continue
call BeginSub(subname)
call HistoryPutRealEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:,:,:,:,:) : | real, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutReal5( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
real, intent(in):: array(:,:,:,:,:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutReal5"
continue
call BeginSub(subname)
call HistoryPutRealEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:,:,:,:,:,:) : | real, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutReal6( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
real, intent(in):: array(:,:,:,:,:,:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutReal6"
continue
call BeginSub(subname)
call HistoryPutRealEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | |
| varname : | character(*), intent(in) |
| array(:,:,:,:,:,:,:) : | real, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| range : | character(*), intent(in), optional |
| time : | real, intent(in), optional |
| quiet : | logical, intent(in), optional |
| difftime : | type(DC_DIFFTIME), intent(in), optional |
| time_average_store : | logical, intent(in), optional |
| err : | logical, intent(out), optional |
subroutine HistoryPutReal7( varname, array, history, range, time, quiet, difftime, time_average_store, err )
!
!
use gtool_history_types, only: GT_HISTORY
use dc_date_types, only: DC_DIFFTIME
use dc_types, only: STRING, TOKEN, DP
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
character(*), intent(in):: varname
real, intent(in):: array(:,:,:,:,:,:,:)
type(GT_HISTORY), intent(inout), optional, target:: history
character(*), intent(in), optional:: range
real, intent(in), optional:: time
logical, intent(in), optional:: quiet
type(DC_DIFFTIME), intent(in), optional:: difftime
logical, intent(in), optional:: time_average_store
logical, intent(out), optional:: err
character(*), parameter:: subname = "HistoryPutReal7"
continue
call BeginSub(subname)
call HistoryPutRealEx( varname, pack(array, .true.), size(array), history = history, range = range, time = time, quiet = quiet, difftime = difftime, time_average_store = time_average_store, err = err ) ! (out) optional
call EndSub(subname)
end subroutine
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | real, intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
recursive subroutine HistoryPutRealEx( varname, array, arraysize, history, range, time, quiet, difftime, time_average_store, err )
!
!== データ出力
!
! こちらは配列サイズを指定する必要があるため、
! HistoryPut を利用してください。
!
use gtool_history_types, only: GT_HISTORY
use gtool_history_generic, only: HistoryAxisInquire
use gtool_history_internal, only: default, lookup_variable_ord
#ifdef LIB_MPI
use gtool_history_internal, only: gtmpi_axis_register, gtmpi_vars_mkindex
#endif
use gtdata_generic, only: Put, GTVarSync, Slice, Inquire, Get_Slice, Get, PutLine, Open, Close
use gtdata_types, only: GT_VARIABLE
use dc_types, only: STRING, DP
use dc_string, only: StoA, Printf, toChar, JoinChar
use dc_present, only: present_and_not_empty, present_select, present_and_false, present_and_true
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
use dc_date_types, only: DC_DIFFTIME
use dc_date_generic, only: operator(==), DCDiffTimeCreate, mod, operator(-), EvalByUnit, operator(/), toChar
use dc_trace, only: BeginSub, EndSub, DbgMessage
#ifdef LIB_MPI
use mpi
#endif
implicit none
character(*), intent(in):: varname
integer, intent(in):: arraysize
real, 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 で
! *time_average* (または *average*)
! に .true. を与えた場合には,
! *time*, *difftime*
! のどちらの引数も与えない場合に,
! プログラムはエラーを発生させます.
!
! また, この引数と *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.".
!
type(DC_DIFFTIME), intent(in), optional:: difftime
!
! 時刻 (dc_date_types#DC_DIFFTIME 型)
!
! この引数を与える場合,
! 出力するかどうかをプログラムが
! 自動的に判断します.
! *difftime* に与えられた時刻が
! HistoryCreate に与えた *interval*
! で割り切れる場合には出力が行われます.
!
! HistoryAddVariable で
! *time_average* (または *average*)
! に .true. を与えた場合には,
! *time*, *difftime*
! のどちらの引数も与えない場合に,
! プログラムはエラーを発生させます.
!
! この引数と *time* が与えられた場合,
! *difftime* が優先されます.
!
! この引数と *range* は併用できません.
! 併用した場合には,
! プログラムはエラーを発生させます.
!
logical, intent(in), optional:: time_average_store
!
! 平均値の出力フラグ.
! この値に .true. を与えた場合には,
! 出力せずに与えられた値を一旦蓄えます.
! .false. を与えた場合には,
! *time* もしくは *difftime* と
! HistoryCreate に与えた *interval* に
! 関わらず出力を行います.
!
! HistoryAddVariable で
! *time_average* (または *average*)
! に .true. を与えない場合は無効です.
!
! *time* と *difftime*
! のどちらかを同時に与える必要があります.
!
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.
real, target:: array_work(arraysize)
real, pointer:: array_work2(:) =>null()
integer:: arraysize_work2
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
type(DC_DIFFTIME):: difftimew
real(DP):: avr_coef
#ifdef LIB_MPI
integer, allocatable:: array_overwrap(:)
integer:: new_index
type(GT_VARIABLE):: dimvar
integer:: numdims, dimord, dimsize, dimsize_max, allcount, ra
character(STRING):: dimname
integer:: err_mpi, st_mpi(MPI_STATUS_SIZE)
real, allocatable:: array_mpi_tmp(:)
real, allocatable:: array_mpi_all(:,:)
#endif
character(STRING):: cause_c
character(*), parameter:: subname = "HistoryPutRealEx"
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) .or. present(difftime) ) .and. present_and_not_empty(range) ) then
call MessageNotify('W', subname, '(varname=%c) "range" and "time" or "difftime" are not suppored at the same time', c1 = trim(varname) )
stat = USR_ERRNO
cause_c = '"range" and "time" or "difftime" are not suppored at the same time'
goto 999
end if
!-----------------------------------------------------------------
! hst 内の varname 変数の変数番号を取得
! Get variable number of "varname" in "hst"
!-----------------------------------------------------------------
#ifndef LIB_MPI
v_ord = lookup_variable_ord(hst, varname)
#else
if ( .not. hst % mpi_gather ) then
v_ord = lookup_variable_ord(hst, varname)
else
if ( hst % mpi_myrank == 0 ) then
v_ord = lookup_variable_ord(hst, varname)
end if
call MPI_Bcast( v_ord, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, err_mpi )
end if
#endif
!-----------------------------------------------------------------
! 時間平均値のためのデータ格納
! Store data for time average value
!-----------------------------------------------------------------
if ( v_ord > 0 ) then
if ( hst % var_avr_count( v_ord ) > -1 ) then
if ( .not. present(time) .and. .not. present(difftime) ) then
call MessageNotify('W', subname, '(varname=%c) arguments "time" or "difftime" are needed ' // 'when "time_average=.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
if ( .not. present(difftime) ) then
call DCDiffTimeCreate( difftimew, time, '', hst % unlimited_units_symbol ) ! (in)
else
difftimew = difftime
end if
if ( hst % var_avr_firstput( v_ord ) ) then
if ( hst % var_avr_count( v_ord ) == 0 ) then
avr_coef = 1.0_DP
hst % var_avr_prevtime( v_ord ) = difftimew
else
hst % var_avr_baseint( v_ord ) = difftimew - hst % var_avr_prevtime( v_ord )
avr_coef = 1.0_DP
hst % var_avr_prevtime( v_ord ) = difftimew
hst % var_avr_firstput( v_ord ) = .false.
end if
else
if ( hst % var_avr_count( v_ord ) == 0 ) then
hst % var_avr_baseint( v_ord ) = difftimew - hst % var_avr_prevtime( v_ord )
avr_coef = 1.0_DP
hst % var_avr_prevtime( v_ord ) = difftimew
else
avr_coef = ( difftimew - hst % var_avr_prevtime( v_ord ) ) / hst % var_avr_baseint( v_ord )
hst % var_avr_prevtime( v_ord ) = difftimew
end if
end if
hst % var_avr_data( v_ord ) % a_DataAvr = hst % var_avr_data( v_ord ) % a_DataAvr + array * avr_coef
hst % var_avr_count( v_ord ) = hst % var_avr_count( v_ord ) + 1
hst % var_avr_coefsum( v_ord ) = hst % var_avr_coefsum( v_ord ) + avr_coef
if ( present(difftime) ) then
hst % time_bnds(2:2) = EvalByUnit( difftime, '', hst % unlimited_units_symbol )
else
hst % time_bnds(2:2) = time
end if
end if
end if
!-----------------------------------------------------------------
! 初期時刻の設定
! Configure initial time
!-----------------------------------------------------------------
if ( .not. hst % origin_setting ) then
if ( present(difftime) ) then
hst % origin = difftime
hst % time_bnds = EvalByUnit( difftime, '', hst % unlimited_units_symbol )
hst % origin_setting = .true.
elseif ( present(time) ) then
call DCDiffTimeCreate( hst % origin, time, '', hst % unlimited_units_symbol ) ! (in)
hst % time_bnds = time
hst % origin_setting = .true.
end if
end if
!-----------------------------------------------------------------
! 時刻の自動チェック
! Check time automatically
!-----------------------------------------------------------------
output_step = .true.
if ( present_and_false(time_average_store) ) then
output_step = .true.
elseif ( present_and_true(time_average_store) ) then
output_step = .false.
elseif ( present(difftime) .or. present(time) ) then
output_step = .false.
if ( hst % interval == 0 ) then
output_step = .true.
else
if ( .not. present(difftime) ) then
call DCDiffTimeCreate( difftimew, time, '', hst % unlimited_units_symbol ) ! (in)
else
difftimew = difftime
end if
if ( mod( difftimew - hst % origin, hst % interval ) == 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 = ''
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_coefsum( v_ord ) )
hst % var_avr_data( v_ord ) % a_DataAvr = 0.0
hst % var_avr_count( v_ord ) = 0
hst % var_avr_coefsum( v_ord ) = 0.0_DP
hst % var_avr_firstput( v_ord ) = .false.
end if
end if
end if
#ifndef LIB_MPI
array_work2 => array_work
arraysize_work2 = arraysize
#else
if ( .not. hst % mpi_gather ) then
array_work2 => array_work
arraysize_work2 = arraysize
else
!-----------------------------------------------------------------
! MPI 使用時に, 座標軸のデータが与えられた場合には, そのデータを保管.
! If data of axis is given, the data is stored when MPI is used
!-----------------------------------------------------------------
numdims = size( hst % mpi_fileinfo % axes )
if ( hst % mpi_myrank == 0 ) then
dimord = 0
do i = 1, numdims
call HistoryAxisInquire( hst % mpi_fileinfo % axes(i), name = dimname ) ! (out)
if ( trim(varname) == trim(dimname) ) then
dimord = i
exit
end if
end do
call MPI_Bcast( dimord, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, err_mpi )
else
call MPI_Bcast( dimord, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, err_mpi )
end if
if ( dimord > 0 ) then
call HistoryAxisInquire( hst % mpi_fileinfo % axes(dimord), size = dimsize_max ) ! (out)
dimsize = size( array )
if ( dimsize > dimsize_max .and. hst % unlimited_index /= dimord ) then
call MessageNotify('W', subname, 'dim=<%c> data size (%d) exceeds size of the dim (%d) by HistoryCreate. ' // 'the data will be trancated. ', i = (/ dimsize, dimsize_max /), c1 = trim(varname) )
dimsize = dimsize_max
end if
if ( associated( hst % mpi_dimdata_each( dimord ) % a_Axis ) ) then
deallocate( hst % mpi_dimdata_each( dimord ) % a_Axis )
end if
allocate( hst % mpi_dimdata_each( dimord ) % a_Axis(dimsize) )
hst % mpi_dimdata_each( dimord ) % a_Axis = array(1:dimsize)
hst % mpi_dimdata_each( dimord ) % length = dimsize
end if
!-----------------------------------------------------------------
! MPI 使用時に, 従属変数のデータが与えられた場合, データ集約の情報を整理.
! If data of dependent variables is given,
! information for integration is arranged when MPI is used
!-----------------------------------------------------------------
if ( v_ord > 0 ) then
if ( .not. associated( hst % mpi_gthr_info ) ) then
call gtmpi_axis_register( hst, err ) ! (inout)
end if
if ( present_and_true( err ) ) goto 999
if ( .not. associated( hst % mpi_vars_index( v_ord ) % allcount ) ) then
call gtmpi_vars_mkindex( hst, v_ord, err ) ! (inout)
end if
if ( present_and_true( err ) ) goto 999
end if
!-----------------------------------------------------------------
! MPI 使用時は, 各ノードのデータを rank == 0 へ集約する.
! Data on each node is integrated when MPI is used
!-----------------------------------------------------------------
if ( v_ord > 0 ) then
arraysize_work2 = hst % mpi_vars_index(v_ord) % allcount_all
if ( arraysize_work2 < 1 ) arraysize_work2 = 1
if ( hst % mpi_myrank == 0 ) then
do ra = 1, hst % mpi_nprocs - 1
allcount = hst % mpi_vars_index(v_ord) % allcount(ra)
call MPI_Send( allcount, 1, MPI_INTEGER, ra, 0, MPI_COMM_WORLD, err_mpi )
end do
else
call MPI_Recv( allcount, 1, MPI_INTEGER, 0, 0, MPI_COMM_WORLD, st_mpi, err_mpi )
end if
if ( hst % mpi_myrank /= 0 ) then
call MPI_Send( array_work, allcount, MPI_REAL, 0, 0, MPI_COMM_WORLD, err_mpi )
else
allocate( array_mpi_all(0: hst % mpi_nprocs - 1, arraysize_work2 ) )
allocate( array_mpi_tmp( arraysize_work2 ) )
array_mpi_all(:,:) = 0.0
array_mpi_tmp(:) = 0.0
allcount = hst % mpi_vars_index(v_ord) % allcount(0)
array_mpi_all(0,1:allcount) = array_work
do ra = 1, hst % mpi_nprocs - 1
allcount = hst % mpi_vars_index(v_ord) % allcount(ra)
call MPI_Recv( array_mpi_tmp(1:allcount), allcount, MPI_REAL, ra, 0, MPI_COMM_WORLD, st_mpi, err_mpi )
array_mpi_all(ra,1:allcount) = array_mpi_tmp(1:allcount)
end do
allocate( array_work2( arraysize_work2 ) )
allocate( array_overwrap( arraysize_work2 ) )
array_work2 = 0.0
array_overwrap(:) = 0
do ra = 0, hst % mpi_nprocs - 1
do i = 1, hst % mpi_vars_index(v_ord) % allcount(ra)
new_index = hst % mpi_vars_index(v_ord) % each2all(ra, i)
array_work2( new_index ) = array_work2( new_index ) + array_mpi_all( ra, i )
array_overwrap( new_index ) = array_overwrap( new_index ) + 1
end do
end do
where ( array_overwrap == 0 )
array_overwrap = 1
end where
array_work2(:) = array_work2(:) / array_overwrap(:)
deallocate( array_mpi_all, array_mpi_tmp, array_overwrap )
! array_work2 はデータ出力の後に割り付け解除される.
end if
else
array_work2 => array_work
arraysize_work2 = arraysize
end if
end if
#endif
!-----------------------------------------------------------------
! 時刻を1つ進めて, データ出力
! Progress one time, and output data
!-----------------------------------------------------------------
#ifdef LIB_MPI
if ( .not. hst % mpi_gather .or. ( hst % mpi_gather .and. hst % mpi_myrank == 0 .and. hst % mpi_fileinfo % already_output) ) then
#endif
call TimeGoAhead( varname = varname, head = real(array_work2(1)), var = var, history = history, err = err ) ! (out)
call Inquire( var, 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_work2, arraysize_work2)
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_work2, arraysize_work2)
! 復元
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)
if ( hst % mpi_gather .and. v_ord > 0 ) then
deallocate( array_work2 )
end if
#ifdef LIB_MPI
end if
#endif
!-----------------------------------------------------------------
! "time_bnds" 変数への出力
! Output to "time_bnds" variable
!-----------------------------------------------------------------
#ifdef LIB_MPI
if ( .not. hst % mpi_gather .or. ( hst % mpi_gather .and. hst % mpi_myrank == 0 .and. hst % mpi_fileinfo % already_output ) ) then
#endif
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, url = url, name = time_name ) ! (out)
call UrlSplit( fullname = url, 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, rank = bnds_rank ) ! (out)
time_count = 1
if ( bnds_rank > 1 ) then
call Inquire( var = bndsvar, dimord = hst % growable_indices(bnds_ord), allcount = time_count ) ! (out)
end if
if ( (hst % time_bnds_output_count < 1) .or. (hst % time_bnds_output_count < time_count) ) then
call Slice(bndsvar, hst % growable_indices(bnds_ord), start=hst % time_bnds_output_count+1, count=1) ! (in)
call Put(bndsvar, hst % time_bnds, 2)
hst % time_bnds_output_count = hst % time_bnds_output_count + 1
end if
call Close( var = bndsvar ) ! (inout)
if ( present(difftime) ) then
hst % time_bnds(1:1) = EvalByUnit( difftime, '', hst % unlimited_units_symbol )
else
hst % time_bnds(1:1) = time
end if
end if
end if
#ifdef LIB_MPI
end if
#endif
!-----------------------------------------------------------------
! メッセージ出力
! Output messages
!-----------------------------------------------------------------
#ifdef LIB_MPI
if ( .not. hst % mpi_gather .or. ( hst % mpi_gather .and. hst % mpi_myrank == 0 .and. hst % mpi_fileinfo % already_output ) ) then
#endif
if ( present_and_false(quiet) ) then
call Inquire( hst % dimvars(1), url = url ) ! (out)
call UrlSplit( fullname = url, file = file ) ! (out)
if ( hst % unlimited_index < 1 ) then
time_str = ''
else
timevar = hst % dimvars(hst % unlimited_index)
call Slice( timevar, 1, start = hst % count(v_ord), count = 1 ) ! (in)
call Get( timevar, time_value, 1, 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
#ifdef LIB_MPI
end if
#endif
!-----------------------------------------------------------------
! 終了処理, 例外処理
! Termination and Exception handling
!-----------------------------------------------------------------
999 continue
call StoreError( stat, subname, err, cause_c )
call EndSub(subname)
end subroutine HistoryPutRealEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | real, intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutRealEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | real, intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutRealEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | real, intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutRealEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | real, intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutRealEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | real, intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutRealEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | real, intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutRealEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | real, intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutRealEx
| Subroutine : | recursive | ||
| varname : | character(*), intent(in) | ||
| array(arraysize) : | real, intent(in) | ||
| arraysize : | integer, intent(in) | ||
| history : | type(GT_HISTORY), intent(inout), target, optional | ||
| range : | character(*), intent(in), optional
| ||
| time : | real, intent(in), optional
| ||
| quiet : | logical, intent(in), optional
| ||
| difftime : | type(DC_DIFFTIME), intent(in), optional
| ||
| time_average_store : | logical, intent(in), optional
| ||
| err : | logical, intent(out), optional
|
こちらは配列サイズを指定する必要があるため、 HistoryPut を利用してください。
Original external subprogram is gtool/gtool_history/historyput.F90#HistoryPutRealEx
| Subroutine : | |
| varname : | character(len = *), intent(in) |
| var : | type(GT_VARIABLE), intent(out) |
| head : | real, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| err : | logical, intent(out), optional |
history 内の (省略された場合は gtool_history 内に内包 される GT_HISTORY 変数) の変数名 varname の時間を1つ分 進め、その最新の時間断面で切り取った変数 ID を var に返します。
subroutine TimeGoAhead( varname, var, head, history, err )
!
! *history* 内の (省略された場合は gtool_history 内に内包
! される GT_HISTORY 変数) の変数名 *varname* の時間を1つ分
! 進め、その最新の時間断面で切り取った変数 ID を *var* に返します。
!
!
use gtool_history_types, only: GT_HISTORY
use gtool_history_internal, only: default, lookup_variable, lookup_dimension
use gtdata_generic, only: Slice, Get_Slice, Put, Get, Get_Attr
use gtdata_types, only: GT_VARIABLE
use dc_types, only: STRING, DP
use dc_error, only: StoreError, NF_ENOTVAR, DC_NOERR
use dc_date_generic, only: EvalByUnit, operator(+), operator(*), DCDiffTimeCreate, min, max, EvalSec, DCDiffTimePutLine
use dc_date_types, only: DC_DIFFTIME
use dc_trace, only: BeginSub, EndSub, DbgMessage
implicit none
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
real(DP):: curtime
type(DC_DIFFTIME):: headdiff
character(STRING):: cause_c, subname_r
character(*), parameter:: subname = "TimeGoAhead"
continue
call BeginSub(subname, 'varname=%c head=%r', c1=trim(varname), r=(/head/))
stat = DC_NOERR
cause_c = ''
subname_r = subname
if (present(history)) then
hst => history
else
hst => default
endif
! hst 内での変数 varname の変数 ID を var に、
! hst における変数添字を v_ord に取得
var = lookup_variable( hst, varname, ord = v_ord ) ! (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) ! (in)
else
!-----------------------
! HistorySetTime を利用しない場合
!
! 時間次元に値が書き込まれていない場合, 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) ! (in)
!-----------------------
! 時間次元変数へのデータ出力
!
! 変数の 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)
curtime = EvalByUnit( hst % origin, '', hst % unlimited_units_symbol )
call Put(timevar, (/curtime/), 1) ! (in)
elseif (hst % count(v_ord) > timestart) then
!---------------------
! 時間次元のデータの初期値以外を作成
!
! 変数の count が時間次元の start より大きい場合、
! hst % interval でその間を埋める。
rest = timestart + 1
do
call Slice(timevar, 1, start=rest, count=1)
curtime = EvalByUnit( hst % origin + hst % interval * (rest - 1), '', hst % unlimited_units_symbol )
call Put(timevar, (/curtime/), 1 ) ! (in)
rest = rest + 1
if ( rest > hst % count(v_ord) ) exit
enddo
endif
deallocate(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
subname_r = 'HistoryPut'
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
call DCDiffTimeCreate( headdiff, head, '', hst % unlimited_units_symbol ) ! (in)
hst % newest = max(hst % newest, headdiff)
hst % oldest = min(hst % oldest, headdiff)
call Slice(var, 1, start=hst % count(1), count=1)
999 continue
call StoreError(stat, trim(subname_r), err, cause_c)
call EndSub(subname)
end subroutine TimeGoAhead
| Subroutine : | |
| varname : | character(len = *), intent(in) |
| var : | type(GT_VARIABLE), intent(out) |
| head : | real, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| err : | logical, intent(out), optional |
history 内の (省略された場合は gtool_history 内に内包 される GT_HISTORY 変数) の変数名 varname の時間を1つ分 進め、その最新の時間断面で切り取った変数 ID を var に返します。
Original external subprogram is gtool/gtool_history/historyput.F90#TimeGoAhead
| Subroutine : | |
| varname : | character(len = *), intent(in) |
| var : | type(GT_VARIABLE), intent(out) |
| head : | real, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| err : | logical, intent(out), optional |
history 内の (省略された場合は gtool_history 内に内包 される GT_HISTORY 変数) の変数名 varname の時間を1つ分 進め、その最新の時間断面で切り取った変数 ID を var に返します。
Original external subprogram is gtool/gtool_history/historyput.F90#TimeGoAhead
| Subroutine : | |
| varname : | character(len = *), intent(in) |
| var : | type(GT_VARIABLE), intent(out) |
| head : | real, intent(in) |
| history : | type(GT_HISTORY), intent(inout), optional, target |
| err : | logical, intent(out), optional |
history 内の (省略された場合は gtool_history 内に内包 される GT_HISTORY 変数) の変数名 varname の時間を1つ分 進め、その最新の時間断面で切り取った変数 ID を var に返します。
Original external subprogram is gtool/gtool_history/historyput.F90#TimeGoAhead