Newer
Older
sparonuz
committed
!== IN: ptab is an array ==!
sparonuz
committed
# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k)
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
#if ! defined key_mpi_off
# define MPI_TYPE MPI_2REAL
#endif
# define PRECISION sp
# else
# define ARRAY_TYPE(i,j,k) REAL(dp) , INTENT(in ) :: ARRAY_IN(i,j,k)
#if ! defined key_mpi_off
# define MPI_TYPE MPI_2DOUBLE_PRECISION
#endif
# define PRECISION dp
# endif
# if defined DIM_2d
# define ARRAY_IN(i,j,k) ptab(i,j)
# define MASK_IN(i,j,k) ldmsk(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) ldmsk(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, ldmsk, pmin, kindex, ldhalo )
!!----------------------------------------------------------------------
CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine
ARRAY_TYPE(:,:,:) ! array on which loctrans operation is applied
LOGICAL , INTENT(in ) :: MASK_IN(:,:,:) ! local mask
REAL(PRECISION) , INTENT( out) :: pmin ! Global minimum of ptab
INDEX_TYPE(:) ! index of minimum in global frame
LOGICAL, OPTIONAL, INTENT(in ) :: ldhalo ! If .false. (default) excludes halos in kindex
!
INTEGER :: ierror, ii, idim
INTEGER :: index0
INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs
REAL(PRECISION) :: zmin ! local minimum
REAL(PRECISION), DIMENSION(2,1) :: zain, zaout
LOGICAL :: llhalo
!!-----------------------------------------------------------------------
!
IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. )
!
IF( PRESENT(ldhalo) ) THEN ; llhalo = ldhalo
ELSE ; llhalo = .FALSE.
ENDIF
!
idim = SIZE(kindex)
!
IF ( ANY( MASK_IN(:,:,:) ) ) THEN ! there is at least 1 valid point...
!
ALLOCATE ( ilocs(idim) )
!
ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) )
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
ELSE
! special case for land processors
zmin = ERRVAL(zmin)
index0 = 0
END IF
!
zain(1,:) = zmin
zain(2,:) = REAL(index0, PRECISION)
!
#if ! defined key_mpi_off
IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.)
CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_TYPE, MPI_OPERATION ,MPI_COMM_OCE, ierror)
IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
#else
zaout(:,:) = zain(:,:)
#endif
!
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
IF( .NOT. llhalo ) THEN
kindex(1) = kindex(1) - nn_hls
#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */
kindex(2) = kindex(2) - nn_hls
#endif
ENDIF
END SUBROUTINE ROUTINE_LOC
#undef PRECISION
#undef ARRAY_TYPE
#undef ARRAY_IN
#undef MASK_IN
#undef K_SIZE
#if ! defined key_mpi_off
# undef MPI_TYPE
#endif
#undef MPI_OPERATION
#undef LOC_OPERATION
#undef INDEX_TYPE
#undef ERRVAL