gtool_history_internal.f90

Go to the documentation of this file.

!--
! *** Caution!! ***
!
! This file is generated from "gtool_history_internal.rb2f90" by Ruby 3.3.8.
! Please do not edit this file directly.
!
! [JAPANESE]
!
! ※※※ 注意!!! ※※※
!
! このファイルは "gtool_history_internal.rb2f90" から Ruby 3.3.8
! によって自動生成されたファイルです.
! このファイルを直接編集しませんようお願い致します.
!
!
!++
!> @file gtool_history_internal.f90
!>
!> @author Yasuhiro MORIKAWA, Eizi TOYODA
!> @copyright Copyright (C) GFD Dennou Club, 2000-2026. All rights reserved. <br/>
!>            License is BSD-2-Clause. See [COPYRIGHT](@ref COPYRIGHT) in detail
!>
!> @en
!> @brief A default GT_HISTORY variable and internal procedures for handling of GT_HISTORY
!> @enden
!>
!> @ja
!> @brief デフォルトの GT_HISTORY 変数および GT_HISTORY 操作用内部手続き
!> @endja
module gtool_history_internal
  !> @en
  !> A default GT_HISTORY variable
  !> that is used when "history" argument
  !> of each subroutine is not specified is stored in this module.
  !> In addition, procedures that handle information in GT_HISTORY variables
  !> are provided.
  !> This variable is prepared for internal use,
  !> so do not refer this variable from outside of gtool5.
  !> @enden
  !>
  !> @ja
  !> このモジュールは, 各サブルーチンにおいて, history 引数が
  !> 未指定の場合に使用されるデフォルトの GT_HISTORY 変数を
  !> 保管するとともに, GT_HISTORY 変数内の情報を編集するための
  !> gtool_history モジュール内部で使用する手続きについても提供します.
  !> 内部向けなので, gtool5 ライブラリの外部から呼び出さないでください.
  !> @endja
  use dc_types, only: string
  use gtool_history_types, only: gt_history
  use gtdata_types, only: gt_variable
  implicit none
  private
  type(gt_history), save, target, public:: default
                              ! 各サブルーチンにおいて, history 引数が
                              ! 未指定の場合に使用される
                              ! デフォルトの GT_HISTORY 変数.
                              !
                              ! A default "GT_HISTORY" variable
                              ! that is used when "history" argument
                              ! of each subroutine is not specified.
  character(STRING), parameter, public:: &
    & gtool4_netCDF_Conventions = &
    &     "http://www.gfd-dennou.org/library/gtool4/conventions/"
    ! gtool4 netCDF 規約の URL
  character(STRING), parameter, public:: &
    & gtool4_netCDF_version = "4.3"
    ! gtool4 netCDF 規約のバージョン
  public:: append_attrs, copy_attrs
  public:: set_fake_dim_value
  public:: lookup_variable_ord, lookup_variable
  public:: lookup_dimension, lookup_var_or_dim
  public:: gtmpi_axis_register, gtmpi_vars_mkindex
  interface append_attrs
    module procedure append_attrs
  end interface
  interface copy_attrs
    module procedure copy_attrs
  end interface
  interface set_fake_dim_value
    module procedure set_fake_dim_value
  end interface
  interface lookup_variable_ord
    module procedure lookup_variable_ord
  end interface
  interface lookup_variable
    module procedure lookup_variable
  end interface
  interface lookup_dimension
    module procedure lookup_dimension
  end interface
  interface lookup_var_or_dim
    module procedure lookup_var_or_dim
  end interface
  interface gtmpi_axis_register
    module procedure gtmpi_axis_register
  end interface
  interface gtmpi_vars_mkindex
    module procedure gtmpi_vars_mkindex
  end interface
