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

Last change on this file since 2474 was 2474, checked in by djlea, 13 years ago

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