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

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

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