historyaddvariable.f90

Go to the documentation of this file.

 
  recursive subroutine historyaddvariable1( &
    & varname, dims, longname, units, &
    & xtype, time_average, average, history, err )
    !
    use gtool_history_types, only: gt_history, &
      & gt_history_axis, gt_history_varinfo, gt_history_attr, &
      & gt_history_avrdata, gt_history_mpivarindex
    use gtool_history_internal, only: default, lookup_dimension
    use gtool_history_generic, only: historyaddvariable, historyvarinfocreate
    use gtdata_generic, only: inquire, create, slice, put_attr, &
      & put, putline
    use gtdata_types, only: gt_variable
    use netcdf, only: nf90_ebaddim
    use dc_error, only: storeerror, dc_noerr, dc_enotinit, hst_enodependtime, &
      & hst_empinoaxisdata
    use dc_string, only: cprintf, joinchar, stoa
    use dc_url, only: gt_atmark, urlresolve
    use dc_present, only: present_and_true
    use dc_date, only: dcdifftimecreate
    use dc_date_types, only: dc_difftime
    use dc_message, only: messagenotify
    use dc_trace, only: beginsub, endsub
    use dc_types, only: string, dp
    use mpi
    implicit none
    character(len = *), intent(in):: varname
                              ! 定義する変数の名前
                              !
                              ! 最大文字数は dc_types::TOKEN
                              !
    character(len = *), intent(in):: dims(:)
                              ! 変数が依存する次元の名前
                              !
                              ! 時間の次元は配列の最後に指定
                              ! しなければならない。
                              ! ここで指定するものは、
                              ! HistoryCreate にて dims で指定
                              ! されていなければならない。
                              !
                              ! もしもスカラー変数を作成
                              ! する場合には, サイズが 1 で
                              ! 中身が空の文字型配列,
                              ! すなわち <tt> (/''/) </tt>
                              ! を与えること.
                              !
    character(len = *), intent(in):: longname
                              ! 変数の記述的名称
                              !
                              ! 最大文字数は dc_types::STRING
                              !
    character(len = *), intent(in):: units
                              ! 変数の単位
                              !
                              ! 最大文字数は dc_types::STRING
                              !
    character(len = *), intent(in), optional:: xtype
                              ! 変数のデータ型
                              !
                              ! デフォルトはfloat (単精度実数型)
                              ! である。 有効なのは、
                              ! double (倍精度実数型)、 int
                              ! (整数型)、char (文字型)である。
                              ! 指定しない場合や、無効な型を指定した
                              ! 場合には、 float (単精度実数型)
                              ! となる。
                              !
    logical, intent(in), optional:: time_average
                              ! 出力データを時間平均する場合には
                              ! .true. を与えます。
                              ! デフォルトは .false. です。
                              !
                              ! If output data is averaged in time direction,
                              ! specify ".true.".
                              ! Default is ".false.".
                              !
    logical, intent(in), optional:: average
                              ! time_average の旧版.
                              ! Old version of "time_average"
    type(gt_history), intent(inout), optional, target:: history
                              ! 出力ファイルの設定に関する情報を
                              ! 格納した構造体
                              !
                              ! ここに指定するものは、
                              ! HistoryCreate によって初期設定
                              ! されていなければなりません。
                              !
    logical, intent(out), optional:: err
                              ! 例外処理用フラグ.
                              ! デフォルトでは, この手続き内でエラーが
                              ! 生じた場合, プログラムは強制終了します.
                              ! 引数 *err* が与えられる場合,
                              ! プログラムは強制終了せず, 代わりに
                              ! *err* に .true. が代入されます.
                              !
                              ! Exception handling flag.
                              ! By default, when error occur in
                              ! this procedure, the program aborts.
                              ! If this *err* argument is given,
                              ! .true. is substituted to *err* and
                              ! the program does not abort.
    type(gt_history), pointer:: hst =>null()
    type(gt_variable), pointer:: vwork(:) =>null(), dimvars(:) =>null()
    character(STRING):: fullname, url, cause_c
    integer, pointer:: count_work(:) =>null()
    integer, pointer:: var_avr_count_work(:) =>null()
    integer:: var_avr_length
    type(gt_history_avrdata), pointer:: var_avr_data_work(:) =>null()
    logical, pointer:: var_avr_firstput_work(:) =>null()
    real(dp), pointer:: var_avr_coefsum_work(:) =>null()
    real(dp), pointer:: var_avr_baseint_work(:) =>null()
    real(dp), pointer:: var_avr_prevtime_work(:) =>null()
