Oasis3 4.0.2
|
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_