doc-doxygen/html/mpp__global__reduce_8h_source.html

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_