New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
mpp_loc_generic.h90 in NEMO/trunk/src/OCE/LBC – NEMO

source: NEMO/trunk/src/OCE/LBC/mpp_loc_generic.h90 @ 13226

Last change on this file since 13226 was 13226, checked in by orioltp, 4 years ago

Merging dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation into the trunk

File size: 4.3 KB
Line 
1                          !==  IN: ptab is an array  ==!
2#   if defined SINGLE_PRECISION
3#      define ARRAY_TYPE(i,j,k)    REAL(sp)        , INTENT(in   ) ::   ARRAY_IN(i,j,k)
4#      define MASK_TYPE(i,j,k)     REAL(sp)        , INTENT(in   ) ::   MASK_IN(i,j,k)
5#      define PRECISION sp
6#   else
7#      define ARRAY_TYPE(i,j,k)    REAL(dp)        , INTENT(in   ) ::   ARRAY_IN(i,j,k)
8#      define MASK_TYPE(i,j,k)     REAL(dp)        , INTENT(in   ) ::   MASK_IN(i,j,k)
9#      define PRECISION dp
10#   endif
11
12#   if defined DIM_2d
13#      define ARRAY_IN(i,j,k)   ptab(i,j)
14#      define MASK_IN(i,j,k)    pmask(i,j)
15#      define INDEX_TYPE(k)        INTEGER         , INTENT(  out) ::   kindex(2)
16#      define K_SIZE(ptab)      1
17#   endif
18#   if defined DIM_3d
19#      define ARRAY_IN(i,j,k)   ptab(i,j,k)
20#      define MASK_IN(i,j,k)    pmask(i,j,k)
21#      define INDEX_TYPE(k)        INTEGER         , INTENT(  out) ::   kindex(3)
22#      define K_SIZE(ptab)      SIZE(ptab,3)
23#   endif
24#   if defined OPERATION_MAXLOC
25#      define MPI_OPERATION mpi_maxloc
26#      define LOC_OPERATION MAXLOC
27#      define ERRVAL -HUGE
28#   endif
29#   if defined OPERATION_MINLOC
30#      define MPI_OPERATION mpi_minloc
31#      define LOC_OPERATION MINLOC
32#      define ERRVAL HUGE
33#   endif
34
35   SUBROUTINE ROUTINE_LOC( cdname, ptab, pmask, pmin, kindex )
36      !!----------------------------------------------------------------------
37      CHARACTER(len=*), INTENT(in   ) ::   cdname  ! name of the calling subroutine
38      ARRAY_TYPE(:,:,:)                            ! array on which loctrans operation is applied
39      MASK_TYPE(:,:,:)                             ! local mask
40      REAL(PRECISION)        , INTENT(  out) ::   pmin    ! Global minimum of ptab
41      INDEX_TYPE(:)                                ! index of minimum in global frame
42      !
43      INTEGER  ::   ierror, ii, idim
44      INTEGER  ::   index0
45      REAL(PRECISION) ::   zmin     ! local minimum
46      INTEGER , DIMENSION(:), ALLOCATABLE  ::   ilocs
47      REAL(dp), DIMENSION(2,1) ::   zain, zaout
48      !!-----------------------------------------------------------------------
49      !
50      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. )
51      !
52      idim = SIZE(kindex)
53      !
54      IF ( ALL(MASK_IN(:,:,:) /= 1._wp) ) THEN
55         ! special case for land processors
56         zmin = ERRVAL(zmin)
57         index0 = 0
58      ELSE
59         ALLOCATE ( ilocs(idim) )
60         !
61         ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) == 1._wp )
62         zmin  = ARRAY_IN(ilocs(1),ilocs(2),ilocs(3))
63         !
64         kindex(1) = mig( ilocs(1) )
65#if defined DIM_2d || defined DIM_3d    /* avoid warning when kindex has 1 element */
66         kindex(2) = mjg( ilocs(2) )
67#endif
68#if defined DIM_3d                      /* avoid warning when kindex has 2 elements */
69         kindex(3) = ilocs(3)
70#endif
71         !
72         DEALLOCATE (ilocs)
73         !
74         index0 = kindex(1)-1   ! 1d index starting at 0
75#if defined DIM_2d || defined DIM_3d   /* avoid warning when kindex has 1 element */
76         index0 = index0 + jpiglo * (kindex(2)-1)
77#endif
78#if defined DIM_3d                     /* avoid warning when kindex has 2 elements */
79         index0 = index0 + jpiglo * jpjglo * (kindex(3)-1)
80#endif
81      END IF
82      zain(1,:) = zmin
83      zain(2,:) = REAL(index0, wp)
84      !
85      IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.)
86#if defined key_mpp_mpi
87      CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION, MPI_OPERATION ,MPI_COMM_OCE, ierror)
88#else
89      zaout(:,:) = zain(:,:)
90#endif
91      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
92      !
93      pmin      = zaout(1,1)
94      index0    = NINT( zaout(2,1) )
95#if defined DIM_3d                     /* avoid warning when kindex has 2 elements */
96      kindex(3) = index0 / (jpiglo*jpjglo)
97      index0    = index0 - kindex(3) * (jpiglo*jpjglo)
98#endif
99#if defined DIM_2d || defined DIM_3d   /* avoid warning when kindex has 1 element */
100      kindex(2) = index0 / jpiglo
101      index0 = index0 - kindex(2) * jpiglo
102#endif
103      kindex(1) = index0
104      kindex(:) = kindex(:) + 1   ! start indices at 1
105
106   END SUBROUTINE ROUTINE_LOC
107
108
109#undef PRECISION
110#undef ARRAY_TYPE
111#undef MAX_TYPE
112#undef ARRAY_IN
113#undef MASK_IN
114#undef K_SIZE
115#undef MPI_OPERATION
116#undef LOC_OPERATION
117#undef INDEX_TYPE
118#undef ERRVAL
Note: See TracBrowser for help on using the repository browser.