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 @ 2335

Last change on this file since 2335 was 2335, checked in by gm, 14 years ago

v3.3beta: Suppress obsolete key_mpp_shmem

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