contains
  subroutine append_attrs(varname, attrs, history)
    !
    ! GT_HISTORY_ATTR 変数を history の varname 変数に
    ! 付加するためのサブルーチン. 公開用ではなく,
    ! HistoryCreate や HistoryAddVariable に GT_HISTORY_AXIS
    ! や GT_HISTORY_VARINFO が与えられた時に内部的に利用される.
    !
    use gtool_history_generic, only: historyaddattr
    use gtdata_generic, only: put_attr
    use dc_trace, only: beginsub, endsub, dbgmessage
    use dc_string     , only: strhead, lchar, tochar
    use gtool_history_types, only: gt_history, gt_history_axis, gt_history_varinfo, gt_history_attr
    implicit none
    character(*),     intent(in):: varname
    type(gt_history_attr),  intent(in):: attrs(:)
    type(gt_history), intent(inout), target, optional:: history
    type(gt_history), pointer:: hst =>null()
    integer                      :: i
    character(*), parameter:: subname = "append_attrs"
  continue
    call beginsub(subname, 'varname=<%c>, size(attrs(:))=<%d>', &
      &        c1=trim(varname), i=(/size(attrs(:))/))
    if (present(history)) then
      hst => history
    else
      hst => default
    endif
    ! attrs(:) のサイズ分だけループ
    do i = 1, size( attrs(:) )
      ! attrs(i)%attrtype の種別で与える変数を変える
      if ( strhead( 'char', trim(lchar(attrs(i)%attrtype))) ) then
        call historyaddattr( &
          & varname, attrs(i)%attrname, &
          & trim(attrs(i)%Charvalue), hst )
      elseif ( strhead( 'int', trim(lchar(attrs(i)%attrtype))) ) then
        if ( attrs(i)%array ) then
          call dbgmessage('Intarray(:) is selected.')
          call historyaddattr( &
            & varname, attrs(i)%attrname , &
            & attrs(i)%Intarray, hst       )
        else
          call dbgmessage('Intvalue is selected')
          call historyaddattr( &
            & varname, attrs(i)%attrname , &
            & attrs(i)%Intvalue, hst      )
        endif
      elseif ( strhead( 'real', trim(lchar(attrs(i)%attrtype))) ) then
        if ( attrs(i)%array ) then
          call dbgmessage('Realarray(:) is selected.')
          call historyaddattr( &
            & varname, attrs(i)%attrname, attrs(i)%Realarray, hst)
        else
          call dbgmessage('Realvalue is selected')
          call historyaddattr( &
            & varname, attrs(i)%attrname, attrs(i)%Realvalue, hst)
        endif
      elseif ( strhead( 'double', trim(lchar(attrs(i)%attrtype))) ) then
        if ( attrs(i)%array ) then
          call dbgmessage('Doublearray(:) is selected.')
          call historyaddattr( &
            & varname, attrs(i)%attrname, attrs(i)%Doublearray, hst)
        else
          call dbgmessage('Doublevalue is selected')
          call historyaddattr( &
            & varname, attrs(i)%attrname, attrs(i)%Doublevalue, hst)
        endif
      elseif ( strhead( 'logical', trim(lchar(attrs(i)%attrtype))) ) then
        call historyaddattr( &
          & varname, attrs(i)%attrname, attrs(i)%Logicalvalue, hst)
      else
        call dbgmessage('attrtype=<%c>=<%c>is Invalid.'   , &
          &      c1=trim(attrs(i)%attrtype)         , &
          &      c2=trim(lchar(attrs(i)%attrtype))      )
      endif
    enddo
    call endsub(subname)
  end subroutine append_attrs
  subroutine copy_attrs(from, to, err)
    !
    ! GT_HISTORY_ATTR 変数をコピーするためのサブルーチン
    ! このモジュール内部で利用されることを想定している.
    ! from と to の配列サイズは同じであることが想定されている.
    ! err を与えると, コピーの際何らかの不具合が生じると
    ! 終了せずに err が真になって返る.
    !
    use dc_string,only: lchar, strhead
    use dc_trace, only: beginsub, endsub, dbgmessage
    use dc_error, only: storeerror, &
      &  gt_eargsizemismatch, gt_ebadattrname, dc_noerr
    use dc_types, only: string
    use gtool_history_types, only: gt_history, gt_history_axis, gt_history_varinfo, gt_history_attr
    implicit none
    type(gt_history_attr), intent(in)  :: from(:)
    type(gt_history_attr), intent(out) :: to(:)
    logical,               intent(out), optional :: err
    integer     :: i, stat
    character(STRING) :: cause_c
    character(STRING), parameter:: subname = "copy_attrs"
  continue
    call beginsub(subname)
    stat = dc_noerr
    cause_c = ''
    call dbgmessage('size(from)=<%d>, size(to)=<%d>, So copy <%d> times.', &
      &       i=(/ size(from), size(to), min(size(from),size(to)) /) )
    if ( size(to) < size(from) ) then
      stat = gt_eargsizemismatch
      cause_c = 'from is larger than to'
      goto 999
    end if
    ! from と to の小さい方に合わせてループ
    do i = 1, min( size(from), size(to) )
      ! attrname と attrtype と array はまずコピー
      to(i)%attrname       = from(i)%attrname
      to(i)%attrtype       = from(i)%attrtype
      to(i)%array          = from(i)%array
      ! from(i)%attrtype の種別でコピーする変数を変える.
      if ( strhead( 'char', trim(lchar(from(i)%attrtype))) ) then
        to(i)%Charvalue      = from(i)%Charvalue
                          elseif ( strhead( &
        &   lchar('Int'), trim(lchar(from(i)%attrtype)))) then
        if ( from(i)%array ) then
          allocate(  to(i)%Intarray( size(from(i)%Intarray) )  )
          to(i)%Intarray = from(i)%Intarray
        else
          to(i)%Intvalue = from(i)%Intvalue
        endif
      elseif ( strhead( &
        &   lchar('Real'), trim(lchar(from(i)%attrtype)))) then
        if ( from(i)%array ) then
          allocate(  to(i)%Realarray( size(from(i)%Realarray) )  )
          to(i)%Realarray = from(i)%Realarray
        else
          to(i)%Realvalue = from(i)%Realvalue
        endif
      elseif ( strhead( &
        &   lchar('Double'), trim(lchar(from(i)%attrtype)))) then
        if ( from(i)%array ) then
          allocate(  to(i)%Doublearray( size(from(i)%Doublearray) )  )
          to(i)%Doublearray = from(i)%Doublearray
        else
          to(i)%Doublevalue = from(i)%Doublevalue
        endif
      elseif ( strhead( 'logical', trim(lchar(from(i)%attrtype))) ) then
        to(i)%Logicalvalue = from(i)%Logicalvalue
      else
        stat = gt_ebadattrname
        cause_c = from(i)%attrtype
        goto 999
      endif
    enddo
