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/UKMO/r6232_tracer_advection/NEMOGCM/NEMO/OPA_SRC/OBS – NEMO

source: branches/UKMO/r6232_tracer_advection/NEMOGCM/NEMO/OPA_SRC/OBS/obs_mpp.F90 @ 9295

Last change on this file since 9295 was 9295, checked in by jcastill, 6 years ago

Remove svn keywords

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