00001 function MPP_GLOBAL_REDUCE_2D_( domain, field, locus )
00002 MPP_TYPE_ :: MPP_GLOBAL_REDUCE_2D_
00003 type(domain2D), intent(in) :: domain
00004 MPP_TYPE_, intent(in) :: field(:,:)
00005 integer, intent(out), optional :: locus(2)
00006 MPP_TYPE_ :: field3D(size(field,1),size(field,2),1)
00007 integer :: locus3D(3)
00008 #ifdef use_CRI_pointers
00009 pointer( ptr, field3D )
00010 ptr = LOC(field)
00011 if( PRESENT(locus) )then
00012 MPP_GLOBAL_REDUCE_2D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D )
00013 locus = locus3D(1:2)
00014 else
00015 MPP_GLOBAL_REDUCE_2D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D )
00016 end if
00017 #else
00018 field3D = RESHAPE( field, SHAPE(field3D) )
00019 if( PRESENT(locus) )then
00020 MPP_GLOBAL_REDUCE_2D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D )
00021 locus = locus3D(1:2)
00022 else
00023 MPP_GLOBAL_REDUCE_2D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D )
00024 end if
00025 #endif
00026 return
00027 end function MPP_GLOBAL_REDUCE_2D_
00028
00029 function MPP_GLOBAL_REDUCE_3D_( domain, field, locus )
00030 MPP_TYPE_ :: MPP_GLOBAL_REDUCE_3D_
00031 type(domain2D), intent(in) :: domain
00032 MPP_TYPE_, intent(in) :: field(0:,0:,:)
00033 integer, intent(out), optional :: locus(3)
00034 MPP_TYPE_ :: local
00035 integer :: here, ioff, joff
00036
00037 if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_GLOBAL_REDUCE: You must first call mpp_domains_init.' )
00038 if( size(field,1).EQ.domain%x%compute%size .AND. size(field,2).EQ.domain%y%compute%size )then
00039 !field is on compute domain
00040 ioff = domain%x%compute%begin
00041 joff = domain%y%compute%begin
00042 else if( size(field,1).EQ.domain%x%data%size .AND. size(field,2).EQ.domain%y%data%size )then
00043 !field is on data domain
00044 ioff = domain%x%data%begin
00045 joff = domain%y%data%begin
00046 else
00047 call mpp_error( FATAL, 'MPP_GLOBAL_REDUCE_: incoming field array must match either compute domain or data domain.' )
00048 end if
00049
00050 !get your local max/min
00051 local = REDUCE_VAL_(field)
00052 !find the global
00053 MPP_GLOBAL_REDUCE_3D_ = local
00054 call MPP_REDUCE_( MPP_GLOBAL_REDUCE_3D_, domain%list(:)%pe )
00055 !find locus of the global max/min
00056 if( PRESENT(locus) )then
00057 !which PE is it on? min of all the PEs that have it
00058 here = mpp_npes()+1
00059 if( MPP_GLOBAL_REDUCE_3D_.EQ.local )here = pe
00060 call mpp_min( here, domain%list(:)%pe )
00061 !find the locus here
00062 if( pe.EQ.here )locus = REDUCE_LOC_(field)
00063 locus(1) = locus(1) + ioff
00064 locus(2) = locus(2) + joff
00065 call mpp_broadcast( locus, 3, here, domain%list(:)%pe )
00066 end if
00067 return
00068 end function MPP_GLOBAL_REDUCE_3D_
00069
00070 function MPP_GLOBAL_REDUCE_4D_( domain, field, locus )
00071 MPP_TYPE_ :: MPP_GLOBAL_REDUCE_4D_
00072 type(domain2D), intent(in) :: domain
00073 MPP_TYPE_, intent(in) :: field(:,:,:,:)
00074 integer, intent(out), optional :: locus(4)
00075 MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4))
00076 integer :: locus3D(3)
00077 #ifdef use_CRI_pointers
00078 pointer( ptr, field3D )
00079 ptr = LOC(field)
00080 if( PRESENT(locus) )then
00081 MPP_GLOBAL_REDUCE_4D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D )
00082 locus(1:2) = locus3D(1:2)
00083 locus(3) = modulo(locus3D(3),size(field,3))
00084 locus(4) = (locus3D(3)-locus(3))/size(field,3) + 1
00085 if( locus(3).EQ.0 )then
00086 locus(3) = size(field,3)
00087 locus(4) = locus(4) - 1
00088 end if
00089 else
00090 MPP_GLOBAL_REDUCE_4D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D )
00091 end if
00092 #else
00093 field3D = RESHAPE( field, SHAPE(field3D) )
00094 if( PRESENT(locus) )then
00095 MPP_GLOBAL_REDUCE_4D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D )
00096 locus(1:2) = locus3D(1:2)
00097 locus(3) = modulo(locus3D(3),size(field,3))
00098 locus(4) = (locus3D(3)-locus(3))/size(field,3) + 1
00099 if( locus(3).EQ.0 )then
00100 locus(3) = size(field,3)
00101 locus(4) = locus(4) - 1
00102 end if
00103 else
00104 MPP_GLOBAL_REDUCE_4D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D )
00105 end if
00106 #endif
00107 return
00108 end function MPP_GLOBAL_REDUCE_4D_
00109
00110 function MPP_GLOBAL_REDUCE_5D_( domain, field, locus )
00111 MPP_TYPE_ :: MPP_GLOBAL_REDUCE_5D_
00112 type(domain2D), intent(in) :: domain
00113 MPP_TYPE_, intent(in) :: field(:,:,:,:,:)
00114 integer, intent(out), optional :: locus(5)
00115 MPP_TYPE_ :: field3D(size(field,1),size(field,2),size(field,3)*size(field,4)*size(field,5))
00116 integer :: locus3D(3)
00117 #ifdef use_CRI_pointers
00118 pointer( ptr, field3D )
00119 ptr = LOC(field)
00120 if( PRESENT(locus) )then
00121 MPP_GLOBAL_REDUCE_5D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D )
00122 locus(1:2) = locus3D(1:2)
00123 locus(3) = modulo(locus3D(3),size(field,3))
00124 locus(4) = modulo(locus3D(3),size(field,3)*size(field,4))
00125 locus(5) = (locus3D(3)-locus(4))/size(field,3)/size(field,4) + 1
00126 if( locus(3).EQ.0 )then
00127 locus(3) = size(field,3)
00128 locus(4) = locus(4) - 1
00129 end if
00130 else
00131 MPP_GLOBAL_REDUCE_5D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D )
00132 end if
00133 #else
00134 field3D = RESHAPE( field, SHAPE(field3D) )
00135 if( PRESENT(locus) )then
00136 MPP_GLOBAL_REDUCE_5D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D, locus3D )
00137 locus(1:2) = locus3D(1:2)
00138 locus(3) = modulo(locus3D(3),size(field,3))
00139 locus(4) = modulo(locus3D(3),size(field,3)*size(field,4))
00140 locus(5) = (locus3D(3)-locus(4))/size(field,3)/size(field,4) + 1
00141 if( locus(3).EQ.0 )then
00142 locus(3) = size(field,3)
00143 locus(4) = locus(4) - 1
00144 end if
00145 else
00146 MPP_GLOBAL_REDUCE_5D_ = MPP_GLOBAL_REDUCE_3D_( domain, field3D )
00147 end if
00148 #endif
00149 return
00150 end function MPP_GLOBAL_REDUCE_5D_
