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 NEMO/branches/UKMO/dev_r9922_GC3_cpl_pkg/src/OCE/OBS – NEMO

source: NEMO/branches/UKMO/dev_r9922_GC3_cpl_pkg/src/OCE/OBS/obs_mpp.F90 @ 9947

Last change on this file since 9947 was 9947, checked in by timgraham, 6 years ago

Clear svn keywords

File size: 16.7 KB
Line 
1MODULE obs_mpp
2   !!======================================================================
3   !!                       ***  MODULE obs_mpp  ***
4   !! Observation diagnostics: Various MPP support routines
5   !!======================================================================
6   !! History :  2.0  ! 2006-03  (K. Mogensen)  Original code
7   !!             -   ! 2006-05  (K. Mogensen)  Reformatted
8   !!             -   ! 2008-01  (K. Mogensen)  add mpp_global_max
9   !!            3.6  ! 2015-01  (J. Waters) obs_mpp_find_obs_proc
10   !!                            rewritten to avoid global arrays
11   !!----------------------------------------------------------------------
12#  define mpivar mpi_double_precision
13   !!----------------------------------------------------------------------
14   !! obs_mpp_bcast_integer : Broadcast an integer array from a processor to all processors
15   !! obs_mpp_max_integer   : Find maximum on all processors of each value in an integer on all processors
16   !! obs_mpp_find_obs_proc : Find processors which should hold the observations, avoiding global arrays
17   !! obs_mpp_sum_integers  : Sum an integer array from all processors
18   !! obs_mpp_sum_integer   : Sum an integer from all processors
19   !!----------------------------------------------------------------------
20   USE dom_oce, ONLY :   nproc, mig, mjg   ! Ocean space and time domain variables
21   USE mpp_map, ONLY :   mppmap
22   USE in_out_manager
23#if defined key_mpp_mpi
24   USE lib_mpp, ONLY :   mpi_comm_oce      ! MPP library
25#endif
26   IMPLICIT NONE
27   PRIVATE
28
29   PUBLIC obs_mpp_bcast_integer, & !: Broadcast an integer array from a proc to all procs
30      &   obs_mpp_max_integer,   & !: Find maximum across processors in an integer array
31      &   obs_mpp_find_obs_proc, & !: Find processors which should hold the observations
32      &   obs_mpp_sum_integers,  & !: Sum an integer array from all processors
33      &   obs_mpp_sum_integer,   & !: Sum an integer from all processors
34      &   mpp_alltoall_int,      &
35      &   mpp_alltoallv_int,     &
36      &   mpp_alltoallv_real,    &
37      &   mpp_global_max
38
39   !!----------------------------------------------------------------------
40   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
41   !! $Id$
42   !! Software governed by the CeCILL licence     (./LICENSE)
43   !!----------------------------------------------------------------------
44CONTAINS
45
46   SUBROUTINE obs_mpp_bcast_integer( kvals, kno, kroot )
47      !!----------------------------------------------------------------------
48      !!               ***  ROUTINE obs_mpp_bcast_integer ***
49      !!         
50      !! ** Purpose : Send array kvals to all processors
51      !!
52      !! ** Method  : MPI broadcast
53      !!
54      !! ** Action  : This does only work for MPI.
55      !!              MPI_COMM_OCE needs to be replace for OASIS4.!
56      !!
57      !! References : http://www.mpi-forum.org
58      !!----------------------------------------------------------------------
59      INTEGER                , INTENT(in   ) ::   kno     ! Number of elements in array
60      INTEGER                , INTENT(in   ) ::   kroot   ! Processor to send data
61      INTEGER, DIMENSION(kno), INTENT(inout) ::   kvals   ! Array to send on kroot, receive for non-kroot
62      !
63#if defined key_mpp_mpi
64      !
65      INTEGER :: ierr 
66      !
67INCLUDE 'mpif.h'
68      !!----------------------------------------------------------------------
69
70      ! Call the MPI library to broadcast data
71      CALL mpi_bcast( kvals, kno, mpi_integer,  &
72         &            kroot, mpi_comm_oce, ierr )
73#else
74      ! no MPI: empty routine
75#endif
76      !
77   END SUBROUTINE obs_mpp_bcast_integer
78
79 
80   SUBROUTINE obs_mpp_max_integer( kvals, kno )
81      !!----------------------------------------------------------------------
82      !!               ***  ROUTINE obs_mpp_bcast_integer ***
83      !!         
84      !! ** Purpose : Find maximum across processors in an integer array.
85      !!
86      !! ** Method  : MPI all reduce.
87      !!
88      !! ** Action  : This does only work for MPI.
89      !!              It does not work for SHMEM.
90      !!              MPI_COMM_OCE needs to be replace for OASIS4.!
91      !!
92      !! References : http://www.mpi-forum.org
93      !!----------------------------------------------------------------------
94      INTEGER                , INTENT(in   ) ::   kno     ! Number of elements in array
95      INTEGER, DIMENSION(kno), INTENT(inout) ::   kvals   ! Array to send on kroot, receive for non-kroot 
96      !
97#if defined key_mpp_mpi
98      !
99      INTEGER :: ierr 
100      INTEGER, DIMENSION(kno) ::   ivals
101      !
102INCLUDE 'mpif.h'
103      !!----------------------------------------------------------------------
104
105      ! Call the MPI library to find the maximum across processors
106      CALL mpi_allreduce( kvals, ivals, kno, mpi_integer,   &
107         &                mpi_max, mpi_comm_oce, ierr )
108      kvals(:) = ivals(:)
109#else
110      ! no MPI: empty routine
111#endif
112   END SUBROUTINE obs_mpp_max_integer
113
114
115   SUBROUTINE obs_mpp_find_obs_proc( kobsp,kno )
116      !!----------------------------------------------------------------------
117      !!               ***  ROUTINE obs_mpp_find_obs_proc  ***
118      !!         
119      !! ** Purpose : From the array kobsp containing the results of the
120      !!              grid search on each processor the processor return a
121      !!              decision of which processors should hold the observation.
122      !!
123      !! ** Method  : Synchronize the processor number for each obs using
124      !!              obs_mpp_max_integer. If an observation exists on two
125      !!              processors it will be allocated to the lower numbered
126      !!              processor.
127      !!
128      !! ** Action  : This does only work for MPI.
129      !!              It does not work for SHMEM.
130      !!
131      !! References : http://www.mpi-forum.org
132      !!----------------------------------------------------------------------
133      INTEGER                , INTENT(in   ) ::   kno
134      INTEGER, DIMENSION(kno), INTENT(inout) ::   kobsp
135      !
136#if defined key_mpp_mpi
137      !
138      !
139      INTEGER :: ji, isum
140      INTEGER, DIMENSION(kno) ::   iobsp
141      !!
142      !!
143
144      iobsp(:)=kobsp(:)
145
146      WHERE( iobsp(:) == -1 )
147         iobsp(:) = 9999999
148      END WHERE
149
150      iobsp(:)=-1*iobsp(:)
151
152      CALL obs_mpp_max_integer( iobsp, kno )
153
154      kobsp(:)=-1*iobsp(:)
155
156      isum=0
157      DO ji = 1, kno
158         IF ( kobsp(ji) == 9999999 ) THEN
159            isum=isum+1
160            kobsp(ji)=-1
161         ENDIF
162      ENDDO
163
164
165      IF ( isum > 0 ) THEN
166         IF (lwp) WRITE(numout,*) isum, ' observations failed the grid search.'
167         IF (lwp) WRITE(numout,*)'If ln_grid_search_lookup=.TRUE., try reducing grid_search_res'
168      ENDIF
169
170#else
171      ! no MPI: empty routine
172#endif     
173     
174   END SUBROUTINE obs_mpp_find_obs_proc
175
176
177   SUBROUTINE obs_mpp_sum_integers( kvalsin, kvalsout, kno )
178      !!----------------------------------------------------------------------
179      !!               ***  ROUTINE obs_mpp_sum_integers ***
180      !!         
181      !! ** Purpose : Sum an integer array.
182      !!
183      !! ** Method  : MPI all reduce.
184      !!
185      !! ** Action  : This does only work for MPI.
186      !!              It does not work for SHMEM.
187      !!
188      !! References : http://www.mpi-forum.org
189      !!----------------------------------------------------------------------
190      INTEGER                , INTENT(in   ) :: kno
191      INTEGER, DIMENSION(kno), INTENT(in   ) ::   kvalsin
192      INTEGER, DIMENSION(kno), INTENT(  out) ::   kvalsout
193      !
194#if defined key_mpp_mpi
195      !
196      INTEGER :: ierr
197      !
198INCLUDE 'mpif.h'
199      !!----------------------------------------------------------------------
200      !
201      !-----------------------------------------------------------------------
202      ! Call the MPI library to find the sum across processors
203      !-----------------------------------------------------------------------
204      CALL mpi_allreduce( kvalsin, kvalsout, kno, mpi_integer, &
205         &                mpi_sum, mpi_comm_oce, ierr )
206#else
207      !-----------------------------------------------------------------------
208      ! For no-MPP just return input values
209      !-----------------------------------------------------------------------
210      kvalsout(:) = kvalsin(:)
211#endif
212      !
213   END SUBROUTINE obs_mpp_sum_integers
214
215
216   SUBROUTINE obs_mpp_sum_integer( kvalin, kvalout )
217      !!----------------------------------------------------------------------
218      !!               ***  ROUTINE obs_mpp_sum_integers ***
219      !!         
220      !! ** Purpose : Sum a single integer
221      !!
222      !! ** Method  : MPI all reduce.
223      !!
224      !! ** Action  : This does only work for MPI.
225      !!              It does not work for SHMEM.
226      !!
227      !! References : http://www.mpi-forum.org
228      !!----------------------------------------------------------------------
229      INTEGER, INTENT(in   ) ::   kvalin
230      INTEGER, INTENT(  out) ::   kvalout
231      !
232#if defined key_mpp_mpi
233      !
234      INTEGER :: ierr
235      !
236INCLUDE 'mpif.h'
237      !!----------------------------------------------------------------------
238      !
239      !-----------------------------------------------------------------------
240      ! Call the MPI library to find the sum across processors
241      !-----------------------------------------------------------------------
242      CALL mpi_allreduce( kvalin, kvalout, 1, mpi_integer,   &
243         &                mpi_sum, mpi_comm_oce, ierr )
244#else
245      !-----------------------------------------------------------------------
246      ! For no-MPP just return input values
247      !-----------------------------------------------------------------------
248      kvalout = kvalin
249#endif
250      !
251   END SUBROUTINE obs_mpp_sum_integer
252
253
254   SUBROUTINE mpp_global_max( pval )
255      !!----------------------------------------------------------------------
256      !!               ***  ROUTINE mpp_global_or ***
257      !!         
258      !! ** Purpose : Get the maximum value across processors for a global
259      !!              real array
260      !!
261      !! ** Method  : MPI allreduce
262      !!
263      !! ** Action  : This does only work for MPI.
264      !!              It does not work for SHMEM.
265      !!
266      !! References : http://www.mpi-forum.org
267      !!----------------------------------------------------------------------
268      REAL(KIND=wp), DIMENSION(jpiglo,jpjglo), INTENT(inout) ::   pval
269      !
270      INTEGER :: ierr
271      !
272#if defined key_mpp_mpi
273      !
274INCLUDE 'mpif.h'
275      REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE ::   zcp
276      !!----------------------------------------------------------------------
277
278      ! Copy data for input to MPI
279
280      ALLOCATE( &
281         & zcp(jpiglo,jpjglo) &
282         & )
283      zcp(:,:) = pval(:,:)
284
285      ! Call the MPI library to find the coast lines globally
286
287      CALL mpi_allreduce( zcp, pval, jpiglo*jpjglo, mpivar, &
288         &                mpi_max, mpi_comm_oce, ierr )
289
290      DEALLOCATE( &
291         & zcp &
292         & )
293
294#else
295      ! no MPI: empty routine
296#endif
297      !
298   END SUBROUTINE mpp_global_max
299
300
301   SUBROUTINE mpp_alltoall_int( kno, kvalsin, kvalsout )
302      !!----------------------------------------------------------------------
303      !!               ***  ROUTINE mpp_allgatherv ***
304      !!         
305      !! ** Purpose : all to all.
306      !!
307      !! ** Method  : MPI alltoall
308      !!
309      !! ** Action  : This does only work for MPI.
310      !!              It does not work for SHMEM.
311      !!
312      !! References : http://www.mpi-forum.org
313      !!----------------------------------------------------------------------
314      INTEGER                      , INTENT(in   ) ::   kno
315      INTEGER, DIMENSION(kno*jpnij), INTENT(in   ) ::   kvalsin
316      INTEGER, DIMENSION(kno*jpnij), INTENT(  out) ::   kvalsout
317      !!
318      INTEGER :: ierr
319      !
320#if defined key_mpp_mpi
321      !
322INCLUDE 'mpif.h'
323      !-----------------------------------------------------------------------
324      ! Call the MPI library to do the all to all operation of the data
325      !-----------------------------------------------------------------------
326      CALL mpi_alltoall( kvalsin,  kno, mpi_integer, &
327         &               kvalsout, kno, mpi_integer, &
328         &               mpi_comm_oce, ierr )
329#else
330      !-----------------------------------------------------------------------
331      ! For no-MPP just return input values
332      !-----------------------------------------------------------------------
333      kvalsout = kvalsin
334#endif
335      !
336   END SUBROUTINE mpp_alltoall_int
337
338
339   SUBROUTINE mpp_alltoallv_int( kvalsin, knoin , kinv , kvalsout,   &
340      &                                   knoout, koutv )
341      !!----------------------------------------------------------------------
342      !!               ***  ROUTINE mpp_alltoallv_int ***
343      !!         
344      !! ** Purpose : all to all (integer version).
345      !!
346      !! ** Method  : MPI alltoall
347      !!
348      !! ** Action  : This does only work for MPI.
349      !!              It does not work for SHMEM.
350      !!
351      !! References : http://www.mpi-forum.org
352      !!----------------------------------------------------------------------
353      INTEGER                   , INTENT(in) :: knoin
354      INTEGER                   , INTENT(in) :: knoout
355      INTEGER, DIMENSION(jpnij)                 ::   kinv, koutv
356      INTEGER, DIMENSION(knoin) , INTENT(in   ) ::   kvalsin
357      INTEGER, DIMENSION(knoout), INTENT(  out) ::   kvalsout
358      !!
359      INTEGER :: ierr
360      INTEGER :: jproc
361      !
362#if defined key_mpp_mpi
363      !
364INCLUDE 'mpif.h'
365      INTEGER, DIMENSION(jpnij) ::   irdsp, isdsp
366      !-----------------------------------------------------------------------
367      ! Compute displacements
368      !-----------------------------------------------------------------------
369      irdsp(1) = 0
370      isdsp(1) = 0
371      DO jproc = 2, jpnij
372         isdsp(jproc) = isdsp(jproc-1) + kinv(jproc-1)
373         irdsp(jproc) = irdsp(jproc-1) + koutv(jproc-1)
374      END DO
375      !-----------------------------------------------------------------------
376      ! Call the MPI library to do the all to all operation of the data
377      !-----------------------------------------------------------------------
378      CALL mpi_alltoallv( kvalsin,  kinv,  isdsp, mpi_integer, &
379         &                kvalsout, koutv, irdsp, mpi_integer, &
380         &                mpi_comm_oce, ierr )
381#else
382      !-----------------------------------------------------------------------
383      ! For no-MPP just return input values
384      !-----------------------------------------------------------------------
385      kvalsout = kvalsin
386#endif
387      !
388   END SUBROUTINE mpp_alltoallv_int
389
390
391   SUBROUTINE mpp_alltoallv_real( pvalsin, knoin , kinv , pvalsout,   &
392      &                                    knoout, koutv )
393      !!----------------------------------------------------------------------
394      !!               ***  ROUTINE mpp_alltoallv_real ***
395      !!         
396      !! ** Purpose : all to all (integer version).
397      !!
398      !! ** Method  : MPI alltoall
399      !!
400      !! ** Action  : This does only work for MPI.
401      !!              It does not work for SHMEM.
402      !!
403      !! References : http://www.mpi-forum.org
404      !!----------------------------------------------------------------------
405      INTEGER                    , INTENT(in   ) :: knoin
406      INTEGER                    , INTENT(in   ) :: knoout
407      INTEGER , DIMENSION(jpnij)                 ::   kinv, koutv
408      REAL(wp), DIMENSION(knoin) , INTENT(in   ) ::   pvalsin
409      REAL(wp), DIMENSION(knoout), INTENT(  out) ::   pvalsout
410      !!
411      INTEGER :: ierr
412      INTEGER :: jproc
413      !
414#if defined key_mpp_mpi
415      !
416INCLUDE 'mpif.h'
417      INTEGER, DIMENSION(jpnij) ::   irdsp, isdsp
418      !!----------------------------------------------------------------------
419      !
420      !-----------------------------------------------------------------------
421      ! Compute displacements
422      !-----------------------------------------------------------------------
423      irdsp(1) = 0
424      isdsp(1) = 0
425      DO jproc = 2, jpnij
426         isdsp(jproc) = isdsp(jproc-1) + kinv(jproc-1)
427         irdsp(jproc) = irdsp(jproc-1) + koutv(jproc-1)
428      END DO
429      !-----------------------------------------------------------------------
430      ! Call the MPI library to do the all to all operation of the data
431      !-----------------------------------------------------------------------
432      CALL mpi_alltoallv( pvalsin,  kinv,  isdsp, mpivar, &
433         &                pvalsout, koutv, irdsp, mpivar, &
434         &                mpi_comm_oce, ierr )
435#else
436      !-----------------------------------------------------------------------
437      ! For no-MPP just return input values
438      !-----------------------------------------------------------------------
439      pvalsout = pvalsin
440#endif
441      !
442   END SUBROUTINE mpp_alltoallv_real
443
444   !!======================================================================
445END MODULE obs_mpp
Note: See TracBrowser for help on using the repository browser.