!!$    type(DC_DIFFTIME), pointer:: var_avr_baseint_work(:) =>null()
!!$    type(DC_DIFFTIME), pointer:: var_avr_prevtime_work(:) =>null()
    character(STRING):: time_name, time_xtype, time_url
    type(gt_variable), pointer:: dimvars_work(:) =>null()
    logical, pointer:: dim_value_written_work(:) =>null()
    integer:: dimvars_size
    logical:: nv_exist, bnds_exist
    character(STRING):: nv_name_check, bnds_name_check
    character(*), parameter:: nv_suffix = '_nv'
    character(*), parameter:: bnds_suffix = '_bnds'
    integer, pointer:: dimord(:) =>null()
    integer:: nvars, numdims, i, stat
    integer:: err_mpi
    type(gt_history_varinfo), pointer:: work_mpi_varinfo(:) =>null()
    type(gt_history_mpivarindex), pointer:: work_mpi_vars_index(:) =>null()
    character(*), parameter:: subname = "HistoryAddVariable1"
  continue
    call beginsub(subname, 'name=<%a>, dims=<%a>, longname=<%a>, units=<%a>', &
      & ca=stoa(varname, joinchar(dims), longname, units))
    stat = dc_noerr
    cause_c = ''
    ! 操作対象決定
    !
    if (present(history)) then
      hst => history
    else
      hst => default
    endif
    ! 初期設定のチェック
    ! Check initialization
    !
    if ( .not. hst % initialized ) then
      stat = dc_enotinit
      cause_c = 'GT_HISTORY'
      goto 999
    end if
    ! HistoryPutAxisMPI が既に呼ばれていることをチェック
    ! Check that "HistoryPutAxisMPI" is already called
    !
    if ( hst % mpi_gather .and. hst % mpi_myrank == 0 .and. &
      &  .not. hst % mpi_fileinfo % already_output ) then
      call messagenotify('W', subname, &
        & 'Specify data of axes in whole area by "HistoryPutAxisMPI" explicitly ' // &
        & 'before "call HistoryAddVariable".' )
      stat = hst_empinoaxisdata
      goto 999
    end if
    ! 変数表拡張 (MPI, ファイル統合版)
    !
    if ( hst % mpi_gather ) then
      if ( associated(hst % mpi_varinfo) ) then
        nvars = size(hst % mpi_varinfo(:))
        work_mpi_varinfo => hst % mpi_varinfo
        nullify( hst % mpi_varinfo )
        allocate( hst % mpi_varinfo(nvars + 1) )
        hst % mpi_varinfo(1:nvars) = work_mpi_varinfo
        deallocate( work_mpi_varinfo )
        nvars = size(hst % mpi_vars_index(:))
        work_mpi_vars_index => hst % mpi_vars_index
        nullify( hst % mpi_vars_index )
        allocate( hst % mpi_vars_index(nvars + 1) )
        hst % mpi_vars_index(1:nvars) = work_mpi_vars_index
        deallocate( work_mpi_vars_index )
      else
        nvars = 0
        allocate( hst % mpi_varinfo(nvars + 1) )
        allocate( hst % mpi_vars_index(nvars + 1) )
      end if
      call historyvarinfocreate( &
        & hst % mpi_varinfo(nvars + 1), &          ! (out)
        & varname, dims, longname, units, xtype, & ! (in)
        & time_average, average )                  ! (in) optional
    end if
    ! 変数表拡張
    !
    if (associated(hst % vars)) then
      nvars = size(hst % vars(:))
      vwork => hst % vars
      count_work => hst % count
      nullify(hst % vars, hst % count)
      allocate(hst % vars(nvars + 1), hst % count(nvars + 1))
      hst % vars(1:nvars) = vwork(1:nvars)
      hst % count(1:nvars) = count_work(1:nvars)
      deallocate(vwork, count_work)
      count_work => hst % growable_indices
      nullify(hst % growable_indices)
      allocate(hst % growable_indices(nvars + 1))
      hst % growable_indices(1:nvars) = count_work(1:nvars)
      deallocate(count_work)
      ! 平均値出力のための変数表コピー
      ! Copy table of variables for average value output
      !
      var_avr_count_work => hst % var_avr_count
      nullify( hst % var_avr_count )
      allocate( hst % var_avr_count(nvars + 1) )
      hst % var_avr_count(1:nvars) = var_avr_count_work(1:nvars)
      deallocate( var_avr_count_work )
      var_avr_data_work => hst % var_avr_data
      nullify(hst % var_avr_data)
      allocate(hst % var_avr_data(nvars + 1))
      do i = 1, nvars
        hst % var_avr_data(i) % length = var_avr_data_work(i) % length
        allocate(hst % var_avr_data(i) % &
          & a_dataavr(var_avr_data_work(i) % length))
        hst % var_avr_data(i) % a_DataAvr = var_avr_data_work(i) % a_DataAvr
        deallocate( var_avr_data_work(i) % a_DataAvr )
      end do
      deallocate( var_avr_data_work )
      var_avr_firstput_work => hst % var_avr_firstput
      nullify( hst % var_avr_firstput )
      allocate( hst % var_avr_firstput(nvars + 1) )
      hst % var_avr_firstput(1:nvars) = var_avr_firstput_work(1:nvars)
      deallocate( var_avr_firstput_work )
      var_avr_coefsum_work => hst % var_avr_coefsum
      nullify( hst % var_avr_coefsum )
      allocate( hst % var_avr_coefsum(nvars + 1) )
      hst % var_avr_coefsum(1:nvars) = var_avr_coefsum_work(1:nvars)
      deallocate( var_avr_coefsum_work )
      var_avr_baseint_work => hst % var_avr_baseint
      nullify( hst % var_avr_baseint )
      allocate( hst % var_avr_baseint(nvars + 1) )
      hst % var_avr_baseint(1:nvars) = var_avr_baseint_work(1:nvars)
      deallocate( var_avr_baseint_work )
      var_avr_prevtime_work => hst % var_avr_prevtime
      nullify( hst % var_avr_prevtime )
      allocate( hst % var_avr_prevtime(nvars + 1) )
      hst % var_avr_prevtime(1:nvars) = var_avr_prevtime_work(1:nvars)
      deallocate( var_avr_prevtime_work )
    else
      ! トリッキーだが, ここで count だけ 2 要素確保するのは,
      ! HistorySetTime による巻き戻しに備えるため.
      !
      allocate(hst % vars(1), hst % count(2), hst % growable_indices(1))
      hst % count(2) = 0
      allocate(hst % var_avr_count(1), hst % var_avr_data(1))
      allocate(hst % var_avr_firstput(1), hst % var_avr_coefsum(1))
      allocate(hst % var_avr_baseint(1), hst % var_avr_prevtime(1))
    endif
    nvars = size(hst % vars(:))
    hst % growable_indices(nvars) = 0
    if ( nvars < 2 ) then
      hst % count(nvars) = 0
    else
      hst % count(nvars) = hst % count(1)
    end if
    ! スカラー変数作成への対応
    !
    if (size(dims) == 1 .and. trim(dims(1)) == '') then
      numdims = 0
    else
      numdims = size(dims)
    end if
    allocate( dimvars(numdims) )
    allocate( dimord(numdims) )
    if ( .not. hst % mpi_gather &
      &  .or. ( hst % mpi_gather .and. hst % mpi_myrank == 0 ) ) then
    ! 次元の ID の取得
    !
    do, i = 1, numdims
      ! hst 内で, 次元変数名 dim(i) に当たる次元変数の ID である
      ! hst % dimvar(i) を dimvars(i) に, 添字を dimord に
      !
      dimvars(i) = lookup_dimension( hst, dims(i), &   ! (in)
        &                            ord = dimord(i) ) ! (out)
      if (dimord(i) == 0) then
        stat = nf90_ebaddim
        cause_c = cprintf('"%c" dimension is not found.', c1=trim(dims(i)))
        goto 999
      end if
    end do
      if ( hst % mpi_gather ) then
        call mpi_bcast( dimord, numdims, mpi_integer, 0, mpi_comm_world, err_mpi )
      end if
    elseif ( hst % mpi_gather .and. hst % mpi_myrank /= 0 ) then
      call mpi_bcast( dimord, numdims, mpi_integer, 0, mpi_comm_world, err_mpi )
    end if
    ! 変数添字次元を決定
    !
    do, i = 1, numdims
      ! 無制限次元の添字と一致する場合に,
      ! その添字を hst % growable_indices(nvars) に
      !
      if (dimord(i) == hst % unlimited_index) then
        hst % growable_indices(nvars) = i
      endif
    enddo
    if ( .not. hst % mpi_gather &
      &  .or. ( hst % mpi_gather .and. hst % mpi_myrank == 0 ) ) then
    ! 変数作成
    !
    call inquire(hst % dimvars(1), url=url)
    fullname = urlresolve((gt_atmark // trim(varname)), trim(url))
    call create(hst % vars(nvars), trim(fullname), dimvars, xtype=xtype)
    if ( associated(dimvars) ) deallocate( dimvars )
    ! 拡張可能次元があったらそれをサイズ 1 に拡張しておく
    !
    if (hst % growable_indices(nvars) /= 0) then
      call slice(hst % vars(nvars), hst % growable_indices(nvars), &
        & start=1, count=1, stride=1)
    endif
    call put_attr(hst % vars(nvars), 'long_name', longname)
    call put_attr(hst % vars(nvars), 'units', units)
    end if
    ! 平均処理に関する情報管理
    !
    if (      present_and_true( time_average ) &
      &  .or. present_and_true( average ) ) then
      hst % var_avr_count(nvars) = 0
      if ( .not. hst % mpi_gather &
        &  .or. ( hst % mpi_gather .and. hst % mpi_myrank == 0 ) ) then
      ! 情報の取得
      ! Get Information
      !
      call inquire( &
        & var = hst % dimvars( hst % unlimited_index ), & ! (in)
        & name = time_name, url = time_url, & ! (out)
        & xtype = time_xtype )                ! (out)
        if ( hst % mpi_gather ) then
          call mpi_bcast( time_name,  string, mpi_character, 0, mpi_comm_world, err_mpi )
          call mpi_bcast( time_url,   string, mpi_character, 0, mpi_comm_world, err_mpi )
          call mpi_bcast( time_xtype, string, mpi_character, 0, mpi_comm_world, err_mpi )
        end if
      elseif ( hst % mpi_gather .and. hst % mpi_myrank /= 0 ) then
        call mpi_bcast( time_name,  string, mpi_character, 0, mpi_comm_world, err_mpi )
        call mpi_bcast( time_url,   string, mpi_character, 0, mpi_comm_world, err_mpi )
        call mpi_bcast( time_xtype, string, mpi_character, 0, mpi_comm_world, err_mpi )
      end if
      ! 変数のデータ数の取得
      !
      if ( .not. hst % mpi_gather ) then
      call inquire(hst % vars(nvars), size = var_avr_length )
      else
        var_avr_length = 1
        do i = 1, numdims
          if ( hst % unlimited_index == dimord(i) ) cycle
          var_avr_length = &
            & var_avr_length * hst % mpi_dimdata_each( dimord(i) ) % length
        end do
      end if
      ! 割り付け
      !
      hst % var_avr_data(nvars) % length = var_avr_length
      allocate(hst % var_avr_data(nvars) % a_DataAvr(var_avr_length))
      hst % var_avr_data(nvars) % a_DataAvr = 0.0_dp
      ! デフォルト値設定
      !
      hst % var_avr_firstput = .true.
      hst % var_avr_coefsum(nvars) = 0.0_dp
      hst % var_avr_baseint(nvars) = 0.0_dp
!!$      call DCDiffTimeCreate( &
!!$        & hst % var_avr_baseint(nvars), & ! (out)
!!$        & sec = 0.0_DP )                   ! (in)
      hst % var_avr_prevtime(nvars) = hst % var_avr_baseint(nvars)
      ! 時間次元情報の取得
      !
      if ( hst % growable_indices(nvars) < 1 ) then
        stat = hst_enodependtime
        cause_c = trim(varname)
        goto 999
      end if
      if ( .not. hst % mpi_gather &
        &  .or. ( hst % mpi_gather .and. hst % mpi_myrank == 0 ) ) then
      ! 時間次元への属性 "bounds" の追加
      !
      call put_attr( var = hst % dimvars( hst % unlimited_index ), & ! (inout)
        & name = 'bounds', &                       ! (in)
        & value = trim(time_name) // bnds_suffix ) ! (in)
      ! 変数 "varname" への属性 "cell_methods" の追加
      !
      call put_attr( var = hst % vars(nvars), & ! (inout)
        & name = 'cell_methods', &              ! (in)
        & value = trim(time_name) // ': mean' ) ! (in)
      ! "time_nv" 次元の作成 (既に作成されていたら何もしない)
      !
      dimvars_size = size( hst % dimvars )
      nv_exist = .false.
      do i = 1, dimvars_size
        call inquire( &
          & var = hst % dimvars(i), & ! (in)
          & name = nv_name_check )    ! (out)
        if ( trim(time_name) // trim(nv_suffix) == trim(nv_name_check) ) then
          nv_exist = .true.
          exit
        end if
      end do
      if ( .not. nv_exist ) then
        dimvars_work => hst % dimvars
        dim_value_written_work => hst % dim_value_written
        nullify(hst % dimvars, hst % dim_value_written)
        allocate(hst % dimvars(dimvars_size + 1))
        allocate(hst % dim_value_written(dimvars_size + 1))
        hst % dimvars(1:dimvars_size) = dimvars_work(1:dimvars_size)
        hst % dim_value_written(1:dimvars_size) = dim_value_written_work(1:dimvars_size)
        deallocate(dimvars_work)
        deallocate(dim_value_written_work)
        call create( &
          & var = hst % dimvars(dimvars_size + 1), &   ! (out)
          & url = trim(time_url) // trim(nv_suffix), & ! (in)
          & length = 2, xtype = 'integer' )            ! (in)
        hst % time_nv_index = dimvars_size + 1
        call put_attr( var = hst % dimvars(dimvars_size + 1), & ! (inout)
          & name = 'long_name', &                               ! (in)
          & value = 'number of vertices of time')               ! (in)
        call put_attr( var = hst % dimvars(dimvars_size + 1), & ! (inout)
          & name = 'units', value = '1' )                       ! (in)
        call put( var = hst % dimvars(dimvars_size + 1), & ! (inout)
          & value = (/1, 2/) )                             ! (in)
        hst % dim_value_written(dimvars_size + 1) = .true.
      end if
      ! "time_bnds" 変数の作成 (既に作成されていたら何もしない)
      !
      bnds_exist = .false.
      do i = 1, nvars
        call inquire( &
          & var = hst % vars(i), &   ! (in)
          & name = bnds_name_check ) ! (out)
        if ( trim(time_name) // trim(bnds_suffix) == trim(bnds_name_check) ) then
          bnds_exist = .true.
          exit
        end if
      end do
        if ( hst % mpi_gather ) then
          call mpi_bcast( hst % time_nv_index, 1, mpi_integer, 0, mpi_comm_world, err_mpi )
          call mpi_bcast( bnds_exist, 1, mpi_logical, 0, mpi_comm_world, err_mpi )
        end if
      elseif ( hst % mpi_gather .and. hst % mpi_myrank /= 0 ) then
        call mpi_bcast( hst % time_nv_index, 1, mpi_integer, 0, mpi_comm_world, err_mpi )
        call mpi_bcast( bnds_exist, 1, mpi_logical, 0, mpi_comm_world, err_mpi )
      end if
      if ( associated(dimord) )  deallocate( dimord )
      if ( .not. bnds_exist ) then
        call historyaddvariable( &
          &  history = hst, &                                 ! (inout)
          &  varname = trim(time_name) // trim(bnds_suffix), &
          &     dims = stoa( trim(time_name) // trim(nv_suffix), &
          &                  trim(time_name) ), &             ! (in)
          & longname = 'bounds of time', &                    ! (in)
          & units = hst % unlimited_units, &                  ! (in)
          & xtype = time_xtype )                              ! (in)
      end if
    ! 平均処理が不要な場合
    !
    else
      hst % var_avr_count(nvars) = -1
      ! 割り付け
      !
      var_avr_length = 1
      hst % var_avr_data(nvars) % length = var_avr_length
      allocate(hst % var_avr_data(nvars) % a_DataAvr(var_avr_length))
      hst % var_avr_data(nvars) % a_DataAvr = 0.0_dp
      ! デフォルト値設定
      !
      hst % var_avr_firstput = .true.
      hst % var_avr_coefsum(nvars) = 0.0_dp
      hst % var_avr_baseint(nvars) = 0.0_dp
!!$      call DCDiffTimeCreate( &
!!$        & hst % var_avr_baseint(nvars), & ! (out)
!!$        & sec = 0.0_DP )                   ! (in)
      hst % var_avr_prevtime(nvars) = hst % var_avr_baseint(nvars)
    end if
    ! 終了処理, 例外処理
    ! Termination and Exception handling
    !
999 continue
    if ( associated(dimvars) ) deallocate( dimvars )
    if ( associated(dimord) )  deallocate( dimord )
    call storeerror(stat, subname, err, cause_c)
    call endsub(subname)
  end subroutine historyaddvariable1
  subroutine historyaddvariable2( &
    & varinfo, history, err )
    !
    use dc_string, only: joinchar
    use gtool_history_generic, only: historyaddvariable
    use gtool_history_types, only: gt_history, gt_history_varinfo
    use gtool_history_internal, only: append_attrs
    use dc_trace, only: beginsub, endsub
    implicit none
    type(gt_history_varinfo), intent(in)             :: varinfo
                              ! 変数情報を格納した構造体
                              !
                              ! ここに指定するものは、
                              ! HistoryVarinfoCreate によって
                              ! 初期設定されていなければなりません。
                              !
    type(gt_history),         intent(inout), optional:: history
                              ! 出力ファイルの設定に関する情報を
                              ! 格納した構造体
                              !
                              ! ここに指定するものは、
                              ! HistoryCreate によって初期設定
                              ! されていなければなりません。
                              !
    logical, intent(out), optional:: err
                              ! 例外処理用フラグ.
                              ! デフォルトでは, この手続き内でエラーが
                              ! 生じた場合, プログラムは強制終了します.
                              ! 引数 *err* が与えられる場合,
                              ! プログラムは強制終了せず, 代わりに
                              ! *err* に .true. が代入されます.
                              !
                              ! Exception handling flag.
                              ! By default, when error occur in
                              ! this procedure, the program aborts.
                              ! If this *err* argument is given,
                              ! .true. is substituted to *err* and
                              ! the program does not abort.
    character(len = *), parameter:: subname = "HistoryAddVariable2"
  continue
    call beginsub(subname, 'varname=<%c>, dims=<%c>, longname=<%c>', &
      & c1=trim(varinfo % name), c2=trim(joinchar(varinfo % dims)),   &
      & c3=trim(varinfo % longname)                               )
    call historyaddvariable( &
      & history = history, &              ! (inout)
      & varname = varinfo % name, &       ! (in)
      & dims = varinfo % dims, &          ! (in)
      & longname = varinfo % longname, &  ! (in)
      & units = varinfo % units, &        ! (in)
      & xtype = varinfo % xtype, &        ! (in)
      & time_average = varinfo % time_average, & ! (in) optional
      & err = err )                              ! (out) optional
    if (associated( varinfo % attrs )) then
      call append_attrs( varinfo % name, varinfo % attrs, history )
    end if
    call endsub(subname)
  end subroutine historyaddvariable2