mpp_reduce.h

Go to the documentation of this file.
00001     subroutine MPP_REDUCE_( a, pelist )
00002 !find the max of scalar a the PEs in pelist (all PEs if this argument is omitted)
00003 !result is also automatically broadcast to all PEs
00004       MPP_TYPE_, intent(inout) :: a
00005       integer, intent(in), optional :: pelist(0:)
00006       integer :: n
00007 #ifdef use_libSMA
00008 !work holds pWrk array + 1 word for symmetric copy of a
00009       MPP_TYPE_ :: work(SHMEM_REDUCE_MIN_WRKDATA_SIZE+1)
00010       pointer( ptr, work )
00011       integer :: words
00012       character(len=8) :: text
00013 #endif use_libSMA
00014 #ifdef use_libMPI
00015       MPP_TYPE_ :: work
00016 #endif
00017       if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_REDUCE: You must first call mpp_init.' )
00018       n = get_peset(pelist); if( peset(n)%count.EQ.1 )return
00019 
00020       if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
00021 #ifdef use_libSMA
00022 !allocate space from the stack for pwrk and b
00023       ptr = LOC(mpp_stack)
00024       words = size(work)*size(transfer(work(1),word))
00025       if( words.GT.mpp_stack_size )then
00026           write( text, '(i8)' )words
00027           call mpp_error( FATAL, 'MPP_REDUCE user stack overflow: call mpp_set_stack_size('//text//') from all PEs.' )
00028       end if
00029       mpp_stack_hwm = max( words, mpp_stack_hwm )
00030       
00031       work(1) = a
00032       call SHMEM_REDUCE_( work, work, 1, peset(n)%start, peset(n)%log2stride, peset(n)%count, work(2), sync )
00033       call mpp_sync(pelist)
00034       a = work(1)
00035 #endif use_libSMA
00036 #ifdef use_libMPI
00037       if( verbose )call mpp_error( NOTE, 'MPP_REDUCE_: using MPI_ALLREDUCE...' )
00038       call MPI_ALLREDUCE( a, work, 1, MPI_TYPE_, MPI_REDUCE_, peset(n)%id, error )
00039       a = work
00040 #endif
00041       if( current_clock.NE.0 )call increment_current_clock( EVENT_ALLREDUCE, MPP_TYPE_BYTELEN_ )
00042       return
00043     end subroutine MPP_REDUCE_