Oasis3 4.0.2
|
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('//text//') from all PEs.' ) 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_