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

Last change on this file since 12603 was 12603, checked in by orioltp, 6 months ago

Adding several interfaces to work with both single and double precision

File size: 4.4 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# if defined key_mpp_mpi
43      !
44      INTEGER  ::   ierror, ii, idim
45      INTEGER  ::   index0
46      REAL(PRECISION) ::   zmin     ! local minimum
47      INTEGER , DIMENSION(:), ALLOCATABLE  ::   ilocs
48      REAL(dp), DIMENSION(2,1) ::   zain, zaout
49      !!-----------------------------------------------------------------------
50      !
51      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. )
52      !
53      idim = SIZE(kindex)
54      !
55      IF ( ALL(MASK_IN(:,:,:) /= 1._wp) ) THEN
56         ! special case for land processors
57         zmin = ERRVAL(zmin)
58         index0 = 0
59      ELSE
60         ALLOCATE ( ilocs(idim) )
61         !
62         ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) == 1._wp )
63         zmin  = ARRAY_IN(ilocs(1),ilocs(2),ilocs(3))
64         !
65         kindex(1) = mig( ilocs(1) )
66#  if defined DIM_2d || defined DIM_3d    /* avoid warning when kindex has 1 element */
67         kindex(2) = mjg( ilocs(2) )
68#  endif
69#  if defined DIM_3d                      /* avoid warning when kindex has 2 elements */
70         kindex(3) = ilocs(3)
71#  endif
72         !
73         DEALLOCATE (ilocs)
74         !
75         index0 = kindex(1)-1   ! 1d index starting at 0
76#  if defined DIM_2d || defined DIM_3d   /* avoid warning when kindex has 1 element */
77         index0 = index0 + jpiglo * (kindex(2)-1)
78#  endif
79#  if defined DIM_3d                     /* avoid warning when kindex has 2 elements */
80         index0 = index0 + jpiglo * jpjglo * (kindex(3)-1)
81#  endif
82      END IF
83      zain(1,:) = zmin
84      zain(2,:) = REAL(index0, wp)
85      !
86      IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.)
87      CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION, MPI_OPERATION ,MPI_COMM_OCE, ierror)
88      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
89      !
90      pmin      = zaout(1,1)
91      index0    = NINT( zaout(2,1) )
92#  if defined DIM_3d                     /* avoid warning when kindex has 2 elements */
93      kindex(3) = index0 / (jpiglo*jpjglo)
94      index0    = index0 - kindex(3) * (jpiglo*jpjglo)
95#  endif
96#  if defined DIM_2d || defined DIM_3d   /* avoid warning when kindex has 1 element */
97      kindex(2) = index0 / jpiglo
98      index0 = index0 - kindex(2) * jpiglo
99#  endif
100      kindex(1) = index0
101      kindex(:) = kindex(:) + 1   ! start indices at 1
102#else
103      kindex = 0 ; pmin = 0.
104      WRITE(*,*) 'ROUTINE_LOC: You should not have seen this print! error?'
105#endif
106
107   END SUBROUTINE ROUTINE_LOC
108
109
110#undef PRECISION
111#undef ARRAY_TYPE
112#undef MAX_TYPE
113#undef ARRAY_IN
114#undef MASK_IN
115#undef K_SIZE
116#undef MPI_OPERATION
117#undef LOC_OPERATION
118#undef INDEX_TYPE
119#undef ERRVAL
Note: See TracBrowser for help on using the repository browser.