999 continue
    call storeerror(stat, subname, err, cause_c=cause_c)
    call endsub(subname)
  end subroutine copy_attrs
  subroutine set_fake_dim_value(history, dimord)
    !
    ! 次元 history % dimvars(dimord) に値が設定されていない場合、
    ! 「とりあえず」値を設定する。ただし、無制限次元 (時間次元)
    ! に関しては history % origin, history % interval, history % count
    ! から「まっとうな」値が設定される。
    !
    use gtdata_generic, only: inquire, slice, put
    use dc_error, only: dumperror
    use dc_types, only: dp
!    use dc_calendar, only: DCCalConvertByUnit
!    use dc_date, only: EvalByUnit
    type(gt_history), intent(inout):: history
    integer, intent(in):: dimord
    integer:: length, i
    real(DP), allocatable:: value(:)
    logical:: err
  continue
    if (dimord == history % unlimited_index) then
      if (.not. associated(history % count)) return
      length = maxval(history % count(:))
    else
      call inquire(history % dimvars(dimord), size=length)
    endif
    if (length == 0) return
    allocate(value(length))
    if (dimord == history % unlimited_index) then
      value(:) = (/(real(i, dp), i = 1, length)/)
      value(:) =   &
        &   history % origin &
        & + (value(:) - 1.0_dp) * history % interval
!!$      value(:) =   &
!!$        &   EvalByUnit( history % origin, '', history % unlimited_units_symbol ) &
!!$        & + (value(:) - 1.0) &
!!$        &   * EvalByUnit( history % interval, '', history % unlimited_units_symbol )
      call slice(history % dimvars(dimord), 1, start=1, count=length)
    else
      value(:) = (/(real(i, dp), i = 1, length)/)
    endif
    call put(history % dimvars(dimord), value, size(value), err)
    if (err) call dumperror
    deallocate(value)
  end subroutine set_fake_dim_value
  integer function lookup_variable_ord(history, varname) result(result)
    !
    ! history 内の varname 変数の変数番号を返す.
    ! 現在, 明示的に history 変数を与えない場合の変数番号の
    ! 検索は出来ない.
    !
    use dc_types, only: string
    use gtdata_generic, only: inquire
    use dc_trace, only: beginsub, endsub, dbgmessage
    implicit none
    type(gt_history), intent(in):: history
    character(len = *), intent(in):: varname
    character(len = string):: name
    character(len = *), parameter:: subname = 'lookup_variable_ord'
  continue
    call beginsub(subname, 'var=%c', c1 = trim(varname))
    if (associated(history % vars)) then
      do, result = 1, size(history % vars)
        call inquire(history % vars(result), name=name)
        if (name == varname) goto 999
        call dbgmessage('no match <%c> <%c>', c1=trim(name), c2=trim(varname))
      enddo
    endif
    result = 0
