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 branches/nemo_v3_3_beta/NEMOGCM/NEMO/OPA_SRC/OBS – NEMO

source: branches/nemo_v3_3_beta/NEMOGCM/NEMO/OPA_SRC/OBS/obs_mpp.F90 @ 2363

Last change on this file since 2363 was 2363, checked in by rblod, 13 years ago

Fixes to compile with key_agrif and key_mpp_mpi
  • Property svn:keywords set to Id
File size: 19.6 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   !!----------------------------------------------------------------------
10#if defined key_mpp_mpi
11# if defined key_sp
12#  define mpivar mpi_real
13# else
14#  define mpivar mpi_double_precision
15# endif
16#endif
17   !!----------------------------------------------------------------------
18   !! obs_mpp_bcast_integer : Broadcast an integer array from a processor to all processors
19   !! obs_mpp_max_integer   : Find maximum on all processors of each value in an integer on all processors
20   !! obs_mpp_find_obs_proc : Find processors which should hold the observations
21   !! obs_mpp_sum_integers  : Sum an integer array from all processors
22   !! obs_mpp_sum_integer   : Sum an integer from all processors
23   !!----------------------------------------------------------------------
24   USE dom_oce, ONLY :   nproc, mig, mjg   ! Ocean space and time domain variables
25   USE mpp_map, ONLY :   mppmap
26   USE in_out_manager
27#if defined key_mpp_mpi
28   USE lib_mpp, ONLY :   mpi_comm_opa      ! MPP library
29#endif
30   IMPLICIT NONE
31   PRIVATE
32
33   PUBLIC obs_mpp_bcast_integer, & !: Broadcast an integer array from a proc to all procs
34      &   obs_mpp_max_integer,   & !: Find maximum across processors in an integer array
35      &   obs_mpp_find_obs_proc, & !: Find processors which should hold the observations
36      &   obs_mpp_sum_integers,  & !: Sum an integer array from all processors
37      &   obs_mpp_sum_integer,   & !: Sum an integer from all processors
38      &   mpp_alltoall_int,      &
39      &   mpp_alltoallv_int,     &
40      &   mpp_alltoallv_real,    &
41      &   mpp_global_max
42
43   !!----------------------------------------------------------------------
44   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
45   !! $Id$
46   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
47   !!----------------------------------------------------------------------
48CONTAINS
49
50   SUBROUTINE obs_mpp_bcast_integer( kvals, kno, kroot )
51      !!----------------------------------------------------------------------
52      !!               ***  ROUTINE obs_mpp_bcast_integer ***
53      !!         
54      !! ** Purpose : Send array kvals to all processors
55      !!
56      !! ** Method  : MPI broadcast
57      !!
58      !! ** Action  : This does only work for MPI.
59      !!              MPI_COMM_OPA needs to be replace for OASIS4.!
60      !!
61      !! References : http://www.mpi-forum.org
62      !!----------------------------------------------------------------------
63      INTEGER                , INTENT(in   ) ::   kno     ! Number of elements in array
64      INTEGER                , INTENT(in   ) ::   kroot   ! Processor to send data
65      INTEGER, DIMENSION(kno), INTENT(inout) ::   kvals   ! Array to send on kroot, receive for non-kroot
66      !!
67#if defined key_mpp_mpi
68      INTEGER :: ierr 
69
70INCLUDE 'mpif.h'
71      !!----------------------------------------------------------------------
72
73      ! Call the MPI library to broadcast data
74      CALL mpi_bcast( kvals, kno, mpi_integer,  &
75         &            kroot, mpi_comm_opa, ierr )
76#else
77      ! no MPI: empty routine
78#endif
79      !
80   END SUBROUTINE obs_mpp_bcast_integer
81
82 
83   SUBROUTINE obs_mpp_max_integer( kvals, kno )
84      !!----------------------------------------------------------------------
85      !!               ***  ROUTINE obs_mpp_bcast_integer ***
86      !!         
87      !! ** Purpose : Find maximum across processors in an integer array.
88      !!
89      !! ** Method  : MPI all reduce.
90      !!
91      !! ** Action  : This does only work for MPI.
92      !!              It does not work for SHMEM.
93      !!              MPI_COMM_OPA needs to be replace for OASIS4.!
94      !!
95      !! References : http://www.mpi-forum.org
96      !!----------------------------------------------------------------------
97      INTEGER                , INTENT(in   ) ::   kno     ! Number of elements in array
98      INTEGER, DIMENSION(kno), INTENT(inout) ::   kvals   ! Array to send on kroot, receive for non-kroot 
99      !!
100#if defined key_mpp_mpi
101      INTEGER :: ierr 
102      INTEGER, DIMENSION(kno) ::   ivals
103
104INCLUDE 'mpif.h'
105      !!----------------------------------------------------------------------
106
107      ! Call the MPI library to find the maximum across processors
108      CALL mpi_allreduce( kvals, ivals, kno, mpi_integer,   &
109         &                mpi_max, mpi_comm_opa, ierr )
110      kvals(:) = ivals(:)
111#else
112      ! no MPI: empty routine
113#endif
114   END SUBROUTINE obs_mpp_max_integer
115
116
117   SUBROUTINE obs_mpp_find_obs_proc( kobsp, kobsi, kobsj, kno )
118      !!----------------------------------------------------------------------
119      !!               ***  ROUTINE obs_mpp_find_obs_proc ***
120      !!         
121      !! ** Purpose : From the array kobsp containing the results of the grid
122      !!              grid search on each processor the processor return a
123      !!              decision of which processors should hold the observation.
124      !!
125      !! ** Method  : A temporary 2D array holding all the decisions is
126      !!              constructed using mpi_allgather on each processor.
127      !!              If more than one processor has found the observation
128      !!              with the observation in the inner domain gets it
129      !!
130      !! ** Action  : This does only work for MPI.
131      !!              It does not work for SHMEM.
132      !!
133      !! References : http://www.mpi-forum.org
134      !!----------------------------------------------------------------------
135      INTEGER                , INTENT(in   ) ::   kno
136      INTEGER, DIMENSION(kno), INTENT(in   ) ::   kobsi, kobsj
137      INTEGER, DIMENSION(kno), INTENT(inout) ::   kobsp
138      !!
139#if defined key_mpp_mpi
140      INTEGER :: ji
141      INTEGER :: jj
142      INTEGER :: size
143      INTEGER :: ierr
144      INTEGER :: iobsip
145      INTEGER :: iobsjp
146      INTEGER :: num_sus_obs
147      INTEGER, DIMENSION(kno) ::   iobsig, iobsjg
148      INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   iobsp, iobsi, iobsj
149      !!
150INCLUDE 'mpif.h'
151      !!----------------------------------------------------------------------
152
153      !-----------------------------------------------------------------------
154      ! Call the MPI library to find the maximum accross processors
155      !-----------------------------------------------------------------------
156      CALL mpi_comm_size( mpi_comm_opa, size, ierr )
157      !-----------------------------------------------------------------------
158      ! Convert local grids points to global grid points
159      !-----------------------------------------------------------------------
160      DO ji = 1, kno
161         IF ( ( kobsi(ji) >= 1 ) .AND. ( kobsi(ji) <= jpi ) .AND. &
162            & ( kobsj(ji) >= 1 ) .AND. ( kobsj(ji) <= jpj ) ) THEN
163            iobsig(ji) = mig( kobsi(ji) )
164            iobsjg(ji) = mjg( kobsj(ji) )
165         ELSE
166            iobsig(ji) = -1
167            iobsjg(ji) = -1
168         ENDIF
169      END DO
170      !-----------------------------------------------------------------------
171      ! Get the decisions from all processors
172      !-----------------------------------------------------------------------
173      ALLOCATE( iobsp(kno,size) )
174      ALLOCATE( iobsi(kno,size) )
175      ALLOCATE( iobsj(kno,size) )
176      CALL mpi_allgather( kobsp, kno, mpi_integer, &
177         &                iobsp, kno, mpi_integer, &
178         &                mpi_comm_opa, ierr )
179      CALL mpi_allgather( iobsig, kno, mpi_integer, &
180         &                iobsi, kno, mpi_integer, &
181         &                mpi_comm_opa, ierr )
182      CALL mpi_allgather( iobsjg, kno, mpi_integer, &
183         &                iobsj, kno, mpi_integer, &
184         &                mpi_comm_opa, ierr )
185
186      !-----------------------------------------------------------------------
187      ! Find the processor with observations from the lowest processor
188      ! number among processors holding the observation.
189      !-----------------------------------------------------------------------
190      kobsp(:) = -1
191      num_sus_obs = 0
192      DO ji = 1, kno
193         DO jj = 1, size
194            IF ( ( kobsp(ji) == -1 ) .AND. ( iobsp(ji,jj) /= -1 ) ) THEN
195               kobsp(ji) = iobsp(ji,jj)
196               iobsip = iobsi(ji,jj)
197               iobsjp = iobsj(ji,jj)
198            ENDIF
199            IF ( ( kobsp(ji) /= -1 ) .AND. ( iobsp(ji,jj) /= -1 ) ) THEN
200               IF ( ( iobsip /= iobsi(ji,jj) ) .OR. &
201                  & ( iobsjp /= iobsj(ji,jj) ) ) THEN
202                  IF ( ( kobsp(ji) < 1000000 ) .AND. &
203                     & ( iobsp(ji,jj) < 1000000 ) ) THEN
204                     num_sus_obs=num_sus_obs+1
205                  ENDIF
206               ENDIF
207               IF ( mppmap(iobsip,iobsjp) /= ( kobsp(ji)+1 ) ) THEN
208                  IF ( ( iobsi(ji,jj) /= -1 ) .AND. &
209                     & ( iobsj(ji,jj) /= -1 ) ) THEN
210                     IF ((mppmap(iobsi(ji,jj),iobsj(ji,jj)) == (iobsp(ji,jj)+1))&
211                        & .OR. ( iobsp(ji,jj) < kobsp(ji) ) ) THEN
212                        kobsp(ji) = iobsp(ji,jj)
213                        iobsip = iobsi(ji,jj)
214                        iobsjp = iobsj(ji,jj)
215                     ENDIF
216                  ENDIF
217               ENDIF
218            ENDIF
219         END DO
220      END DO
221      IF (lwp) WRITE(numout,*) 'Number of suspicious observations: ',num_sus_obs
222
223      DEALLOCATE( iobsj )
224      DEALLOCATE( iobsi )
225      DEALLOCATE( iobsp )
226#else
227      ! no MPI: empty routine
228#endif
229      !
230   END SUBROUTINE obs_mpp_find_obs_proc
231
232
233   SUBROUTINE obs_mpp_sum_integers( kvalsin, kvalsout, kno )
234      !!----------------------------------------------------------------------
235      !!               ***  ROUTINE obs_mpp_sum_integers ***
236      !!         
237      !! ** Purpose : Sum an integer array.
238      !!
239      !! ** Method  : MPI all reduce.
240      !!
241      !! ** Action  : This does only work for MPI.
242      !!              It does not work for SHMEM.
243      !!
244      !! References : http://www.mpi-forum.org
245      !!----------------------------------------------------------------------
246      INTEGER                , INTENT(in   ) :: kno
247      INTEGER, DIMENSION(kno), INTENT(in   ) ::   kvalsin
248      INTEGER, DIMENSION(kno), INTENT(  out) ::   kvalsout
249      !!
250#if defined key_mpp_mpi
251      INTEGER :: ierr
252      !!
253INCLUDE 'mpif.h'
254      !!----------------------------------------------------------------------
255      !
256      !-----------------------------------------------------------------------
257      ! Call the MPI library to find the sum across processors
258      !-----------------------------------------------------------------------
259      CALL mpi_allreduce( kvalsin, kvalsout, kno, mpi_integer, &
260         &                mpi_sum, mpi_comm_opa, ierr )
261#else
262      !-----------------------------------------------------------------------
263      ! For no-MPP just return input values
264      !-----------------------------------------------------------------------
265      kvalsout(:) = kvalsin(:)
266#endif
267      !
268   END SUBROUTINE obs_mpp_sum_integers
269
270
271   SUBROUTINE obs_mpp_sum_integer( kvalin, kvalout )
272      !!----------------------------------------------------------------------
273      !!               ***  ROUTINE obs_mpp_sum_integers ***
274      !!         
275      !! ** Purpose : Sum a single integer
276      !!
277      !! ** Method  : MPI all reduce.
278      !!
279      !! ** Action  : This does only work for MPI.
280      !!              It does not work for SHMEM.
281      !!
282      !! References : http://www.mpi-forum.org
283      !!----------------------------------------------------------------------
284      INTEGER, INTENT(in   ) ::   kvalin
285      INTEGER, INTENT(  out) ::   kvalout
286      !!
287#if defined key_mpp_mpi
288      INTEGER :: ierr
289      !!
290INCLUDE 'mpif.h'
291      !!----------------------------------------------------------------------
292      !
293      !-----------------------------------------------------------------------
294      ! Call the MPI library to find the sum across processors
295      !-----------------------------------------------------------------------
296      CALL mpi_allreduce( kvalin, kvalout, 1, mpi_integer,   &
297         &                mpi_sum, mpi_comm_opa, ierr )
298#else
299      !-----------------------------------------------------------------------
300      ! For no-MPP just return input values
301      !-----------------------------------------------------------------------
302      kvalout = kvalin
303#endif
304      !
305   END SUBROUTINE obs_mpp_sum_integer
306
307
308   SUBROUTINE mpp_global_max( pval )
309      !!----------------------------------------------------------------------
310      !!               ***  ROUTINE mpp_global_or ***
311      !!         
312      !! ** Purpose : Get the maximum value across processors for a global
313      !!              real array
314      !!
315      !! ** Method  : MPI allreduce
316      !!
317      !! ** Action  : This does only work for MPI.
318      !!              It does not work for SHMEM.
319      !!
320      !! References : http://www.mpi-forum.org
321      !!----------------------------------------------------------------------
322      REAL(KIND=wp), DIMENSION(jpiglo,jpjglo), INTENT(inout) ::   pval
323      !!
324      INTEGER :: ierr
325#if defined key_mpp_mpi
326INCLUDE 'mpif.h'
327      REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE ::   zcp
328      !!----------------------------------------------------------------------
329
330      ! Copy data for input to MPI
331
332      ALLOCATE( &
333         & zcp(jpiglo,jpjglo) &
334         & )
335      zcp(:,:) = pval(:,:)
336
337      ! Call the MPI library to find the coast lines globally
338
339      CALL mpi_allreduce( zcp, pval, jpiglo*jpjglo, mpivar, &
340         &                mpi_max, mpi_comm_opa, ierr )
341
342      DEALLOCATE( &
343         & zcp &
344         & )
345
346#else
347      ! no MPI: empty routine
348#endif
349      !
350   END SUBROUTINE mpp_global_max
351
352
353   SUBROUTINE mpp_alltoall_int( kno, kvalsin, kvalsout )
354      !!----------------------------------------------------------------------
355      !!               ***  ROUTINE mpp_allgatherv ***
356      !!         
357      !! ** Purpose : all to all.
358      !!
359      !! ** Method  : MPI alltoall
360      !!
361      !! ** Action  : This does only work for MPI.
362      !!              It does not work for SHMEM.
363      !!
364      !! References : http://www.mpi-forum.org
365      !!----------------------------------------------------------------------
366      INTEGER                      , INTENT(in   ) ::   kno
367      INTEGER, DIMENSION(kno*jpnij), INTENT(in   ) ::   kvalsin
368      INTEGER, DIMENSION(kno*jpnij), INTENT(  out) ::   kvalsout
369      !!
370      INTEGER :: ierr
371#if defined key_mpp_mpi
372INCLUDE 'mpif.h'
373      !-----------------------------------------------------------------------
374      ! Call the MPI library to do the all to all operation of the data
375      !-----------------------------------------------------------------------
376      CALL mpi_alltoall( kvalsin,  kno, mpi_integer, &
377         &               kvalsout, kno, mpi_integer, &
378         &               mpi_comm_opa, ierr )
379#else
380      !-----------------------------------------------------------------------
381      ! For no-MPP just return input values
382      !-----------------------------------------------------------------------
383      kvalsout = kvalsin
384#endif
385      !
386   END SUBROUTINE mpp_alltoall_int
387
388
389   SUBROUTINE mpp_alltoallv_int( kvalsin, knoin , kinv , kvalsout,   &
390      &                                   knoout, koutv )
391      !!----------------------------------------------------------------------
392      !!               ***  ROUTINE mpp_alltoallv_int ***
393      !!         
394      !! ** Purpose : all to all (integer version).
395      !!
396      !! ** Method  : MPI alltoall
397      !!
398      !! ** Action  : This does only work for MPI.
399      !!              It does not work for SHMEM.
400      !!
401      !! References : http://www.mpi-forum.org
402      !!----------------------------------------------------------------------
403      INTEGER                   , INTENT(in) :: knoin
404      INTEGER                   , INTENT(in) :: knoout
405      INTEGER, DIMENSION(jpnij)                 ::   kinv, koutv
406      INTEGER, DIMENSION(knoin) , INTENT(in   ) ::   kvalsin
407      INTEGER, DIMENSION(knoout), INTENT(  out) ::   kvalsout
408      !!
409      INTEGER :: ierr
410      INTEGER :: jproc
411#if defined key_mpp_mpi
412INCLUDE 'mpif.h'
413      INTEGER, DIMENSION(jpnij) ::   irdsp, isdsp
414      !-----------------------------------------------------------------------
415      ! Compute displacements
416      !-----------------------------------------------------------------------
417      irdsp(1) = 0
418      isdsp(1) = 0
419      DO jproc = 2, jpnij
420         isdsp(jproc) = isdsp(jproc-1) + kinv(jproc-1)
421         irdsp(jproc) = irdsp(jproc-1) + koutv(jproc-1)
422      END DO
423      !-----------------------------------------------------------------------
424      ! Call the MPI library to do the all to all operation of the data
425      !-----------------------------------------------------------------------
426      CALL mpi_alltoallv( kvalsin,  kinv,  isdsp, mpi_integer, &
427         &                kvalsout, koutv, irdsp, mpi_integer, &
428         &                mpi_comm_opa, ierr )
429#else
430      !-----------------------------------------------------------------------
431      ! For no-MPP just return input values
432      !-----------------------------------------------------------------------
433      kvalsout = kvalsin
434#endif
435      !
436   END SUBROUTINE mpp_alltoallv_int
437
438
439   SUBROUTINE mpp_alltoallv_real( pvalsin, knoin , kinv , pvalsout,   &
440      &                                    knoout, koutv )
441      !!----------------------------------------------------------------------
442      !!               ***  ROUTINE mpp_alltoallv_real ***
443      !!         
444      !! ** Purpose : all to all (integer version).
445      !!
446      !! ** Method  : MPI alltoall
447      !!
448      !! ** Action  : This does only work for MPI.
449      !!              It does not work for SHMEM.
450      !!
451      !! References : http://www.mpi-forum.org
452      !!----------------------------------------------------------------------
453      INTEGER                    , INTENT(in   ) :: knoin
454      INTEGER                    , INTENT(in   ) :: knoout
455      INTEGER , DIMENSION(jpnij)                 ::   kinv, koutv
456      REAL(wp), DIMENSION(knoin) , INTENT(in   ) ::   pvalsin
457      REAL(wp), DIMENSION(knoout), INTENT(  out) ::   pvalsout
458      !!
459      INTEGER :: ierr
460      INTEGER :: jproc
461#if defined key_mpp_mpi
462INCLUDE 'mpif.h'
463      INTEGER, DIMENSION(jpnij) ::   irdsp, isdsp
464      !!----------------------------------------------------------------------
465      !
466      !-----------------------------------------------------------------------
467      ! Compute displacements
468      !-----------------------------------------------------------------------
469      irdsp(1) = 0
470      isdsp(1) = 0
471      DO jproc = 2, jpnij
472         isdsp(jproc) = isdsp(jproc-1) + kinv(jproc-1)
473         irdsp(jproc) = irdsp(jproc-1) + koutv(jproc-1)
474      END DO
475      !-----------------------------------------------------------------------
476      ! Call the MPI library to do the all to all operation of the data
477      !-----------------------------------------------------------------------
478      CALL mpi_alltoallv( pvalsin,  kinv,  isdsp, mpivar, &
479         &                pvalsout, koutv, irdsp, mpivar, &
480         &                mpi_comm_opa, ierr )
481#else
482      !-----------------------------------------------------------------------
483      ! For no-MPP just return input values
484      !-----------------------------------------------------------------------
485      pvalsout = pvalsin
486#endif
487      !
488   END SUBROUTINE mpp_alltoallv_real
489
490   !!======================================================================
491END MODULE obs_mpp
Note: See TracBrowser for help on using the repository browser.