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.
lib_mpp_tam.F90 in branches/TAM_V3_0/NEMOTAM/OPATAM_SRC – NEMO

source: branches/TAM_V3_0/NEMOTAM/OPATAM_SRC/lib_mpp_tam.F90 @ 1885

Last change on this file since 1885 was 1885, checked in by rblod, 14 years ago

add TAM sources

File size: 77.3 KB
Line 
1#if defined key_mpp_mpi
2#if defined key_sp
3#define mpivar mpi_real
4#else
5#define mpivar mpi_double_precision
6#endif
7#endif
8MODULE lib_mpp_tam
9   !!======================================================================
10   !!                       ***  MODULE  lib_mpp_tam  ***
11   !! Ocean numerics:  adjoints of massively parallel processing library
12   !!=====================================================================
13#if   defined key_mpp_mpi   ||   defined key_mpp_shmem
14   !!----------------------------------------------------------------------
15   !!   'key_mpp_mpi'     OR      MPI massively parallel processing library
16   !!   'key_mpp_shmem'         SHMEM massively parallel processing library
17   !!----------------------------------------------------------------------
18   !!   mpp_lnkadj  : generic interface (defined in lbclnkadj) for :
19   !!                 mpp_lnkadj_2d, mpp_lnkadj_3d
20   !!   mpp_lnkadj_3d_gather :  Message passing manadgement for two 3D arrays
21   !!   mpp_lnkadj_e   : interface defined in lbclnkadj
22   !!----------------------------------------------------------------------
23   !! History :
24   !!        !  07-07  (K. Mogensen) Original code (lib_mppadj
25   !!        !  09-02  (A. Vidard) nemo v3 update
26   !! * Modules used
27   USE dom_oce                    ! ocean space and time domain
28   USE in_out_manager             ! I/O manager
29   USE lib_mpp                    ! Direct MPP library
30
31   IMPLICIT NONE
32
33   PRIVATE
34   PUBLIC  mpp_lnk_3d_adj, mpp_lnk_2d_adj, mpp_lnk_3d_gather_adj, mpp_lnk_2d_e_adj
35#if defined key_ecmwf_dynmem
36   PUBLIC lib_mpp_alloc_adj
37#endif
38#if defined key_mpp_mpi
39   !! ========================= !!
40   !!  MPI  variable definition !!
41   !! ========================= !!
42!$AGRIF_DO_NOT_TREAT
43#  include <mpif.h>
44!$AGRIF_END_DO_NOT_TREAT
45#endif
46
47   INTERFACE mpp_lbc_north_adj
48      MODULE PROCEDURE mpp_lbc_north_3d_adj, mpp_lbc_north_2d_adj 
49   END INTERFACE
50
51#ifdef key_ecmwf_dynmem
52   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) ::   &
53       t3ns_ad, t3sn_ad  ! 3d message passing arrays north-south & south-north
54   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) ::   &
55       t3ew_ad, t3we_ad  ! 3d message passing arrays east-west & west-east
56   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   &
57       t2ns_ad, t2sn_ad  ! 2d message passing arrays north-south & south-north
58   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   &
59       t2ew_ad, t2we_ad  ! 2d message passing arrays east-west & west-east
60   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   &
61       tr2ns_ad, tr2sn_ad  ! 2d message passing arrays north-south & south-north including extra outer halo
62   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   &
63       tr2ew_ad, tr2we_ad  ! 2d message passing arrays east-west & west-east including extra outer halo
64#else
65!!   REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) ::   &
66!!       t4ns, t4sn  ! 3d message passing arrays north-south & south-north
67!!   REAL(wp), DIMENSION(jpj,jpreci,jpk,2,2) ::   &
68!!       t4ew, t4we  ! 3d message passing arrays east-west & west-east
69!!   REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) ::   &
70!!       t4p1, t4p2  ! 3d message passing arrays north fold
71   REAL(wp), DIMENSION(jpi,jprecj,jpk,2) ::   &
72       t3ns_ad, t3sn_ad  ! 3d message passing arrays north-south & south-north
73   REAL(wp), DIMENSION(jpj,jpreci,jpk,2) ::   &
74       t3ew_ad, t3we_ad  ! 3d message passing arrays east-west & west-east
75!!   REAL(wp), DIMENSION(jpi,jprecj,jpk,2) ::   &
76!!       t3p1, t3p2  ! 3d message passing arrays north fold
77   REAL(wp), DIMENSION(jpi,jprecj,2) ::   &
78       t2ns_ad, t2sn_ad  ! 2d message passing arrays north-south & south-north
79   REAL(wp), DIMENSION(jpj,jpreci,2) ::   &
80       t2ew_ad, t2we_ad  ! 2d message passing arrays east-west & west-east
81!!   REAL(wp), DIMENSION(jpi,jprecj,2) ::   &
82!!       t2p1, t2p2  ! 2d message passing arrays north fold
83   REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) ::   &
84       tr2ns_ad, tr2sn_ad  ! 2d message passing arrays north-south & south-north including extra outer halo
85   REAL(wp), DIMENSION(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) ::   &
86       tr2ew_ad, tr2we_ad  ! 2d message passing arrays east-west & west-east including extra outer halo
87#endif
88
89CONTAINS
90
91   SUBROUTINE mpp_lnk_3d_adj( ptab_ad, cd_type, psgn, cd_mpp, pval )
92      !!-----------------------------------------------------------------------
93      !!
94      !!      ***  ROUTINE mpp_lnk_3d_adj : ADJOINT OF ROUTINE mpp_lnkadj_adj  ***
95      !!
96      !! ** Purpose of direct routine   : Message passing manadgement
97      !!
98      !! ** Method of direct routine    : Use mppsend and mpprecv function for
99      !!            passing mask between processors following neighboring
100      !!            subdomains.
101      !!            domain parameters
102      !!                    nlci   : first dimension of the local subdomain
103      !!                    nlcj   : second dimension of the local subdomain
104      !!                    nbondi : mark for "east-west local boundary"
105      !!                    nbondj : mark for "north-south local boundary"
106      !!                    noea   : number for local neighboring processors
107      !!                    nowe   : number for local neighboring processors
108      !!                    noso   : number for local neighboring processors
109      !!                    nono   : number for local neighboring processors
110      !!
111      !! ** Comments on Adjoint Routine :
112      !!
113      !! ** Action  : ptab_ad with update value at its periphery
114      !!                   
115      !! References :
116      !!
117      !! History :
118      !!        ! 07-07 (K. Mogensen) Initial version
119      !!        ! 09-02 (A. Vidard) NEMO v3 update
120      !!-----------------------------------------------------------------------
121      !! * Modules used
122      !! * Arguments
123      CHARACTER(len=1) , INTENT( in ) ::   &
124         cd_type       ! define the nature of ptab_ad array grid-points
125         !             ! = T , U , V , F , W points
126         !             ! = S : T-point, north fold treatment ???
127         !             ! = G : F-point, north fold treatment ???
128      REAL(wp), INTENT( in ) ::   &
129         psgn          ! control of the sign change
130         !             !   = -1. , the sign is changed if north fold boundary
131         !             !   =  1. , the sign is kept  if north fold boundary
132      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) ::   &
133         ptab_ad          ! 3D array on which the boundary condition is applied
134      CHARACTER(len=3), INTENT( in ), OPTIONAL ::    &
135         cd_mpp        ! fill the overlap area only
136      REAL(wp)        , INTENT(in   ), OPTIONAL           ::   pval      ! background value (used at closed boundaries)
137                                                                         ! only here for compatibility
138      !! * Local declarations
139      INTEGER ::   ji, jj, jk, jl                        ! dummy loop indices
140      INTEGER ::   imigr, iihom, ijhom, iloc, ijt, iju   ! temporary integers
141      INTEGER ::   ml_req1, ml_req2, ml_err     ! for key_mpi_isend
142      INTEGER ::   ml_stat(MPI_STATUS_SIZE)     ! for key_mpi_isend
143      !!----------------------------------------------------------------------
144
145      ! 5. East and west directions exchange
146      ! ------------------------------------
147
148      SELECT CASE ( npolj )
149
150      CASE ( 3, 4, 5, 6 )
151
152         ! 5.3 Write Dirichlet lateral conditions
153
154         iihom = nlci-jpreci
155
156         SELECT CASE ( nbondi)
157         CASE ( -1 )
158            DO jl = 1, jpreci
159               t3we_ad(:,jl,:,1)     = ptab_ad(iihom+jl,:,:)
160               ptab_ad(iihom+jl,:,:) = 0.0_wp
161            END DO
162         CASE ( 0 ) 
163            DO jl = 1, jpreci
164               t3we_ad(:,jl,:,1)     = ptab_ad(iihom+jl,:,:)
165               ptab_ad(iihom+jl,:,:) = 0.0_wp
166               t3ew_ad(:,jl,:,1)     = ptab_ad(jl      ,:,:)
167               ptab_ad(jl      ,:,:) = 0.0_wp
168            END DO
169         CASE ( 1 )
170            DO jl = 1, jpreci
171               t3ew_ad(:,jl,:,1)     = ptab_ad(jl      ,:,:)
172               ptab_ad(jl      ,:,:) = 0.0_wp
173            END DO
174         END SELECT
175
176         ! 5.2 Migrations
177
178#if defined key_mpp_shmem
179error "key_mpp_shmem not support in nemovar"
180#elif defined key_mpp_mpi
181         !! MPI version
182
183         imigr=jpreci*jpj*jpk
184 
185         SELECT CASE ( nbondi )
186         CASE ( -1 )
187            CALL mppsend( 2, t3we_ad(1,1,1,1), imigr, noea, ml_req1 )
188            CALL mpprecv( 1, t3ew_ad(1,1,1,2), imigr )
189            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
190         CASE ( 0 )
191            CALL mppsend( 1, t3ew_ad(1,1,1,1), imigr, nowe, ml_req1 )
192            CALL mppsend( 2, t3we_ad(1,1,1,1), imigr, noea, ml_req2 )
193            CALL mpprecv( 1, t3ew_ad(1,1,1,2), imigr )
194            CALL mpprecv( 2, t3we_ad(1,1,1,2), imigr )
195            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
196            IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
197         CASE ( 1 )
198            CALL mppsend( 1, t3ew_ad(1,1,1,1), imigr, nowe, ml_req1 )
199            CALL mpprecv( 2, t3we_ad(1,1,1,2), imigr )
200            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
201         END SELECT
202#endif
203
204         ! 5.1 Read Dirichlet lateral conditions
205
206         SELECT CASE ( nbondi )
207
208         CASE ( -1, 0, 1 )
209            iihom = nlci-nreci
210            DO jl = 1, jpreci
211               ptab_ad(iihom +jl,:,:) = ptab_ad(iihom +jl,:,:) + t3ew_ad(:,jl,:,2)
212               ptab_ad(jpreci+jl,:,:) = ptab_ad(jpreci+jl,:,:) + t3we_ad(:,jl,:,2)
213            END DO
214
215         END SELECT
216
217      END SELECT    ! npolj
218     
219
220      ! 4. north fold treatment
221      ! -----------------------
222
223      IF (PRESENT(cd_mpp)) THEN
224         ! No north fold treatment (it is assumed to be already OK)
225     
226      ELSE     
227
228      ! 4.1 treatment without exchange (jpni odd)
229      !     T-point pivot 
230
231      SELECT CASE ( jpni )
232
233      CASE ( 1 )  ! only one proc along I, no mpp exchange
234
235         SELECT CASE ( npolj )
236 
237         CASE ( 3 , 4 )    ! T pivot
238            iloc = jpiglo - 2 * ( nimpp - 1 )
239
240            SELECT CASE ( cd_type )
241
242            CASE ( 'T' , 'S', 'W' )
243               DO jk = jpk, 1, -1
244                  DO ji = nlci, nlci/2+1, -1
245                     ijt=iloc-ji+2
246                     ptab_ad(ijt,nlcj-1,jk) =        ptab_ad(ijt,nlcj-1,jk) &
247                        &                   + psgn * ptab_ad(ji ,nlcj-1,jk)
248                     ptab_ad(ji ,nlcj-1,jk) = 0.0_wp
249                  END DO
250                  DO ji = nlci, 2, -1
251                     ijt=iloc-ji+2
252                     ptab_ad(ijt,nlcj-2,jk) =        ptab_ad(ijt,nlcj-2,jk) &
253                        &                   + psgn * ptab_ad(ji ,nlcj  ,jk) 
254                     ptab_ad(ji, nlcj,  jk) = 0.0_wp
255                  END DO
256               END DO
257         
258            CASE ( 'U' )
259               DO jk = jpk, 1, -1
260                  DO ji = nlci-1, nlci/2, -1
261                     iju=iloc-ji+1
262                     ptab_ad(iju,nlcj-1,jk) =        ptab_ad(iju,nlcj-1,jk) &
263                        &                   + psgn * ptab_ad(ji ,nlcj-1,jk)
264                     ptab_ad(ji ,nlcj-1,jk) = 0.0_wp
265                  END DO
266                  DO ji = nlci-1, 1, -1
267                     iju=iloc-ji+1
268                     ptab_ad(iju,nlcj-2,jk) =        ptab_ad(iju,nlcj-2,jk) &
269                        &                   + psgn * ptab_ad(ji ,nlcj  ,jk)
270                     ptab_ad(ji ,nlcj  ,jk) = 0.0_wp
271                  END DO
272               END DO
273
274            CASE ( 'V' )
275               DO jk = jpk, 1, -1
276                  DO ji = nlci, 2, -1 
277                     ijt=iloc-ji+2
278                     ptab_ad(ijt,nlcj-3,jk) =        ptab_ad(ijt,nlcj-3,jk) &
279                        &                   + psgn * ptab_ad(ji ,nlcj  ,jk)
280                     ptab_ad(ji ,nlcj  ,jk) = 0.0_wp
281                     ptab_ad(ijt,nlcj-2,jk) =        ptab_ad(ijt,nlcj-2,jk) &
282                        &                   + psgn * ptab_ad(ji ,nlcj-1,jk)
283                     ptab_ad(ji ,nlcj-1,jk) = 0.0_wp
284                  END DO
285               END DO
286
287            CASE ( 'F', 'G' )
288               DO jk = jpk, 1, -1
289                  DO ji = nlci-1, 1, -1
290                     iju=iloc-ji+1
291                     ptab_ad(iju,nlcj-3,jk) =        ptab_ad(iju,nlcj-3,jk) &
292                        &                   + psgn * ptab_ad(ji ,nlcj  ,jk)
293                     ptab_ad(ji ,nlcj  ,jk) = 0.0_wp
294                     ptab_ad(iju,nlcj-2,jk) =        ptab_ad(iju,nlcj-2,jk) &
295                        &                   + psgn * ptab_ad(ji ,nlcj-1,jk)
296                     ptab_ad(ji ,nlcj-1,jk) = 0.0_wp
297                  END DO
298               END DO
299 
300          END SELECT
301       
302         CASE ( 5 , 6 ) ! F pivot
303            iloc=jpiglo-2*(nimpp-1)
304 
305            SELECT CASE ( cd_type )
306
307            CASE ( 'T' , 'S', 'W' )
308               DO jk = jpk, 1, -1
309                  DO ji = nlci, 1, -1
310                     ijt=iloc-ji+1
311                     ptab_ad(ijt,nlcj-1,jk) =        ptab_ad(ijt,nlcj-1,jk) &
312                        &                   + psgn * ptab_ad(ji ,nlcj  ,jk) 
313                     ptab_ad(ji ,nlcj  ,jk) = 0.0_wp
314                  END DO
315               END DO
316
317            CASE ( 'U' )
318               DO jk = jpk, 1, -1
319                  DO ji = nlci-1, 1, -1
320                     iju=iloc-ji
321                     ptab_ad(iju,nlcj-1,jk) =        ptab_ad(iju,nlcj-1,jk) &
322                        &                   + psgn * ptab_ad(ji ,nlcj  ,jk)
323                     ptab_ad(ji ,nlcj  ,jk) = 0.0_wp
324                  END DO
325               END DO
326
327            CASE ( 'V' )
328               DO jk = jpk, 1, -1
329                  DO ji = nlci, nlci/2+1, -1
330                     ijt=iloc-ji+1
331                     ptab_ad(ijt,nlcj-1,jk) =        ptab_ad(ijt,nlcj-1,jk) &
332                        &                   + psgn * ptab_ad(ji ,nlcj-1,jk)
333                     ptab_ad(ji ,nlcj-1,jk) = 0.0_wp
334                  END DO
335                  DO ji = nlci, 1, -1
336                     ijt=iloc-ji+1
337                     ptab_ad(ijt,nlcj-2,jk) =        ptab_ad(ijt,nlcj-2,jk) &
338                        &                   + psgn * ptab_ad(ji ,nlcj  ,jk) 
339                     ptab_ad(ji, nlcj  ,jk) = 0.0_wp
340                  END DO
341               END DO
342
343            CASE ( 'F', 'G' )
344               DO jk = jpk, 1, -1
345                  DO ji = nlci-1, nlci/2+1, -1
346                     iju=iloc-ji
347                     ptab_ad(iju,nlcj-1,jk) =        ptab_ad(iju,nlcj-1,jk) &
348                        &                   + psgn * ptab_ad(ji ,nlcj-1,jk)
349                     ptab_ad(ji ,nlcj-1,jk) = 0.0_wp
350                  END DO
351                  DO ji = nlci-1, 1, -1
352                     iju=iloc-ji
353                     ptab_ad(iju,nlcj-2,jk) =        ptab_ad(iju,nlcj-2,jk) &
354                        &                   + psgn * ptab_ad(ji ,nlcj  ,jk)
355                     ptab_ad(ji ,nlcj  ,jk) = 0.0_wp
356                  END DO
357               END DO
358            END SELECT  ! cd_type
359
360            ptab_ad(nlci,nlcj,jk) = 0.e0
361            ptab_ad( 1  ,nlcj,jk) = 0.e0
362           
363         END SELECT     !  npolj
364 
365      CASE DEFAULT ! more than 1 proc along I
366         IF ( npolj /= 0 ) CALL mpp_lbc_north_adj (ptab_ad, cd_type, psgn)  ! only for northern procs.
367
368      END SELECT ! jpni
369
370      ENDIF
371
372      ! 3. North and south directions
373      ! -----------------------------
374
375      ! 3.3 Write Dirichlet lateral conditions
376
377      ijhom = nlcj-jprecj
378
379      t3ns_ad(:,:,:,:) = 0.0_wp
380      t3sn_ad(:,:,:,:) = 0.0_wp
381
382      SELECT CASE ( nbondj )
383      CASE ( -1 )
384         DO jl = 1, jprecj
385            t3sn_ad(:,jl,:,1)     = ptab_ad(:,ijhom+jl,:)
386            ptab_ad(:,ijhom+jl,:) = 0.0_wp
387         END DO
388      CASE ( 0 ) 
389         DO jl = 1, jprecj
390             t3sn_ad(:,jl,:,1)     = ptab_ad(:,ijhom+jl      ,:)
391             ptab_ad(:,ijhom+jl,:) = 0.0_wp
392             t3ns_ad(:,jl,:,1)     = ptab_ad(:,jl,:)
393             ptab_ad(:,jl      ,:) = 0.0_wp
394         END DO
395      CASE ( 1 )
396         DO jl = 1, jprecj
397            t3ns_ad(:,jl,:,1) = ptab_ad(:,jl,:)
398            ptab_ad(:,jl,:)   = 0.0_wp
399         END DO
400      END SELECT
401
402      ! 3.2 Migrations
403
404#if defined key_mpp_shmem
405error "key_mpp_shmem not supported in nemovar"
406#elif defined key_mpp_mpi
407      !! * Local variables   (MPI version)
408 
409      imigr=jprecj*jpi*jpk
410
411      SELECT CASE ( nbondj )     
412      CASE ( -1 )
413         CALL mppsend( 4, t3sn_ad(1,1,1,1), imigr, nono, ml_req1 )
414         CALL mpprecv( 3, t3ns_ad(1,1,1,2), imigr )
415         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
416      CASE ( 0 )
417         CALL mppsend( 3, t3ns_ad(1,1,1,1), imigr, noso, ml_req1 )
418         CALL mppsend( 4, t3sn_ad(1,1,1,1), imigr, nono, ml_req2 )
419         CALL mpprecv( 3, t3ns_ad(1,1,1,2), imigr )
420         CALL mpprecv( 4, t3sn_ad(1,1,1,2), imigr )
421         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
422         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
423      CASE ( 1 ) 
424         CALL mppsend( 3, t3ns_ad(1,1,1,1), imigr, noso, ml_req1 )
425         CALL mpprecv( 4, t3sn_ad(1,1,1,2), imigr )
426         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
427      END SELECT
428
429#endif
430
431      ! 3.1 Read Dirichlet lateral conditions
432
433      IF( nbondj /= 2 ) THEN
434         ijhom = nlcj-nrecj
435         DO jl = 1, jprecj
436             ptab_ad(:,jprecj+jl,:) = ptab_ad(:,jprecj+jl,:) + t3sn_ad(:,jl,:,2)
437             ptab_ad(:,ijhom +jl,:) = ptab_ad(:,ijhom +jl,:) + t3ns_ad(:,jl,:,2)
438         END DO
439      ENDIF
440
441      ! 2. East and west directions exchange
442      ! ------------------------------------
443
444      ! 2.3 Write Dirichlet lateral conditions
445
446      iihom = nlci-jpreci
447
448      SELECT CASE ( nbondi)
449      CASE ( -1 )
450         DO jl = 1, jpreci
451            t3we_ad(:,jl,:,1)     = ptab_ad(iihom+jl,:,:)
452            ptab_ad(iihom+jl,:,:) = 0.0_wp
453         END DO
454      CASE ( 0 ) 
455         DO jl = 1, jpreci
456            t3we_ad(:,jl,:,1)     = ptab_ad(iihom+jl,:,:)
457            ptab_ad(iihom+jl,:,:) = 0.0_wp
458            t3ew_ad(:,jl,:,1)     = ptab_ad(jl      ,:,:)
459            ptab_ad(jl      ,:,:) = 0.0_wp
460         END DO
461      CASE ( 1 )
462         DO jl = 1, jpreci
463            t3ew_ad(:,jl,:,1)     = ptab_ad(jl      ,:,:)
464            ptab_ad(jl      ,:,:) = 0.0_wp
465         END DO
466      END SELECT
467
468      ! 2.2 Migrations
469
470#if defined key_mpp_shmem
471error "key_mpp_shmem not support in nemovar"
472#elif defined key_mpp_mpi
473      !! * Local variables   (MPI version)
474
475      imigr=jpreci*jpj*jpk
476     
477      SELECT CASE ( nbondi )
478      CASE ( -1 )
479         CALL mppsend( 2, t3we_ad(1,1,1,1), imigr, noea, ml_req1 )
480         CALL mpprecv( 1, t3ew_ad(1,1,1,2), imigr )
481         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
482      CASE ( 0 )
483         CALL mppsend( 1, t3ew_ad(1,1,1,1), imigr, nowe, ml_req1 )
484         CALL mppsend( 2, t3we_ad(1,1,1,1), imigr, noea, ml_req2 )
485         CALL mpprecv( 1, t3ew_ad(1,1,1,2), imigr )
486         CALL mpprecv( 2, t3we_ad(1,1,1,2), imigr )
487         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
488         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
489      CASE ( 1 )
490         CALL mppsend( 1, t3ew_ad(1,1,1,1), imigr, nowe, ml_req1 )
491         CALL mpprecv( 2, t3we_ad(1,1,1,2), imigr )
492         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
493      END SELECT
494#endif
495
496      ! 2.1 Read Dirichlet lateral conditions
497
498     SELECT CASE ( nbondi )
499     CASE ( -1, 0, 1 )    ! all exept 2
500        iihom = nlci-nreci
501        DO jl = 1, jpreci
502           ptab_ad(iihom +jl,:,:) = ptab_ad(iihom +jl,:,:) + t3ew_ad(:,jl,:,2)
503           ptab_ad(jpreci+jl,:,:) = ptab_ad(jpreci+jl,:,:) + t3we_ad(:,jl,:,2)
504        END DO
505     END SELECT
506
507      ! 1. standard boundary treatment
508      ! ------------------------------
509
510      IF( PRESENT( cd_mpp ) ) THEN
511         DO jj = nlcj+1, jpj   ! only fill extra allows last line
512            ptab_ad(1:nlci, jj, :) = ptab_ad(1:nlci, nlej, :)
513         END DO
514         DO ji = nlci+1, jpi   ! only fill extra allows last column
515            ptab_ad(ji    , : , :) = ptab_ad(nlei  , :   , :)
516         END DO
517      ELSE     
518
519         !                                        ! North-South boundaries
520         !                                        ! ======================
521          SELECT CASE ( cd_type )
522          CASE ( 'T', 'U', 'V', 'W' )
523             ptab_ad(:,nlcj-jprecj+1:jpj   ,:) = 0.0_wp
524             ptab_ad(:,     1       :jprecj,:) = 0.0_wp
525          CASE ( 'F' )
526             ptab_ad(:,nlcj-jprecj+1:jpj   ,:) = 0.0_wp
527          END SELECT
528
529         !                                        ! East-West boundaries
530         !                                        ! ====================
531         IF( nbondi == 2 .AND.   &      ! Cyclic east-west
532            &   (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
533            ptab_ad( 2   ,:,:) = ptab_ad( 2   ,:,:) + ptab_ad(jpi,:,:)
534            ptab_ad(jpi  ,:,:) = 0
535            ptab_ad(jpim1,:,:) = ptab_ad(jpim1,:,:) + ptab_ad( 1 ,:,:)
536            ptab_ad( 1   ,:,:) = 0
537         ELSE                           ! closed
538            SELECT CASE ( cd_type )
539            CASE ( 'T', 'U', 'V', 'W' )
540               ptab_ad(nlci-jpreci+1:jpi   ,:,:) = 0.e0
541               ptab_ad(     1       :jpreci,:,:) = 0.e0
542            CASE ( 'F' )
543               ptab_ad(nlci-jpreci+1:jpi   ,:,:) = 0.e0
544            END SELECT
545         ENDIF
546
547      ENDIF
548
549   END SUBROUTINE mpp_lnk_3d_adj
550
551   SUBROUTINE mpp_lnk_2d_adj( pt2d_ad, cd_type, psgn, cd_mpp, pval )
552      !!----------------------------------------------------------------------
553      !!                  ***  routine mpp_lnk_2d_adj  ***
554      !!                 
555      !! ** Purpose :   Message passing manadgement for 2d array
556      !!
557      !! ** Method  :   Use mppsend and mpprecv function for passing mask
558      !!      between processors following neighboring subdomains.
559      !!            domain parameters
560      !!                    nlci   : first dimension of the local subdomain
561      !!                    nlcj   : second dimension of the local subdomain
562      !!                    nbondi : mark for "east-west local boundary"
563      !!                    nbondj : mark for "north-south local boundary"
564      !!                    noea   : number for local neighboring processors
565      !!                    nowe   : number for local neighboring processors
566      !!                    noso   : number for local neighboring processors
567      !!                    nono   : number for local neighboring processors
568      !!
569      !!----------------------------------------------------------------------
570      !! * Arguments
571      CHARACTER(len=1) , INTENT( in ) ::   &
572         cd_type       ! define the nature of pt2d_ad array grid-points
573         !             !  = T , U , V , F , W
574         !             !  = S : T-point, north fold treatment
575         !             !  = G : F-point, north fold treatment
576         !             !  = I : sea-ice velocity at F-point with index shift
577      REAL(wp), INTENT( in ) ::   &
578         psgn          ! control of the sign change
579         !             !   = -1. , the sign is changed if north fold boundary
580         !             !   =  1. , the sign is kept  if north fold boundary
581      REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) ::   &
582         pt2d_ad          ! 2D array on which the boundary condition is applied
583      CHARACTER(len=3), INTENT( in ), OPTIONAL ::    &
584         cd_mpp        ! fill the overlap area only
585      REAL(wp)        , INTENT(in   ), OPTIONAL           ::   pval      ! background value (used at closed boundaries)
586                                                                         ! only here for compatibility
587
588      !! * Local variables
589      INTEGER  ::   ji, jj, jl      ! dummy loop indices
590      INTEGER  ::   &
591         imigr, iihom, ijhom,    &  ! temporary integers
592         iloc, ijt, iju             !    "          "
593      INTEGER  ::   ml_req1, ml_req2, ml_err     ! for key_mpi_isend
594      INTEGER  ::   ml_stat(MPI_STATUS_SIZE)     ! for key_mpi_isend
595      !!----------------------------------------------------------------------
596
597
598      ! 5. East and west directions exchange
599      ! ------------------------------------
600
601      SELECT CASE ( npolj )
602
603      CASE ( 3, 4, 5, 6 )
604
605         ! 5.3 Write Dirichlet lateral conditions
606
607         iihom = nlci-jpreci
608
609         SELECT CASE ( nbondi)
610         CASE ( -1 )
611            DO jl = 1, jpreci
612               t2we_ad(:,jl,1)     = pt2d_ad(iihom+jl,:)
613               pt2d_ad(iihom+jl,:) = 0.0_wp
614            END DO
615         CASE ( 0 ) 
616            DO jl = 1, jpreci
617               t2we_ad(:,jl,1)     = pt2d_ad(iihom+jl,:)
618               pt2d_ad(iihom+jl,:) = 0.0_wp
619               t2ew_ad(:,jl,1)     = pt2d_ad(jl      ,:)
620               pt2d_ad(jl      ,:) = 0.0_wp
621            END DO
622         CASE ( 1 )
623            DO jl = 1, jpreci
624               t2ew_ad(:,jl,1)     = pt2d_ad(jl      ,:)
625               pt2d_ad(jl      ,:) = 0.0_wp
626            END DO
627         END SELECT
628
629         ! 5.2 Migrations
630
631#if defined key_mpp_shmem
632error "key_mpp_shmem not support in nemovar"
633#elif defined key_mpp_mpi
634         !! MPI version
635
636         imigr=jpreci*jpj
637 
638       SELECT CASE ( nbondi )
639         CASE ( -1 )
640            CALL mppsend( 2, t2we_ad(1,1,1), imigr, noea, ml_req1 )
641            CALL mpprecv( 1, t2ew_ad(1,1,2), imigr )
642            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
643         CASE ( 0 )
644            CALL mppsend( 1, t2ew_ad(1,1,1), imigr, nowe, ml_req1 )
645            CALL mppsend( 2, t2we_ad(1,1,1), imigr, noea, ml_req2 )
646            CALL mpprecv( 1, t2ew_ad(1,1,2), imigr )
647            CALL mpprecv( 2, t2we_ad(1,1,2), imigr )
648            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
649            IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
650         CASE ( 1 )
651            CALL mppsend( 1, t2ew_ad(1,1,1), imigr, nowe, ml_req1 )
652            CALL mpprecv( 2, t2we_ad(1,1,2), imigr )
653            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
654         END SELECT
655#endif
656
657         ! 5.1 Read Dirichlet lateral conditions
658
659         SELECT CASE ( nbondi )
660
661         CASE ( -1, 0, 1 )
662            iihom = nlci-nreci 
663            DO jl = 1, jpreci
664               DO jj=1, jpj
665                  pt2d_ad(iihom +jl,jj) = pt2d_ad(iihom +jl,jj) + t2ew_ad(jj,jl,2)
666                  pt2d_ad(jpreci+jl,jj) = pt2d_ad(jpreci+jl,jj) + t2we_ad(jj,jl,2)
667               END DO
668            END DO
669
670         END SELECT
671
672      END SELECT    ! npolj
673     
674
675      ! 4. north fold treatment
676      ! -----------------------
677
678      IF (PRESENT(cd_mpp)) THEN
679         ! No north fold treatment (it is assumed to be already OK)
680     
681      ELSE     
682
683      ! 4.1 treatment without exchange (jpni odd)
684      !     T-point pivot 
685
686      SELECT CASE ( jpni )
687
688      CASE ( 1 )  ! only one proc along I, no mpp exchange
689
690         SELECT CASE ( npolj )
691 
692         CASE ( 3 , 4 )    ! T pivot
693            iloc = jpiglo - 2 * ( nimpp - 1 )
694
695            SELECT CASE ( cd_type )
696
697            CASE ( 'T' , 'S', 'W' )
698               DO ji = nlci, nlci/2+1, -1
699                  ijt=iloc-ji+2
700                  pt2d_ad(ijt,nlcj-1) =        pt2d_ad(ijt,nlcj-1) &
701                     &                + psgn * pt2d_ad(ji ,nlcj-1)
702                  pt2d_ad(ji ,nlcj-1) = 0.0_wp
703               END DO
704               DO ji = nlci, 2, -1
705                  ijt=iloc-ji+2
706                  pt2d_ad(ijt,nlcj-2) =        pt2d_ad(ijt,nlcj-2) &
707                     &                + psgn * pt2d_ad(ji ,nlcj  ) 
708                  pt2d_ad(ji, nlcj  ) = 0.0_wp
709               END DO
710         
711            CASE ( 'U' )
712               DO ji = nlci-1, nlci/2, -1
713                  iju=iloc-ji+1
714                  pt2d_ad(iju,nlcj-1) =        pt2d_ad(iju,nlcj-1) &
715                     &                + psgn * pt2d_ad(ji ,nlcj-1)
716                  pt2d_ad(ji ,nlcj-1) = 0.0_wp
717               END DO
718               DO ji = nlci-1, 1, -1
719                  iju=iloc-ji+1
720                  pt2d_ad(iju,nlcj-2) =        pt2d_ad(iju,nlcj-2) &
721                     &                + psgn * pt2d_ad(ji ,nlcj  )
722                  pt2d_ad(ji ,nlcj  ) = 0.0_wp
723               END DO
724
725            CASE ( 'V' )
726               DO ji = nlci, 2, -1 
727                  ijt=iloc-ji+2
728                  pt2d_ad(ijt,nlcj-3) =        pt2d_ad(ijt,nlcj-3) &
729                     &                + psgn * pt2d_ad(ji ,nlcj  )
730                  pt2d_ad(ji ,nlcj  ) = 0.0_wp
731                  pt2d_ad(ijt,nlcj-2) =        pt2d_ad(ijt,nlcj-2) &
732                     &                + psgn * pt2d_ad(ji ,nlcj-1)
733                  pt2d_ad(ji ,nlcj-1) = 0.0_wp
734               END DO
735
736            CASE ( 'F', 'G' )
737               DO ji = nlci-1, 1, -1
738                  iju=iloc-ji+1
739                  pt2d_ad(iju,nlcj-3) =        pt2d_ad(iju,nlcj-3) &
740                     &                + psgn * pt2d_ad(ji ,nlcj  )
741                  pt2d_ad(ji ,nlcj  ) = 0.0_wp
742                  pt2d_ad(iju,nlcj-2) =        pt2d_ad(iju,nlcj-2) &
743                     &                + psgn * pt2d_ad(ji ,nlcj-1)
744                  pt2d_ad(ji ,nlcj-1) = 0.0_wp
745               END DO
746
747            CASE ( 'I' )                                  ! ice U-V point
748               DO ji = nlci, 3, -1
749                  iju = iloc - ji + 3
750                  pt2d_ad(iju,nlcj-1) = pt2d_ad(iju,nlcj-1) + psgn * pt2d_ad(ji,nlcj)
751                  pt2d_ad(ji,nlcj)    = 0.0_wp
752               END DO
753               pt2d_ad(3,nlcj-1) = pt2d_ad(3,nlcj-1) + psgn * pt2d_ad(2,nlcj)
754               pt2d_ad(2,nlcj)   = 0.0_wp
755 
756          END SELECT
757       
758         CASE ( 5 , 6 ) ! F pivot
759            iloc=jpiglo-2*(nimpp-1)
760 
761            SELECT CASE ( cd_type )
762
763            CASE ( 'T' , 'S', 'W' )
764               DO ji = nlci, 1, -1
765                  ijt=iloc-ji+1
766                  pt2d_ad(ijt,nlcj-1) =        pt2d_ad(ijt,nlcj-1) &
767                     &                + psgn * pt2d_ad(ji ,nlcj  ) 
768                  pt2d_ad(ji ,nlcj  ) = 0.0_wp
769               END DO
770
771            CASE ( 'U' )
772               DO ji = nlci-1, 1, -1
773                  iju=iloc-ji
774                  pt2d_ad(iju,nlcj-1) =        pt2d_ad(iju,nlcj-1) &
775                     &                + psgn * pt2d_ad(ji ,nlcj  )
776                  pt2d_ad(ji ,nlcj  ) = 0.0_wp
777               END DO
778
779            CASE ( 'V' )
780               DO ji = nlci, nlci/2+1, -1
781                  ijt=iloc-ji+1
782                  pt2d_ad(ijt,nlcj-1) =        pt2d_ad(ijt,nlcj-1) &
783                     &                + psgn * pt2d_ad(ji ,nlcj-1)
784                  pt2d_ad(ji ,nlcj-1) = 0.0_wp
785               END DO
786               DO ji = nlci, 1, -1
787                  ijt=iloc-ji+1
788                  pt2d_ad(ijt,nlcj-2) =        pt2d_ad(ijt,nlcj-2) &
789                     &                + psgn * pt2d_ad(ji ,nlcj  ) 
790                  pt2d_ad(ji, nlcj  ) = 0.0_wp
791               END DO
792
793            CASE ( 'F', 'G' )
794               DO ji = nlci-1, nlci/2+1, -1
795                  iju=iloc-ji
796                  pt2d_ad(iju,nlcj-1) =        pt2d_ad(iju,nlcj-1) &
797                     &                + psgn * pt2d_ad(ji ,nlcj-1)
798                  pt2d_ad(ji ,nlcj-1) = 0.0_wp
799               END DO
800               DO ji = nlci-1, 1, -1
801                  iju=iloc-ji
802                  pt2d_ad(iju,nlcj-2) =        pt2d_ad(iju,nlcj-2) &
803                     &                + psgn * pt2d_ad(ji ,nlcj  )
804                  pt2d_ad(ji ,nlcj  ) = 0.0_wp
805               END DO
806
807            CASE ( 'I' )                                  ! ice U-V point
808               DO ji = nlci-1, 2 , -1
809                  ijt = iloc - ji + 2
810                  pt2d_ad(ji,nlcj-1)  = pt2d_ad(ji,nlcj-1)  +  0.5 * pt2d_ad(ji,nlcj)
811                  pt2d_ad(ijt,nlcj-1) = pt2d_ad(ijt,nlcj-1) + psgn * pt2d_ad(ji,nlcj)
812                  pt2d_ad(ji,nlcj)    = 0.0_wp
813               END DO
814               pt2d_ad( 2 ,nlcj) = 0.0_wp
815 
816            END SELECT  ! cd_type
817
818         END SELECT     !  npolj
819 
820         pt2d_ad(nlci,nlcj) = 0.e0
821         pt2d_ad( 1  ,nlcj) = 0.e0
822
823      CASE DEFAULT ! more than 1 proc along I
824         IF ( npolj /= 0 ) CALL mpp_lbc_north_adj (pt2d_ad, cd_type, psgn)  ! only for northern procs.
825
826      END SELECT ! jpni
827
828      ENDIF
829
830      ! 3. North and south directions
831      ! -----------------------------
832
833      ! 3.3 Write Dirichlet lateral conditions
834
835      ijhom = nlcj-jprecj
836
837      t2ns_ad(:,:,:) = 0.0_wp
838      t2sn_ad(:,:,:) = 0.0_wp
839
840      SELECT CASE ( nbondj )
841      CASE ( -1 )
842         DO jl = 1, jprecj
843            t2sn_ad(:,jl,1)     = pt2d_ad(:,ijhom+jl)
844            pt2d_ad(:,ijhom+jl) = 0.0_wp
845         END DO
846      CASE ( 0 ) 
847         DO jl = 1, jprecj
848            t2sn_ad(:,jl,1)     = pt2d_ad(:,ijhom+jl) 
849            pt2d_ad(:,ijhom+jl) = 0.0_wp
850            t2ns_ad(:,jl,1)     = pt2d_ad(:,jl      )
851            pt2d_ad(:,jl      ) = 0.0_wp
852         END DO
853      CASE ( 1 )
854         DO jl = 1, jprecj
855            t2ns_ad(:,jl,1) = pt2d_ad(:,jl)
856            pt2d_ad(:,jl)   = 0.0_wp
857         END DO
858      END SELECT
859
860      ! 3.2 Migrations
861
862#if defined key_mpp_shmem
863error "key_mpp_shmem not support in nemovar"
864#elif defined key_mpp_mpi
865      !! * Local variables   (MPI version)
866 
867      imigr=jprecj*jpi
868
869      SELECT CASE ( nbondj )     
870      CASE ( -1 )
871         CALL mppsend( 4, t2sn_ad(1,1,1), imigr, nono, ml_req1 )
872         CALL mpprecv( 3, t2ns_ad(1,1,2), imigr )
873         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
874      CASE ( 0 )
875         CALL mppsend( 3, t2ns_ad(1,1,1), imigr, noso, ml_req1 )
876         CALL mppsend( 4, t2sn_ad(1,1,1), imigr, nono, ml_req2 )
877         CALL mpprecv( 3, t2ns_ad(1,1,2), imigr )
878         CALL mpprecv( 4, t2sn_ad(1,1,2), imigr )
879         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
880         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
881      CASE ( 1 ) 
882         CALL mppsend( 3, t2ns_ad(1,1,1), imigr, noso, ml_req1 )
883         CALL mpprecv( 4, t2sn_ad(1,1,2), imigr )
884         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
885      END SELECT
886
887#endif
888
889      ! 3.1 Read Dirichlet lateral conditions
890
891      IF( nbondj /= 2 ) THEN
892         ijhom = nlcj-nrecj
893         DO jl = 1, jprecj
894            DO ji = 1, jpi
895               pt2d_ad(ji,ijhom +jl) = pt2d_ad(ji,ijhom +jl) + t2ns_ad(ji,jl,2) 
896               pt2d_ad(ji,jprecj+jl) = pt2d_ad(ji,jprecj+jl) + t2sn_ad(ji,jl,2)
897            END DO
898         END DO
899      ENDIF
900
901      ! 2. East and west directions exchange
902      ! ------------------------------------
903
904      ! 2.3 Write Dirichlet lateral conditions
905
906      iihom = nlci-jpreci
907
908      SELECT CASE ( nbondi )
909      CASE ( -1 )
910         DO jl = 1, jpreci
911            t2we_ad(:,jl,1) = pt2d_ad(iihom+jl,:)
912            pt2d_ad(iihom+jl,:)=0.0_wp
913         END DO
914      CASE ( 0 ) 
915         DO jl = 1, jpreci
916            t2we_ad(:,jl,1) = pt2d_ad(iihom+jl,:)
917            pt2d_ad(iihom+jl,:)=0.0_wp
918            t2ew_ad(:,jl,1) = pt2d_ad(jl      ,:)
919            pt2d_ad(jl      ,:)=0.0_wp
920         END DO
921      CASE ( 1 )
922         DO jl = 1, jpreci
923            t2ew_ad(:,jl,1) = pt2d_ad(jl      ,:)
924            pt2d_ad(jl      ,:)=0.0_wp
925         END DO
926      END SELECT
927     
928      ! 2.2 Migrations
929
930#if defined key_mpp_shmem
931error "key_mpp_shmem not support in nemovar"
932#elif defined key_mpp_mpi
933      !! * Local variables   (MPI version)
934
935      imigr = jpreci * jpj
936
937      SELECT CASE ( nbondi ) 
938      CASE ( -1 )
939         CALL mppsend( 2, t2we_ad(1,1,1), imigr, noea, ml_req1 )
940         CALL mpprecv( 1, t2ew_ad(1,1,2), imigr )
941         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
942      CASE ( 0 )
943         CALL mppsend( 1, t2ew_ad(1,1,1), imigr, nowe, ml_req1 )
944         CALL mppsend( 2, t2we_ad(1,1,1), imigr, noea, ml_req2 )
945         CALL mpprecv( 1, t2ew_ad(1,1,2), imigr )
946         CALL mpprecv( 2, t2we_ad(1,1,2), imigr )
947         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
948         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
949      CASE ( 1 )
950         CALL mppsend( 1, t2ew_ad(1,1,1), imigr, nowe, ml_req1 )
951         CALL mpprecv( 2, t2we_ad(1,1,2), imigr )
952         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
953      END SELECT
954#endif
955
956      ! 2.1 Read Dirichlet lateral conditions
957
958      SELECT CASE ( nbondi )
959      CASE ( -1, 0, 1 )    ! all exept 2
960         iihom = nlci-nreci
961         DO jl = 1, jpreci
962            pt2d_ad(iihom +jl,:) = pt2d_ad(iihom +jl,:) + t2ew_ad(:,jl,2)
963            pt2d_ad(jpreci+jl,:) = pt2d_ad(jpreci+jl,:) + t2we_ad(:,jl,2)
964         END DO
965      END SELECT
966
967      ! 1. standard boundary treatment
968      ! ------------------------------
969
970      IF( PRESENT( cd_mpp ) ) THEN
971         DO jj = nlcj+1, jpj   ! only fill extra allows last line
972            pt2d_ad(1:nlci, jj) = pt2d_ad(1:nlci, nlej)
973         END DO
974         DO ji = nlci+1, jpi   ! only fill extra allows last column
975            pt2d_ad(ji    , : ) = pt2d_ad(nlei  , :   )
976         END DO
977      ELSE     
978
979         !                                        ! East-West boundaries
980         !                                        ! ====================
981         IF( nbondi == 2 .AND.   &      ! Cyclic east-west
982            &   (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
983            pt2d_ad( 2   ,:) = pt2d_ad( 2   ,:) + pt2d_ad(jpi,:)
984            pt2d_ad(jpi  ,:) = 0
985            pt2d_ad(jpim1,:) = pt2d_ad(jpim1,:) + pt2d_ad( 1 ,:)
986            pt2d_ad( 1   ,:) = 0
987
988         ELSE                           ! closed
989            SELECT CASE ( cd_type )
990            CASE ( 'T', 'U', 'V', 'W' )
991               pt2d_ad(nlci-jpreci+1:jpi   ,:) = 0.e0
992               pt2d_ad(     1       :jpreci,:) = 0.e0
993            CASE ( 'F' )
994               pt2d_ad(nlci-jpreci+1:jpi   ,:) = 0.e0
995            END SELECT
996         ENDIF
997
998         !                                        ! North-South boundaries
999         !                                        ! ======================
1000         SELECT CASE ( cd_type )
1001         CASE ( 'T', 'U', 'V', 'W' )
1002            pt2d_ad(:,nlcj-jprecj+1:jpj   ) = 0.e0
1003            pt2d_ad(:,     1       :jprecj) = 0.e0
1004         CASE ( 'F' )
1005            pt2d_ad(:,nlcj-jprecj+1:jpj   ) = 0.e0
1006         END SELECT
1007     
1008      ENDIF
1009
1010   END SUBROUTINE mpp_lnk_2d_adj
1011
1012   SUBROUTINE mpp_lnk_3d_gather_adj( ptab1_ad, cd_type1, ptab2_ad, cd_type2, psgn )
1013      !!-----------------------------------------------------------------------
1014      !!
1015      !! ***  ROUTINE mpp_lnk_3d_gather_adj : ADJOINT OF ROUTINE mpp_lnk_3d_gather  ***
1016      !!
1017      !! ** Purpose of direct routine   : Message passing manadgement for two
1018      !!              3D arrays
1019      !!
1020      !! ** Method of direct routine    : Use mppsend and mpprecv function for
1021      !!              passing mask between processors following neighboring
1022      !!              subdomains.
1023      !!
1024      !! ** Comments on Adjoint Routine :
1025      !!
1026      !! ** Action  : ptab_ad1 and ptab_ad2  with update value at its periphery
1027      !!                   
1028      !! References :
1029      !!
1030      !! History :
1031      !!        ! 07-07 (K. Mogensen) skeleton
1032      !!        ! 09-03 (A. Vidard) nemo V3
1033      !!-----------------------------------------------------------------------
1034      !! * Modules used
1035      !! * Arguments
1036      CHARACTER(len=1) , INTENT( in ) ::   &
1037         cd_type1, cd_type2       ! define the nature of ptab_ad array grid-points
1038         !                        ! = T , U , V , F , W points
1039         !                        ! = S : T-point, north fold treatment ???
1040         !                        ! = G : F-point, north fold treatment ???
1041      REAL(wp), INTENT( in ) ::   &
1042         psgn          ! control of the sign change
1043         !             !   = -1. , the sign is changed if north fold boundary
1044         !             !   =  1. , the sign is kept  if north fold boundary
1045      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) ::   &
1046         ptab1_ad, ptab2_ad             ! 3D array on which the boundary condition is applied
1047      !! * Local variables
1048      INTEGER ::   ji, jk, jl   ! dummy loop indices
1049      INTEGER ::   imigr, iihom, ijhom, iloc, ijt, iju   ! temporary integers
1050      INTEGER ::   ml_req1, ml_req2, ml_err     ! for key_mpi_isend
1051      INTEGER ::   ml_stat(MPI_STATUS_SIZE)     ! for key_mpi_isend
1052      !!----------------------------------------------------------------------
1053
1054      CALL ctl_stop('mpp_lnk_3d_gather_adj is not done yet')
1055
1056   END SUBROUTINE mpp_lnk_3d_gather_adj
1057
1058   SUBROUTINE mpp_lnk_2d_e_adj( pt2d_ad, cd_type, psgn, cd_mpp, pval )
1059      !!----------------------------------------------------------------------
1060      !!                  ***  routine mpp_lnk_2d_e_adj  ***
1061      !!                 
1062      !! ** Purpose of the direct routine:
1063      !!                Message passing manadgement for 2d array (with halo)
1064      !!
1065      !! ** Method  :   Use mppsend and mpprecv function for passing mask
1066      !!      between processors following neighboring subdomains.
1067      !!            domain parameters
1068      !!                    nlci   : first dimension of the local subdomain
1069      !!                    nlcj   : second dimension of the local subdomain
1070      !!                    jpr2di : number of rows for extra outer halo
1071      !!                    jpr2dj : number of columns for extra outer halo
1072      !!                    nbondi : mark for "east-west local boundary"
1073      !!                    nbondj : mark for "north-south local boundary"
1074      !!                    noea   : number for local neighboring processors
1075      !!                    nowe   : number for local neighboring processors
1076      !!                    noso   : number for local neighboring processors
1077      !!                    nono   : number for local neighboring processors
1078      !!   
1079      !! History of the direct routine:
1080      !!       
1081      !!   9.0  !  05-09  (R. Benshila, G. Madec)  original code
1082      !!
1083      !! History of the adjoint routine:
1084      !!       
1085      !!   9.0  !  09-03  (A. Vidard) Adjoint of the 05-09 version
1086      !!
1087      !!----------------------------------------------------------------------
1088      !! * Arguments
1089      CHARACTER(len=1) , INTENT( in ) ::   &
1090         cd_type       ! define the nature of pt2d_ad array grid-points
1091         !             !  = T , U , V , F , W
1092         !             !  = S : T-point, north fold treatment
1093         !             !  = G : F-point, north fold treatment
1094         !             !  = I : sea-ice velocity at F-point with index shift
1095      REAL(wp), INTENT( in ) ::   &
1096         psgn          ! control of the sign change
1097         !             !   = -1. , the sign is changed if north fold boundary
1098         !             !   =  1. , the sign is kept  if north fold boundary
1099      REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) ::   &
1100         pt2d_ad          ! 2D array on which the boundary condition is applied
1101      CHARACTER(len=3), INTENT( in ), OPTIONAL ::    &
1102         cd_mpp        ! fill the overlap area only
1103      REAL(wp)        , INTENT(in   ), OPTIONAL           ::   pval      ! background value (used at closed boundaries)
1104                                                                         ! only here for compatibility
1105
1106      !! * Local variables
1107      INTEGER  ::   ji, jj, jl      ! dummy loop indices
1108      INTEGER  ::   &
1109         imigr, iihom, ijhom,    &  ! temporary integers
1110         iloc, ijt, iju             !    "          "
1111      INTEGER  ::   ml_req1, ml_req2, ml_err     ! for key_mpi_isend
1112      INTEGER  ::   ml_stat(MPI_STATUS_SIZE)     ! for key_mpi_isend
1113      INTEGER :: ipreci, iprecj
1114      !!----------------------------------------------------------------------
1115
1116      ! take into account outer extra 2D overlap area
1117      ipreci = jpreci + jpr2di
1118      iprecj = jprecj + jpr2dj
1119
1120      ! 5. East and west directions exchange
1121      ! ------------------------------------
1122
1123      SELECT CASE ( npolj )
1124
1125      CASE ( 3, 4, 5, 6 )
1126
1127         ! 5.3 Write Dirichlet lateral conditions
1128
1129         iihom = nlci-jpreci
1130
1131         SELECT CASE ( nbondi)
1132         CASE ( -1 )
1133            DO jl = ipreci, 1, -1
1134               tr2we_ad(:,jl,1)     = pt2d_ad(iihom+jl,:)
1135               pt2d_ad(iihom+jl,:)  = 0.0_wp
1136            END DO
1137         CASE ( 0 ) 
1138            DO jl = ipreci, 1, -1
1139               tr2we_ad(:,jl,1)      = pt2d_ad(iihom+jl,:)
1140               pt2d_ad(iihom+jl,:)   = 0.0_wp
1141               tr2ew_ad(:,jl,1)      = pt2d_ad(jl- jpr2di,:)
1142               pt2d_ad(jl- jpr2di,:) = 0.0_wp
1143            END DO
1144         CASE ( 1 )
1145            DO jl = ipreci, 1, -1
1146               tr2ew_ad(:,jl,1)     = pt2d_ad(jl-jpr2di,:)
1147               pt2d_ad(jl-jpr2di,:) = 0.0_wp
1148            END DO
1149         END SELECT
1150
1151         ! 5.2 Migrations
1152
1153#if defined key_mpp_shmem
1154error "key_mpp_shmem not support in nemovar"
1155#elif defined key_mpp_mpi
1156         !! MPI version
1157
1158         imigr=ipreci* ( jpj + 2*jpr2dj )
1159 
1160         SELECT CASE ( nbondi )
1161         CASE ( -1 )
1162            CALL mppsend( 2, tr2we_ad(1-jpr2dj,1,1), imigr, noea, ml_req1 )
1163            CALL mpprecv( 1, tr2ew_ad(1-jpr2dj,1,2), imigr )
1164            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1165         CASE ( 0 )
1166            CALL mppsend( 1, tr2ew_ad(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
1167            CALL mppsend( 2, tr2we_ad(1-jpr2dj,1,1), imigr, noea, ml_req2 )
1168            CALL mpprecv( 1, tr2ew_ad(1-jpr2dj,1,2), imigr )
1169            CALL mpprecv( 2, tr2we_ad(1-jpr2dj,1,2), imigr )
1170            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1171            IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1172         CASE ( 1 )
1173            CALL mppsend( 1, tr2ew_ad(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
1174            CALL mpprecv( 2, tr2we_ad(1-jpr2dj,1,2), imigr )
1175            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1176         END SELECT 
1177#endif
1178
1179         ! 5.1 Read Dirichlet lateral conditions
1180
1181         SELECT CASE ( nbondi )
1182
1183         CASE ( -1, 0, 1 )
1184            iihom = nlci-nreci -jpr2di
1185            DO jl = 1, ipreci
1186               pt2d_ad(iihom +jl,:) = pt2d_ad(iihom +jl,:) + tr2ew_ad(:,jl,2)
1187               pt2d_ad(jpreci+jl,:) = pt2d_ad(jpreci+jl,:) + tr2we_ad(:,jl,2)
1188            END DO
1189
1190         END SELECT
1191
1192      END SELECT    ! npolj
1193     
1194
1195      ! 4. north fold treatment
1196      ! -----------------------
1197
1198      ! 4.1 treatment without exchange (jpni odd)
1199      !     T-point pivot 
1200
1201      SELECT CASE ( jpni )
1202
1203      CASE ( 1 )  ! only one proc along I, no mpp exchange
1204
1205         SELECT CASE ( npolj )
1206 
1207         CASE ( 3 , 4 )    ! T pivot
1208            iloc = jpiglo - 2 * ( nimpp - 1 )
1209
1210            SELECT CASE ( cd_type )
1211
1212            CASE ( 'T' , 'S', 'W' )
1213               DO ji = nlci+jpr2di, nlci/2+1, -1
1214                  ijt=iloc-ji+2
1215                  pt2d_ad(ijt,nlcj-1) =        pt2d_ad(ijt,nlcj-1) &
1216                     &                + psgn * pt2d_ad(ji ,nlcj-1)
1217                  pt2d_ad(ji ,nlcj-1) = 0.0_wp
1218               END DO
1219               DO jl = iprecj-1, 0, -1
1220                  DO ji = nlci+jpr2di, 2-jpr2di, -1
1221                     ijt=iloc-ji+2
1222                     pt2d_ad(ijt,nlcj-2-jl) =        pt2d_ad(ijt,nlcj-2-jl) &
1223                        &                   + psgn * pt2d_ad(ji ,nlcj+jl  ) 
1224                     pt2d_ad(ji, nlcj+jl)   = 0.0_wp
1225                  END DO
1226               END DO
1227         
1228            CASE ( 'U' )
1229               DO ji = nlci-1+jpr2di, nlci/2, -1
1230                  iju=iloc-ji+1
1231                  pt2d_ad(iju,nlcj-1) =        pt2d_ad(iju,nlcj-1) &
1232                     &                + psgn * pt2d_ad(ji ,nlcj-1)
1233                  pt2d_ad(ji ,nlcj-1) = 0.0_wp
1234               END DO
1235               DO jl =iprecj-1, 0, -1
1236                  DO ji = nlci-1-jpr2di, 1-jpr2di, -1
1237                     iju=iloc-ji+1
1238                     pt2d_ad(iju,nlcj-2-jl) =        pt2d_ad(iju,nlcj-2-jl) &
1239                        &                   + psgn * pt2d_ad(ji ,nlcj+jl)
1240                     pt2d_ad(ji ,nlcj+jl)   = 0.0_wp
1241                  END DO
1242               END DO
1243
1244            CASE ( 'V' )
1245               DO jl = iprecj-1, -1, -1
1246                  DO ji = nlci+jpr2di, 2-jpr2di, -1
1247                     ijt=iloc-ji+2
1248                     pt2d_ad(ijt,nlcj-3-jl) =        pt2d_ad(ijt,nlcj-3-jl) &
1249                        &                   + psgn * pt2d_ad(ji ,nlcj+jl  )
1250                     pt2d_ad(ji ,nlcj+jl  ) = 0.0_wp
1251                  END DO
1252               END DO
1253
1254            CASE ( 'F', 'G' )
1255               DO jl = iprecj-1, -1, -1
1256                  DO ji = nlci-1+jpr2di, 1-jpr2di, -1
1257                     iju=iloc-ji+1
1258                     pt2d_ad(iju,nlcj-3-jl) =        pt2d_ad(iju,nlcj-3-jl) &
1259                        &                   + psgn * pt2d_ad(ji ,nlcj+jl)
1260                     pt2d_ad(ji ,nlcj+jl)   = 0.0_wp
1261                  END DO
1262               END DO
1263
1264            CASE ( 'I' )                                  ! ice U-V point
1265               DO jl = iprecj-1, 0, -1
1266                  DO ji = nlci+jpr2di, 3, -1
1267                     iju = iloc - ji + 3
1268                     pt2d_ad(iju,nlcj-1-jl) = pt2d_ad(iju,nlcj-1-jl) + psgn * pt2d_ad(ji,nlcj+jl)
1269                     pt2d_ad(ji,nlcj+jl)    = 0.0_wp
1270                  END DO
1271                  pt2d_ad(3,nlcj-1-jl)      = pt2d_ad(3,nlcj-1-jl) + psgn * pt2d_ad(2,nlcj+jl)
1272                  pt2d_ad(2,nlcj+jl)        = 0.0_wp
1273               END DO
1274   
1275          END SELECT
1276       
1277         CASE ( 5 , 6 ) ! F pivot
1278            iloc=jpiglo-2*(nimpp-1)
1279 
1280            SELECT CASE ( cd_type )
1281
1282            CASE ( 'T' , 'S', 'W' )
1283               DO jl = iprecj-1, 0, -1
1284                  DO ji = nlci+jpr2di, 1-jpr2di, -1
1285                     ijt=iloc-ji+1
1286                     pt2d_ad(ijt,nlcj-1-jl) =        pt2d_ad(ijt,nlcj-1-jl) &
1287                        &                   + psgn * pt2d_ad(ji ,nlcj+jl) 
1288                     pt2d_ad(ji ,nlcj+jl)   = 0.0_wp
1289                  END DO
1290               END DO
1291
1292            CASE ( 'U' )
1293              DO jl = iprecj-1, 0, -1
1294                 DO ji = nlci-1+jpr2di, 1-jpr2di, -1
1295                    iju=iloc-ji
1296                    pt2d_ad(iju,nlcj-1-jl) =        pt2d_ad(iju,nlcj-1-jl) &
1297                       &                   + psgn * pt2d_ad(ji ,nlcj + jl)
1298                    pt2d_ad(ji ,nlcj+jl)   = 0.0_wp
1299                 END DO
1300              END DO
1301
1302            CASE ( 'V' )
1303               DO ji = nlci+jpr2di, nlci/2+1, -1
1304                  ijt=iloc-ji+1
1305                  pt2d_ad(ijt,nlcj-1) =        pt2d_ad(ijt,nlcj-1) &
1306                     &                + psgn * pt2d_ad(ji ,nlcj-1)
1307                  pt2d_ad(ji ,nlcj-1) = 0.0_wp
1308               END DO
1309               DO jl = iprecj-1, 0, -1
1310                  DO ji =  nlci+jpr2di, 1-jpr2di, -1
1311                     ijt=iloc-ji+1
1312                     pt2d_ad(ijt,nlcj-2-jl) =        pt2d_ad(ijt,nlcj-2-jl) &
1313                        &                   + psgn * pt2d_ad(ji ,nlcj+jl) 
1314                     pt2d_ad(ji, nlcj+jl)   = 0.0_wp
1315                  END DO
1316               END DO
1317
1318            CASE ( 'F', 'G' )
1319               DO ji = nlci-1+jpr2di, nlci/2+1, -1
1320                  iju=iloc-ji
1321                  pt2d_ad(iju,nlcj-1) =        pt2d_ad(iju,nlcj-1) &
1322                     &                + psgn * pt2d_ad(ji ,nlcj-1)
1323                  pt2d_ad(ji ,nlcj-1) = 0.0_wp
1324               END DO
1325               DO jl =  iprecj-1, 0, -1
1326                  DO ji = nlci-1+jpr2di, 1-jpr2di, -1
1327                     iju=iloc-ji
1328                     pt2d_ad(iju,nlcj-2-jl) =        pt2d_ad(iju,nlcj-2-jl) &
1329                        &                   + psgn * pt2d_ad(ji ,nlcj+jl)
1330                     pt2d_ad(ji ,nlcj+jl)   = 0.0_wp
1331                  END DO
1332               END DO
1333            CASE ( 'I' )                                  ! ice U-V point
1334               DO jl = iprecj-1,0, -1
1335                  DO ji = nlci-1+jpr2di, 2, -1
1336                     ijt = iloc - ji + 2
1337                     pt2d_ad(ji,nlcj-1-jl)  = pt2d_ad(ji,nlcj-1-jl)  + 0.5  * pt2d_ad(ji,nlcj+jl)
1338                     pt2d_ad(ijt,nlcj-1-jl) = pt2d_ad(ijt,nlcj-1-jl) + psgn * pt2d_ad(ji,nlcj+jl)
1339                     pt2d_ad(ji,nlcj+jl)    = 0.0_wp
1340                  END DO
1341               END DO
1342               pt2d_ad( 2 ,nlcj) = 0.0_wp
1343              END SELECT  ! cd_type
1344
1345         END SELECT     !  npolj
1346 
1347      CASE DEFAULT ! more than 1 proc along I
1348         IF ( npolj /= 0 ) CALL mpp_lbc_north_adj (pt2d_ad, cd_type, psgn)  ! only for northern procs.
1349
1350      END SELECT ! jpni
1351
1352      ! 3. North and south directions
1353      ! -----------------------------
1354
1355      ! 3.3 Write Dirichlet lateral conditions
1356
1357      ijhom = nlcj-jprecj
1358
1359      tr2ns_ad(:,:,:) = 0.0_wp
1360      tr2sn_ad(:,:,:) = 0.0_wp
1361
1362      SELECT CASE ( nbondj )
1363      CASE ( -1 )
1364         DO jl = 1, iprecj
1365            tr2sn_ad(:,jl,1   ) = pt2d_ad(:,ijhom+jl)
1366            pt2d_ad(:,ijhom+jl) = 0.0_wp
1367         END DO
1368      CASE ( 0 ) 
1369         DO jl = 1, iprecj
1370            tr2ns_ad(:,jl,1    ) = pt2d_ad(:,jl-jpr2dj)
1371            pt2d_ad(:,jl-jpr2dj) = 0.0_wp
1372            tr2sn_ad(:,jl,1    ) = pt2d_ad(:,ijhom+jl ) 
1373            pt2d_ad(:,ijhom+jl ) = 0.0_wp
1374         END DO
1375      CASE ( 1 )
1376         DO jl = 1, iprecj
1377            tr2ns_ad(:,jl,1    ) = pt2d_ad(:,jl-jpr2dj)
1378            pt2d_ad(:,jl-jpr2dj) = 0.0_wp
1379         END DO
1380      END SELECT
1381
1382      ! 3.2 Migrations
1383
1384#if defined key_mpp_shmem
1385error "key_mpp_shmem not support in nemovar"
1386#elif defined key_mpp_mpi
1387      !! * Local variables   (MPI version)
1388 
1389      imigr = iprecj * ( jpi + 2*jpr2di )
1390
1391      SELECT CASE ( nbondj )
1392      CASE ( -1 )
1393         CALL mppsend( 4, tr2sn_ad(1-jpr2di,1,1), imigr, nono, ml_req1 )
1394         CALL mpprecv( 3, tr2ns_ad(1-jpr2di,1,2), imigr )
1395         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1396      CASE ( 0 )
1397         CALL mppsend( 3, tr2ns_ad(1-jpr2di,1,1), imigr, noso, ml_req1 )
1398         CALL mppsend( 4, tr2sn_ad(1-jpr2di,1,1), imigr, nono, ml_req2 )
1399         CALL mpprecv( 3, tr2ns_ad(1-jpr2di,1,2), imigr )
1400         CALL mpprecv( 4, tr2sn_ad(1-jpr2di,1,2), imigr )
1401         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1402         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1403      CASE ( 1 )
1404         CALL mppsend( 3, tr2ns_ad(1-jpr2di,1,1), imigr, noso, ml_req1 )
1405         CALL mpprecv( 4, tr2sn_ad(1-jpr2di,1,2), imigr )
1406         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1407      END SELECT
1408
1409#endif
1410
1411      ! 3.1 Read Dirichlet lateral conditions
1412
1413      IF( nbondj /= 2 ) THEN
1414         ijhom = nlcj-nrecj-jpr2dj
1415         DO jl = 1, iprecj
1416            pt2d_ad(:,ijhom +jl) = pt2d_ad(:,ijhom +jl) + tr2ns_ad(:,jl,2) 
1417            pt2d_ad(:,jprecj+jl) = pt2d_ad(:,jprecj+jl) + tr2sn_ad(:,jl,2)
1418         END DO
1419      ENDIF
1420
1421      ! 2. East and west directions exchange
1422      ! ------------------------------------
1423
1424      ! 2.3 Write Dirichlet lateral conditions
1425
1426      iihom = nlci-jpreci
1427
1428      SELECT CASE ( nbondi )
1429      CASE ( -1 )
1430         DO jl = 1, ipreci
1431            tr2we_ad(:,jl,1) = pt2d_ad( iihom+jl,:)
1432            pt2d_ad( iihom+jl,:)=0.0_wp
1433         END DO
1434      CASE ( 0 ) 
1435         DO jl = 1, ipreci
1436            tr2we_ad(:,jl,1) = pt2d_ad( iihom+jl,:)
1437            pt2d_ad( iihom+jl,:)=0.0_wp
1438            tr2ew_ad(:,jl,1) = pt2d_ad(jl-jpr2di,:)
1439            pt2d_ad(jl-jpr2di,:)=0.0_wp
1440         END DO
1441      CASE ( 1 )
1442         DO jl = 1, ipreci
1443            tr2ew_ad(:,jl,1) = pt2d_ad(jl-jpr2di,:)
1444            pt2d_ad(jl-jpr2di,:)=0.0_wp
1445         END DO
1446      END SELECT
1447     
1448      ! 2.2 Migrations
1449
1450#if defined key_mpp_shmem
1451error "key_mpp_shmem not support in nemovar"
1452#elif defined key_mpp_mpi
1453      !! * Local variables   (MPI version)
1454
1455      imigr = ipreci * ( jpj + 2*jpr2dj)
1456
1457      SELECT CASE ( nbondi )
1458      CASE ( -1 )
1459         CALL mppsend( 2, tr2we_ad(1-jpr2dj,1,1), imigr, noea, ml_req1 )
1460         CALL mpprecv( 1, tr2ew_ad(1-jpr2dj,1,2), imigr )
1461         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1462      CASE ( 0 )
1463         CALL mppsend( 1, tr2ew_ad(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
1464         CALL mppsend( 2, tr2we_ad(1-jpr2dj,1,1), imigr, noea, ml_req2 )
1465         CALL mpprecv( 1, tr2ew_ad(1-jpr2dj,1,2), imigr )
1466         CALL mpprecv( 2, tr2we_ad(1-jpr2dj,1,2), imigr )
1467         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1468         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1469      CASE ( 1 )
1470         CALL mppsend( 1, tr2ew_ad(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
1471         CALL mpprecv( 2, tr2we_ad(1-jpr2dj,1,2), imigr )
1472         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1473      END SELECT
1474#endif
1475
1476      ! 2.1 Read Dirichlet lateral conditions
1477
1478      SELECT CASE ( nbondi )
1479      CASE ( -1, 0, 1 )    ! all exept 2
1480         iihom = nlci-nreci-jpr2di
1481         DO jl = 1, ipreci
1482            pt2d_ad(iihom +jl,:) = pt2d_ad(iihom +jl,:) + tr2ew_ad(:,jl,2)
1483            pt2d_ad(jpreci+jl,:) = pt2d_ad(jpreci+jl,:) + tr2we_ad(:,jl,2)
1484         END DO
1485      END SELECT
1486
1487      ! 1. standard boundary treatment
1488      ! ------------------------------
1489
1490
1491      !                                        ! North-South boundaries
1492      !                                        ! ======================
1493      SELECT CASE ( cd_type )
1494      CASE ( 'T', 'U', 'V', 'W' , 'I' )
1495         pt2d_ad(:,nlcj-jprecj+1:jpj+jpr2dj) = 0.e0
1496         pt2d_ad(:,  1-jpr2dj   :  jprecj  ) = 0.e0
1497      CASE ( 'F' )
1498         pt2d_ad(:,nlcj-jprecj+1:jpj+jpr2dj ) = 0.e0
1499      END SELECT
1500
1501      !                                        ! East-West boundaries
1502      !                                        ! ====================
1503      IF( nbondi == 2 .AND.   &      ! Cyclic east-west
1504    &   (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1505     pt2d_ad(     2      :2+jpr2di,:) = pt2d_ad(     2      :2+jpr2di,:) + pt2d_ad(   jpi  :jpi+jpr2di,:)
1506     pt2d_ad(    jpi   :jpi+jpr2di,:) = 0
1507     pt2d_ad(jpim1-jpr2di:  jpim1 ,:) = pt2d_ad(jpim1-jpr2di:  jpim1 ,:) + pt2d_ad(1-jpr2di:     1    ,:)
1508     pt2d_ad(1-jpr2di:      1     ,:) = 0
1509
1510      ELSE                           ! closed
1511    SELECT CASE ( cd_type )
1512    CASE ( 'T', 'U', 'V', 'W' , 'I' )
1513       pt2d_ad(nlci-jpreci+1:jpi+jpr2di,:) = 0.e0
1514       pt2d_ad(  1-jpr2di   :jpreci    ,:) = 0.e0
1515    CASE ( 'F' )
1516       pt2d_ad(nlci-jpreci+1:jpi+jpr2di,:) = 0.e0
1517    END SELECT
1518      ENDIF
1519     
1520   END SUBROUTINE mpp_lnk_2d_e_adj
1521
1522   SUBROUTINE mpp_lbc_north_3d_adj ( pt3d_ad, cd_type, psgn )
1523      !!-----------------------------------------------------------------------
1524      !!
1525      !! ** ROUTINE mpp_lbc_northadj_3d : ADJOINT OF ROUTINE mpp_lbc_north_3d  ***
1526      !!
1527      !! ** Purpose of direct routine   : Ensure proper north fold horizontal
1528      !!              bondary condition in mpp configuration in case of
1529      !!              jpn1 > 1 (for 3d array)
1530      !!
1531      !! ** Method of direct routine    : Gather the 4 northern lines of the
1532      !!              global domain on 1 processor and  apply lbc north-fold
1533      !!              on this sub array. Then scatter the fold array back
1534      !!              to the processors.
1535      !!
1536      !! ** Comments on Adjoint Routine :
1537      !!
1538      !! ** Action  :
1539      !!                   
1540      !! References :
1541      !!
1542      !! History :
1543      !!        ! 07-11 (K. Mogensen) Initial version
1544      !!        ! 09-03 (A. Vidard) V3
1545      !!-----------------------------------------------------------------------
1546      !! * Arguments
1547      CHARACTER(len=1), INTENT( in ) ::   &
1548         cd_type       ! nature of pt3d_ad grid-points
1549         !             !   = T ,  U , V , F or W  gridpoints
1550      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) ::   &
1551         pt3d_ad          ! 3D array on which the boundary condition is applied
1552      REAL(wp), INTENT( in ) ::   &
1553         psgn          ! control of the sign change
1554         !             !   = -1. , the sign is changed if north fold boundary
1555         !             !   =  1. , the sign is kept  if north fold boundary
1556
1557      !! * Local declarations
1558      INTEGER :: ji, jj, jk, jr, jproc
1559      INTEGER :: ierr
1560      INTEGER :: ildi,ilei,iilb
1561      INTEGER :: ijpj,ijpjm1,ij,ijt,iju
1562      INTEGER :: itaille
1563      REAL(wp), DIMENSION(jpiglo,4,jpk) :: ztabad
1564      REAL(wp), DIMENSION(jpi,4,jpk,jpni) :: znorthgloioad
1565      REAL(wp), DIMENSION(jpi,4,jpk) :: znorthlocad
1566
1567      ! If we get in this routine it s because : North fold condition and mpp with more
1568      !   than one proc across i : we deal only with the North condition
1569      znorthlocad(  :,:,:  )=0.0_wp   
1570      znorthgloioad(:,:,:,:)=0.0_wp   
1571
1572      ! 0. Sign setting
1573      ! ---------------
1574
1575      ijpj=4
1576      ijpjm1=3
1577     
1578      ! put in znorthlocad the last 4 jlines of pt3d_ad
1579      DO jk = 1, jpk 
1580         DO jj = nlcj - ijpj +1, nlcj
1581            ij = jj - nlcj + ijpj
1582            znorthlocad(:,ij,jk) = pt3d_ad(:,jj,jk)
1583         END DO
1584      END DO
1585     
1586
1587      IF (npolj /= 0 ) THEN
1588         ! Build in proc 0 of ncomm_north the znorthgloioad
1589         
1590#ifdef key_mpp_shmem
1591         not done : compiler error
1592#elif defined key_mpp_mpi
1593         itaille=jpi*jpk*ijpj
1594         CALL mpi_gather(znorthlocad,itaille,mpivar,znorthgloioad,itaille,mpivar,0,ncomm_north,ierr)
1595#endif
1596
1597      ENDIF
1598     
1599      IF (narea == north_root+1 ) THEN
1600       ! recover the global north array
1601         ztabad(:,:,:) = 0_wp
1602         
1603         DO jr = 1, ndim_rank_north
1604            jproc = nrank_north(jr) + 1
1605            ildi  = nldit (jproc)
1606            ilei  = nleit (jproc)
1607            iilb  = nimppt(jproc)
1608            DO jk = 1, jpk 
1609                DO jj = 1, ijpj
1610                  DO ji = ildi, ilei
1611                     ztabad(ji+iilb-1,jj,jk) = znorthgloioad(ji,jj,jk,jr)
1612                     znorthgloioad(ji,jj,jk,jr)=0.0_wp
1613                  END DO
1614               END DO
1615            END DO
1616         END DO
1617         
1618         ! 2. North-Fold boundary conditions
1619         ! ----------------------------------
1620         
1621         SELECT CASE ( npolj )
1622           
1623         CASE ( 3 , 4 )    ! T pivot
1624           
1625            SELECT CASE ( cd_type )
1626               
1627            CASE ( 'T' , 'S', 'W' )
1628               DO jk = jpk, 1, -1
1629                  DO ji = jpiglo, jpiglo/2+1, -1
1630                     ijt=jpiglo-ji+2
1631                     ztabad(ijt,ijpj-1,jk) =        ztabad(ijt,ijpj-1,jk) &
1632                        &                  + psgn * ztabad(ji ,ijpj-1,jk)
1633                     ztabad(ji ,ijpj-1,jk) = 0.0_wp
1634                  END DO
1635                  DO ji = jpiglo, 2, -1
1636                     ijt=jpiglo-ji+2
1637                     ztabad(ijt,ijpj-2,jk) =        ztabad(ijt,ijpj-2,jk) &
1638                        &                  + psgn * ztabad(ji ,ijpj  ,jk) 
1639                     ztabad(ji, ijpj,  jk) = 0.0_wp
1640                  END DO
1641               END DO
1642               
1643            CASE ( 'U' )
1644               DO jk = jpk, 1, -1
1645                  DO ji = jpiglo-1, jpiglo/2, -1
1646                     iju=jpiglo-ji+1
1647                     ztabad(iju,ijpj-1,jk) =        ztabad(iju,ijpj-1,jk) &
1648                        &                  + psgn * ztabad(ji ,ijpj-1,jk)
1649                     ztabad(ji ,ijpj-1,jk) = 0.0_wp
1650                  END DO
1651                  DO ji = jpiglo-1, 1, -1
1652                     iju=jpiglo-ji+1
1653                     ztabad(iju,ijpj-2,jk) =        ztabad(iju,ijpj-2,jk) &
1654                        &                  + psgn * ztabad(ji ,ijpj  ,jk)
1655                     ztabad(ji ,ijpj  ,jk) = 0.0_wp
1656                  END DO
1657               END DO
1658
1659            CASE ( 'V' )
1660               DO jk = jpk, 1, -1
1661                  DO ji = jpiglo, 2, -1 
1662                     ijt=jpiglo-ji+2
1663                     ztabad(ijt,ijpj-3,jk) =        ztabad(ijt,ijpj-3,jk) &
1664                        &                  + psgn * ztabad(ji ,ijpj  ,jk)
1665                     ztabad(ji ,ijpj  ,jk) = 0.0_wp
1666                     ztabad(ijt,ijpj-2,jk) =        ztabad(ijt,ijpj-2,jk) &
1667                        &                  + psgn * ztabad(ji ,ijpj-1,jk)
1668                     ztabad(ji ,ijpj-1,jk) = 0.0_wp
1669                  END DO
1670               END DO
1671
1672            CASE ( 'F', 'G' )
1673               DO jk = jpk, 1, -1
1674                  DO ji = jpiglo-1, 1, -1
1675                     iju=jpiglo-ji+1
1676                     ztabad(iju,ijpj-3,jk) =        ztabad(iju,ijpj-3,jk) &
1677                        &                  + psgn * ztabad(ji ,ijpj  ,jk)
1678                     ztabad(ji ,ijpj  ,jk) = 0.0_wp
1679                     ztabad(iju,ijpj-2,jk) =        ztabad(iju,ijpj-2,jk) &
1680                        &                  + psgn * ztabad(ji ,ijpj-1,jk)
1681                     ztabad(ji ,ijpj-1,jk) = 0.0_wp
1682                  END DO
1683               END DO
1684 
1685            END SELECT
1686
1687            ztabad( 1    ,ijpj,:) = 0.0_wp
1688            ztabad(jpiglo,ijpj,:) = 0.0_wp 
1689     
1690         CASE ( 5 , 6 ) ! F pivot
1691           
1692            SELECT CASE ( cd_type )
1693               
1694            CASE ( 'T' , 'S', 'W' )
1695               DO jk = jpk, 1, -1
1696                  DO ji = jpiglo, 1, -1
1697                     ijt=jpiglo-ji+1
1698                     ztabad(ijt,ijpj-1,jk) =        ztabad(ijt,ijpj-1,jk) &
1699                        &                  + psgn * ztabad(ji ,ijpj  ,jk) 
1700                     ztabad(ji ,ijpj  ,jk) = 0.0_wp
1701                  END DO
1702               END DO
1703
1704            CASE ( 'U' )
1705               DO jk = jpk, 1, -1
1706                  DO ji = jpiglo-1, 1, -1
1707                     iju=jpiglo-ji
1708                     ztabad(iju,ijpj-1,jk) =        ztabad(iju,ijpj-1,jk) &
1709                        &                  + psgn * ztabad(ji ,ijpj  ,jk)
1710                     ztabad(ji ,ijpj  ,jk) = 0.0_wp
1711                  END DO
1712               END DO
1713
1714            CASE ( 'V' )
1715               DO jk = jpk, 1, -1
1716                  DO ji = jpiglo, jpiglo/2+1, -1
1717                     ijt=jpiglo-ji+1
1718                     ztabad(ijt,ijpj-1,jk) =        ztabad(ijt,ijpj-1,jk) &
1719                        &                  + psgn * ztabad(ji ,ijpj-1,jk)
1720                     ztabad(ji ,ijpj-1,jk) = 0.0_wp
1721                  END DO
1722                  DO ji = jpiglo, 1, -1
1723                     ijt=jpiglo-ji+1
1724                     ztabad(ijt,ijpj-2,jk) =        ztabad(ijt,ijpj-2,jk) &
1725                        &                  + psgn * ztabad(ji ,ijpj  ,jk) 
1726                     ztabad(ji, ijpj  ,jk) = 0.0_wp
1727                  END DO
1728               END DO
1729
1730            CASE ( 'F', 'G' )
1731               DO jk = jpk, 1, -1
1732                  DO ji = jpiglo-1, jpiglo/2+1, -1
1733                     iju=jpiglo-ji
1734                     ztabad(iju,ijpj-1,jk) =        ztabad(iju,ijpj-1,jk) &
1735                        &                  + psgn * ztabad(ji ,ijpj-1,jk)
1736                     ztabad(ji ,ijpj-1,jk) = 0.0_wp
1737                  END DO
1738                  DO ji = jpiglo-1, 1, -1
1739                     iju=jpiglo-ji
1740                     ztabad(iju,ijpj-2,jk) =        ztabad(iju,ijpj-2,jk) &
1741                        &                  + psgn * ztabad(ji ,ijpj  ,jk)
1742                     ztabad(ji ,ijpj  ,jk) = 0.0_wp
1743                  END DO
1744               END DO
1745            END SELECT  ! cd_type
1746
1747            ztabad(jpiglo,ijpj,:) = 0.e0
1748            ztabad( 1  ,ijpj,:) = 0.e0
1749
1750         CASE DEFAULT                           ! *  closed
1751
1752            SELECT CASE ( cd_type) 
1753
1754            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
1755               ztabad(:, 1  ,jk) = 0.e0
1756               ztabad(:,ijpj,jk) = 0.e0
1757
1758            CASE ( 'F' )                               ! F-point
1759               ztabad(:,ijpj,jk) = 0.e0
1760
1761            END SELECT
1762           
1763         END SELECT     !  npolj
1764
1765         !! Scatter back to pt3d_ad
1766         DO jr = 1, ndim_rank_north
1767            jproc=nrank_north(jr)+1
1768            ildi=nldit (jproc)
1769            ilei=nleit (jproc)
1770            iilb=nimppt(jproc)
1771            DO jk=  1, jpk
1772                DO jj=1,4
1773                  DO ji=ildi,ilei
1774                     znorthgloioad(ji,jj,jk,jr)=ztabad(ji+iilb-1,jj,jk)
1775                  END DO
1776               END DO
1777            END DO
1778         END DO
1779         
1780      ENDIF      ! only done on proc 0 of ncomm_north
1781
1782#ifdef key_mpp_shmem
1783      not done yet in shmem : compiler error
1784#elif key_mpp_mpi
1785      IF ( npolj /= 0 ) THEN
1786         itaille=jpi*jpk*ijpj
1787         CALL mpi_scatter(znorthgloioad,itaille,mpivar,znorthlocad,itaille,mpivar,0,ncomm_north,ierr)
1788      ENDIF
1789#endif
1790
1791      ! put in the last ijpj jlines of pt3d_ad znorthlocad
1792      DO jk = 1 , jpk 
1793         DO jj = nlcj - ijpj + 1 , nlcj
1794            ij = jj - nlcj + ijpj
1795            pt3d_ad(:,jj,jk)= znorthlocad(:,ij,jk)
1796         END DO
1797      END DO
1798       
1799   END SUBROUTINE mpp_lbc_north_3d_adj
1800
1801   SUBROUTINE mpp_lbc_north_2d_adj ( pt2d_ad, cd_type, psgn )
1802      !!-----------------------------------------------------------------------
1803      !!
1804      !! ** ROUTINE mpp_lbc_north_2d_adj : ADJOINT OF ROUTINE mpp_lbc_north_2d  ***
1805      !!
1806      !! ** Purpose of direct routine   : Ensure proper north fold horizontal
1807      !!              bondary condition in mpp configuration in case of
1808      !!              jpn1 > 1 (for 2d array)
1809      !!
1810      !! ** Method of direct routine    : Gather the 4 northern lines of the
1811      !!              global domain on 1 processor and  apply lbc north-fold
1812      !!              on this sub array. Then scatter the fold array back
1813      !!              to the processors.
1814      !!
1815      !! ** Comments on Adjoint Routine :
1816      !!
1817      !! ** Action  :
1818      !!                   
1819      !! References :
1820      !!
1821      !! History :
1822      !!        ! 07-11 (K. Mogensen) Initial version
1823      !!        ! 09-03 (A. Vidard) nemo V3
1824      !!-----------------------------------------------------------------------
1825      !! * Arguments
1826      CHARACTER(len=1), INTENT( in ) ::   &
1827         cd_type       ! nature of pt2d_ad grid-points
1828         !             !   = T ,  U , V , F or W  gridpoints
1829      REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) ::   &
1830         pt2d_ad          ! 2D array on which the boundary condition is applied
1831      REAL(wp), INTENT( in ) ::   &
1832         psgn          ! control of the sign change
1833         !             !   = -1. , the sign is changed if north fold boundary
1834         !             !   =  1. , the sign is kept  if north fold boundary
1835
1836      !! * Local declarations
1837      INTEGER :: ji, jj, jk, jr, jproc
1838      INTEGER :: ierr
1839      INTEGER :: ildi,ilei,iilb
1840      INTEGER :: ijpj,ijpjm1,ij,ijt,iju
1841      INTEGER :: itaille
1842      REAL(wp), DIMENSION(jpiglo,4) :: ztabad
1843      REAL(wp), DIMENSION(jpi,4,jpni) :: znorthgloioad
1844      REAL(wp), DIMENSION(jpi,4) :: znorthlocad
1845
1846      ! If we get in this routine it s because : North fold condition and mpp with more
1847      !   than one proc across i : we deal only with the North condition
1848     
1849      ! 0. Sign setting
1850      ! ---------------
1851     
1852      ijpj=4
1853      ijpjm1=3
1854     
1855      znorthlocad(    :,:) = 0.0_wp
1856      znorthgloioad(:,:,:) = 0.0_wp
1857 
1858      ! put in znorthlocad the last 4 jlines of pt2d_ad
1859      DO jj = nlcj - ijpj +1, nlcj
1860         ij = jj - nlcj + ijpj
1861         znorthlocad(:,ij)=pt2d_ad(:,jj)
1862      END DO
1863     
1864      IF (npolj /= 0 ) THEN
1865         ! Build in proc 0 of ncomm_north the znorthgloioad
1866#ifdef key_mpp_shmem
1867         not done : compiler error
1868#elif defined key_mpp_mpi
1869         itaille=jpi*ijpj
1870         CALL MPI_GATHER(znorthlocad,itaille,mpivar,znorthgloioad,itaille,mpivar,0,ncomm_north,ierr)
1871#endif
1872      ENDIF
1873     
1874      IF (narea == north_root+1 ) THEN
1875       ! recover the global north array
1876         ztabad(:,:) = 0_wp
1877         
1878         DO jr = 1, ndim_rank_north
1879            jproc=nrank_north(jr)+1
1880            ildi=nldit (jproc)
1881            ilei=nleit (jproc)
1882            iilb=nimppt(jproc)
1883            DO jj=1,ijpj
1884               DO ji=ildi,ilei
1885                  ztabad(ji+iilb-1,jj)=znorthgloioad(ji,jj,jr)
1886                  znorthgloioad(ji,jj,jr)=0.0_wp
1887               END DO
1888            END DO
1889         END DO
1890         
1891       
1892         ! 2. North-Fold boundary conditions
1893         ! ----------------------------------
1894         
1895         SELECT CASE ( npolj )
1896 
1897         CASE ( 3 , 4 )    ! T pivot
1898
1899            SELECT CASE ( cd_type )
1900
1901            CASE ( 'T' , 'S', 'W' )
1902               DO ji = jpiglo, jpiglo/2+1, -1
1903                  ijt=jpiglo-ji+2
1904                  ztabad(ijt,ijpj-1) =        ztabad(ijt,ijpj-1) &
1905                     &               + psgn * ztabad(ji ,ijpj-1)
1906                  ztabad(ji ,ijpj-1) = 0.0_wp
1907               END DO
1908               DO ji = jpiglo, 2, -1
1909                  ijt=jpiglo-ji+2
1910                  ztabad(ijt,ijpj-2) =        ztabad(ijt,ijpj-2) &
1911                     &               + psgn * ztabad(ji ,ijpj  ) 
1912                  ztabad(ji, ijpj  ) = 0.0_wp
1913               END DO
1914         
1915            CASE ( 'U' )
1916               DO ji = jpiglo-1, jpiglo/2, -1
1917                  iju=jpiglo-ji+1
1918                  ztabad(iju,ijpj-1) =        ztabad(iju,ijpj-1) &
1919                     &               + psgn * ztabad(ji ,ijpj-1)
1920                  ztabad(ji ,ijpj-1) = 0.0_wp
1921               END DO
1922               DO ji = jpiglo-1, 1, -1
1923                  iju=jpiglo-ji+1
1924                  ztabad(iju,ijpj-2) =        ztabad(iju,ijpj-2) &
1925                     &               + psgn * ztabad(ji ,ijpj  )
1926                  ztabad(ji ,ijpj  ) = 0.0_wp
1927               END DO
1928
1929            CASE ( 'V' )
1930               DO ji = jpiglo, 2, -1 
1931                  ijt=jpiglo-ji+2
1932                  ztabad(ijt,ijpj-3) =        ztabad(ijt,ijpj-3) &
1933                     &               + psgn * ztabad(ji ,ijpj  )
1934                  ztabad(ji ,ijpj  ) = 0.0_wp
1935                  ztabad(ijt,ijpj-2) =        ztabad(ijt,ijpj-2) &
1936                     &               + psgn * ztabad(ji ,ijpj-1)
1937                  ztabad(ji ,ijpj-1) = 0.0_wp
1938               END DO
1939
1940            CASE ( 'F', 'G' )
1941               DO ji = jpiglo-1, 1, -1
1942                  iju=jpiglo-ji+1
1943                  ztabad(iju,ijpj-3) =        ztabad(iju,ijpj-3) &
1944                     &               + psgn * ztabad(ji ,ijpj  )
1945                  ztabad(ji ,ijpj  ) = 0.0_wp
1946                  ztabad(iju,ijpj-2) =        ztabad(iju,ijpj-2) &
1947                     &               + psgn * ztabad(ji ,ijpj-1)
1948                  ztabad(ji ,ijpj-1) = 0.0_wp
1949               END DO
1950 
1951          END SELECT
1952
1953          ztabad(jpiglo,ijpj) = 0.e0
1954          ztabad( 1  ,ijpj)   = 0.e0
1955       
1956         CASE ( 5 , 6 ) ! F pivot
1957 
1958            SELECT CASE ( cd_type )
1959
1960            CASE ( 'T' , 'S', 'W' )
1961               DO ji = jpiglo, 1, -1
1962                  ijt=jpiglo-ji+1
1963                  ztabad(ijt,ijpj-1) =        ztabad(ijt,ijpj-1) &
1964                     &               + psgn * ztabad(ji ,ijpj  ) 
1965                  ztabad(ji ,ijpj  ) = 0.0_wp
1966               END DO
1967
1968            CASE ( 'U' )
1969               DO ji = jpiglo-1, 1, -1
1970                  iju=jpiglo-ji
1971                  ztabad(iju,ijpj-1) =        ztabad(iju,ijpj-1) &
1972                     &               + psgn * ztabad(ji ,ijpj  )
1973                     ztabad(ji ,ijpj  ) = 0.0_wp
1974               END DO
1975
1976            CASE ( 'V' )
1977               DO ji = jpiglo, jpiglo/2+1, -1
1978                  ijt=jpiglo-ji+1
1979                  ztabad(ijt,ijpj-1) =        ztabad(ijt,ijpj-1) &
1980                     &               + psgn * ztabad(ji ,ijpj-1)
1981                  ztabad(ji ,ijpj-1) = 0.0_wp
1982               END DO
1983               DO ji = jpiglo, 1, -1
1984                  ijt=jpiglo-ji+1
1985                  ztabad(ijt,ijpj-2) =        ztabad(ijt,ijpj-2) &
1986                     &               + psgn * ztabad(ji ,ijpj  ) 
1987                  ztabad(ji, ijpj  ) = 0.0_wp
1988               END DO
1989
1990            CASE ( 'F', 'G' )
1991               DO ji = jpiglo-1, jpiglo/2+1, -1
1992                  iju=jpiglo-ji
1993                  ztabad(iju,ijpj-1) =        ztabad(iju,ijpj-1) &
1994                     &               + psgn * ztabad(ji ,ijpj-1)
1995                  ztabad(ji ,ijpj-1) = 0.0_wp
1996               END DO
1997               DO ji = jpiglo-1, 1, -1
1998                  iju=jpiglo-ji
1999                  ztabad(iju,ijpj-2) =        ztabad(iju,ijpj-2) &
2000                     &               + psgn * ztabad(ji ,ijpj  )
2001                  ztabad(ji ,ijpj  ) = 0.0_wp
2002               END DO
2003            END SELECT  ! cd_type
2004
2005            ztabad(jpiglo,ijpj) = 0.e0
2006            ztabad( 1  ,ijpj) = 0.e0
2007
2008         END SELECT     !  npolj
2009       
2010         !     End of slab
2011         !     ===========
2012
2013         !! Scatter back to pt2d_ad
2014         DO jr = 1, ndim_rank_north
2015            jproc=nrank_north(jr)+1
2016            ildi=nldit (jproc)
2017            ilei=nleit (jproc)
2018            iilb=nimppt(jproc)
2019            DO jj=1,4
2020               DO ji=ildi,ilei
2021                  znorthgloioad(ji,jj,jr)=ztabad(ji+iilb-1,jj)
2022               END DO
2023            END DO
2024         END DO
2025
2026      ENDIF      ! only done on proc 0 of ncomm_north
2027
2028#ifdef key_mpp_shmem
2029      not done yet in shmem : compiler error
2030#elif key_mpp_mpi
2031      IF ( npolj /= 0 ) THEN
2032         itaille=jpi*ijpj
2033         CALL mpi_scatter(znorthgloioad,itaille,mpivar,znorthlocad,itaille,mpivar,0,ncomm_north,ierr)
2034      ENDIF
2035#endif
2036
2037      ! put in the last ijpj jlines of pt2d_ad znorthlocad
2038      DO jj = nlcj - ijpj + 1 , nlcj
2039         ij = jj - nlcj + ijpj
2040         pt2d_ad(:,jj)= znorthlocad(:,ij)
2041      END DO
2042
2043   END SUBROUTINE mpp_lbc_north_2d_adj
2044
2045#if defined key_ecmwf_dynmem   
2046   SUBROUTINE lib_mpp_alloc_adj     
2047      !!---------------------------------------------------------------------
2048      !!                   ***  routine lib_mpp_alloc_adj  ***     
2049      !!       
2050      !! ** Purpose :: Allocate memory for dynamic memory version     
2051      !!     
2052      !! ** Method  ::       
2053      !!       
2054      !! History :: 08/10 :: K. Mogensen initial version     
2055      !!     
2056      !!---------------------------------------------------------------------
2057      ALLOCATE( &         
2058         & t3ns_ad(jpi,jprecj,jpk,2), &         
2059         & t3sn_ad(jpi,jprecj,jpk,2), &         
2060         & t3ew_ad(jpj,jpreci,jpk,2), &         
2061         & t3we_ad(jpj,jpreci,jpk,2), &         
2062         & t2ns_ad(jpi,jprecj,2), &         
2063         & t2sn_ad(jpi,jprecj,2), &         
2064         & t2ew_ad(jpj,jpreci,2), &         
2065         & t2we_ad(jpj,jpreci,2), &         
2066         & tr2ns_ad(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2), &         
2067         & tr2sn_ad(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2), &         
2068         & tr2ew_ad(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2), &         
2069         & tr2we_ad(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2)  &         
2070         & )   
2071   END SUBROUTINE lib_mpp_alloc_adj
2072#endif
2073#else
2074   !!----------------------------------------------------------------------
2075   !!   Default case:            Dummy module        share memory computing
2076   !!----------------------------------------------------------------------
2077#endif
2078END MODULE lib_mpp_tam
Note: See TracBrowser for help on using the repository browser.