999 continue
    call endsub(subname, "result=%d", i=(/result/))
  end function
  type(gt_variable) function lookup_variable(history, varname, ord) result(result)
    !
    !  history 内での変数 varname の ID を取得
    !    ID を取得できた場合, 返り値 result と ord にそれぞれ
    !    その ID が返される。
    !    ID を取得できない場合、ord が渡されていなければその場で終了
    !    ord が渡されている場合は ord に 0 が返される。
    !
    use dc_types, only: string
    use dc_error, only: storeerror, nf90_enotvar, dc_noerr
    use dc_trace, only: beginsub, endsub, dbgmessage
    implicit none
    type(gt_history), intent(in):: history
    character(len = *), intent(in):: varname
    character(len = STRING) :: cause_c
    integer, intent(out), optional:: ord
    integer:: ordwork
    integer:: i, stat
    character(len = *), parameter:: subname = 'lookup_variable'
  continue
    call beginsub(subname, '%c', c1=trim(varname))
    stat = dc_noerr
    cause_c = ''
    if (present(ord)) ord = 0
    ordwork = 0
    i = lookup_variable_ord(history, varname)
    if (i > 0) then
      result = history % vars(i)
      if (present(ord)) ord = i
      goto 999
    endif
    if (present(ord)) then
      ord = 0
    else
      stat = nf90_enotvar
      cause_c = varname
      i = 0
    endif
999 continue
    call storeerror(stat, subname, cause_c=cause_c)
    if (present(ord)) ordwork = ord
    call endsub(subname, "ord=%d (0: not found)", i=(/ordwork/))
  end function
  type(gt_variable) function lookup_dimension(history, dimname, ord) result(result)
    !
    ! history 内の dimname という変数名を持つ次元の GT_VARIABLE
    ! 変数を返す. dimname 末尾の空白は無視される.
    !
    use gtdata_generic, only: inquire
    use dc_types, only: string
    use dc_error, only: storeerror, gt_ebaddimname, dc_noerr
    use dc_trace, only: beginsub, endsub, dbgmessage
    implicit none
    type(gt_history), intent(in):: history
    character(len = *), intent(in):: dimname
    integer, intent(out), optional:: ord
    integer:: ordwork
    character(len = STRING):: name, cause_c
    integer:: i, stat
    character(len = *), parameter:: subname = 'lookup_dimension'
  continue
    call beginsub(subname, 'dimname=%c', c1=trim(dimname))
    stat = dc_noerr
    if (present(ord)) ord = 0
    ordwork = 0
    if (associated(history % dimvars)) then
      do, i = 1, size(history % dimvars)
        call inquire(history % dimvars(i), name=name)
        if (name == trim(dimname)) then
          result = history % dimvars(i)
          if (present(ord)) ord = i
          stat = dc_noerr
          cause_c = ""
          goto 999
        endif
      enddo
    endif
    if (present(ord)) then
      ord = 0
    else
      stat = gt_ebaddimname
      cause_c = dimname
    endif
