SURFEX  V8_0
Surfex V8_0 release
 All Classes Files Functions Variables
mode_glt_nemo_bound.F90
Go to the documentation of this file.
1 !SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
2 !SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
3 !SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
4 !SFX_LIC for details. version 1.
5 !GLT_LIC The GELATO model is a seaice model used in stand-alone or embedded mode.
6 !GLT_LIC It has been developed by Meteo-France. The holder of GELATO is Meteo-France.
7 !GLT_LIC
8 !GLT_LIC This software is governed by the CeCILL-C license under French law and biding
9 !GLT_LIC by the rules of distribution of free software. See the CeCILL-C_V1-en.txt
10 !GLT_LIC (English) and CeCILL-C_V1-fr.txt (French) for details. The CeCILL is a free
11 !GLT_LIC software license, explicitly compatible with the GNU GPL
12 !GLT_LIC (see http://www.gnu.org/licenses/license-list.en.html#CeCILL)
13 !GLT_LIC
14 !GLT_LIC The CeCILL-C licence agreement grants users the right to modify and re-use the
15 !GLT_LIC software governed by this free software license. The exercising of this right
16 !GLT_LIC is conditional upon the obligation to make available to the community the
17 !GLT_LIC modifications made to the source code of the software so as to contribute to
18 !GLT_LIC its evolution.
19 !GLT_LIC
20 !GLT_LIC In consideration of access to the source code and the rights to copy, modify
21 !GLT_LIC and redistribute granted by the license, users are provided only with a limited
22 !GLT_LIC warranty and the software's author, the holder of the economic rights, and the
23 !GLT_LIC successive licensors only have limited liability. In this respect, the risks
24 !GLT_LIC associated with loading, using, modifying and/or developing or reproducing the
25 !GLT_LIC software by the user are brought to the user's attention, given its Free
26 !GLT_LIC Software status, which may make it complicated to use, with the result that its
27 !GLT_LIC use is reserved for developers and experienced professionals having in-depth
28 !GLT_LIC computer knowledge. Users are therefore encouraged to load and test the
29 !GLT_LIC suitability of the software as regards their requirements in conditions enabling
30 !GLT_LIC the security of their systems and/or data to be ensured and, more generally, to
31 !GLT_LIC use and operate it in the same conditions of security.
32 !GLT_LIC
33 !GLT_LIC The GELATO sofware is cureently distibuted with the SURFEX software, available at
34 !GLT_LIC http://www.cnrm.meteo.fr/surfex. The fact that you download the software deemed that
35 !GLT_LIC you had knowledge of the CeCILL-C license and that you accept its terms.
36 !GLT_LIC Attempts to use this software in a way not complying with CeCILL-C license
37 !GLT_LIC may lead to prosecution.
38 !GLT_LIC
39 MODULE mode_glt_nemo_bound
40 
41  !!======================================================================
42  !! *** MODULE lbclnk ***
43  !! Ocean : lateral boundary conditions
44  !!=====================================================================
45  !! OPA 9.0 , LOCEAN-IPSL (2005)
46  !! $Id: lbclnk.F90 1344 2009-03-27 14:02:19Z rblod $
47  !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt
48  !!----------------------------------------------------------------------
49 
50  !!----------------------------------------------------------------------
51  !! Default option shared memory computing
52  !!----------------------------------------------------------------------
53  !! lbc_lnk : generic interface for lbc_lnk_3d and lbc_lnk_2d
54  !! lbc_lnk_2d : set the lateral boundary condition on a 2D variable
55  !! on OPA ocean mesh
56  !!----------------------------------------------------------------------
57  !! * Modules used
58  USE modd_glt_param
59 #if ! defined in_surfex
60  USE modd_glt_mpp_opa
61  USE modd_glt_mppv
62  USE mpi
63 #else
64 #ifdef SFX_MPI
65  !! define mpp_min, mpp_max, mpp_sum for Offline Surfex case with MPI
66  USE modd_surfex_mpi, ONLY : mpi_comm_opa => ncomm
67 #else
68  !! Case of Offline without MPI : no call to MPI,
69  !! mpp_min, mpp_max, mpp_sum are dummies (see below)
70 #endif
71 #endif
72 
73 
74  IMPLICIT NONE
75 #if ! defined in_surfex
76  !! empty
77 #else
78 #ifdef SFX_MPI
79  include 'mpif.h'
80 #endif
81 #endif
82  PRIVATE
83 
84 #if ! defined in_surfex
85  INTERFACE lbc_lnk ! From NEMO lbclnk.F90 routine
86  MODULE PROCEDURE lbc_lnk_3d_gather, lbc_lnk_3d, lbc_lnk_2d
87  END INTERFACE
88  INTERFACE mpp_lnk ! From NEMO lib_mpp.F90 routine
89  MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d
90  END INTERFACE
91  INTERFACE lbc_lnk_e ! From NEMO lib_mpp.F90 routine
92  MODULE PROCEDURE mpp_lnk_2d_e
93  END INTERFACE
94  INTERFACE lbc_nfd ! From NEMO lbcnfd.F90 routine
95  MODULE PROCEDURE lbc_nfd_3d, lbc_nfd_2d
96  END INTERFACE
97 #endif
98 
99  INTERFACE mpp_min
100  MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
101  END INTERFACE
102  INTERFACE mpp_max
103  MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
104  END INTERFACE
105  INTERFACE mpp_sum
106  MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real
107  END INTERFACE
108 
109 #if ! defined in_surfex
110  INTERFACE mpp_lbc_north ! From NEMO lib_mpp.F90 routine
111  MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d
112  END INTERFACE
113  INTERFACE mpp_minloc
114  MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
115  END INTERFACE
116  INTERFACE mpp_maxloc
117  MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
118  END INTERFACE
119 #endif
120 
121  !! * Routines called outside this module
122 
123 #if ! defined in_surfex
124  PUBLIC lbc_lnk,mpp_lnk,mpp_ini_north !,mpp_alloc,mpp_dealloc
125 #endif
126 
127  PUBLIC mpp_sum,mpp_min,mpp_max
128 
129 #if ! defined in_surfex
130  !! * Extracted from lib_mpp.F90 : definition of arrays for the
131  !! following routines
132  !!
133  INTEGER :: ngrp_world ! group ID for the world processors
134  INTEGER :: ngrp_north ! group ID for the northern processors (to be fold)
135  INTEGER :: ncomm_north ! communicator made by the processors belonging to ngrp_north
136  INTEGER :: ndim_rank_north ! number of 'sea' processor in the northern line (can be /= jpni !)
137  INTEGER :: njmppmax ! value of njmpp for the processors of the northern line
138 
139  INTEGER, DIMENSION(:), ALLOCATABLE :: nrank_north ! dimension ndim_rank_north
140  !!----------------------------------------------------------------------
141 #endif
142 
143  CONTAINS
144 
145 
146 #if ! defined in_surfex
147  SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn )
148  !!---------------------------------------------------------------------
149  !! *** ROUTINE lbc_lnk_3d_gather ***
150  !!
151  !! ** Purpose : set lateral boundary conditions (non mpp case)
152  !!
153  !! ** Method :
154  !!
155  !! History :
156  !! ! 97-06 (G. Madec) Original code
157  !! 8.5 ! 02-09 (G. Madec) F90: Free form and module
158  !! ! 09-03 (R. Benshila) External north fold treatment
159  !!----------------------------------------------------------------------
160  !! * Arguments
161  CHARACTER(len=1), INTENT( in ) :: &
162  cd_type1, cd_type2 ! nature of pt3d grid-points
163  ! ! = T , U , V , F or W gridpoints
164  REAL, DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: &
165  pt3d1, pt3d2 ! 3D array on which the boundary condition is applied
166  REAL, INTENT( in ) :: &
167  psgn ! control of the sign change
168  ! ! =-1 , the sign is changed if north fold boundary
169  ! ! = 1 , no sign change
170  ! ! = 0 , no sign change and > 0 required (use the inner
171  ! ! row/column if closed boundary)
172 
173  CALL lbc_lnk_3d( pt3d1, cd_type1, psgn)
174  CALL lbc_lnk_3d( pt3d2, cd_type2, psgn)
175 
176  END SUBROUTINE lbc_lnk_3d_gather
177 
178 
179  SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval )
180  !!---------------------------------------------------------------------
181  !! *** ROUTINE lbc_lnk_3d ***
182  !!
183  !! ** Purpose : set lateral boundary conditions (non mpp case)
184  !!
185  !! ** Method :
186  !!
187  !! History :
188  !! ! 97-06 (G. Madec) Original code
189  !! 8.5 ! 02-09 (G. Madec) F90: Free form and module
190  !! ! 09-03 (R. Benshila) External north fold treatment
191  !!----------------------------------------------------------------------
192  !! * Arguments
193  CHARACTER(len=1), INTENT( in ) :: &
194  cd_type ! nature of pt3d grid-points
195  ! ! = T , U , V , F or W gridpoints
196  REAL, DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: &
197  pt3d ! 3D array on which the boundary condition is applied
198  REAL, INTENT( in ) :: &
199  psgn ! control of the sign change
200  ! ! =-1 , the sign is changed if north fold boundary
201  ! ! = 1 , no sign change
202  ! ! = 0 , no sign change and > 0 required (use the inner
203  ! ! row/column if closed boundary)
204  CHARACTER(len=3), INTENT( in ), OPTIONAL :: &
205  cd_mpp ! fill the overlap area only (here do nothing)
206  REAL , INTENT(in ), OPTIONAL :: pval ! background value (used at closed boundaries)
207 
208  !! * Local declarations
209  REAL :: zland
210 
211  IF( present( pval ) ) THEN ! set land value (zero by default)
212  zland = pval
213  ELSE
214  zland = 0.e0
215  ENDIF
216 
217 
218  IF( present( cd_mpp ) ) THEN
219  ! only fill the overlap area and extra allows
220  ! this is in mpp case. In this module, just do nothing
221  ELSE
222 
223  ! ! East-West boundaries
224  ! ! ======================
225  SELECT CASE ( nperio )
226  !
227  CASE ( 1 , 4 , 6 ) !** cyclic east-west
228  pt3d( 1 ,:,:) = pt3d(jpim1,:,:) ! all points
229  pt3d(jpi,:,:) = pt3d( 2 ,:,:)
230  !
231  CASE default !** East closed -- West closed
232  SELECT CASE ( cd_type )
233  CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
234  pt3d( 1 ,:,:) = zland
235  pt3d(jpi,:,:) = zland
236  CASE ( 'F' ) ! F-point
237  pt3d(jpi,:,:) = zland
238  END SELECT
239  !
240  END SELECT
241 
242  ! ! North-South boundaries
243  ! ! ======================
244  SELECT CASE ( nperio )
245  !
246  CASE ( 2 ) !** South symmetric -- North closed
247  SELECT CASE ( cd_type )
248  CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points
249  pt3d(:, 1 ,:) = pt3d(:,3,:)
250  pt3d(:,jpj,:) = zland
251  CASE ( 'V' , 'F' ) ! V-, F-points
252  pt3d(:, 1 ,:) = psgn * pt3d(:,2,:)
253  pt3d(:,jpj,:) = zland
254  END SELECT
255  !
256  CASE ( 3 , 4 , 5 , 6 ) !** North fold T or F-point pivot -- South closed
257  SELECT CASE ( cd_type ) ! South : closed
258  CASE ( 'T' , 'U' , 'V' , 'W' , 'I' ) ! all points except F-point
259  pt3d(:, 1 ,:) = zland
260  END SELECT
261  ! ! North fold
262  pt3d( 1 ,jpj,:) = zland
263  pt3d(jpi,jpj,:) = zland
264  CALL lbc_nfd( pt3d(:,:,:), cd_type, psgn )
265  !
266  CASE default !** North closed -- South closed
267  SELECT CASE ( cd_type )
268  CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
269  pt3d(:, 1 ,:) = zland
270  pt3d(:,jpj,:) = zland
271  CASE ( 'F' ) ! F-point
272  pt3d(:,jpj,:) = zland
273  END SELECT
274  !
275  END SELECT
276 
277  ENDIF
278 
279  END SUBROUTINE lbc_lnk_3d
280 
281 
282  SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
283  !!---------------------------------------------------------------------
284  !! *** ROUTINE lbc_lnk_2d ***
285  !!
286  !! ** Purpose : set lateral boundary conditions (non mpp case)
287  !!
288  !! ** Method :
289  !!
290  !! History :
291  !! ! 97-06 (G. Madec) Original code
292  !! ! 01-05 (E. Durand) correction
293  !! 8.5 ! 02-09 (G. Madec) F90: Free form and module
294  !! ! 09-03 (R. Benshila) External north fold treatment
295  !!----------------------------------------------------------------------
296  !! * Arguments
297  CHARACTER(len=1), INTENT( in ) :: &
298  cd_type ! nature of pt2d grid-point
299  ! ! = T , U , V , F or W gridpoints
300  ! ! = I sea-ice U-V gridpoint (= F ocean grid point with indice shift)
301  REAL, INTENT( in ) :: &
302  psgn ! control of the sign change
303  ! ! =-1 , the sign is modified following the type of b.c. used
304  ! ! = 1 , no sign change
305  REAL, DIMENSION(jpi,jpj), INTENT( inout ) :: &
306  pt2d ! 2D array on which the boundary condition is applied
307  CHARACTER(len=3), INTENT( in ), OPTIONAL :: &
308  cd_mpp ! fill the overlap area only (here do nothing)
309  REAL , INTENT(in ), OPTIONAL :: pval ! background value (used at closed boundaries)
310 
311  !! * Local declarations
312  REAL :: zland
313 
314  IF( present( pval ) ) THEN ! set land value (zero by default)
315  zland = pval
316  ELSE
317  zland = 0.e0
318  ENDIF
319 
320  IF (present(cd_mpp)) THEN
321  ! only fill the overlap area and extra allows
322  ! this is in mpp case. In this module, just do nothing
323  ELSE
324 
325  ! ! East-West boundaries
326  ! ! ====================
327  SELECT CASE ( nperio )
328  !
329  CASE ( 1 , 4 , 6 ) !** cyclic east-west
330  pt2d( 1 ,:) = pt2d(jpim1,:) ! all points
331  pt2d(jpi,:) = pt2d( 2 ,:)
332  !
333  CASE default !** East closed -- West closed
334  SELECT CASE ( cd_type )
335  CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
336  pt2d( 1 ,:) = zland
337  pt2d(jpi,:) = zland
338  CASE ( 'F' ) ! F-point
339  pt2d(jpi,:) = zland
340  END SELECT
341  !
342  END SELECT
343 
344  ! ! North-South boundaries
345  ! ! ======================
346  SELECT CASE ( nperio )
347  !
348  CASE ( 2 ) !** South symmetric -- North closed
349  SELECT CASE ( cd_type )
350  CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points
351  pt2d(:, 1 ) = pt2d(:,3)
352  pt2d(:,jpj) = zland
353  CASE ( 'V' , 'F' ) ! V-, F-points
354  pt2d(:, 1 ) = psgn * pt2d(:,2)
355  pt2d(:,jpj) = zland
356  END SELECT
357  !
358  CASE ( 3 , 4 , 5 , 6 ) !** North fold T or F-point pivot -- South closed
359  SELECT CASE ( cd_type ) ! South : closed
360  CASE ( 'T' , 'U' , 'V' , 'W' , 'I' ) ! all points except F-point
361  pt2d(:, 1 ) = zland
362  END SELECT
363  ! ! North fold
364  pt2d( 1 ,1 ) = zland
365  pt2d( 1 ,jpj) = zland
366  pt2d(jpi,jpj) = zland
367  CALL lbc_nfd( pt2d(:,:), cd_type, psgn )
368  !
369  CASE default !** North closed -- South closed
370  SELECT CASE ( cd_type )
371  CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
372  pt2d(:, 1 ) = zland
373  pt2d(:,jpj) = zland
374  CASE ( 'F' ) ! F-point
375  pt2d(:,jpj) = zland
376  END SELECT
377  !
378  END SELECT
379 
380  ENDIF
381 
382  END SUBROUTINE lbc_lnk_2d
383 
384 
385  SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn )
386  !!----------------------------------------------------------------------
387  !! *** routine mpp_lnk_3d_gather ***
388  !!
389  !! ** Purpose : Message passing manadgement for two 3D arrays
390  !!
391  !! ** Method : Use mppsend and mpprecv function for passing mask
392  !! between processors following neighboring subdomains.
393  !! domain parameters
394  !! nlci : first dimension of the local subdomain
395  !! nlcj : second dimension of the local subdomain
396  !! nbondi : mark for "east-west local boundary"
397  !! nbondj : mark for "north-south local boundary"
398  !! noea : number for local neighboring processors
399  !! nowe : number for local neighboring processors
400  !! noso : number for local neighboring processors
401  !! nono : number for local neighboring processors
402  !!
403  !! ** Action : ptab1 and ptab2 with update value at its periphery
404  !!
405  !!----------------------------------------------------------------------
406  REAL, DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab1 ! first and second 3D array on which
407  REAL, DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab2 ! the boundary condition is applied
408  CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! nature of ptab1 and ptab2 arrays
409  CHARACTER(len=1) , INTENT(in ) :: cd_type2 ! i.e. grid-points = T , U , V , F or W points
410  REAL , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
411  !! ! = 1. , the sign is kept
412  INTEGER :: jl ! dummy loop indices
413  INTEGER :: imigr, iihom, ijhom ! temporary integers
414  INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
415  INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
416  !!----------------------------------------------------------------------
417 
418  ! 1. standard boundary treatment
419  ! ------------------------------
420  ! ! East-West boundaries
421  ! !* Cyclic east-west
422  IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
423  ptab1( 1 ,:,:) = ptab1(jpim1,:,:)
424  ptab1(jpi,:,:) = ptab1( 2 ,:,:)
425  ptab2( 1 ,:,:) = ptab2(jpim1,:,:)
426  ptab2(jpi,:,:) = ptab2( 2 ,:,:)
427  ELSE !* closed
428  IF( .NOT. cd_type1 == 'F' ) ptab1( 1 :jpreci,:,:) = 0.e0 ! south except at F-point
429  IF( .NOT. cd_type2 == 'F' ) ptab2( 1 :jpreci,:,:) = 0.e0
430  ptab1(nlci-jpreci+1:jpi ,:,:) = 0.e0 ! north
431  ptab2(nlci-jpreci+1:jpi ,:,:) = 0.e0
432  ENDIF
433 
434 
435  ! ! North-South boundaries
436  IF( .NOT. cd_type1 == 'F' ) ptab1(:, 1 :jprecj,:) = 0.e0 ! south except at F-point
437  IF( .NOT. cd_type2 == 'F' ) ptab2(:, 1 :jprecj,:) = 0.e0
438  ptab1(:,nlcj-jprecj+1:jpj ,:) = 0.e0 ! north
439  ptab2(:,nlcj-jprecj+1:jpj ,:) = 0.e0
440 
441 
442  ! 2. East and west directions exchange
443  ! ------------------------------------
444  ! we play with the neigbours AND the row number because of the periodicity
445  !
446  SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
447  CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
448  iihom = nlci-nreci
449  DO jl = 1, jpreci
450  t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:)
451  t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:)
452  t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:)
453  t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:)
454  END DO
455  END SELECT
456  !
457  ! ! Migrations
458  imigr = jpreci * jpj * jpk *2
459  !
460  SELECT CASE ( nbondi )
461  CASE ( -1 )
462  CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 )
463  CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
464  IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
465  CASE ( 0 )
466  CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
467  CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 )
468  CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
469  CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
470  IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
471  IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
472  CASE ( 1 )
473  CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
474  CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
475  IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
476  END SELECT
477  !
478  ! ! Write Dirichlet lateral conditions
479  iihom = nlci - jpreci
480  !
481  SELECT CASE ( nbondi )
482  CASE ( -1 )
483  DO jl = 1, jpreci
484  ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
485  ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
486  END DO
487  CASE ( 0 )
488  DO jl = 1, jpreci
489  ptab1(jl ,:,:) = t4we(:,jl,:,1,2)
490  ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
491  ptab2(jl ,:,:) = t4we(:,jl,:,2,2)
492  ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
493  END DO
494  CASE ( 1 )
495  DO jl = 1, jpreci
496  ptab1(jl ,:,:) = t4we(:,jl,:,1,2)
497  ptab2(jl ,:,:) = t4we(:,jl,:,2,2)
498  END DO
499  END SELECT
500 
501 
502  ! 3. North and south directions
503  ! -----------------------------
504  ! always closed : we play only with the neigbours
505  !
506  IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
507  ijhom = nlcj - nrecj
508  DO jl = 1, jprecj
509  t4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:)
510  t4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:)
511  t4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:)
512  t4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:)
513  END DO
514  ENDIF
515  !
516  ! ! Migrations
517  imigr = jprecj * jpi * jpk * 2
518  !
519  SELECT CASE ( nbondj )
520  CASE ( -1 )
521  CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 )
522  CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
523  IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
524  CASE ( 0 )
525  CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
526  CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 )
527  CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
528  CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
529  IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
530  IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
531  CASE ( 1 )
532  CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
533  CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
534  IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
535  END SELECT
536  !
537  ! ! Write Dirichlet lateral conditions
538  ijhom = nlcj - jprecj
539  !
540  SELECT CASE ( nbondj )
541  CASE ( -1 )
542  DO jl = 1, jprecj
543  ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
544  ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
545  END DO
546  CASE ( 0 )
547  DO jl = 1, jprecj
548  ptab1(:,jl ,:) = t4sn(:,jl,:,1,2)
549  ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
550  ptab2(:,jl ,:) = t4sn(:,jl,:,2,2)
551  ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
552  END DO
553  CASE ( 1 )
554  DO jl = 1, jprecj
555  ptab1(:,jl,:) = t4sn(:,jl,:,1,2)
556  ptab2(:,jl,:) = t4sn(:,jl,:,2,2)
557  END DO
558  END SELECT
559 
560 
561  ! 4. north fold treatment
562  ! -----------------------
563  IF( npolj /= 0 ) THEN
564  !
565  SELECT CASE ( jpni )
566  CASE ( 1 )
567  CALL lbc_nfd( ptab1, cd_type1, psgn ) ! only for northern procs.
568  CALL lbc_nfd( ptab2, cd_type2, psgn )
569  CASE default
570  CALL mpp_lbc_north( ptab1, cd_type1, psgn ) ! for all northern procs.
571  CALL mpp_lbc_north(ptab2, cd_type2, psgn)
572  END SELECT
573  !
574  ENDIF
575  !
576  END SUBROUTINE mpp_lnk_3d_gather
577 
578 
579  SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval )
580  !!----------------------------------------------------------------------
581  !! *** routine mpp_lnk_3d ***
582  !!
583  !! ** Purpose : Message passing manadgement
584  !!
585  !! ** Method : Use mppsend and mpprecv function for passing mask
586  !! between processors following neighboring subdomains.
587  !! domain parameters
588  !! nlci : first dimension of the local subdomain
589  !! nlcj : second dimension of the local subdomain
590  !! nbondi : mark for "east-west local boundary"
591  !! nbondj : mark for "north-south local boundary"
592  !! noea : number for local neighboring processors
593  !! nowe : number for local neighboring processors
594  !! noso : number for local neighboring processors
595  !! nono : number for local neighboring processors
596  !!
597  !! ** Action : ptab with update value at its periphery
598  !!
599  !!----------------------------------------------------------------------
600  REAL, DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied
601  CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
602  ! ! = T , U , V , F , W points
603  REAL , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
604  ! ! = 1. , the sign is kept
605  CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
606  REAL , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
607  !!
608  INTEGER :: ji, jj, jk, jl ! dummy loop indices
609  INTEGER :: imigr, iihom, ijhom ! temporary integers
610  INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
611  REAL :: zland
612  INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
613  !!----------------------------------------------------------------------
614 
615  IF( present( pval ) ) THEN ; zland = pval ! set land value
616  ELSE ; zland = 0.e0 ! zero by default
617  ENDIF
618 
619  ! 1. standard boundary treatment
620  ! ------------------------------
621  IF( present( cd_mpp ) ) THEN ! only fill added line/raw with existing values
622  !
623  ! WARNING ptab is defined only between nld and nle
624  DO jk = 1, jpk
625  DO jj = nlcj+1, jpj ! added line(s) (inner only)
626  ptab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk)
627  ptab(1 :nldi-1, jj ,jk) = ptab(nldi , nlej,jk)
628  ptab(nlei+1:nlci , jj ,jk) = ptab( nlei, nlej,jk)
629  END DO
630  DO ji = nlci+1, jpi ! added column(s) (full)
631  ptab(ji ,nldj :nlej ,jk) = ptab( nlei,nldj:nlej,jk)
632  ptab(ji ,1 :nldj-1,jk) = ptab( nlei,nldj ,jk)
633  ptab(ji ,nlej+1:jpj ,jk) = ptab( nlei, nlej,jk)
634  END DO
635  END DO
636  !
637  ELSE ! standard close or cyclic treatment
638  !
639  ! ! East-West boundaries
640  ! !* Cyclic east-west
641  IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
642  ptab( 1 ,:,:) = ptab(jpim1,:,:)
643  ptab(jpi,:,:) = ptab( 2 ,:,:)
644  ELSE !* closed
645  IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point
646  ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north
647  ENDIF
648  ! ! North-South boundaries (always closed)
649  IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point
650  ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north
651  !
652  ENDIF
653 
654  ! 2. East and west directions exchange
655  ! ------------------------------------
656  ! we play with the neigbours AND the row number because of the periodicity
657  !
658  SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
659  CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
660  iihom = nlci-nreci
661  DO jl = 1, jpreci
662  t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
663  t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
664  END DO
665  END SELECT
666  !
667  ! ! Migrations
668  imigr = jpreci * jpj * jpk
669  !
670  SELECT CASE ( nbondi )
671  CASE ( -1 )
672  CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
673  CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
674  IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
675  CASE ( 0 )
676  CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
677  CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
678  CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
679  CALL mpprecv( 2, t3we(1,1,1,2), imigr )
680  IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
681  IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
682  CASE ( 1 )
683  CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
684  CALL mpprecv( 2, t3we(1,1,1,2), imigr )
685  IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
686  END SELECT
687  !
688  ! ! Write Dirichlet lateral conditions
689  iihom = nlci-jpreci
690  !
691  SELECT CASE ( nbondi )
692  CASE ( -1 )
693  DO jl = 1, jpreci
694  ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
695  END DO
696  CASE ( 0 )
697  DO jl = 1, jpreci
698  ptab(jl ,:,:) = t3we(:,jl,:,2)
699  ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
700  END DO
701  CASE ( 1 )
702  DO jl = 1, jpreci
703  ptab(jl ,:,:) = t3we(:,jl,:,2)
704  END DO
705  END SELECT
706 
707 
708  ! 3. North and south directions
709  ! -----------------------------
710  ! always closed : we play only with the neigbours
711  !
712  IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
713  ijhom = nlcj-nrecj
714  DO jl = 1, jprecj
715  t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
716  t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
717  END DO
718  ENDIF
719  !
720  ! ! Migrations
721  imigr = jprecj * jpi * jpk
722  !
723  SELECT CASE ( nbondj )
724  CASE ( -1 )
725  CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
726  CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
727  IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
728  CASE ( 0 )
729  CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
730  CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
731  CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
732  CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
733  IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
734  IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
735  CASE ( 1 )
736  CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
737  CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
738  IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
739  END SELECT
740  !
741  ! ! Write Dirichlet lateral conditions
742  ijhom = nlcj-jprecj
743  !
744  SELECT CASE ( nbondj )
745  CASE ( -1 )
746  DO jl = 1, jprecj
747  ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
748  END DO
749  CASE ( 0 )
750  DO jl = 1, jprecj
751  ptab(:,jl ,:) = t3sn(:,jl,:,2)
752  ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
753  END DO
754  CASE ( 1 )
755  DO jl = 1, jprecj
756  ptab(:,jl,:) = t3sn(:,jl,:,2)
757  END DO
758  END SELECT
759 
760 
761  ! 4. north fold treatment
762  ! -----------------------
763  !
764  IF( npolj /= 0 .AND. .NOT. present(cd_mpp) ) THEN
765  !
766  SELECT CASE ( jpni )
767  CASE ( 1 ) ; CALL lbc_nfd( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp
768  CASE default ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.
769  END SELECT
770  !
771  ENDIF
772  !
773  END SUBROUTINE mpp_lnk_3d
774 
775 
776  SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
777  !!----------------------------------------------------------------------
778  !! *** routine mpp_lnk_2d ***
779  !!
780  !! ** Purpose : Message passing manadgement for 2d array
781  !!
782  !! ** Method : Use mppsend and mpprecv function for passing mask
783  !! between processors following neighboring subdomains.
784  !! domain parameters
785  !! nlci : first dimension of the local subdomain
786  !! nlcj : second dimension of the local subdomain
787  !! nbondi : mark for "east-west local boundary"
788  !! nbondj : mark for "north-south local boundary"
789  !! noea : number for local neighboring processors
790  !! nowe : number for local neighboring processors
791  !! noso : number for local neighboring processors
792  !! nono : number for local neighboring processors
793  !!
794  !!----------------------------------------------------------------------
795  REAL, DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied
796  CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
797  ! ! = T , U , V , F , W and I points
798  REAL , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
799  ! ! = 1. , the sign is kept
800  CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
801  REAL , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
802  !!
803  INTEGER :: ji, jj, jl ! dummy loop indices
804  INTEGER :: imigr, iihom, ijhom ! temporary integers
805  INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
806  REAL :: zland
807  INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
808  !!----------------------------------------------------------------------
809 
810  IF( present( pval ) ) THEN ; zland = pval ! set land value
811  ELSE ; zland = 0.e0 ! zero by default
812  ENDIF
813 
814  ! 1. standard boundary treatment
815  ! ------------------------------
816  !
817  IF( present( cd_mpp ) ) THEN ! only fill added line/raw with existing values
818  !
819  ! WARNING pt2d is defined only between nld and nle
820  DO jj = nlcj+1, jpj ! added line(s) (inner only)
821  pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej)
822  pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej)
823  pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej)
824  END DO
825  DO ji = nlci+1, jpi ! added column(s) (full)
826  pt2d(ji ,nldj :nlej ) = pt2d( nlei,nldj:nlej)
827  pt2d(ji ,1 :nldj-1) = pt2d( nlei,nldj )
828  pt2d(ji ,nlej+1:jpj ) = pt2d( nlei, nlej)
829  END DO
830  !
831  ELSE ! standard close or cyclic treatment
832  !
833  ! ! East-West boundaries
834  IF( nbondi == 2 .AND. & ! Cyclic east-west
835  & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
836  pt2d( 1 ,:) = pt2d(jpim1,:) ! west
837  pt2d(jpi,:) = pt2d( 2 ,:) ! east
838  ELSE ! closed
839  IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point
840  pt2d(nlci-jpreci+1:jpi ,:) = zland ! north
841  ENDIF
842  ! ! North-South boundaries (always closed)
843  IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland !south except F-point
844  pt2d(:,nlcj-jprecj+1:jpj ) = zland ! north
845  !
846  ENDIF
847 
848  ! 2. East and west directions exchange
849  ! ------------------------------------
850  ! we play with the neigbours AND the row number because of the periodicity
851  !
852  SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
853  CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
854  iihom = nlci-nreci
855  DO jl = 1, jpreci
856  t2ew(:,jl,1) = pt2d(jpreci+jl,:)
857  t2we(:,jl,1) = pt2d(iihom +jl,:)
858  END DO
859  END SELECT
860  !
861  ! ! Migrations
862  imigr = jpreci * jpj
863  !
864  SELECT CASE ( nbondi )
865  CASE ( -1 )
866  CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
867  CALL mpprecv( 1, t2ew(1,1,2), imigr )
868  IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
869  CASE ( 0 )
870  CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
871  CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
872  CALL mpprecv( 1, t2ew(1,1,2), imigr )
873  CALL mpprecv( 2, t2we(1,1,2), imigr )
874  IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
875  IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
876  CASE ( 1 )
877  CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
878  CALL mpprecv( 2, t2we(1,1,2), imigr )
879  IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
880  END SELECT
881  !
882  ! ! Write Dirichlet lateral conditions
883  iihom = nlci - jpreci
884  !
885  SELECT CASE ( nbondi )
886  CASE ( -1 )
887  DO jl = 1, jpreci
888  pt2d(iihom+jl,:) = t2ew(:,jl,2)
889  END DO
890  CASE ( 0 )
891  DO jl = 1, jpreci
892  pt2d(jl ,:) = t2we(:,jl,2)
893  pt2d(iihom+jl,:) = t2ew(:,jl,2)
894  END DO
895  CASE ( 1 )
896  DO jl = 1, jpreci
897  pt2d(jl ,:) = t2we(:,jl,2)
898  END DO
899  END SELECT
900 
901 
902  ! 3. North and south directions
903  ! -----------------------------
904  ! always closed : we play only with the neigbours
905  !
906  IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
907  ijhom = nlcj-nrecj
908  DO jl = 1, jprecj
909  t2sn(:,jl,1) = pt2d(:,ijhom +jl)
910  t2ns(:,jl,1) = pt2d(:,jprecj+jl)
911  END DO
912  ENDIF
913  !
914  ! ! Migrations
915  imigr = jprecj * jpi
916  !
917  SELECT CASE ( nbondj )
918  CASE ( -1 )
919  CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
920  CALL mpprecv( 3, t2ns(1,1,2), imigr )
921  IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
922  CASE ( 0 )
923  CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
924  CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
925  CALL mpprecv( 3, t2ns(1,1,2), imigr )
926  CALL mpprecv( 4, t2sn(1,1,2), imigr )
927  IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
928  IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
929  CASE ( 1 )
930  CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
931  CALL mpprecv( 4, t2sn(1,1,2), imigr )
932  IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
933  END SELECT
934  !
935  ! ! Write Dirichlet lateral conditions
936  ijhom = nlcj - jprecj
937  !
938  SELECT CASE ( nbondj )
939  CASE ( -1 )
940  DO jl = 1, jprecj
941  pt2d(:,ijhom+jl) = t2ns(:,jl,2)
942  END DO
943  CASE ( 0 )
944  DO jl = 1, jprecj
945  pt2d(:,jl ) = t2sn(:,jl,2)
946  pt2d(:,ijhom+jl) = t2ns(:,jl,2)
947  END DO
948  CASE ( 1 )
949  DO jl = 1, jprecj
950  pt2d(:,jl ) = t2sn(:,jl,2)
951  END DO
952  END SELECT
953 
954 
955  ! 4. north fold treatment
956  ! -----------------------
957  !
958  IF( npolj /= 0 .AND. .NOT. present(cd_mpp) ) THEN
959  !
960  SELECT CASE ( jpni )
961  CASE ( 1 ) ; CALL lbc_nfd( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp
962  CASE default ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs.
963  END SELECT
964  !
965  ENDIF
966  !
967  END SUBROUTINE mpp_lnk_2d
968 
969 
970  SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn )
971  !!----------------------------------------------------------------------
972  !! *** routine mpp_lnk_2d_e ***
973  !!
974  !! ** Purpose : Message passing manadgement for 2d array (with halo)
975  !!
976  !! ** Method : Use mppsend and mpprecv function for passing mask
977  !! between processors following neighboring subdomains.
978  !! domain parameters
979  !! nlci : first dimension of the local subdomain
980  !! nlcj : second dimension of the local subdomain
981  !! jpr2di : number of rows for extra outer halo
982  !! jpr2dj : number of columns for extra outer halo
983  !! nbondi : mark for "east-west local boundary"
984  !! nbondj : mark for "north-south local boundary"
985  !! noea : number for local neighboring processors
986  !! nowe : number for local neighboring processors
987  !! noso : number for local neighboring processors
988  !! nono : number for local neighboring processors
989  !!
990  !!----------------------------------------------------------------------
991  REAL, DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) :: pt2d ! 2D array with extra halo
992  CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points
993  ! ! = T , U , V , F , W and I points
994  REAL , INTENT(in ) :: psgn ! =-1 the sign change across the
995  !! ! north boundary, = 1. otherwise
996  INTEGER :: jl ! dummy loop indices
997  INTEGER :: imigr, iihom, ijhom ! temporary integers
998  INTEGER :: ipreci, iprecj ! temporary integers
999  INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
1000  INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
1001  !!----------------------------------------------------------------------
1002 
1003  ipreci = jpreci + jpr2di ! take into account outer extra 2D overlap area
1004  iprecj = jprecj + jpr2dj
1005 
1006 
1007  ! 1. standard boundary treatment
1008  ! ------------------------------
1009  ! Order matters Here !!!!
1010  !
1011  ! !* North-South boundaries (always colsed)
1012  IF( .NOT. cd_type == 'F' ) pt2d(:, 1-jpr2dj : jprecj ) = 0.e0 ! south except at F-point
1013  pt2d(:,nlcj-jprecj+1:jpj+jpr2dj) = 0.e0 ! north
1014 
1015  ! ! East-West boundaries
1016  ! !* Cyclic east-west
1017  IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1018  pt2d(1-jpr2di: 1 ,:) = pt2d(jpim1-jpr2di: jpim1 ,:) ! east
1019  pt2d( jpi :jpi+jpr2di,:) = pt2d( 2 :2+jpr2di,:) ! west
1020  !
1021  ELSE !* closed
1022  IF( .NOT. cd_type == 'F' ) pt2d( 1-jpr2di :jpreci ,:) = 0.e0 ! south except at F-point
1023  pt2d(nlci-jpreci+1:jpi+jpr2di,:) = 0.e0 ! north
1024  ENDIF
1025  !
1026 
1027  ! north fold treatment
1028  ! -----------------------
1029  IF( npolj /= 0 ) THEN
1030  !
1031  SELECT CASE ( jpni )
1032  CASE ( 1 ) ; CALL lbc_nfd( pt2d(1:jpi,1:jpj+jpr2dj), cd_type, psgn, pr2dj=jpr2dj )
1033  CASE default ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn )
1034  END SELECT
1035  !
1036  ENDIF
1037 
1038  ! 2. East and west directions exchange
1039  ! ------------------------------------
1040  ! we play with the neigbours AND the row number because of the periodicity
1041  !
1042  SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
1043  CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
1044  iihom = nlci-nreci-jpr2di
1045  DO jl = 1, ipreci
1046  tr2ew(:,jl,1) = pt2d(jpreci+jl,:)
1047  tr2we(:,jl,1) = pt2d(iihom +jl,:)
1048  END DO
1049  END SELECT
1050  !
1051  ! ! Migrations
1052  imigr = ipreci * ( jpj + 2*jpr2dj)
1053  !
1054  SELECT CASE ( nbondi )
1055  CASE ( -1 )
1056  CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 )
1057  CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
1058  IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1059  CASE ( 0 )
1060  CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
1061  CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 )
1062  CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
1063  CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
1064  IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1065  IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1066  CASE ( 1 )
1067  CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
1068  CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
1069  IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1070  END SELECT
1071  !
1072  ! ! Write Dirichlet lateral conditions
1073  iihom = nlci - jpreci
1074  !
1075  SELECT CASE ( nbondi )
1076  CASE ( -1 )
1077  DO jl = 1, ipreci
1078  pt2d(iihom+jl,:) = tr2ew(:,jl,2)
1079  END DO
1080  CASE ( 0 )
1081  DO jl = 1, ipreci
1082  pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
1083  pt2d( iihom+jl,:) = tr2ew(:,jl,2)
1084  END DO
1085  CASE ( 1 )
1086  DO jl = 1, ipreci
1087  pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
1088  END DO
1089  END SELECT
1090 
1091 
1092  ! 3. North and south directions
1093  ! -----------------------------
1094  ! always closed : we play only with the neigbours
1095  !
1096  IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
1097  ijhom = nlcj-nrecj-jpr2dj
1098  DO jl = 1, iprecj
1099  tr2sn(:,jl,1) = pt2d(:,ijhom +jl)
1100  tr2ns(:,jl,1) = pt2d(:,jprecj+jl)
1101  END DO
1102  ENDIF
1103  !
1104  ! ! Migrations
1105  imigr = iprecj * ( jpi + 2*jpr2di )
1106  !
1107  SELECT CASE ( nbondj )
1108  CASE ( -1 )
1109  CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 )
1110  CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
1111  IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1112  CASE ( 0 )
1113  CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
1114  CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req2 )
1115  CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
1116  CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
1117  IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1118  IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1119  CASE ( 1 )
1120  CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
1121  CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
1122  IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1123  END SELECT
1124  !
1125  ! ! Write Dirichlet lateral conditions
1126  ijhom = nlcj - jprecj
1127  !
1128  SELECT CASE ( nbondj )
1129  CASE ( -1 )
1130  DO jl = 1, iprecj
1131  pt2d(:,ijhom+jl) = tr2ns(:,jl,2)
1132  END DO
1133  CASE ( 0 )
1134  DO jl = 1, iprecj
1135  pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
1136  pt2d(:,ijhom+jl ) = tr2ns(:,jl,2)
1137  END DO
1138  CASE ( 1 )
1139  DO jl = 1, iprecj
1140  pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
1141  END DO
1142  END SELECT
1143 
1144  END SUBROUTINE mpp_lnk_2d_e
1145 
1146 
1147  SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
1148  !!----------------------------------------------------------------------
1149  !! *** routine mppsend ***
1150  !!
1151  !! ** Purpose : Send messag passing array
1152  !!
1153  !!----------------------------------------------------------------------
1154  REAL, INTENT(inout) :: pmess(*) ! array of real
1155  INTEGER , INTENT(in ) :: kbytes ! size of the array pmess
1156  INTEGER , INTENT(in ) :: kdest ! receive process number
1157  INTEGER , INTENT(in ) :: ktyp ! tag of the message
1158 ! The intent is changed from 'in' to 'inout' (for NEC...)
1159  INTEGER , INTENT(inout) :: md_req ! argument for isend
1160  !!
1161  INTEGER :: iflag
1162  !!----------------------------------------------------------------------
1163  !
1164  SELECT CASE ( cn_mpi_send )
1165  CASE ( 'S' ) ! Standard mpi send (blocking)
1166  CALL mpi_send( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa , iflag )
1167  CASE ( 'B' ) ! Buffer mpi send (blocking)
1168  CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa , iflag )
1169  CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
1170  ! be carefull, one more argument here : the mpi request identifier..
1171  CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa, md_req, iflag )
1172  END SELECT
1173  !
1174  END SUBROUTINE mppsend
1175 
1176 
1177  SUBROUTINE mpprecv( ktyp, pmess, kbytes )
1178  !!----------------------------------------------------------------------
1179  !! *** routine mpprecv ***
1180  !!
1181  !! ** Purpose : Receive messag passing array
1182  !!
1183  !!----------------------------------------------------------------------
1184  REAL, INTENT(inout) :: pmess(*) ! array of real
1185  INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess
1186  INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message
1187  !!
1188  INTEGER :: istatus(mpi_status_size)
1189  INTEGER :: iflag
1190  !!----------------------------------------------------------------------
1191  !
1192  CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp, mpi_comm_opa, istatus, iflag )
1193  !
1194  END SUBROUTINE mpprecv
1195 #endif
1196 
1197 
1198 
1199  SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
1200  !!----------------------------------------------------------------------
1201  !! *** routine mppmax_a_int ***
1202  !!
1203  !! ** Purpose : Find maximum value in an integer layout array
1204  !!
1205  !!----------------------------------------------------------------------
1206  INTEGER , INTENT(in ) :: kdim ! size of array
1207  INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
1208  INTEGER , INTENT(in ), OPTIONAL :: kcom !
1209  !!
1210  INTEGER :: ierror, localcomm ! temporary integer
1211  INTEGER, DIMENSION(kdim) :: iwork
1212  !!----------------------------------------------------------------------
1213  !
1214 #if !defined in_surfex || defined SFX_MPI
1215  localcomm = mpi_comm_opa
1216  IF( present(kcom) ) localcomm = kcom
1217  !
1218 !$OMP SINGLE
1219  CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror )
1220 !$OMP END SINGLE
1221  !
1222  ktab(:) = iwork(:)
1223 #endif
1224  !
1225  END SUBROUTINE mppmax_a_int
1226 
1227 
1228  SUBROUTINE mppmax_int( ktab, kcom )
1229  !!----------------------------------------------------------------------
1230  !! *** routine mppmax_int ***
1231  !!
1232  !! ** Purpose : Find maximum value in an integer layout array
1233  !!
1234  !!----------------------------------------------------------------------
1235  INTEGER, INTENT(inout) :: ktab ! ???
1236  INTEGER, INTENT(in ), OPTIONAL :: kcom ! ???
1237  !!
1238  INTEGER :: ierror, iwork, localcomm ! temporary integer
1239  !!----------------------------------------------------------------------
1240  !
1241 #if !defined in_surfex || defined SFX_MPI
1242  localcomm = mpi_comm_opa
1243  IF( present(kcom) ) localcomm = kcom
1244  !
1245 !$OMP SINGLE
1246  CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror)
1247 !$OMP END SINGLE
1248  !
1249  ktab = iwork
1250 #endif
1251  !
1252  END SUBROUTINE mppmax_int
1253 
1254 
1255  SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
1256  !!----------------------------------------------------------------------
1257  !! *** routine mppmin_a_int ***
1258  !!
1259  !! ** Purpose : Find minimum value in an integer layout array
1260  !!
1261  !!----------------------------------------------------------------------
1262  INTEGER , INTENT( in ) :: kdim ! size of array
1263  INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
1264  INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array
1265  !!
1266  INTEGER :: ierror, localcomm ! temporary integer
1267  INTEGER, DIMENSION(kdim) :: iwork
1268  !!----------------------------------------------------------------------
1269  !
1270 #if !defined in_surfex || defined SFX_MPI
1271  localcomm = mpi_comm_opa
1272  IF( present(kcom) ) localcomm = kcom
1273  !
1274 !$OMP SINGLE
1275  CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror )
1276 !$OMP END SINGLE
1277  !
1278  ktab(:) = iwork(:)
1279 #endif
1280  !
1281  END SUBROUTINE mppmin_a_int
1282 
1283 
1284  SUBROUTINE mppmin_int( ktab, kcom )
1285  !!----------------------------------------------------------------------
1286  !! *** routine mppmin_int ***
1287  !!
1288  !! ** Purpose : Find minimum value in an integer layout array
1289  !!
1290  !!----------------------------------------------------------------------
1291  INTEGER, INTENT(inout) :: ktab ! ???
1292  INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array
1293  !!
1294  INTEGER :: ierror, iwork, localcomm
1295  !!----------------------------------------------------------------------
1296  !
1297 #if !defined in_surfex || defined SFX_MPI
1298  localcomm = mpi_comm_opa
1299  IF( present(kcom) ) localcomm = kcom
1300  !
1301 !$OMP SINGLE
1302  CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror )
1303 !$OMP END SINGLE
1304  !
1305  ktab = iwork
1306 #endif
1307  !
1308  END SUBROUTINE mppmin_int
1309 
1310 
1311  SUBROUTINE mppsum_a_int( ktab, kdim )
1312  !!----------------------------------------------------------------------
1313  !! *** routine mppsum_a_int ***
1314  !!
1315  !! ** Purpose : Global integer sum, 1D array case
1316  !!
1317  !!----------------------------------------------------------------------
1318  INTEGER, INTENT(in ) :: kdim ! ???
1319  INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ???
1320  !!
1321  INTEGER :: ierror
1322  INTEGER, DIMENSION (kdim) :: iwork
1323  !!----------------------------------------------------------------------
1324  !
1325 #if !defined in_surfex || defined SFX_MPI
1326 !$OMP SINGLE
1327  CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1328 !$OMP END SINGLE
1329  !
1330  ktab(:) = iwork(:)
1331 #endif
1332  !
1333  END SUBROUTINE mppsum_a_int
1334 
1335 
1336  SUBROUTINE mppsum_int( ktab )
1337  !!----------------------------------------------------------------------
1338  !! *** routine mppsum_int ***
1339  !!
1340  !! ** Purpose : Global integer sum
1341  !!
1342  !!----------------------------------------------------------------------
1343  INTEGER, INTENT(inout) :: ktab
1344  !!
1345  INTEGER :: ierror, iwork
1346  !!----------------------------------------------------------------------
1347  !
1348 #if !defined in_surfex || defined SFX_MPI
1349 !$OMP SINGLE
1350  CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1351 !$OMP END SINGLE
1352  !
1353  ktab = iwork
1354 #endif
1355  !
1356  END SUBROUTINE mppsum_int
1357 
1358 
1359  SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
1360  !!----------------------------------------------------------------------
1361  !! *** routine mppmax_a_real ***
1362  !!
1363  !! ** Purpose : Maximum
1364  !!
1365  !!----------------------------------------------------------------------
1366  INTEGER , INTENT(in ) :: kdim
1367  REAL, INTENT(inout), DIMENSION(kdim) :: ptab
1368  INTEGER , INTENT(in ), OPTIONAL :: kcom
1369  !!
1370  INTEGER :: ierror, localcomm
1371  REAL, DIMENSION(kdim) :: zwork
1372  !!----------------------------------------------------------------------
1373  !
1374 #if !defined in_surfex || defined SFX_MPI
1375  localcomm = mpi_comm_opa
1376  IF( present(kcom) ) localcomm = kcom
1377  !
1378 !$OMP SINGLE
1379  CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror )
1380 !$OMP END SINGLE
1381  ptab(:) = zwork(:)
1382 #endif
1383  !
1384  END SUBROUTINE mppmax_a_real
1385 
1386 
1387  SUBROUTINE mppmax_real( ptab, kcom )
1388  !!----------------------------------------------------------------------
1389  !! *** routine mppmax_real ***
1390  !!
1391  !! ** Purpose : Maximum
1392  !!
1393  !!----------------------------------------------------------------------
1394  REAL, INTENT(inout) :: ptab ! ???
1395  INTEGER , INTENT(in ), OPTIONAL :: kcom ! ???
1396  !!
1397  INTEGER :: ierror, localcomm
1398  REAL :: zwork
1399  !!----------------------------------------------------------------------
1400  !
1401 #if !defined in_surfex || defined SFX_MPI
1402  localcomm = mpi_comm_opa
1403  IF( present(kcom) ) localcomm = kcom
1404  !
1405 !$OMP SINGLE
1406  CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror )
1407 !$OMP END SINGLE
1408  ptab = zwork
1409 #endif
1410  !
1411  END SUBROUTINE mppmax_real
1412 
1413 
1414  SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
1415  !!----------------------------------------------------------------------
1416  !! *** routine mppmin_a_real ***
1417  !!
1418  !! ** Purpose : Minimum of REAL, array case
1419  !!
1420  !!-----------------------------------------------------------------------
1421  INTEGER , INTENT(in ) :: kdim
1422  REAL, INTENT(inout), DIMENSION(kdim) :: ptab
1423  INTEGER , INTENT(in ), OPTIONAL :: kcom
1424  !!
1425  INTEGER :: ierror, localcomm
1426  REAL, DIMENSION(kdim) :: zwork
1427  !!-----------------------------------------------------------------------
1428  !
1429 #if !defined in_surfex || defined SFX_MPI
1430  localcomm = mpi_comm_opa
1431  IF( present(kcom) ) localcomm = kcom
1432  !
1433 !$OMP SINGLE
1434  CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror )
1435 !$OMP END SINGLE
1436  ptab(:) = zwork(:)
1437 #endif
1438  !
1439  END SUBROUTINE mppmin_a_real
1440 
1441 
1442  SUBROUTINE mppmin_real( ptab, kcom )
1443  !!----------------------------------------------------------------------
1444  !! *** routine mppmin_real ***
1445  !!
1446  !! ** Purpose : minimum of REAL, scalar case
1447  !!
1448  !!-----------------------------------------------------------------------
1449  REAL, INTENT(inout) :: ptab !
1450  INTEGER , INTENT(in ), OPTIONAL :: kcom
1451  !!
1452  INTEGER :: ierror
1453  REAL :: zwork
1454  INTEGER :: localcomm
1455  !!-----------------------------------------------------------------------
1456  !
1457 #if !defined in_surfex || defined SFX_MPI
1458  localcomm = mpi_comm_opa
1459  IF( present(kcom) ) localcomm = kcom
1460  !
1461 !$OMP SINGLE
1462  CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror )
1463 !$OMP END SINGLE
1464  ptab = zwork
1465 #endif
1466  !
1467  END SUBROUTINE mppmin_real
1468 
1469 
1470  SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
1471  !!----------------------------------------------------------------------
1472  !! *** routine mppsum_a_real ***
1473  !!
1474  !! ** Purpose : global sum, REAL ARRAY argument case
1475  !!
1476  !!-----------------------------------------------------------------------
1477  INTEGER , INTENT( in ) :: kdim ! size of ptab
1478  REAL, DIMENSION(kdim), INTENT( inout ) :: ptab ! input array
1479  INTEGER , INTENT( in ), OPTIONAL :: kcom
1480  !!
1481  INTEGER :: ierror ! temporary integer
1482  INTEGER :: localcomm
1483  REAL, DIMENSION(kdim) :: zwork ! temporary workspace
1484  !!-----------------------------------------------------------------------
1485  !
1486 #if !defined in_surfex || defined SFX_MPI
1487  localcomm = mpi_comm_opa
1488  IF( present(kcom) ) localcomm = kcom
1489  !
1490 !$OMP SINGLE
1491  CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror )
1492 !$OMP END SINGLE
1493  ptab(:) = zwork(:)
1494 #endif
1495  !
1496  END SUBROUTINE mppsum_a_real
1497 
1498 
1499  SUBROUTINE mppsum_real( ptab, kcom )
1500  !!----------------------------------------------------------------------
1501  !! *** routine mppsum_real ***
1502  !!
1503  !! ** Purpose : global sum, SCALAR argument case
1504  !!
1505  !!-----------------------------------------------------------------------
1506  REAL, INTENT(inout) :: ptab ! input scalar
1507  INTEGER , INTENT(in ), OPTIONAL :: kcom
1508  !!
1509  INTEGER :: ierror, localcomm
1510  REAL :: zwork
1511  !!-----------------------------------------------------------------------
1512  !
1513 #if !defined in_surfex || defined SFX_MPI
1514  localcomm = mpi_comm_opa
1515  IF( present(kcom) ) localcomm = kcom
1516  !
1517 !$OMP SINGLE
1518  CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror )
1519 !$OMP END SINGLE
1520  ptab = zwork
1521 #endif
1522  !
1523  END SUBROUTINE mppsum_real
1524 
1525 
1526 #if ! defined in_surfex
1527  SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj )
1528  !!------------------------------------------------------------------------
1529  !! *** routine mpp_minloc ***
1530  !!
1531  !! ** Purpose : Compute the global minimum of an array ptab
1532  !! and also give its global position
1533  !!
1534  !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1535  !!
1536  !!--------------------------------------------------------------------------
1537  REAL, DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array
1538  REAL, DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask
1539  REAL , INTENT( out) :: pmin ! Global minimum of ptab
1540  INTEGER , INTENT( out) :: ki, kj ! index of minimum in global frame
1541  !!
1542  INTEGER , DIMENSION(2) :: ilocs
1543  INTEGER :: ierror
1544  REAL :: zmin ! local minimum
1545  REAL, DIMENSION(2,1) :: zain, zaout
1546  !!-----------------------------------------------------------------------
1547  !
1548  zmin = minval( ptab(:,:) , mask= pmask == 1.e0 )
1549  ilocs = minloc( ptab(:,:) , mask= pmask == 1.e0 )
1550  !
1551  ki = ilocs(1) + nimpp - 1
1552  kj = ilocs(2) + njmpp - 1
1553  !
1554  zain(1,:)=zmin
1555  zain(2,:)=ki+10000.*kj
1556  !
1557  CALL mpi_allreduce( zain,zaout, 1, mpi_2double_precision,mpi_minloc,mpi_comm_opa,ierror)
1558  !
1559  pmin = zaout(1,1)
1560  kj = int(zaout(2,1)/10000.)
1561  ki = int(zaout(2,1) - 10000.*kj )
1562  !
1563  END SUBROUTINE mpp_minloc2d
1564 
1565 
1566  SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk)
1567  !!------------------------------------------------------------------------
1568  !! *** routine mpp_minloc ***
1569  !!
1570  !! ** Purpose : Compute the global minimum of an array ptab
1571  !! and also give its global position
1572  !!
1573  !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1574  !!
1575  !!--------------------------------------------------------------------------
1576  REAL, DIMENSION (jpi,jpj,jpk), INTENT(in ) :: ptab ! Local 2D array
1577  REAL, DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pmask ! Local mask
1578  REAL , INTENT( out) :: pmin ! Global minimum of ptab
1579  INTEGER , INTENT( out) :: ki, kj, kk ! index of minimum in global frame
1580  !!
1581  INTEGER :: ierror
1582  REAL :: zmin ! local minimum
1583  INTEGER , DIMENSION(3) :: ilocs
1584  REAL, DIMENSION(2,1) :: zain, zaout
1585  !!-----------------------------------------------------------------------
1586  !
1587  zmin = minval( ptab(:,:,:) , mask= pmask == 1.e0 )
1588  ilocs = minloc( ptab(:,:,:) , mask= pmask == 1.e0 )
1589  !
1590  ki = ilocs(1) + nimpp - 1
1591  kj = ilocs(2) + njmpp - 1
1592  kk = ilocs(3)
1593  !
1594  zain(1,:)=zmin
1595  zain(2,:)=ki+10000.*kj+100000000.*kk
1596  !
1597  CALL mpi_allreduce( zain,zaout, 1, mpi_2double_precision,mpi_minloc,mpi_comm_opa,ierror)
1598  !
1599  pmin = zaout(1,1)
1600  kk = int( zaout(2,1) / 100000000. )
1601  kj = int( zaout(2,1) - kk * 100000000. ) / 10000
1602  ki = int( zaout(2,1) - kk * 100000000. -kj * 10000. )
1603  !
1604  END SUBROUTINE mpp_minloc3d
1605 
1606 
1607  SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
1608  !!------------------------------------------------------------------------
1609  !! *** routine mpp_maxloc ***
1610  !!
1611  !! ** Purpose : Compute the global maximum of an array ptab
1612  !! and also give its global position
1613  !!
1614  !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1615  !!
1616  !!--------------------------------------------------------------------------
1617  REAL, DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array
1618  REAL, DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask
1619  REAL , INTENT( out) :: pmax ! Global maximum of ptab
1620  INTEGER , INTENT( out) :: ki, kj ! index of maximum in global frame
1621  !!
1622  INTEGER :: ierror
1623  INTEGER, DIMENSION (2) :: ilocs
1624  REAL :: zmax ! local maximum
1625  REAL, DIMENSION(2,1) :: zain, zaout
1626  !!-----------------------------------------------------------------------
1627  !
1628  zmax = maxval( ptab(:,:) , mask= pmask == 1.e0 )
1629  ilocs = maxloc( ptab(:,:) , mask= pmask == 1.e0 )
1630  !
1631  ki = ilocs(1) + nimpp - 1
1632  kj = ilocs(2) + njmpp - 1
1633  !
1634  zain(1,:) = zmax
1635  zain(2,:) = ki + 10000. * kj
1636  !
1637  CALL mpi_allreduce( zain,zaout, 1, mpi_2double_precision,mpi_maxloc,mpi_comm_opa,ierror)
1638  !
1639  pmax = zaout(1,1)
1640  kj = int( zaout(2,1) / 10000. )
1641  ki = int( zaout(2,1) - 10000.* kj )
1642  !
1643  END SUBROUTINE mpp_maxloc2d
1644 
1645 
1646  SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
1647  !!------------------------------------------------------------------------
1648  !! *** routine mpp_maxloc ***
1649  !!
1650  !! ** Purpose : Compute the global maximum of an array ptab
1651  !! and also give its global position
1652  !!
1653  !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1654  !!
1655  !!--------------------------------------------------------------------------
1656  REAL, DIMENSION (jpi,jpj,jpk), INTENT(in ) :: ptab ! Local 2D array
1657  REAL, DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pmask ! Local mask
1658  REAL , INTENT( out) :: pmax ! Global maximum of ptab
1659  INTEGER , INTENT( out) :: ki, kj, kk ! index of maximum in global frame
1660  !!
1661  REAL :: zmax ! local maximum
1662  REAL, DIMENSION(2,1) :: zain, zaout
1663  INTEGER , DIMENSION(3) :: ilocs
1664  INTEGER :: ierror
1665  !!-----------------------------------------------------------------------
1666  !
1667  zmax = maxval( ptab(:,:,:) , mask= pmask == 1.e0 )
1668  ilocs = maxloc( ptab(:,:,:) , mask= pmask == 1.e0 )
1669  !
1670  ki = ilocs(1) + nimpp - 1
1671  kj = ilocs(2) + njmpp - 1
1672  kk = ilocs(3)
1673  !
1674  zain(1,:)=zmax
1675  zain(2,:)=ki+10000.*kj+100000000.*kk
1676  !
1677  CALL mpi_allreduce( zain,zaout, 1, mpi_2double_precision,mpi_maxloc,mpi_comm_opa,ierror)
1678  !
1679  pmax = zaout(1,1)
1680  kk = int( zaout(2,1) / 100000000. )
1681  kj = int( zaout(2,1) - kk * 100000000. ) / 10000
1682  ki = int( zaout(2,1) - kk * 100000000. -kj * 10000. )
1683  !
1684  END SUBROUTINE mpp_maxloc3d
1685 
1686  SUBROUTINE mpp_ini_north
1687  !!----------------------------------------------------------------------
1688  !! *** routine mpp_ini_north ***
1689  !!
1690  !! ** Purpose : Initialize special communicator for north folding
1691  !! condition together with global variables needed in the mpp folding
1692  !!
1693  !! ** Method : - Look for northern processors
1694  !! - Put their number in nrank_north
1695  !! - Create groups for the world processors and the north processors
1696  !! - Create a communicator for northern processors
1697  !!
1698  !! ** glt_output
1699  !! njmppmax = njmpp for northern procs
1700  !! ndim_rank_north = number of processors in the northern line
1701  !! nrank_north (ndim_rank_north) = number of the northern procs.
1702  !! ngrp_world = group ID for the world processors
1703  !! ngrp_north = group ID for the northern processors
1704  !! ncomm_north = communicator for the northern procs.
1705  !! north_root = number (in the world) of proc 0 in the northern comm.
1706  !!
1707  !!----------------------------------------------------------------------
1708  INTEGER :: ierr
1709  INTEGER :: jjproc
1710  INTEGER :: ii, ji
1711  !!----------------------------------------------------------------------
1712  !
1713  njmppmax = maxval( njmppt )
1714  !
1715  ! Look for how many procs on the northern boundary
1716  ndim_rank_north = 0
1717  DO jjproc = 1, jpnij
1718  IF( njmppt(jjproc) == njmppmax ) ndim_rank_north = ndim_rank_north + 1
1719  END DO
1720  !
1721  ! Allocate the right size to nrank_north
1722  IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
1723  ALLOCATE( nrank_north(ndim_rank_north) )
1724 
1725  ! Fill the nrank_north array with proc. number of northern procs.
1726  ! Note : the rank start at 0 in mpi
1727  ii = 0
1728  DO ji = 1, jpnij
1729  IF ( njmppt(ji) == njmppmax ) THEN
1730  ii=ii+1
1731  nrank_north(ii)=ji-1
1732  END IF
1733  END DO
1734  !
1735  ! create the world group
1736  CALL mpi_comm_group( mpi_comm_opa, ngrp_world, ierr )
1737  !
1738  ! Create the North group from the world group
1739  CALL mpi_group_incl( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
1740  !
1741  ! Create the North communicator , ie the pool of procs in the north group
1742  CALL mpi_comm_create( mpi_comm_opa, ngrp_north, ncomm_north, ierr )
1743  !
1744  END SUBROUTINE mpp_ini_north
1745 
1746 
1747  SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )
1748  !!---------------------------------------------------------------------
1749  !! *** routine mpp_lbc_north_3d ***
1750  !!
1751  !! ** Purpose : Ensure proper north fold horizontal bondary condition
1752  !! in mpp configuration in case of jpn1 > 1
1753  !!
1754  !! ** Method : North fold condition and mpp with more than one proc
1755  !! in i-direction require a specific treatment. We gather
1756  !! the 4 northern lines of the global domain on 1 processor
1757  !! and apply lbc north-fold on this sub array. Then we
1758  !! scatter the north fold array back to the processors.
1759  !!
1760  !!----------------------------------------------------------------------
1761  REAL, DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the b.c. is applied
1762  CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
1763  ! ! = T , U , V , F or W gridpoints
1764  REAL , INTENT(in ) :: psgn ! = -1. the sign change across the north fold
1765  !! ! = 1. , the sign is kept
1766  INTEGER :: ji, jj, jr
1767  INTEGER :: ierr, itaille, ildi, ilei, iilb
1768  INTEGER :: ijpj, ijpjm1, ij, iproc
1769  REAL, DIMENSION(jpiglo,4,jpk) :: ztab
1770  REAL, DIMENSION(jpi ,4,jpk) :: znorthloc
1771  REAL, DIMENSION(jpi ,4,jpk,jpni) :: znorthgloio
1772  !!----------------------------------------------------------------------
1773  !
1774  ijpj = 4
1775  ijpjm1 = 3
1776  !
1777  DO jj = nlcj - ijpj +1, nlcj ! put in znorthloc the last 4 jlines of pt3d
1778  ij = jj - nlcj + ijpj
1779  znorthloc(:,ij,:) = pt3d(:,jj,:)
1780  END DO
1781  !
1782  ! ! Build in procs of ncomm_north the znorthgloio
1783  itaille = jpi * jpk * ijpj
1784  CALL mpi_allgather( znorthloc , itaille, mpi_double_precision, &
1785  & znorthgloio, itaille, mpi_double_precision, ncomm_north, ierr )
1786  !
1787  ! ! recover the global north array
1788  DO jr = 1, ndim_rank_north
1789  iproc = nrank_north(jr) + 1
1790  ildi = nldit(iproc)
1791  ilei = nleit(iproc)
1792  iilb = nimppt(iproc)
1793  DO jj = 1, 4
1794  DO ji = ildi, ilei
1795  ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr)
1796  END DO
1797  END DO
1798  END DO
1799  !
1800  CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition
1801  !
1802  DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d
1803  ij = jj - nlcj + ijpj
1804  DO ji= 1, nlci
1805  pt3d(ji,jj,:) = ztab(ji+nimpp-1,ij,:)
1806  END DO
1807  END DO
1808  !
1809  END SUBROUTINE mpp_lbc_north_3d
1810 
1811 
1812  SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)
1813  !!---------------------------------------------------------------------
1814  !! *** routine mpp_lbc_north_2d ***
1815  !!
1816  !! ** Purpose : Ensure proper north fold horizontal bondary condition
1817  !! in mpp configuration in case of jpn1 > 1 (for 2d array )
1818  !!
1819  !! ** Method : North fold condition and mpp with more than one proc
1820  !! in i-direction require a specific treatment. We gather
1821  !! the 4 northern lines of the global domain on 1 processor
1822  !! and apply lbc north-fold on this sub array. Then we
1823  !! scatter the north fold array back to the processors.
1824  !!
1825  !!----------------------------------------------------------------------
1826  REAL, DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 3D array on which the b.c. is applied
1827  CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
1828  ! ! = T , U , V , F or W gridpoints
1829  REAL , INTENT(in ) :: psgn ! = -1. the sign change across the north fold
1830  !! ! = 1. , the sign is kept
1831  INTEGER :: ji, jj, jr
1832  INTEGER :: ierr, itaille, ildi, ilei, iilb
1833  INTEGER :: ijpj, ijpjm1, ij, iproc
1834  REAL, DIMENSION(jpiglo,4) :: ztab
1835  REAL, DIMENSION(jpi ,4) :: znorthloc
1836  REAL, DIMENSION(jpi ,4,jpni) :: znorthgloio
1837  !!----------------------------------------------------------------------
1838  !
1839  ijpj = 4
1840  ijpjm1 = 3
1841  !
1842  DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d
1843  ij = jj - nlcj + ijpj
1844  znorthloc(:,ij) = pt2d(:,jj)
1845  END DO
1846 
1847  ! ! Build in procs of ncomm_north the znorthgloio
1848  itaille = jpi * ijpj
1849  CALL mpi_allgather( znorthloc , itaille, mpi_double_precision, &
1850  & znorthgloio, itaille, mpi_double_precision, ncomm_north, ierr )
1851  !
1852  DO jr = 1, ndim_rank_north ! recover the global north array
1853  iproc = nrank_north(jr) + 1
1854  ildi=nldit(iproc)
1855  ilei=nleit(iproc)
1856  iilb=nimppt(iproc)
1857  DO jj = 1, 4
1858  DO ji = ildi, ilei
1859  ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)
1860  END DO
1861  END DO
1862  END DO
1863  !
1864  CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition
1865  !
1866  !
1867  DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d
1868  ij = jj - nlcj + ijpj
1869  DO ji = 1, nlci
1870  pt2d(ji,jj) = ztab(ji+nimpp-1,ij)
1871  END DO
1872  END DO
1873  !
1874  END SUBROUTINE mpp_lbc_north_2d
1875 
1876 
1877  SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
1878  !!---------------------------------------------------------------------
1879  !! *** routine mpp_lbc_north_2d ***
1880  !!
1881  !! ** Purpose : Ensure proper north fold horizontal bondary condition
1882  !! in mpp configuration in case of jpn1 > 1 and for 2d
1883  !! array with outer extra halo
1884  !!
1885  !! ** Method : North fold condition and mpp with more than one proc
1886  !! in i-direction require a specific treatment. We gather
1887  !! the 4+2*jpr2dj northern lines of the global domain on 1
1888  !! processor and apply lbc north-fold on this sub array.
1889  !! Then we scatter the north fold array back to the processors.
1890  !!
1891  !!----------------------------------------------------------------------
1892  REAL, DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) :: pt2d ! 2D array with extra halo
1893  CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
1894  ! ! = T , U , V , F or W -points
1895  REAL , INTENT(in ) :: psgn ! = -1. the sign change across the
1896  !! ! north fold, = 1. otherwise
1897  INTEGER :: ji, jj, jr
1898  INTEGER :: ierr, itaille, ildi, ilei, iilb
1899  INTEGER :: ijpj, ij, iproc
1900  REAL, DIMENSION(jpiglo,4+2*jpr2dj) :: ztab
1901  REAL, DIMENSION(jpi ,4+2*jpr2dj) :: znorthloc
1902  REAL, DIMENSION(jpi ,4+2*jpr2dj,jpni) :: znorthgloio
1903  !!----------------------------------------------------------------------
1904  !
1905  ijpj=4
1906 
1907  ij=0
1908  ! put in znorthloc the last 4 jlines of pt2d
1909  DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
1910  ij = ij + 1
1911  DO ji = 1, jpi
1912  znorthloc(ji,ij)=pt2d(ji,jj)
1913  END DO
1914  END DO
1915  !
1916  itaille = jpi * ( ijpj + 2 * jpr2dj )
1917  CALL mpi_allgather( znorthloc(1,1) , itaille, mpi_double_precision, &
1918  & znorthgloio(1,1,1), itaille, mpi_double_precision, ncomm_north, ierr )
1919  !
1920  DO jr = 1, ndim_rank_north ! recover the global north array
1921  iproc = nrank_north(jr) + 1
1922  ildi = nldit(iproc)
1923  ilei = nleit(iproc)
1924  iilb = nimppt(iproc)
1925  DO jj = 1, ijpj+2*jpr2dj
1926  DO ji = ildi, ilei
1927  ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)
1928  END DO
1929  END DO
1930  END DO
1931 
1932 
1933  ! 2. North-Fold boundary conditions
1934  ! ----------------------------------
1935  CALL lbc_nfd( ztab(:,:), cd_type, psgn, pr2dj = jpr2dj )
1936 
1937  ij = jpr2dj
1938  !! Scatter back to pt2d
1939  DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj
1940  ij = ij +1
1941  DO ji= 1, nlci
1942  pt2d(ji,jj) = ztab(ji+nimpp-1,ij)
1943  END DO
1944  END DO
1945  !
1946  END SUBROUTINE mpp_lbc_north_e
1947 
1948 
1949  SUBROUTINE lbc_nfd_3d( pt3d, cd_type, psgn )
1950  !!----------------------------------------------------------------------
1951  !! *** routine lbc_nfd_3d ***
1952  !!
1953  !! ** Purpose : 3D lateral boundary condition : North fold treatment
1954  !! without processor exchanges.
1955  !!
1956  !! ** Method :
1957  !!
1958  !! ** Action : pt3d with update value at its periphery
1959  !!
1960  !!----------------------------------------------------------------------
1961  !! * Arguments
1962  CHARACTER(len=1) , INTENT( in ) :: &
1963  cd_type ! define the nature of ptab array grid-points
1964  ! ! = T , U , V , F , W points
1965  ! ! = S : T-point, north fold treatment ???
1966  ! ! = G : F-point, north fold treatment ???
1967  REAL, INTENT( in ) :: &
1968  psgn ! control of the sign change
1969  ! ! = -1. , the sign is changed if north fold boundary
1970  ! ! = 1. , the sign is kept if north fold boundary
1971  REAL, DIMENSION(:,:,:), INTENT( inout ) :: &
1972  pt3d ! 3D array on which the boundary condition is applied
1973 
1974  !! * Local declarations
1975  INTEGER :: ji, jk
1976  INTEGER :: ijt, iju, ijpj, ijpjm1
1977 
1978 
1979  SELECT CASE ( jpni )
1980  CASE ( 1 ) ! only one proc along I
1981  ijpj = nlcj
1982  CASE default
1983  ijpj = 4
1984  END SELECT
1985  ijpjm1 = ijpj-1
1986 
1987  DO jk = 1, jpk
1988 
1989  SELECT CASE ( npolj )
1990 
1991  CASE ( 3 , 4 ) ! * North fold T-point pivot
1992 
1993  SELECT CASE ( cd_type )
1994  CASE ( 'T' , 'W' ) ! T-, W-point
1995  DO ji = 2, jpiglo
1996  ijt = jpiglo-ji+2
1997  pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk)
1998  END DO
1999  DO ji = jpiglo/2+1, jpiglo
2000  ijt = jpiglo-ji+2
2001  pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk)
2002  END DO
2003  CASE ( 'U' ) ! U-point
2004  DO ji = 1, jpiglo-1
2005  iju = jpiglo-ji+1
2006  pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk)
2007  END DO
2008  DO ji = jpiglo/2, jpiglo-1
2009  iju = jpiglo-ji+1
2010  pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk)
2011  END DO
2012  CASE ( 'V' ) ! V-point
2013  DO ji = 2, jpiglo
2014  ijt = jpiglo-ji+2
2015  pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk)
2016  pt3d(ji,ijpj ,jk) = psgn * pt3d(ijt,ijpj-3,jk)
2017  END DO
2018  CASE ( 'F' ) ! F-point
2019  DO ji = 1, jpiglo-1
2020  iju = jpiglo-ji+1
2021  pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk)
2022  pt3d(ji,ijpj ,jk) = psgn * pt3d(iju,ijpj-3,jk)
2023  END DO
2024  END SELECT
2025 
2026  CASE ( 5 , 6 ) ! * North fold F-point pivot
2027 
2028  SELECT CASE ( cd_type )
2029  CASE ( 'T' , 'W' ) ! T-, W-point
2030  DO ji = 1, jpiglo
2031  ijt = jpiglo-ji+1
2032  pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk)
2033  END DO
2034  CASE ( 'U' ) ! U-point
2035  DO ji = 1, jpiglo-1
2036  iju = jpiglo-ji
2037  pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk)
2038  END DO
2039  CASE ( 'V' ) ! V-point
2040  DO ji = 1, jpiglo
2041  ijt = jpiglo-ji+1
2042  pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk)
2043  END DO
2044  DO ji = jpiglo/2+1, jpiglo
2045  ijt = jpiglo-ji+1
2046  pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk)
2047  END DO
2048  CASE ( 'F' ) ! F-point
2049  DO ji = 1, jpiglo-1
2050  iju = jpiglo-ji
2051  pt3d(ji,ijpj ,jk) = psgn * pt3d(iju,ijpj-2,jk)
2052  END DO
2053  DO ji = jpiglo/2+1, jpiglo-1
2054  iju = jpiglo-ji
2055  pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk)
2056  END DO
2057  END SELECT
2058 
2059  CASE default ! * closed : the code probably never go through
2060 
2061  SELECT CASE ( cd_type)
2062  CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
2063  pt3d(:, 1 ,jk) = 0.e0
2064  pt3d(:,ijpj,jk) = 0.e0
2065  CASE ( 'F' ) ! F-point
2066  pt3d(:,ijpj,jk) = 0.e0
2067  END SELECT
2068 
2069  END SELECT ! npolj
2070 
2071  END DO
2072 
2073  END SUBROUTINE lbc_nfd_3d
2074 
2075 
2076  SUBROUTINE lbc_nfd_2d( pt2d, cd_type, psgn, pr2dj )
2077  !!----------------------------------------------------------------------
2078  !! *** routine lbc_nfd_2d ***
2079  !!
2080  !! ** Purpose : 2D lateral boundary condition : North fold treatment
2081  !! without processor exchanges.
2082  !!
2083  !! ** Method :
2084  !!
2085  !! ** Action : pt2d with update value at its periphery
2086  !!
2087  !!----------------------------------------------------------------------
2088  !! * Arguments
2089  CHARACTER(len=1) , INTENT( in ) :: &
2090  cd_type ! define the nature of ptab array grid-points
2091  ! ! = T , U , V , F , W points
2092  ! ! = S : T-point, north fold treatment ???
2093  ! ! = G : F-point, north fold treatment ???
2094  REAL, INTENT( in ) :: &
2095  psgn ! control of the sign change
2096  ! ! = -1. , the sign is changed if north fold boundary
2097  ! ! = 1. , the sign is kept if north fold boundary
2098  REAL, DIMENSION(:,:), INTENT( inout ) :: &
2099  pt2d ! 3D array on which the boundary condition is applied
2100  INTEGER, OPTIONAL, INTENT(in) :: pr2dj
2101 
2102  !! * Local declarations
2103  INTEGER :: ji, jl, ipr2dj
2104  INTEGER :: ijt, iju, ijpj, ijpjm1
2105 
2106  SELECT CASE ( jpni )
2107  CASE ( 1 ) ! only one proc along I
2108  ijpj = nlcj
2109  CASE default
2110  ijpj = 4
2111  END SELECT
2112 
2113 
2114  IF( present(pr2dj) ) THEN
2115  ipr2dj = pr2dj
2116  IF (jpni .GT. 1) ijpj = ijpj + ipr2dj
2117  ELSE
2118  ipr2dj = 0
2119  ENDIF
2120 
2121  ijpjm1 = ijpj-1
2122 
2123 
2124  SELECT CASE ( npolj )
2125 
2126  CASE ( 3, 4 ) ! * North fold T-point pivot
2127 
2128  SELECT CASE ( cd_type )
2129 
2130  CASE ( 'T', 'S', 'W' )
2131  DO jl = 0, ipr2dj
2132  DO ji = 2, jpiglo
2133  ijt=jpiglo-ji+2
2134  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
2135  END DO
2136  END DO
2137  DO ji = jpiglo/2+1, jpiglo
2138  ijt=jpiglo-ji+2
2139  pt2d(ji,ijpj-1) = psgn * pt2d(ijt,ijpj-1)
2140  END DO
2141  CASE ( 'U' ) ! U-point
2142  DO jl =0, ipr2dj
2143  DO ji = 1, jpiglo-1
2144  iju = jpiglo-ji+1
2145  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl)
2146  END DO
2147  END DO
2148  DO ji = jpiglo/2, jpiglo-1
2149  iju = jpiglo-ji+1
2150  pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
2151  END DO
2152  CASE ( 'V' ) ! V-point
2153  DO jl =-1, ipr2dj
2154  DO ji = 2, jpiglo
2155  ijt = jpiglo-ji+2
2156  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-3-jl)
2157  END DO
2158  END DO
2159  CASE ( 'F' , 'G' ) ! F-point
2160  DO jl =-1, ipr2dj
2161  DO ji = 1, jpiglo-1
2162  iju = jpiglo-ji+1
2163  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-3-jl)
2164  END DO
2165  END DO
2166  CASE ( 'I' ) ! ice U-V point
2167 ! Change in I-point definition for Gelato
2168 ! DO jl =0, ipr2dj
2169 ! pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl)
2170 ! DO ji = 3, jpiglo
2171 ! iju = jpiglo - ji + 3
2172 ! pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
2173 ! END DO
2174 ! END DO
2175  DO jl =0, ipr2dj
2176  pt2d(1,ijpj+jl) = psgn * pt2d(2,ijpj-1+jl)
2177  DO ji = 2, jpiglo
2178  iju = jpiglo - ji + 2
2179  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
2180  END DO
2181  END DO
2182  END SELECT
2183 
2184  CASE ( 5, 6 ) ! * North fold F-point pivot
2185 
2186  SELECT CASE ( cd_type )
2187  CASE ( 'T' , 'W' ,'S' ) ! T-, W-point
2188  DO jl = 0, ipr2dj
2189  DO ji = 1, jpiglo
2190  ijt = jpiglo-ji+1
2191  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-1-jl)
2192  END DO
2193  END DO
2194  CASE ( 'U' ) ! U-point
2195  DO jl = 0, ipr2dj
2196  DO ji = 1, jpiglo-1
2197  iju = jpiglo-ji
2198  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
2199  END DO
2200  END DO
2201  CASE ( 'V' ) ! V-point
2202  DO jl = 0, ipr2dj
2203  DO ji = 1, jpiglo
2204  ijt = jpiglo-ji+1
2205  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
2206  END DO
2207  END DO
2208  DO ji = jpiglo/2+1, jpiglo
2209  ijt = jpiglo-ji+1
2210  pt2d(ji,ijpjm1) = psgn * pt2d(ijt,ijpjm1)
2211  END DO
2212  CASE ( 'F' , 'G' ) ! F-point
2213  DO jl = 0, ipr2dj
2214  DO ji = 1, jpiglo-1
2215  iju = jpiglo-ji
2216  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl)
2217  END DO
2218  END DO
2219  DO ji = jpiglo/2+1, jpiglo-1
2220  iju = jpiglo-ji
2221  pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
2222  END DO
2223  CASE ( 'I' ) ! ice U-V point
2224  pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0
2225  DO jl = 0, ipr2dj
2226  DO ji = 2 , jpiglo-1
2227  ijt = jpiglo - ji + 2
2228  pt2d(ji,ijpj+jl)= 0.5 * ( pt2d(ji,ijpj-1-jl) + psgn * pt2d(ijt,ijpj-1-jl) )
2229  END DO
2230  END DO
2231  END SELECT
2232 
2233  CASE default ! * closed : the code probably never go through
2234 
2235  SELECT CASE ( cd_type)
2236  CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
2237  pt2d(:, 1:1-ipr2dj ) = 0.e0
2238  pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
2239  CASE ( 'F' ) ! F-point
2240  pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
2241  CASE ( 'I' ) ! ice U-V point
2242  pt2d(:, 1:1-ipr2dj ) = 0.e0
2243  pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
2244  END SELECT
2245 
2246  END SELECT
2247 
2248  END SUBROUTINE lbc_nfd_2d
2249 #endif
2250 
2251 
2252  !!======================================================================
2253 END MODULE mode_glt_nemo_bound
lib_mpp::mpp_lbc_north::mpp_lbc_north_3d
subroutine mpp_lbc_north_3d(pt3d, cd_type, psgn)
Definition: lib_mpp.F90:2411
modd_surfex_mpi
Definition: modd_surfex_mpi.F90:6
mode_glt_nemo_bound::lbc_lnk
Definition: mode_glt_nemo_bound.F90:85
mode_glt_nemo_bound::lbc_nfd
Definition: mode_glt_nemo_bound.F90:94
mode_glt_nemo_bound::lbc_nfd::lbc_nfd_2d
subroutine lbc_nfd_2d(pt2d, cd_type, psgn, pr2dj)
Definition: mode_glt_nemo_bound.F90:2076
lib_mpp::mpp_max::mppmax_int
subroutine mppmax_int(kint, kcom)
Definition: lib_mpp.F90:2962
lib_mpp::mpp_sum::mppsum_a_real
subroutine mppsum_a_real(ptab, kdim, kcom)
Definition: lib_mpp.F90:1638
lib_mpp::mpp_lnk_2d
subroutine, public mpp_lnk_2d(pt2d, cd_type, psgn, cd_mpp, pval)
Definition: lib_mpp.F90:628
lib_mpp::mpp_maxloc::mpp_maxloc2d
subroutine mpp_maxloc2d(ptab, pmask, pmax, ki, kj)
Definition: lib_mpp.F90:3019
lib_mpp::mpp_minloc::mpp_minloc3d
subroutine mpp_minloc3d(ptab, pmask, pmin, ki, kj, kk)
Definition: lib_mpp.F90:3012
mode_glt_nemo_bound::mpp_maxloc
Definition: mode_glt_nemo_bound.F90:116
lib_mpp::mpp_ini_north
subroutine, public mpp_ini_north
Definition: lib_mpp.F90:2350
mode_glt_nemo_bound::lbc_lnk::lbc_lnk_3d
subroutine lbc_lnk_3d(pt3d, cd_type, psgn, cd_mpp, pval)
Definition: mode_glt_nemo_bound.F90:179
mode_glt_nemo_bound
Definition: mode_glt_nemo_bound.F90:39
lib_mpp::mpp_min::mppmin_real
subroutine mppmin_real(psca, kcom)
Definition: lib_mpp.F90:2949
lib_mpp::mpp_sum::mppsum_a_int
subroutine mppsum_a_int(ktab, kdim)
Definition: lib_mpp.F90:1437
lib_mpp::mpp_lbc_north_e
subroutine, public mpp_lbc_north_e(pt2d, cd_type, psgn)
Definition: lib_mpp.F90:2677
lib_mpp::mppsend
subroutine, public mppsend(ktyp, pmess, kbytes, kdest, md_req)
Definition: lib_mpp.F90:1193
lib_mpp::mpp_min::mppmin_int
subroutine mppmin_int(kint, kcom)
Definition: lib_mpp.F90:2975
lib_mpp::mpp_max::mppmax_a_int
subroutine mppmax_a_int(karr, kdim, kcom)
Definition: lib_mpp.F90:2955
lib_mpp::mpp_minloc::mpp_minloc2d
subroutine mpp_minloc2d(ptab, pmask, pmin, ki, kj)
Definition: lib_mpp.F90:3005
lib_mpp::mpp_lnk_3d_gather
subroutine, public mpp_lnk_3d_gather(ptab1, cd_type1, ptab2, cd_type2, psgn)
Definition: lib_mpp.F90:822
modd_glt_param
Definition: modd_glt_param.F90:53
mode_glt_nemo_bound::mpp_minloc
Definition: mode_glt_nemo_bound.F90:113
mode_glt_nemo_bound::mpp_max
Definition: mode_glt_nemo_bound.F90:102
lib_mpp::mpp_min::mppmin_a_int
subroutine mppmin_a_int(karr, kdim, kcom)
Definition: lib_mpp.F90:2968
lib_mpp::mpp_maxloc::mpp_maxloc3d
subroutine mpp_maxloc3d(ptab, pmask, pmax, ki, kj, kk)
Definition: lib_mpp.F90:3026
mode_glt_nemo_bound::lbc_lnk::lbc_lnk_3d_gather
subroutine lbc_lnk_3d_gather(pt3d1, cd_type1, pt3d2, cd_type2, psgn)
Definition: mode_glt_nemo_bound.F90:147
mode_glt_nemo_bound::lbc_nfd::lbc_nfd_3d
subroutine lbc_nfd_3d(pt3d, cd_type, psgn)
Definition: mode_glt_nemo_bound.F90:1949
lib_mpp::mpp_min::mppmin_a_real
subroutine mppmin_a_real(parr, kdim, kcom)
Definition: lib_mpp.F90:2942
mode_glt_nemo_bound::lbc_lnk::lbc_lnk_2d
subroutine lbc_lnk_2d(pt2d, cd_type, psgn, cd_mpp, pval)
Definition: mode_glt_nemo_bound.F90:282
mode_glt_nemo_bound::mpp_sum
Definition: mode_glt_nemo_bound.F90:105
lib_mpp::mpp_lnk_2d_e
subroutine, public mpp_lnk_2d_e(pt2d, cd_type, psgn)
Definition: lib_mpp.F90:1016
lib_mpp::mpprecv
subroutine, public mpprecv(ktyp, pmess, kbytes, ksource)
Definition: lib_mpp.F90:1222
lib_mpp::mpp_sum::mppsum_int
subroutine mppsum_int(ktab)
Definition: lib_mpp.F90:1466
mode_glt_nemo_bound::mpp_lnk
Definition: mode_glt_nemo_bound.F90:88
lib_mpp::mpp_max::mppmax_real
subroutine mppmax_real(psca, kcom)
Definition: lib_mpp.F90:2936
lib_mpp::mpp_lnk_3d
subroutine, public mpp_lnk_3d(ptab, cd_type, psgn, cd_mpp, pval)
Definition: lib_mpp.F90:431
mode_glt_nemo_bound::mpp_lbc_north
Definition: mode_glt_nemo_bound.F90:110
lib_mpp::mpp_max::mppmax_a_real
subroutine mppmax_a_real(parr, kdim, kcom)
Definition: lib_mpp.F90:2929
mode_glt_nemo_bound::lbc_lnk_e
Definition: mode_glt_nemo_bound.F90:91
mode_glt_nemo_bound::mpp_min
Definition: mode_glt_nemo_bound.F90:99
lib_mpp::mpp_lbc_north::mpp_lbc_north_2d
subroutine mpp_lbc_north_2d(pt2d, cd_type, psgn)
Definition: lib_mpp.F90:2543
lib_mpp::mpp_sum::mppsum_real
subroutine mppsum_real(ptab, kcom)
Definition: lib_mpp.F90:1671
Generated on Fri May 13 2016 09:31:00 for SURFEX by   doxygen 1.8.5