00001 subroutine MPP_SUM_( a, length, pelist )
00002 !sums array a over the PEs in pelist (all PEs if this argument is omitted)
00003 !result is also automatically broadcast: all PEs have the sum in a at the end
00004 !we are using f77-style call: array passed by address and not descriptor; further, the f90 conformance check is avoided.
00005 integer, intent(in) :: length
00006 integer, intent(in), optional :: pelist(:)
00007 MPP_TYPE_, intent(inout) :: a(*)
00008 integer :: n
00009 #ifdef use_libSMA
00010 !first <length> words are array, rest are pWrk
00011 MPP_TYPE_ :: work(length+length/2+1+SHMEM_REDUCE_MIN_WRKDATA_SIZE)
00012 pointer( ptr, work )
00013 integer :: words
00014 character(len=8) :: text
00015 #else
00016 MPP_TYPE_ :: work(length)
00017 #endif
00018
00019 if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_SUM: You must first call mpp_init.' )
00020 n = get_peset(pelist); if( peset(n)%count.EQ.1 )return
00021
00022 if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick)
00023 #ifdef use_libSMA
00024 !allocate space from the stack for pwrk and b
00025 ptr = LOC(mpp_stack)
00026 words = size(work)*size(transfer(work(1),word))
00027 if( words.GT.mpp_stack_size )then
00028 write( text, '(i8)' )words
00029 call mpp_error( FATAL, 'MPP_SUM user stack overflow: call mpp_set_stack_size('
00030 end if
00031 mpp_stack_hwm = max( words, mpp_stack_hwm )
00032 work(1:length) = a(1:length)
00033 call mpp_sync(pelist)
00034 call SHMEM_SUM_( work, work, length, peset(n)%start, peset(n)%log2stride, peset(n)%count, work(length+1), sync )
00035 #endif use_libSMA
00036 #ifdef use_libMPI
00037 if( verbose )call mpp_error( NOTE, 'MPP_SUM: using MPI_ALLREDUCE...' )
00038 if( debug )write( stderr(),* )'pe, n, peset(n)%id=', pe, n, peset(n)%id
00039 call MPI_ALLREDUCE( a, work, length, MPI_TYPE_, MPI_SUM, peset(n)%id, error )
00040 #endif
00041 a(1:length) = work(1:length)
00042 if( current_clock.NE.0 )call increment_current_clock( EVENT_ALLREDUCE, length*MPP_TYPE_BYTELEN_ )
00043 return
00044 end subroutine MPP_SUM_
00045
00046 subroutine MPP_SUM_SCALAR_( a, pelist )
00047 !sums array a when only first element is passed: this routine just converts to a call to MPP_SUM_
00048 MPP_TYPE_, intent(inout) :: a
00049 integer, intent(in), optional :: pelist(:)
00050 MPP_TYPE_ :: b(1)
00051
00052 b(1) = a
00053 if( debug )call mpp_error( NOTE, 'MPP_SUM_SCALAR_: calling MPP_SUM_ ...' )
00054 call MPP_SUM_( b, 1, pelist )
00055 a = b(1)
00056 return
00057 end subroutine MPP_SUM_SCALAR_
00058
00059 subroutine MPP_SUM_2D_( a, length, pelist )
00060 MPP_TYPE_, intent(inout) :: a(:,:)
00061 integer, intent(in) :: length
00062 integer, intent(in), optional :: pelist(:)
00063 MPP_TYPE_ :: a1D(length)
00064 #ifdef use_CRI_pointers
00065 pointer( ptr, a1D )
00066 ptr = LOC(a)
00067 #else
00068 !faster than RESHAPE? length is probably redundant
00069 a1D = TRANSFER( a, a1D, length )
00070 ! a1D = RESHAPE( a, SHAPE(a1D) )
00071 call mpp_sum( a1D, length, pelist )
00072 a = RESHAPE( a1D, SHAPE(a) )
00073 #endif
00074 return
00075 end subroutine MPP_SUM_2D_
00076
00077 subroutine MPP_SUM_3D_( a, length, pelist )
00078 MPP_TYPE_, intent(inout) :: a(:,:,:)
00079 integer, intent(in) :: length
00080 integer, intent(in), optional :: pelist(:)
00081 MPP_TYPE_ :: a1D(length)
00082 #ifdef use_CRI_pointers
00083 pointer( ptr, a1D )
00084 ptr = LOC(a)
00085 #else
00086 !faster than RESHAPE? length is probably redundant
00087 a1D = TRANSFER( a, a1D, length )
00088 ! a1D = RESHAPE( a, SHAPE(a1D) )
00089 call mpp_sum( a1D, length, pelist )
00090 a = RESHAPE( a1D, SHAPE(a) )
00091 #endif
00092 return
00093 end subroutine MPP_SUM_3D_
00094
00095 subroutine MPP_SUM_4D_( a, length, pelist )
00096 MPP_TYPE_, intent(inout) :: a(:,:,:,:)
00097 integer, intent(in) :: length
00098 integer, intent(in), optional :: pelist(:)
00099 MPP_TYPE_ :: a1D(length)
00100 #ifdef use_CRI_pointers
00101 pointer( ptr, a1D )
00102 ptr = LOC(a)
00103 #else
00104 !faster than RESHAPE? length is probably redundant
00105 a1D = TRANSFER( a, a1D, length )
00106 ! a1D = RESHAPE( a, SHAPE(a1D) )
00107 call mpp_sum( a1D, length, pelist )
00108 a = RESHAPE( a1D, SHAPE(a) )
00109 #endif
00110 return
00111 end subroutine MPP_SUM_4D_
00112
00113 subroutine MPP_SUM_5D_( a, length, pelist )
00114 MPP_TYPE_, intent(inout) :: a(:,:,:,:,:)
00115 integer, intent(in) :: length
00116 integer, intent(in), optional :: pelist(:)
00117 MPP_TYPE_ :: a1D(length)
00118 #ifdef use_CRI_pointers
00119 pointer( ptr, a1D )
00120 ptr = LOC(a)
00121 #else
00122 !faster than RESHAPE? length is probably redundant
00123 a1D = TRANSFER( a, a1D, length )
00124 ! a1D = RESHAPE( a, SHAPE(a1D) )
00125 call mpp_sum( a1D, length, pelist )
00126 a = RESHAPE( a1D, SHAPE(a) )
00127 #endif
00128 return
00129 end subroutine MPP_SUM_5D_
