source: CPL/oasis3/trunk/src/lib/mpp_io/include/mpp_global_reduce.h @ 1677

Last change on this file since 1677 was 1677, checked in by aclsce, 12 years ago

Imported oasis3 (tag ipslcm5a) from cvs server to svn server (igcmg project).
File size: 5.5 KB
Line 
1  function MPP_GLOBAL_REDUCE_2D_( domain, field, locus )
2    MPP_TYPE_ :: MPP_GLOBAL_REDUCE_2D_
3    type(domain2D), intent(in) :: domain
4    MPP_TYPE_, intent(in) :: field(:,:)
5    integer, intent(out), optional :: locus(2)
6    MPP_TYPE_ :: field3D(size(field,1),size(field,2),1)
7    integer :: locus3D(3)
8#ifdef use_CRI_pointers
9    pointer( ptr, field3D )
10    ptr = LOC(field)
11    if( PRESENT(locus) )then
12        MPP_GLOBAL_REDUCE_2D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D )
13        locus = locus3D(1:2)
14    else
15        MPP_GLOBAL_REDUCE_2D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D )
16    end if
17#else
18    field3D = RESHAPE( field, SHAPE(field3D) )
19    if( PRESENT(locus) )then
20        MPP_GLOBAL_REDUCE_2D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D )
21        locus = locus3D(1:2)
22    else
23        MPP_GLOBAL_REDUCE_2D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D )
24    end if
25#endif
26    return
27  end function MPP_GLOBAL_REDUCE_2D_
28
29  function MPP_GLOBAL_REDUCE_3D_( domain, field, locus )
30    MPP_TYPE_ :: MPP_GLOBAL_REDUCE_3D_
31    type(domain2D), intent(in) :: domain
32    MPP_TYPE_, intent(in) :: field(0:,0:,:)
33    integer, intent(out), optional :: locus(3)
34    MPP_TYPE_ :: local
35    integer :: here, ioff, joff
36
37    if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_GLOBAL_REDUCE: You must first call mpp_domains_init.' )
38    if( size(field,1).EQ.domain%x%compute%size .AND. size(field,2).EQ.domain%y%compute%size )then
39!field is on compute domain
40        ioff = domain%x%compute%begin
41        joff = domain%y%compute%begin
42    else if( size(field,1).EQ.domain%x%data%size .AND. size(field,2).EQ.domain%y%data%size )then
43!field is on data domain
44        ioff = domain%x%data%begin
45        joff = domain%y%data%begin
46    else
47        call mpp_error( FATAL, 'MPP_GLOBAL_REDUCE_: incoming field array must match either compute domain or data domain.' )
48    end if
49
50!get your local max/min
51    local = REDUCE_VAL_(field)
52!find the global
53    MPP_GLOBAL_REDUCE_3D_ = local
54    call MPP_REDUCE_( MPP_GLOBAL_REDUCE_3D_, domain%list(:)%pe )
55!find locus of the global max/min
56    if( PRESENT(locus) )then
57!which PE is it on? min of all the PEs that have it
58        here = mpp_npes()+1
59        if( MPP_GLOBAL_REDUCE_3D_.EQ.local )here = pe
60        call mpp_min( here, domain%list(:)%pe )
61!find the locus here
62        if( pe.EQ.here )locus = REDUCE_LOC_(field)
63        locus(1) = locus(1) + ioff
64        locus(2) = locus(2) + joff
65        call mpp_broadcast( locus, 3, here, domain%list(:)%pe )
66    end if
67    return
68  end function MPP_GLOBAL_REDUCE_3D_
69
70  function MPP_GLOBAL_REDUCE_4D_( domain, field, locus )
71    MPP_TYPE_ :: MPP_GLOBAL_REDUCE_4D_
72    type(domain2D), intent(in) :: domain
73    MPP_TYPE_, intent(in) :: field(:,:,:,:)
74    integer, intent(out), optional :: locus(4)
75    MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4))
76    integer :: locus3D(3)
77#ifdef use_CRI_pointers
78    pointer( ptr, field3D )
79    ptr = LOC(field)
80    if( PRESENT(locus) )then
81        MPP_GLOBAL_REDUCE_4D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D )
82        locus(1:2) = locus3D(1:2)
83        locus(3) = modulo(locus3D(3),size(field,3))
84        locus(4) = (locus3D(3)-locus(3))/size(field,3) + 1
85        if( locus(3).EQ.0 )then
86            locus(3) = size(field,3)
87            locus(4) = locus(4) - 1
88        end if
89    else
90        MPP_GLOBAL_REDUCE_4D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D )
91    end if
92#else
93    field3D = RESHAPE( field, SHAPE(field3D) )
94    if( PRESENT(locus) )then
95        MPP_GLOBAL_REDUCE_4D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D )
96        locus(1:2) = locus3D(1:2)
97        locus(3) = modulo(locus3D(3),size(field,3))
98        locus(4) = (locus3D(3)-locus(3))/size(field,3) + 1
99        if( locus(3).EQ.0 )then
100            locus(3) = size(field,3)
101            locus(4) = locus(4) - 1
102        end if
103    else
104        MPP_GLOBAL_REDUCE_4D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D )
105    end if
106#endif
107    return
108  end function MPP_GLOBAL_REDUCE_4D_
109
110  function MPP_GLOBAL_REDUCE_5D_( domain, field, locus )
111    MPP_TYPE_ :: MPP_GLOBAL_REDUCE_5D_
112    type(domain2D), intent(in) :: domain
113    MPP_TYPE_, intent(in) :: field(:,:,:,:,:)
114    integer, intent(out), optional :: locus(5)
115    MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)*size(field,5))
116    integer :: locus3D(3)
117#ifdef use_CRI_pointers
118    pointer( ptr, field3D )
119    ptr = LOC(field)
120    if( PRESENT(locus) )then
121        MPP_GLOBAL_REDUCE_5D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D )
122        locus(1:2) = locus3D(1:2)
123        locus(3) = modulo(locus3D(3),size(field,3))
124        locus(4) = modulo(locus3D(3),size(field,3)*size(field,4))
125        locus(5) = (locus3D(3)-locus(4))/size(field,3)/size(field,4) + 1
126        if( locus(3).EQ.0 )then
127            locus(3) = size(field,3)
128            locus(4) = locus(4) - 1
129        end if
130    else
131        MPP_GLOBAL_REDUCE_5D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D )
132    end if
133#else
134    field3D = RESHAPE( field, SHAPE(field3D) )
135    if( PRESENT(locus) )then
136        MPP_GLOBAL_REDUCE_5D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D )
137        locus(1:2) = locus3D(1:2)
138        locus(3) = modulo(locus3D(3),size(field,3))
139        locus(4) = modulo(locus3D(3),size(field,3)*size(field,4))
140        locus(5) = (locus3D(3)-locus(4))/size(field,3)/size(field,4) + 1
141        if( locus(3).EQ.0 )then
142            locus(3) = size(field,3)
143            locus(4) = locus(4) - 1
144        end if
145    else
146        MPP_GLOBAL_REDUCE_5D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D )
147    end if
148#endif
149    return
150  end function MPP_GLOBAL_REDUCE_5D_
Note: See TracBrowser for help on using the repository browser.