999 continue
    call storeerror(stat, subname, cause_c=cause_c)
    if (present(ord)) ordwork = ord
    call endsub(subname, 'ord=%d (0:not found)', i=(/ordwork/))
  end function
  subroutine lookup_var_or_dim(history, name, var, err)
    !
    ! history 内から, name という名前の次元または変数を探査し,
    ! var に GT_VARIABLE 変数を返す. 見つかって正常に
    ! var が返る場合は stat には DC_NOERR が返り,
    ! history 内から name が発見されない場合には, stat に
    ! NF90_ENOTVAR が返る.
    !
    use dc_error, only: storeerror, dc_noerr, nf90_enotvar
    use dc_types, only: string
    use dc_trace, only: beginsub, endsub, dbgmessage
    implicit none
    type(gt_history), intent(in):: history
    character(len = *), intent(in):: name
    type(gt_variable), intent(out):: var
    logical, intent(out):: err
    integer:: stat, ord
    character(STRING) :: cause_c
    character(len = *), parameter:: subname = 'lookup_var_or_dim'
  continue
    call beginsub(subname, 'name=<%c>', c1=trim(name))
    cause_c = ""
    stat = dc_noerr
    var = lookup_variable(history, name, ord)
    if (ord /= 0) then
      stat = dc_noerr
      goto 999
    endif
    var = lookup_dimension(history, name, ord)
    if (ord /= 0) then
      stat = dc_noerr
      goto 999
    endif
    stat = nf90_enotvar
    cause_c = "Any vars and dims are not found"
