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
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
[2128]60      !!
61#if defined key_mpp_mpi
[2363]62      INTEGER :: ierr 
63
[2249]64INCLUDE 'mpif.h'
[2335]65      !!----------------------------------------------------------------------
[2128]66
67      ! Call the MPI library to broadcast data
[2335]68      CALL mpi_bcast( kvals, kno, mpi_integer,  &
[2128]69         &            kroot, mpi_comm_opa, ierr )
[2335]70#else
71      ! no MPI: empty routine
[2128]72#endif
[2335]73      !
74   END SUBROUTINE obs_mpp_bcast_integer
[2128]75
[2335]76 
[2128]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
[2335]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 
[2128]93      !!
94#if defined key_mpp_mpi
[2363]95      INTEGER :: ierr 
[2335]96      INTEGER, DIMENSION(kno) ::   ivals
[2363]97
[2249]98INCLUDE 'mpif.h'
[2335]99      !!----------------------------------------------------------------------
[2128]100
101      ! Call the MPI library to find the maximum across processors
[2335]102      CALL mpi_allreduce( kvals, ivals, kno, mpi_integer,   &
[2128]103         &                mpi_max, mpi_comm_opa, ierr )
104      kvals(:) = ivals(:)
[2335]105#else
106      ! no MPI: empty routine
[2128]107#endif
108   END SUBROUTINE obs_mpp_max_integer
109
[2335]110
111   SUBROUTINE obs_mpp_find_obs_proc( kobsp, kobsi, kobsj, kno )
[2128]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
[2335]128      !!----------------------------------------------------------------------
129      INTEGER                , INTENT(in   ) ::   kno
130      INTEGER, DIMENSION(kno), INTENT(in   ) ::   kobsi, kobsj
131      INTEGER, DIMENSION(kno), INTENT(inout) ::   kobsp
[2128]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
[2335]141      INTEGER, DIMENSION(kno) ::   iobsig, iobsjg
142      INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   iobsp, iobsi, iobsj
143      !!
[2249]144INCLUDE 'mpif.h'
[2335]145      !!----------------------------------------------------------------------
[2128]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 )
[2335]220#else
221      ! no MPI: empty routine
[2128]222#endif
[2335]223      !
[2128]224   END SUBROUTINE obs_mpp_find_obs_proc
225
[2335]226
[2128]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
[2335]239      !!----------------------------------------------------------------------
240      INTEGER                , INTENT(in   ) :: kno
241      INTEGER, DIMENSION(kno), INTENT(in   ) ::   kvalsin
242      INTEGER, DIMENSION(kno), INTENT(  out) ::   kvalsout
[2128]243      !!
244#if defined key_mpp_mpi
245      INTEGER :: ierr
[2335]246      !!
[2249]247INCLUDE 'mpif.h'
[2335]248      !!----------------------------------------------------------------------
249      !
[2128]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
[2335]261      !
[2128]262   END SUBROUTINE obs_mpp_sum_integers
263
[2335]264
[2128]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
[2335]277      !!----------------------------------------------------------------------
278      INTEGER, INTENT(in   ) ::   kvalin
279      INTEGER, INTENT(  out) ::   kvalout
[2128]280      !!
281#if defined key_mpp_mpi
282      INTEGER :: ierr
[2335]283      !!
[2249]284INCLUDE 'mpif.h'
[2335]285      !!----------------------------------------------------------------------
286      !
[2128]287      !-----------------------------------------------------------------------
288      ! Call the MPI library to find the sum across processors
289      !-----------------------------------------------------------------------
[2335]290      CALL mpi_allreduce( kvalin, kvalout, 1, mpi_integer,   &
[2128]291         &                mpi_sum, mpi_comm_opa, ierr )
292#else
293      !-----------------------------------------------------------------------
294      ! For no-MPP just return input values
295      !-----------------------------------------------------------------------
296      kvalout = kvalin
297#endif
[2335]298      !
[2128]299   END SUBROUTINE obs_mpp_sum_integer
300
[2335]301
[2128]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
[2335]315      !!----------------------------------------------------------------------
316      REAL(KIND=wp), DIMENSION(jpiglo,jpjglo), INTENT(inout) ::   pval
[2128]317      !!
318      INTEGER :: ierr
319#if defined key_mpp_mpi
[2249]320INCLUDE 'mpif.h'
[2335]321      REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE ::   zcp
322      !!----------------------------------------------------------------------
[2128]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
[2335]340#else
341      ! no MPI: empty routine
[2128]342#endif
[2335]343      !
[2128]344   END SUBROUTINE mpp_global_max
345
[2335]346
[2128]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
[2335]359      !!----------------------------------------------------------------------
360      INTEGER                      , INTENT(in   ) ::   kno
361      INTEGER, DIMENSION(kno*jpnij), INTENT(in   ) ::   kvalsin
362      INTEGER, DIMENSION(kno*jpnij), INTENT(  out) ::   kvalsout
[2128]363      !!
364      INTEGER :: ierr
365#if defined key_mpp_mpi
[2249]366INCLUDE 'mpif.h'
[2128]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
[2335]379      !
[2128]380   END SUBROUTINE mpp_alltoall_int
381
[2335]382
383   SUBROUTINE mpp_alltoallv_int( kvalsin, knoin , kinv , kvalsout,   &
384      &                                   knoout, koutv )
[2128]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
[2335]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
[2128]402      !!
403      INTEGER :: ierr
404      INTEGER :: jproc
405#if defined key_mpp_mpi
[2249]406INCLUDE 'mpif.h'
[2335]407      INTEGER, DIMENSION(jpnij) ::   irdsp, isdsp
[2128]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
[2335]429      !
[2128]430   END SUBROUTINE mpp_alltoallv_int
431
[2335]432
433   SUBROUTINE mpp_alltoallv_real( pvalsin, knoin , kinv , pvalsout,   &
434      &                                    knoout, koutv )
[2128]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
[2335]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
[2128]452      !!
453      INTEGER :: ierr
454      INTEGER :: jproc
455#if defined key_mpp_mpi
[2249]456INCLUDE 'mpif.h'
[2335]457      INTEGER, DIMENSION(jpnij) ::   irdsp, isdsp
458      !!----------------------------------------------------------------------
459      !
[2128]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
[2335]481      !
[2128]482   END SUBROUTINE mpp_alltoallv_real
483
[2335]484   !!======================================================================
[2128]485END MODULE obs_mpp
Note: See TracBrowser for help on using the repository browser.