gtool_history_internal::gtmpi_vars_mkindex Interface Reference

Public Member Functions
subroutine	gtmpi_vars_mkindex (hst, v_ord, err)

Detailed Description

Definition at line 97 of file gtool_history_internal.f90.

Constructor & Destructor Documentation

gtmpi_vars_mkindex()

subroutine gtool_history_internal::gtmpi_vars_mkindex::gtmpi_vars_mkindex	(	type(gt_history), intent(inout)	hst,
		integer, intent(in)	v_ord,
		logical, intent(out), optional	err )

Definition at line 645 of file gtool_history_internal.f90.

    !
    ! 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)

References dc_trace::beginsub(), dc_trace::dbgmessage(), dc_error::dc_noerr, dc_trace::endsub(), dc_error::storeerror(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

---

The documentation for this interface was generated from the following file:

• /build/gtool5-1.0.0~rc5/debian/build-parallel/src/gtool/gtool_history/gtool_history_internal.f90