gtool_history_internal::gtmpi_axis_register Interface Reference

Public Member Functions
subroutine	gtmpi_axis_register (hst, err)

Detailed Description

Definition at line 94 of file gtool_history_internal.f90.

Constructor & Destructor Documentation

gtmpi_axis_register()

subroutine gtool_history_internal::gtmpi_axis_register::gtmpi_axis_register	(	type(gt_history), intent(inout)	hst,
		logical, intent(out), optional	err )

Definition at line 452 of file gtool_history_internal.f90.

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

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

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