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.
obs_mpp.F90 in NEMO/trunk/src/OCE/OBS – NEMO

source: NEMO/trunk/src/OCE/OBS/obs_mpp.F90 @ 14275

Last change on this file since 14275 was 14275, checked in by smasson, 3 years ago

trunk: suppress nproc ( = mpprank = narea-1)

  • Property svn:keywords set to Id
File size: 16.7 KB
Line 
1MODULE obs_mpp
2   !!======================================================================
3   !!                       ***  MODULE obs_mpp  ***
4   !! Observation diagnostics: Various MPP support routines
5   !!======================================================================
6   !! History :  2.0  ! 2006-03  (K. Mogensen)  Original code
7   !!             -   ! 2006-05  (K. Mogensen)  Reformatted
8   !!             -   ! 2008-01  (K. Mogensen)  add mpp_global_max
9   !!            3.6  ! 2015-01  (J. Waters) obs_mpp_find_obs_proc
10   !!                            rewritten to avoid global arrays
11   !!----------------------------------------------------------------------
12#  define mpivar mpi_double_precision
13   !!----------------------------------------------------------------------
14   !! obs_mpp_bcast_integer : Broadcast an integer array from a processor to all processors
15   !! obs_mpp_max_integer   : Find maximum on all processors of each value in an integer on all processors
16   !! obs_mpp_find_obs_proc : Find processors which should hold the observations, avoiding global arrays
17   !! obs_mpp_sum_integers  : Sum an integer array from all processors
18   !! obs_mpp_sum_integer   : Sum an integer from all processors
19   !!----------------------------------------------------------------------
20   USE mpp_map, ONLY :   mppmap
21   USE in_out_manager
22#if ! defined key_mpi_off
23   USE lib_mpp, ONLY :   mpi_comm_oce      ! MPP library
24#endif
25   IMPLICIT NONE
26   PRIVATE
27
28   PUBLIC obs_mpp_bcast_integer, & !: Broadcast an integer array from a proc to all procs
29      &   obs_mpp_max_integer,   & !: Find maximum across processors in an integer array
30      &   obs_mpp_find_obs_proc, & !: Find processors which should hold the observations
31      &   obs_mpp_sum_integers,  & !: Sum an integer array from all processors
32      &   obs_mpp_sum_integer,   & !: Sum an integer from all processors
33      &   mpp_alltoall_int,      &
34      &   mpp_alltoallv_int,     &
35      &   mpp_alltoallv_real,    &
36      &   mpp_global_max
37
38   !!----------------------------------------------------------------------
39   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
40   !! $Id$
41   !! Software governed by the CeCILL license (see ./LICENSE)
42   !!----------------------------------------------------------------------
43CONTAINS
44
45   SUBROUTINE obs_mpp_bcast_integer( kvals, kno, kroot )
46      !!----------------------------------------------------------------------
47      !!               ***  ROUTINE obs_mpp_bcast_integer ***
48      !!         
49      !! ** Purpose : Send array kvals to all processors
50      !!
51      !! ** Method  : MPI broadcast
52      !!
53      !! ** Action  : This does only work for MPI.
54      !!              MPI_COMM_OCE needs to be replace for OASIS4.!
55      !!
56      !! References : http://www.mpi-forum.org
57      !!----------------------------------------------------------------------
58      INTEGER                , INTENT(in   ) ::   kno     ! Number of elements in array
59      INTEGER                , INTENT(in   ) ::   kroot   ! Processor to send data
60      INTEGER, DIMENSION(kno), INTENT(inout) ::   kvals   ! Array to send on kroot, receive for non-kroot
61      !
62#if ! defined key_mpi_off
63      !
64      INTEGER :: ierr 
65      !
66INCLUDE 'mpif.h'
67      !!----------------------------------------------------------------------
68
69      ! Call the MPI library to broadcast data
70      CALL mpi_bcast( kvals, kno, mpi_integer,  &
71         &            kroot, mpi_comm_oce, ierr )
72#else
73      ! no MPI: empty routine
74#endif
75      !
76   END SUBROUTINE obs_mpp_bcast_integer
77
78 
79   SUBROUTINE obs_mpp_max_integer( kvals, kno )
80      !!----------------------------------------------------------------------
81      !!               ***  ROUTINE obs_mpp_bcast_integer ***
82      !!         
83      !! ** Purpose : Find maximum across processors in an integer array.
84      !!
85      !! ** Method  : MPI all reduce.
86      !!
87      !! ** Action  : This does only work for MPI.
88      !!              It does not work for SHMEM.
89      !!              MPI_COMM_OCE needs to be replace for OASIS4.!
90      !!
91      !! References : http://www.mpi-forum.org
92      !!----------------------------------------------------------------------
93      INTEGER                , INTENT(in   ) ::   kno     ! Number of elements in array
94      INTEGER, DIMENSION(kno), INTENT(inout) ::   kvals   ! Array to send on kroot, receive for non-kroot 
95      !
96#if ! defined key_mpi_off
97      !
98      INTEGER :: ierr 
99      INTEGER, DIMENSION(kno) ::   ivals
100      !
101INCLUDE 'mpif.h'
102      !!----------------------------------------------------------------------
103
104      ! Call the MPI library to find the maximum across processors
105      CALL mpi_allreduce( kvals, ivals, kno, mpi_integer,   &
106         &                mpi_max, mpi_comm_oce, ierr )
107      kvals(:) = ivals(:)
108#else
109      ! no MPI: empty routine
110#endif
111   END SUBROUTINE obs_mpp_max_integer
112
113
114   SUBROUTINE obs_mpp_find_obs_proc( kobsp,kno )
115      !!----------------------------------------------------------------------
116      !!               ***  ROUTINE obs_mpp_find_obs_proc  ***
117      !!         
118      !! ** Purpose : From the array kobsp containing the results of the
119      !!              grid search on each processor the processor return a
120      !!              decision of which processors should hold the observation.
121      !!
122      !! ** Method  : Synchronize the processor number for each obs using
123      !!              obs_mpp_max_integer. If an observation exists on two
124      !!              processors it will be allocated to the lower numbered
125      !!              processor.
126      !!
127      !! ** Action  : This does only work for MPI.
128      !!              It does not work for SHMEM.
129      !!
130      !! References : http://www.mpi-forum.org
131      !!----------------------------------------------------------------------
132      INTEGER                , INTENT(in   ) ::   kno
133      INTEGER, DIMENSION(kno), INTENT(inout) ::   kobsp
134      !
135#if ! defined key_mpi_off
136      !
137      !
138      INTEGER :: ji, isum
139      INTEGER, DIMENSION(kno) ::   iobsp
140      !!
141      !!
142
143      iobsp(:)=kobsp(:)
144
145      WHERE( iobsp(:) == -1 )
146         iobsp(:) = 9999999
147      END WHERE
148
149      iobsp(:)=-1*iobsp(:)
150
151      CALL obs_mpp_max_integer( iobsp, kno )
152
153      kobsp(:)=-1*iobsp(:)
154
155      isum=0
156      DO ji = 1, kno
157         IF ( kobsp(ji) == 9999999 ) THEN
158            isum=isum+1
159            kobsp(ji)=-1
160         ENDIF
161      ENDDO
162
163
164      IF ( isum > 0 ) THEN
165         IF (lwp) WRITE(numout,*) isum, ' observations failed the grid search.'
166         IF (lwp) WRITE(numout,*)'If ln_grid_search_lookup=.TRUE., try reducing grid_search_res'
167      ENDIF
168
169#else
170      ! no MPI: empty routine
171#endif     
172     
173   END SUBROUTINE obs_mpp_find_obs_proc
174
175
176   SUBROUTINE obs_mpp_sum_integers( kvalsin, kvalsout, kno )
177      !!----------------------------------------------------------------------
178      !!               ***  ROUTINE obs_mpp_sum_integers ***
179      !!         
180      !! ** Purpose : Sum an integer array.
181      !!
182      !! ** Method  : MPI all reduce.
183      !!
184      !! ** Action  : This does only work for MPI.
185      !!              It does not work for SHMEM.
186      !!
187      !! References : http://www.mpi-forum.org
188      !!----------------------------------------------------------------------
189      INTEGER                , INTENT(in   ) :: kno
190      INTEGER, DIMENSION(kno), INTENT(in   ) ::   kvalsin
191      INTEGER, DIMENSION(kno), INTENT(  out) ::   kvalsout
192      !
193#if ! defined key_mpi_off
194      !
195      INTEGER :: ierr
196      !
197INCLUDE 'mpif.h'
198      !!----------------------------------------------------------------------
199      !
200      !-----------------------------------------------------------------------
201      ! Call the MPI library to find the sum across processors
202      !-----------------------------------------------------------------------
203      CALL mpi_allreduce( kvalsin, kvalsout, kno, mpi_integer, &
204         &                mpi_sum, mpi_comm_oce, ierr )
205#else
206      !-----------------------------------------------------------------------
207      ! For no-MPP just return input values
208      !-----------------------------------------------------------------------
209      kvalsout(:) = kvalsin(:)
210#endif
211      !
212   END SUBROUTINE obs_mpp_sum_integers
213
214
215   SUBROUTINE obs_mpp_sum_integer( kvalin, kvalout )
216      !!----------------------------------------------------------------------
217      !!               ***  ROUTINE obs_mpp_sum_integers ***
218      !!         
219      !! ** Purpose : Sum a single integer
220      !!
221      !! ** Method  : MPI all reduce.
222      !!
223      !! ** Action  : This does only work for MPI.
224      !!              It does not work for SHMEM.
225      !!
226      !! References : http://www.mpi-forum.org
227      !!----------------------------------------------------------------------
228      INTEGER, INTENT(in   ) ::   kvalin
229      INTEGER, INTENT(  out) ::   kvalout
230      !
231#if ! defined key_mpi_off
232      !
233      INTEGER :: ierr
234      !
235INCLUDE 'mpif.h'
236      !!----------------------------------------------------------------------
237      !
238      !-----------------------------------------------------------------------
239      ! Call the MPI library to find the sum across processors
240      !-----------------------------------------------------------------------
241      CALL mpi_allreduce( kvalin, kvalout, 1, mpi_integer,   &
242         &                mpi_sum, mpi_comm_oce, ierr )
243#else
244      !-----------------------------------------------------------------------
245      ! For no-MPP just return input values
246      !-----------------------------------------------------------------------
247      kvalout = kvalin
248#endif
249      !
250   END SUBROUTINE obs_mpp_sum_integer
251
252
253   SUBROUTINE mpp_global_max( pval )
254      !!----------------------------------------------------------------------
255      !!               ***  ROUTINE mpp_global_or ***
256      !!         
257      !! ** Purpose : Get the maximum value across processors for a global
258      !!              real array
259      !!
260      !! ** Method  : MPI allreduce
261      !!
262      !! ** Action  : This does only work for MPI.
263      !!              It does not work for SHMEM.
264      !!
265      !! References : http://www.mpi-forum.org
266      !!----------------------------------------------------------------------
267      REAL(KIND=wp), DIMENSION(jpiglo,jpjglo), INTENT(inout) ::   pval
268      !
269      INTEGER :: ierr
270      !
271#if ! defined key_mpi_off
272      !
273INCLUDE 'mpif.h'
274      REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE ::   zcp
275      !!----------------------------------------------------------------------
276
277      ! Copy data for input to MPI
278
279      ALLOCATE( &
280         & zcp(jpiglo,jpjglo) &
281         & )
282      zcp(:,:) = pval(:,:)
283
284      ! Call the MPI library to find the coast lines globally
285
286      CALL mpi_allreduce( zcp, pval, jpiglo*jpjglo, mpivar, &
287         &                mpi_max, mpi_comm_oce, ierr )
288
289      DEALLOCATE( &
290         & zcp &
291         & )
292
293#else
294      ! no MPI: empty routine
295#endif
296      !
297   END SUBROUTINE mpp_global_max
298
299
300   SUBROUTINE mpp_alltoall_int( kno, kvalsin, kvalsout )
301      !!----------------------------------------------------------------------
302      !!               ***  ROUTINE mpp_allgatherv ***
303      !!         
304      !! ** Purpose : all to all.
305      !!
306      !! ** Method  : MPI alltoall
307      !!
308      !! ** Action  : This does only work for MPI.
309      !!              It does not work for SHMEM.
310      !!
311      !! References : http://www.mpi-forum.org
312      !!----------------------------------------------------------------------
313      INTEGER                      , INTENT(in   ) ::   kno
314      INTEGER, DIMENSION(kno*jpnij), INTENT(in   ) ::   kvalsin
315      INTEGER, DIMENSION(kno*jpnij), INTENT(  out) ::   kvalsout
316      !!
317      INTEGER :: ierr
318      !
319#if ! defined key_mpi_off
320      !
321INCLUDE 'mpif.h'
322      !-----------------------------------------------------------------------
323      ! Call the MPI library to do the all to all operation of the data
324      !-----------------------------------------------------------------------
325      CALL mpi_alltoall( kvalsin,  kno, mpi_integer, &
326         &               kvalsout, kno, mpi_integer, &
327         &               mpi_comm_oce, ierr )
328#else
329      !-----------------------------------------------------------------------
330      ! For no-MPP just return input values
331      !-----------------------------------------------------------------------
332      kvalsout = kvalsin
333#endif
334      !
335   END SUBROUTINE mpp_alltoall_int
336
337
338   SUBROUTINE mpp_alltoallv_int( kvalsin, knoin , kinv , kvalsout,   &
339      &                                   knoout, koutv )
340      !!----------------------------------------------------------------------
341      !!               ***  ROUTINE mpp_alltoallv_int ***
342      !!         
343      !! ** Purpose : all to all (integer version).
344      !!
345      !! ** Method  : MPI alltoall
346      !!
347      !! ** Action  : This does only work for MPI.
348      !!              It does not work for SHMEM.
349      !!
350      !! References : http://www.mpi-forum.org
351      !!----------------------------------------------------------------------
352      INTEGER                   , INTENT(in) :: knoin
353      INTEGER                   , INTENT(in) :: knoout
354      INTEGER, DIMENSION(jpnij)                 ::   kinv, koutv
355      INTEGER, DIMENSION(knoin) , INTENT(in   ) ::   kvalsin
356      INTEGER, DIMENSION(knoout), INTENT(  out) ::   kvalsout
357      !!
358      INTEGER :: ierr
359      INTEGER :: jproc
360      !
361#if ! defined key_mpi_off
362      !
363INCLUDE 'mpif.h'
364      INTEGER, DIMENSION(jpnij) ::   irdsp, isdsp
365      !-----------------------------------------------------------------------
366      ! Compute displacements
367      !-----------------------------------------------------------------------
368      irdsp(1) = 0
369      isdsp(1) = 0
370      DO jproc = 2, jpnij
371         isdsp(jproc) = isdsp(jproc-1) + kinv(jproc-1)
372         irdsp(jproc) = irdsp(jproc-1) + koutv(jproc-1)
373      END DO
374      !-----------------------------------------------------------------------
375      ! Call the MPI library to do the all to all operation of the data
376      !-----------------------------------------------------------------------
377      CALL mpi_alltoallv( kvalsin,  kinv,  isdsp, mpi_integer, &
378         &                kvalsout, koutv, irdsp, mpi_integer, &
379         &                mpi_comm_oce, ierr )
380#else
381      !-----------------------------------------------------------------------
382      ! For no-MPP just return input values
383      !-----------------------------------------------------------------------
384      kvalsout = kvalsin
385#endif
386      !
387   END SUBROUTINE mpp_alltoallv_int
388
389
390   SUBROUTINE mpp_alltoallv_real( pvalsin, knoin , kinv , pvalsout,   &
391      &                                    knoout, koutv )
392      !!----------------------------------------------------------------------
393      !!               ***  ROUTINE mpp_alltoallv_real ***
394      !!         
395      !! ** Purpose : all to all (integer version).
396      !!
397      !! ** Method  : MPI alltoall
398      !!
399      !! ** Action  : This does only work for MPI.
400      !!              It does not work for SHMEM.
401      !!
402      !! References : http://www.mpi-forum.org
403      !!----------------------------------------------------------------------
404      INTEGER                    , INTENT(in   ) :: knoin
405      INTEGER                    , INTENT(in   ) :: knoout
406      INTEGER , DIMENSION(jpnij)                 ::   kinv, koutv
407      REAL(wp), DIMENSION(knoin) , INTENT(in   ) ::   pvalsin
408      REAL(wp), DIMENSION(knoout), INTENT(  out) ::   pvalsout
409      !!
410      INTEGER :: ierr
411      INTEGER :: jproc
412      !
413#if ! defined key_mpi_off
414      !
415INCLUDE 'mpif.h'
416      INTEGER, DIMENSION(jpnij) ::   irdsp, isdsp
417      !!----------------------------------------------------------------------
418      !
419      !-----------------------------------------------------------------------
420      ! Compute displacements
421      !-----------------------------------------------------------------------
422      irdsp(1) = 0
423      isdsp(1) = 0
424      DO jproc = 2, jpnij
425         isdsp(jproc) = isdsp(jproc-1) + kinv(jproc-1)
426         irdsp(jproc) = irdsp(jproc-1) + koutv(jproc-1)
427      END DO
428      !-----------------------------------------------------------------------
429      ! Call the MPI library to do the all to all operation of the data
430      !-----------------------------------------------------------------------
431      CALL mpi_alltoallv( pvalsin,  kinv,  isdsp, mpivar, &
432         &                pvalsout, koutv, irdsp, mpivar, &
433         &                mpi_comm_oce, ierr )
434#else
435      !-----------------------------------------------------------------------
436      ! For no-MPP just return input values
437      !-----------------------------------------------------------------------
438      pvalsout = pvalsin
439#endif
440      !
441   END SUBROUTINE mpp_alltoallv_real
442
443   !!======================================================================
444END MODULE obs_mpp
Note: See TracBrowser for help on using the repository browser.