1 | subroutine MPP_SUM_( a, length, pelist ) |
---|
2 | !sums array a over the PEs in pelist (all PEs if this argument is omitted) |
---|
3 | !result is also automatically broadcast: all PEs have the sum in a at the end |
---|
4 | !we are using f77-style call: array passed by address and not descriptor; further, the f90 conformance check is avoided. |
---|
5 | integer, intent(in) :: length |
---|
6 | integer, intent(in), optional :: pelist(:) |
---|
7 | MPP_TYPE_, intent(inout) :: a(*) |
---|
8 | integer :: n |
---|
9 | #ifdef use_libSMA |
---|
10 | !first <length> words are array, rest are pWrk |
---|
11 | MPP_TYPE_ :: work(length+length/2+1+SHMEM_REDUCE_MIN_WRKDATA_SIZE) |
---|
12 | pointer( ptr, work ) |
---|
13 | integer :: words |
---|
14 | character(len=8) :: text |
---|
15 | #else |
---|
16 | MPP_TYPE_ :: work(length) |
---|
17 | #endif |
---|
18 | |
---|
19 | if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_SUM: You must first call mpp_init.' ) |
---|
20 | n = get_peset(pelist); if( peset(n)%count.EQ.1 )return |
---|
21 | |
---|
22 | if( current_clock.NE.0 )call SYSTEM_CLOCK(start_tick) |
---|
23 | #ifdef use_libSMA |
---|
24 | !allocate space from the stack for pwrk and b |
---|
25 | ptr = LOC(mpp_stack) |
---|
26 | words = size(work)*size(transfer(work(1),word)) |
---|
27 | if( words.GT.mpp_stack_size )then |
---|
28 | write( text, '(i8)' )words |
---|
29 | call mpp_error( FATAL, 'MPP_SUM user stack overflow: call mpp_set_stack_size('//text//') from all PEs.' ) |
---|
30 | end if |
---|
31 | mpp_stack_hwm = max( words, mpp_stack_hwm ) |
---|
32 | work(1:length) = a(1:length) |
---|
33 | call mpp_sync(pelist) |
---|
34 | call SHMEM_SUM_( work, work, length, peset(n)%start, peset(n)%log2stride, peset(n)%count, work(length+1), sync ) |
---|
35 | #endif /* use_libSMA */ |
---|
36 | #ifdef use_libMPI |
---|
37 | if( verbose )call mpp_error( NOTE, 'MPP_SUM: using MPI_ALLREDUCE...' ) |
---|
38 | if( debug )write( stderr(),* )'pe, n, peset(n)%id=', pe, n, peset(n)%id |
---|
39 | call MPI_ALLREDUCE( a, work, length, MPI_TYPE_, MPI_SUM, peset(n)%id, error ) |
---|
40 | #endif |
---|
41 | a(1:length) = work(1:length) |
---|
42 | if( current_clock.NE.0 )call increment_current_clock( EVENT_ALLREDUCE, length*MPP_TYPE_BYTELEN_ ) |
---|
43 | return |
---|
44 | end subroutine MPP_SUM_ |
---|
45 | |
---|
46 | subroutine MPP_SUM_SCALAR_( a, pelist ) |
---|
47 | !sums array a when only first element is passed: this routine just converts to a call to MPP_SUM_ |
---|
48 | MPP_TYPE_, intent(inout) :: a |
---|
49 | integer, intent(in), optional :: pelist(:) |
---|
50 | MPP_TYPE_ :: b(1) |
---|
51 | |
---|
52 | b(1) = a |
---|
53 | if( debug )call mpp_error( NOTE, 'MPP_SUM_SCALAR_: calling MPP_SUM_ ...' ) |
---|
54 | call MPP_SUM_( b, 1, pelist ) |
---|
55 | a = b(1) |
---|
56 | return |
---|
57 | end subroutine MPP_SUM_SCALAR_ |
---|
58 | |
---|
59 | subroutine MPP_SUM_2D_( a, length, pelist ) |
---|
60 | MPP_TYPE_, intent(inout) :: a(:,:) |
---|
61 | integer, intent(in) :: length |
---|
62 | integer, intent(in), optional :: pelist(:) |
---|
63 | MPP_TYPE_ :: a1D(length) |
---|
64 | #ifdef use_CRI_pointers |
---|
65 | pointer( ptr, a1D ) |
---|
66 | ptr = LOC(a) |
---|
67 | #else |
---|
68 | !faster than RESHAPE? length is probably redundant |
---|
69 | a1D = TRANSFER( a, a1D, length ) |
---|
70 | ! a1D = RESHAPE( a, SHAPE(a1D) ) |
---|
71 | call mpp_sum( a1D, length, pelist ) |
---|
72 | a = RESHAPE( a1D, SHAPE(a) ) |
---|
73 | #endif |
---|
74 | return |
---|
75 | end subroutine MPP_SUM_2D_ |
---|
76 | |
---|
77 | subroutine MPP_SUM_3D_( a, length, pelist ) |
---|
78 | MPP_TYPE_, intent(inout) :: a(:,:,:) |
---|
79 | integer, intent(in) :: length |
---|
80 | integer, intent(in), optional :: pelist(:) |
---|
81 | MPP_TYPE_ :: a1D(length) |
---|
82 | #ifdef use_CRI_pointers |
---|
83 | pointer( ptr, a1D ) |
---|
84 | ptr = LOC(a) |
---|
85 | #else |
---|
86 | !faster than RESHAPE? length is probably redundant |
---|
87 | a1D = TRANSFER( a, a1D, length ) |
---|
88 | ! a1D = RESHAPE( a, SHAPE(a1D) ) |
---|
89 | call mpp_sum( a1D, length, pelist ) |
---|
90 | a = RESHAPE( a1D, SHAPE(a) ) |
---|
91 | #endif |
---|
92 | return |
---|
93 | end subroutine MPP_SUM_3D_ |
---|
94 | |
---|
95 | subroutine MPP_SUM_4D_( a, length, pelist ) |
---|
96 | MPP_TYPE_, intent(inout) :: a(:,:,:,:) |
---|
97 | integer, intent(in) :: length |
---|
98 | integer, intent(in), optional :: pelist(:) |
---|
99 | MPP_TYPE_ :: a1D(length) |
---|
100 | #ifdef use_CRI_pointers |
---|
101 | pointer( ptr, a1D ) |
---|
102 | ptr = LOC(a) |
---|
103 | #else |
---|
104 | !faster than RESHAPE? length is probably redundant |
---|
105 | a1D = TRANSFER( a, a1D, length ) |
---|
106 | ! a1D = RESHAPE( a, SHAPE(a1D) ) |
---|
107 | call mpp_sum( a1D, length, pelist ) |
---|
108 | a = RESHAPE( a1D, SHAPE(a) ) |
---|
109 | #endif |
---|
110 | return |
---|
111 | end subroutine MPP_SUM_4D_ |
---|
112 | |
---|
113 | subroutine MPP_SUM_5D_( a, length, pelist ) |
---|
114 | MPP_TYPE_, intent(inout) :: a(:,:,:,:,:) |
---|
115 | integer, intent(in) :: length |
---|
116 | integer, intent(in), optional :: pelist(:) |
---|
117 | MPP_TYPE_ :: a1D(length) |
---|
118 | #ifdef use_CRI_pointers |
---|
119 | pointer( ptr, a1D ) |
---|
120 | ptr = LOC(a) |
---|
121 | #else |
---|
122 | !faster than RESHAPE? length is probably redundant |
---|
123 | a1D = TRANSFER( a, a1D, length ) |
---|
124 | ! a1D = RESHAPE( a, SHAPE(a1D) ) |
---|
125 | call mpp_sum( a1D, length, pelist ) |
---|
126 | a = RESHAPE( a1D, SHAPE(a) ) |
---|
127 | #endif |
---|
128 | return |
---|
129 | end subroutine MPP_SUM_5D_ |
---|