999 continue
    call storeerror(stat, subname, err, cause_c)
    call endsub(subname, 'ord=%d (0:not found)', i=(/ord/))
  end subroutine lookup_var_or_dim
  subroutine gtmpi_axis_register(hst, err)
    !
    ! hst % mpi_gthr_info に情報の登録を行う.
    !
    use gtool_history_types, only: gt_history, gt_history_axis, gt_history_varinfo, gt_history_attr
    use gtdata_generic, only: inquire
    use gtdata_types, only: gt_variable
    use dc_error, only: storeerror, dc_noerr, hst_empinoaxisdata
    use dc_message, only: messagenotify
    use dc_url, only: urlsplit
    use dc_trace, only: beginsub, endsub, dbgmessage
    use dc_types, only: string, dp
    use mpi
    implicit none
    type(gt_history), intent(inout):: hst
    logical, intent(out), optional:: err
    integer:: i, j, k, ra, numdims
    integer:: err_mpi, st_mpi(MPI_STATUS_SIZE)
    integer, allocatable:: index_all_buf(:)
    character(STRING):: url, dimname
    real:: accuracy
    real(DP):: zero_limit
    logical:: flag_hit
    real(DP), pointer:: large =>null(), small =>null()
    integer:: stat
    character(STRING):: cause_c
    character(*), parameter:: subname = 'gtmpi_axis_register'
    character(*), parameter:: subnameup = 'HistoryPut'
  continue
    call beginsub(subname)
    cause_c = ""
    stat = dc_noerr
    numdims = size( hst % dimvars )
    accuracy = 1.0e-3
    zero_limit = 1.0e-6_dp
    allocate( hst % mpi_gthr_info(numdims) )
    ! 未登録の座標データ (時刻以外) がある場合にはエラー
    ! Error is occurred when non registered data of axes (excluding time)
    !
    do i = 1, numdims
      if ( hst % unlimited_index == i ) cycle
      if ( hst % time_nv_index == i ) cycle
      if ( hst % mpi_myrank == 0 ) then
        call inquire( hst % dimvars(i), & ! (in)
          &           url = url )         ! (out)
        call urlsplit( url, & ! (in)
          &  var = dimname )  ! (out)
        call mpi_bcast( dimname, string, mpi_character, 0, mpi_comm_world, err_mpi )
      else
        call mpi_bcast( dimname, string, mpi_character, 0, mpi_comm_world, err_mpi )
      end if
      if ( hst % mpi_myrank == 0 ) then
        if ( hst % mpi_dimdata_all(i) % length < 0 ) then
          call messagenotify('W', subnameup, &
            & 'data of axis (%c) in whole area is lack. ' // &
            & 'Specify the data by "HistoryPutAxisMPI" explicitly.', &
            & c1 = trim(dimname) )
          stat = hst_empinoaxisdata
          cause_c = dimname
          goto 999
        end if
      end if
      if ( hst % mpi_dimdata_each(i) % length < 0 ) then
        call messagenotify('W', subnameup, &
          & 'data of axis (%c) on node (%d) is lack. ' // &
          & 'Specify the data by "HistoryPut" explicitly.', &
          & c1 = trim(dimname), i = (/ hst % mpi_myrank /) )
        stat = hst_empinoaxisdata
        cause_c = dimname
        goto 999
      end if
    end do
    ! mpi_gthr_info へ情報を登録
    ! Register information to "mpi_gthr_info"
    !
    do i = 1, numdims
      if ( hst % unlimited_index == i ) cycle
      if ( hst % time_nv_index == i ) cycle
      allocate( &
        & hst % mpi_gthr_info(i) % length( 0: hst % mpi_nprocs - 1 ) )
      allocate( &
        & hst % mpi_gthr_info(i) % &
        &  index_all( 0: hst % mpi_nprocs - 1, &
        &             hst % mpi_dimdata_all(i) % length ) )
      hst % mpi_gthr_info(i) % index_all(:,:) = -1
      hst % mpi_gthr_info(i) % length( hst % mpi_myrank ) = &
        & hst % mpi_dimdata_each(i) % length
      k = 1
      do j = 1, hst % mpi_dimdata_all(i) % length
        flag_hit = .false.
        if ( abs( hst % mpi_dimdata_all(i) % a_Axis(j) ) > &
          &  abs( hst % mpi_dimdata_each(i) % a_Axis(k) ) ) then
          large => hst % mpi_dimdata_all(i) % a_Axis(j)
          small => hst % mpi_dimdata_each(i) % a_Axis(k)
        else
          large => hst % mpi_dimdata_each(i) % a_Axis(k)
          small => hst % mpi_dimdata_all(i) % a_Axis(j)
        end if
        if (      large > 0.0_dp .and. small < 0.0_dp &
          &  .or. large < 0.0_dp .and. small > 0.0_dp ) then
          cycle
        end if
        if ( abs( large ) < zero_limit .and. abs( small ) < zero_limit ) then
          flag_hit = .true.
        end if
        if ( .not. flag_hit .and. &
          &  abs( ( large / small ) - 1.0_dp ) < accuracy ) then
          flag_hit = .true.
        end if
        if ( flag_hit ) then
          hst % mpi_gthr_info(i) % index_all ( hst % mpi_myrank, k ) = j
          k = k + 1
        end if
        if ( k > hst % mpi_gthr_info(i) % length( hst % mpi_myrank ) ) exit
      end do
    end do
    ! rank == 0 で情報を受け取る.
    ! Receive information by rank == 0
    !
    if ( hst % mpi_myrank == 0 ) then
      do i = 1, numdims
        if ( hst % unlimited_index == i ) cycle
        if ( hst % time_nv_index == i ) cycle
        allocate( index_all_buf( hst % mpi_dimdata_all(i) % length ) )
        do ra = 1, hst % mpi_nprocs - 1
          call mpi_recv( &
            & index_all_buf, &
            & hst % mpi_dimdata_all(i) % length, &
            & mpi_integer, ra, 0, mpi_comm_world, st_mpi, err_mpi )
          hst % mpi_gthr_info(i) % index_all (ra,:) = index_all_buf(:)
        end do
        deallocate( index_all_buf )
        do ra = 1, hst % mpi_nprocs - 1
          call mpi_recv( &
            & hst % mpi_gthr_info(i) % length (ra), &
            & 1, &
            & mpi_integer, ra, 0, mpi_comm_world, st_mpi, err_mpi )
        end do
      end do
    else
      do i = 1, numdims
        if ( hst % unlimited_index == i ) cycle
        if ( hst % time_nv_index == i ) cycle
        allocate( index_all_buf( hst % mpi_dimdata_all(i) % length ) )
        index_all_buf(:) = hst % mpi_gthr_info(i) % index_all (hst % mpi_myrank,:)
        call mpi_send( &
          & index_all_buf, &
          & hst % mpi_dimdata_all(i) % length, &
          & mpi_integer, 0, 0, mpi_comm_world, err_mpi )
        deallocate( index_all_buf )
        call mpi_send( &
          & hst % mpi_gthr_info(i) % length (hst % mpi_myrank), &
          & 1, &
          & mpi_integer, 0, 0, mpi_comm_world, err_mpi )
      end do
    end if
    ! 情報に不足が無いかチェック
    ! Check lack of information
    !
    if ( hst % mpi_myrank == 0 ) then
      do ra = 0, hst % mpi_nprocs - 1
        do i = 1, numdims
          if ( hst % unlimited_index == i ) cycle
          if ( hst % time_nv_index == i ) cycle
        end do
      end do
      do ra = 0, hst % mpi_nprocs - 1
        do i = 1, numdims
          if ( hst % unlimited_index == i ) cycle
          if ( hst % time_nv_index == i ) cycle
          do j = 1, hst % mpi_gthr_info(i) % length (ra)
            if ( hst % mpi_gthr_info(i) % index_all (ra,j) < 1 ) then
              call inquire( hst % dimvars(i), & ! (in)
                &           url = url )         ! (out)
              call urlsplit( url, & ! (in)
                &  var = dimname )  ! (out)
              call messagenotify('W', subnameup, &
                & 'data of axis (%c) on node (%d) or ' // &
                & 'in whole area are lack. ' // &
                & 'Specify the data by "HistoryPut" or "HistoryPutAxisMPI" explicitly.', &
                & c1 = trim(dimname), i = (/ ra /) )
              stat = hst_empinoaxisdata
              cause_c = dimname
              goto 999
            end if
          end do
        end do
      end do
    end if
