source: NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/LBC/mpp_loc_generic.h90 @ 12603

                          !==  IN: ptab is an array  ==!
#   if defined SINGLE_PRECISION
#      define ARRAY_TYPE(i,j,k)    REAL(sp)        , INTENT(in   ) ::   ARRAY_IN(i,j,k)
#      define MASK_TYPE(i,j,k)     REAL(sp)        , INTENT(in   ) ::   MASK_IN(i,j,k)
#      define PRECISION sp
#   else
#      define ARRAY_TYPE(i,j,k)    REAL(dp)        , INTENT(in   ) ::   ARRAY_IN(i,j,k)
#      define MASK_TYPE(i,j,k)     REAL(dp)        , INTENT(in   ) ::   MASK_IN(i,j,k)
#      define PRECISION dp
#   endif

#   if defined DIM_2d
#      define ARRAY_IN(i,j,k)   ptab(i,j)
#      define MASK_IN(i,j,k)    pmask(i,j)
#      define INDEX_TYPE(k)        INTEGER         , INTENT(  out) ::   kindex(2)
#      define K_SIZE(ptab)      1
#   endif
#   if defined DIM_3d
#      define ARRAY_IN(i,j,k)   ptab(i,j,k)
#      define MASK_IN(i,j,k)    pmask(i,j,k)
#      define INDEX_TYPE(k)        INTEGER         , INTENT(  out) ::   kindex(3)
#      define K_SIZE(ptab)      SIZE(ptab,3)
#   endif
#   if defined OPERATION_MAXLOC
#      define MPI_OPERATION mpi_maxloc
#      define LOC_OPERATION MAXLOC
#      define ERRVAL -HUGE
#   endif
#   if defined OPERATION_MINLOC
#      define MPI_OPERATION mpi_minloc
#      define LOC_OPERATION MINLOC
#      define ERRVAL HUGE
#   endif

   SUBROUTINE ROUTINE_LOC( cdname, ptab, pmask, pmin, kindex )
      !!----------------------------------------------------------------------
      CHARACTER(len=*), INTENT(in   ) ::   cdname  ! name of the calling subroutine
      ARRAY_TYPE(:,:,:)                            ! array on which loctrans operation is applied
      MASK_TYPE(:,:,:)                             ! local mask
      REAL(PRECISION)        , INTENT(  out) ::   pmin    ! Global minimum of ptab
      INDEX_TYPE(:)                                ! index of minimum in global frame
# if defined key_mpp_mpi
      !
      INTEGER  ::   ierror, ii, idim
      INTEGER  ::   index0
      REAL(PRECISION) ::   zmin     ! local minimum
      INTEGER , DIMENSION(:), ALLOCATABLE  ::   ilocs
      REAL(dp), DIMENSION(2,1) ::   zain, zaout
      !!-----------------------------------------------------------------------
      !
      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. )
      !
      idim = SIZE(kindex)
      !
      IF ( ALL(MASK_IN(:,:,:) /= 1._wp) ) THEN
         ! special case for land processors
         zmin = ERRVAL(zmin)
         index0 = 0
      ELSE
         ALLOCATE ( ilocs(idim) )
         !
         ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) == 1._wp )
         zmin  = ARRAY_IN(ilocs(1),ilocs(2),ilocs(3))
         !
         kindex(1) = mig( ilocs(1) )
#  if defined DIM_2d || defined DIM_3d    /* avoid warning when kindex has 1 element */
         kindex(2) = mjg( ilocs(2) )
#  endif
#  if defined DIM_3d                      /* avoid warning when kindex has 2 elements */
         kindex(3) = ilocs(3)
#  endif
         ! 
         DEALLOCATE (ilocs)
         !
         index0 = kindex(1)-1   ! 1d index starting at 0
#  if defined DIM_2d || defined DIM_3d   /* avoid warning when kindex has 1 element */
         index0 = index0 + jpiglo * (kindex(2)-1)
#  endif
#  if defined DIM_3d                     /* avoid warning when kindex has 2 elements */
         index0 = index0 + jpiglo * jpjglo * (kindex(3)-1)
#  endif
      END IF
      zain(1,:) = zmin
      zain(2,:) = REAL(index0, wp)
      !
      IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.)
      CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION, MPI_OPERATION ,MPI_COMM_OCE, ierror)
      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
      !
      pmin      = zaout(1,1)
      index0    = NINT( zaout(2,1) )
#  if defined DIM_3d                     /* avoid warning when kindex has 2 elements */
      kindex(3) = index0 / (jpiglo*jpjglo)
      index0    = index0 - kindex(3) * (jpiglo*jpjglo)
#  endif
#  if defined DIM_2d || defined DIM_3d   /* avoid warning when kindex has 1 element */
      kindex(2) = index0 / jpiglo
      index0 = index0 - kindex(2) * jpiglo
#  endif
      kindex(1) = index0
      kindex(:) = kindex(:) + 1   ! start indices at 1
#else
      kindex = 0 ; pmin = 0.
      WRITE(*,*) 'ROUTINE_LOC: You should not have seen this print! error?'
#endif

   END SUBROUTINE ROUTINE_LOC


#undef PRECISION
#undef ARRAY_TYPE
#undef MAX_TYPE
#undef ARRAY_IN
#undef MASK_IN
#undef K_SIZE
#undef MPI_OPERATION
#undef LOC_OPERATION
#undef INDEX_TYPE
#undef ERRVAL