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

Last change on this file since 2281 was 2281, checked in by smasson, 14 years ago

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