999 continue
    call storeerror(stat, subname, err, cause_c)
    call endsub(subname)
  end subroutine gtmpi_axis_register
  subroutine gtmpi_vars_mkindex(hst, v_ord, err)
    !
    ! hst % mpi_vars_index に配列添字情報の登録を行う.
    !
    use gtool_history_types, only: gt_history, gt_history_axis, gt_history_varinfo, gt_history_attr
    use gtool_history_generic, only: historyvarinfoinquire
    use gtdata_generic, only: inquire
    use gtdata_types, only: gt_variable
    use dc_error, only: storeerror, dc_noerr
    use dc_message, only: messagenotify
    use dc_url, only: urlsplit
    use dc_trace, only: beginsub, endsub, dbgmessage
    use dc_types, only: string, token
    use mpi
    implicit none
    type(gt_history), intent(inout):: hst
    integer, intent(in):: v_ord ! 変数 ID
    logical, intent(out), optional:: err
    character(TOKEN), pointer:: dims(:) =>null(), dims_space(:) =>null()
    integer, pointer:: dimsizes_each(:,:) =>null(), dimsizes_all(:) =>null()
    type(gt_variable):: dimvar
    integer:: i, j, ra, numdims, time_dimord
    integer, pointer:: dimord(:) =>null()
    integer:: each_index
    integer, pointer:: idx(:) =>null()
    integer:: moveup
    integer:: check_dimsizes_all, check_dimsizes_each
    character(STRING):: check_varname
    integer:: err_mpi
    integer:: stat
    character(STRING):: cause_c
    character(*), parameter:: subname = 'gtmpi_vars_mkindex'
    character(*), parameter:: subnameup = 'HistoryPut'
  continue
    call beginsub(subname)
    cause_c = ""
    stat = dc_noerr
    ! rank/=0 は何もせずに終了.
    ! Finish without actions if rank/=0
    !
    ! * 以降の割り付け動作をプロセス 0 でのみ行うと,
    !   なぜか Cray XT 上で並列計算する際に
    !   「異常な数値を ALLOCATE しようとしている」
    !   というエラーが生じるため, (無駄だが) 全プロセスで以降の
    !   割り付け動作を行う.
    !
    !!! if ( hst % mpi_myrank /= 0 ) goto 999
    ! 変数が依存する座標軸情報を取得
    ! Information of axes depended from the variable
    !
    call historyvarinfoinquire( &
      & hst % mpi_varinfo( v_ord ), & ! (in)
      & dims = dims )                 ! (out)
    ! 時刻次元の排除
    ! Ignore time dimension
    !
    numdims = size( dims )
    time_dimord = -1
    allocate( dimord(1) )
    if ( hst % unlimited_index > 0 ) then
      do i = 1, numdims
        if ( hst % mpi_myrank == 0 ) then
          dimvar = lookup_dimension( hst, dims(i), dimord(1) )
        end if
        call mpi_bcast( dimord(1), 1, mpi_integer, 0, mpi_comm_world, err_mpi )
        if ( hst % unlimited_index == dimord(1) ) time_dimord = i
      end do
    end if
    if ( time_dimord > 0 ) then
      allocate( dims_space(numdims - 1) )
      j = 1
      do i = 1, numdims
        if ( i == time_dimord ) cycle
        dims_space(j) = dims(i)
        j = j + 1
      end do
      numdims = numdims - 1
      deallocate( dims )
    else
      dims_space => dims
      nullify( dims )
    end if
    deallocate( dimord )
    ! スカラーの場合は例外処理
    ! Exception handling for scalar value
    !
    if ( numdims < 1 ) then
      allocate( hst % mpi_vars_index(v_ord) % &
        &         each2all( 0: hst % mpi_nprocs - 1, 1 ) )
      allocate( hst % mpi_vars_index(v_ord) % &
        &         allcount( 0: hst % mpi_nprocs - 1 ) )
      hst % mpi_vars_index(v_ord) % each2all(:,:) = 1
      hst % mpi_vars_index(v_ord) % allcount(:) = 1
      goto 999
    end if
    ! 配列の割付
    ! Allocate array
    !
    allocate( dimord( numdims ) )
    allocate( dimsizes_all( numdims ) )
    allocate( dimsizes_each( 0:hst % mpi_nprocs - 1, numdims ) )
    ! 個々の次元のサイズの取得
    ! Get size of each dimension
    !
    do i = 1, numdims
      if ( hst % mpi_myrank == 0 ) then
        dimvar = lookup_dimension( hst, dims_space(i), dimord(i) )
      end if
      call mpi_bcast( dimord(i), 1, mpi_integer, 0, mpi_comm_world, err_mpi )
      dimsizes_all(i)  = hst % mpi_dimdata_all ( dimord(i) ) % length
      do ra = 0, hst % mpi_nprocs - 1
        dimsizes_each(ra, i) = hst % mpi_gthr_info( dimord(i) ) % length( ra )
      end do
    end do
    allocate( hst % mpi_vars_index(v_ord) % &
      &         each2all( 0: hst % mpi_nprocs - 1, product(dimsizes_all) ) )
    allocate( hst % mpi_vars_index(v_ord) % &
      &         allcount( 0: hst % mpi_nprocs - 1 ) )
    hst % mpi_vars_index(v_ord) % each2all(:,:) = -1
    do ra = 0, hst % mpi_nprocs - 1
      hst % mpi_vars_index(v_ord) % allcount(ra) = &
        & product( dimsizes_each(ra,:) )
    end do
    hst % mpi_vars_index(v_ord) % allcount_all = product( dimsizes_all(:) )
    ! rank/=0 はこの時点で終了
    ! Finish at this point if rank/=0
    !
    if ( hst % mpi_myrank /= 0 ) goto 999
    allocate( idx(numdims) )
    do ra = 0, hst % mpi_nprocs - 1
      idx(:) = 1
      idx(1) = 0
      do i = 1, product( dimsizes_each(ra, :) )
        idx(1) = idx(1) + 1
        moveup = 0
        do j = 1, numdims
          if ( moveup > 0 ) then
            idx(j) = idx(j) + moveup
            moveup = 0
          end if
          if ( idx(j) > dimsizes_each(ra,j) ) then
            idx(j) = 1
            moveup = 1
          end if
        end do
        each_index = hst % mpi_gthr_info(dimord(1)) % index_all (ra,idx(1))
        do j = 2, numdims
          each_index = each_index + &
            & ( hst % mpi_gthr_info(dimord(j)) % index_all (ra,idx(j)) - 1 ) &
            &   * product( dimsizes_all(1:j-1) )
        end do
        hst % mpi_vars_index(v_ord) % each2all(ra, i) = each_index
      end do
    end do
    deallocate( idx )
    ! 不足データが無いかチェック
    ! Check lack of data
    !
    check_dimsizes_all = product( dimsizes_all(:) )
    check_dimsizes_each = sum( hst % mpi_vars_index(v_ord) % allcount(:) )
    if ( check_dimsizes_all > check_dimsizes_each ) then
      call inquire( hst % vars(v_ord), &   ! (in)
        &           name = check_varname ) ! (out)
      call messagenotify('W', subnameup, &
        & 'collected data (%c) from each node is lack. ' // &
        & 'collected data size=<%d>, but needed whole data size=<%d>.', &
        & c1 = trim(check_varname), &
        & i = (/ check_dimsizes_each, check_dimsizes_all /) )
    end if
999 continue
    call storeerror(stat, subname, err, cause_c)
    call endsub(subname)
  end subroutine gtmpi_vars_mkindex
end module gtool_history_internal
!--
! vi:set readonly sw=4 ts=8:
!
!Local Variables:
!mode: f90
!buffer-read-only: t
!End:
!
!++