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.
mpp_lnk_generic.h90 in NEMO/trunk/src/OCE/LBC – NEMO

source: NEMO/trunk/src/OCE/LBC/mpp_lnk_generic.h90 @ 13982

Last change on this file since 13982 was 13982, checked in by smasson, 3 years ago

trunk: merge dev_r13923_Tiling_Cleanup_MPI3_LoopFusion into the trunk

  • Property svn:keywords set to Id
  • Property svn:mime-type set to text/x-fortran
File size: 21.1 KB
Line 
1#if defined MULTI
2#   define NAT_IN(k)                cd_nat(k)   
3#   define SGN_IN(k)                psgn(k)
4#   define F_SIZE(ptab)             kfld
5#   define OPT_K(k)                 ,ipf
6#   if defined DIM_2d
7#      if defined SINGLE_PRECISION
8#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_sp)                , INTENT(inout) ::   ptab(f)
9#      else
10#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_dp)                , INTENT(inout) ::   ptab(f)
11#      endif
12#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j)
13#      define K_SIZE(ptab)             1
14#      define L_SIZE(ptab)             1
15#   endif
16#   if defined DIM_3d
17#      if defined SINGLE_PRECISION
18#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_sp)                , INTENT(inout) ::   ptab(f)
19#      else
20#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_dp)                , INTENT(inout) ::   ptab(f)
21#      endif
22#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k)
23#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3)
24#      define L_SIZE(ptab)             1
25#   endif
26#   if defined DIM_4d
27#      if defined SINGLE_PRECISION
28#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_sp)                , INTENT(inout) ::   ptab(f)
29#      else
30#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_dp)                , INTENT(inout) ::   ptab(f)
31#      endif
32#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l)
33#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3)
34#      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4)
35#   endif
36#else
37#   if defined SINGLE_PRECISION
38#      define ARRAY_TYPE(i,j,k,l,f)    REAL(sp)                    , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f)
39#   else
40#      define ARRAY_TYPE(i,j,k,l,f)    REAL(dp)                    , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f)
41#   endif
42#   define NAT_IN(k)                cd_nat
43#   define SGN_IN(k)                psgn
44#   define F_SIZE(ptab)             1
45#   define OPT_K(k)                 
46#   if defined DIM_2d
47#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j)
48#      define K_SIZE(ptab)          1
49#      define L_SIZE(ptab)          1
50#   endif
51#   if defined DIM_3d
52#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k)
53#      define K_SIZE(ptab)          SIZE(ptab,3)
54#      define L_SIZE(ptab)          1
55#   endif
56#   if defined DIM_4d
57#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k,l)
58#      define K_SIZE(ptab)          SIZE(ptab,3)
59#      define L_SIZE(ptab)          SIZE(ptab,4)
60#   endif
61#endif
62
63# if defined SINGLE_PRECISION
64#    define PRECISION sp
65#    define SENDROUTINE mppsend_sp
66#    define RECVROUTINE mpprecv_sp
67# else
68#    define PRECISION dp
69#    define SENDROUTINE mppsend_dp
70#    define RECVROUTINE mpprecv_dp
71# endif
72
73#if defined MULTI
74   SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten )
75      INTEGER             , INTENT(in   ) ::   kfld        ! number of pt3d arrays
76#else
77   SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn      , kfillmode, pfillval, lsend, lrecv, ncsten )
78#endif
79      ARRAY_TYPE(:,:,:,:,:)                                        ! array or pointer of arrays on which the boundary condition is applied
80      CHARACTER(len=*)              , INTENT(in   ) ::   cdname      ! name of the calling subroutine
81      CHARACTER(len=1)              , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points
82      REAL(wp)                      , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary
83      INTEGER ,             OPTIONAL, INTENT(in   ) ::   kfillmode   ! filling method for halo over land (default = constant)
84      REAL(wp),             OPTIONAL, INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries)
85      LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in   ) ::   lsend, lrecv  ! communication with other 4 proc
86      LOGICAL,              OPTIONAL, INTENT(in   ) ::   ncsten      ! 5-point or 9-point stencil
87      !
88      INTEGER  ::    ji,  jj,  jk,  jl,  jf      ! dummy loop indices
89      INTEGER  ::   ipi, ipj, ipk, ipl, ipf      ! dimension of the input array
90      INTEGER  ::   isize, ishift, ishift2       ! local integers
91      INTEGER  ::   ireq_we, ireq_ea, ireq_so, ireq_no     ! mpi_request id
92      INTEGER  ::   ierr
93      INTEGER  ::   ifill_we, ifill_ea, ifill_so, ifill_no
94      REAL(wp) ::   zland
95      INTEGER , DIMENSION(MPI_STATUS_SIZE)        ::   istat          ! for mpi_isend
96      REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsnd_we, zrcv_we, zsnd_ea, zrcv_ea   ! east -west  & west - east  halos
97      REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsnd_so, zrcv_so, zsnd_no, zrcv_no   ! north-south & south-north  halos
98      LOGICAL  ::   llsend_we, llsend_ea, llsend_no, llsend_so       ! communication send
99      LOGICAL  ::   llrecv_we, llrecv_ea, llrecv_no, llrecv_so       ! communication receive
100      LOGICAL  ::   lldo_nfd                                     ! do north pole folding
101      !!----------------------------------------------------------------------
102      !
103#if defined key_mpi3
104#   if defined MULTI
105      CALL lbc_lnk_nc    ( cdname,  ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten )
106#   else
107      CALL lbc_lnk_nc_multi(cdname, ptab, cd_nat, psgn, kfillmode=kfillmode, pfillval=pfillval, lsend=lsend, lrecv=lrecv, ncsten=ncsten)
108#   endif
109#else
110
111      ! ----------------------------------------- !
112      !     0. local variables initialization     !
113      ! ----------------------------------------- !
114      !
115      ipk = K_SIZE(ptab)   ! 3rd dimension
116      ipl = L_SIZE(ptab)   ! 4th    -
117      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers)
118      !
119      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
120      !
121      IF     ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN
122         llsend_we = lsend(1)   ;   llsend_ea = lsend(2)   ;   llsend_so = lsend(3)   ;   llsend_no = lsend(4)
123         llrecv_we = lrecv(1)   ;   llrecv_ea = lrecv(2)   ;   llrecv_so = lrecv(3)   ;   llrecv_no = lrecv(4)
124      ELSE IF( PRESENT(lsend) .OR.  PRESENT(lrecv) ) THEN
125         WRITE(ctmp1,*) ' E R R O R : Routine ', cdname, '  is calling lbc_lnk with only one of the two arguments lsend or lrecv'
126         WRITE(ctmp2,*) ' ========== '
127         CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' )
128      ELSE   ! send and receive with every neighbour
129         llsend_we = nbondi ==  1 .OR. nbondi == 0   ! keep for compatibility, should be defined in mppini
130         llsend_ea = nbondi == -1 .OR. nbondi == 0   ! keep for compatibility, should be defined in mppini
131         llsend_so = nbondj ==  1 .OR. nbondj == 0   ! keep for compatibility, should be defined in mppini
132         llsend_no = nbondj == -1 .OR. nbondj == 0   ! keep for compatibility, should be defined in mppini
133         llrecv_we = llsend_we   ;   llrecv_ea = llsend_ea   ;   llrecv_so = llsend_so   ;   llrecv_no = llsend_no
134      END IF
135         
136         
137      lldo_nfd = npolj /= 0                      ! keep for compatibility, should be defined in mppini
138
139      zland = 0._wp                                     ! land filling value: zero by default
140      IF( PRESENT( pfillval ) )   zland = pfillval      ! set land value
141
142      ! define the method we will use to fill the halos in each direction
143      IF(              llrecv_we ) THEN   ;   ifill_we = jpfillmpi
144      ELSEIF(           l_Iperio ) THEN   ;   ifill_we = jpfillperio
145      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_we = kfillmode
146      ELSE                                ;   ifill_we = jpfillcst
147      END IF
148      !
149      IF(              llrecv_ea ) THEN   ;   ifill_ea = jpfillmpi
150      ELSEIF(           l_Iperio ) THEN   ;   ifill_ea = jpfillperio
151      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_ea = kfillmode
152      ELSE                                ;   ifill_ea = jpfillcst
153      END IF
154      !
155      IF(              llrecv_so ) THEN   ;   ifill_so = jpfillmpi
156      ELSEIF(           l_Jperio ) THEN   ;   ifill_so = jpfillperio
157      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_so = kfillmode
158      ELSE                                ;   ifill_so = jpfillcst
159      END IF
160      !
161      IF(              llrecv_no ) THEN   ;   ifill_no = jpfillmpi
162      ELSEIF(           l_Jperio ) THEN   ;   ifill_no = jpfillperio
163      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_no = kfillmode
164      ELSE                                ;   ifill_no = jpfillcst
165      END IF
166      !
167#if defined PRINT_CAUTION
168      !
169      ! ================================================================================== !
170      ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing !
171      ! ================================================================================== !
172      !
173#endif
174      !
175      ! -------------------------------------------------- !
176      !     1. Do east and west MPI exchange if needed     !
177      ! -------------------------------------------------- !
178      !
179      ! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg
180      isize = nn_hls * jpj * ipk * ipl * ipf     
181      !
182      ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent
183      IF( llsend_we )   ALLOCATE( zsnd_we(nn_hls,jpj,ipk,ipl,ipf) )
184      IF( llsend_ea )   ALLOCATE( zsnd_ea(nn_hls,jpj,ipk,ipl,ipf) )
185      IF( llrecv_we )   ALLOCATE( zrcv_we(nn_hls,jpj,ipk,ipl,ipf) )
186      IF( llrecv_ea )   ALLOCATE( zrcv_ea(nn_hls,jpj,ipk,ipl,ipf) )
187      !
188      IF( llsend_we ) THEN   ! copy western side of the inner mpi domain in local temporary array to be sent by MPI
189         ishift = nn_hls
190         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
191            zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf)   ! nn_hls + 1 -> 2*nn_hls
192         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
193      ENDIF
194      !
195      IF(llsend_ea  ) THEN   ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI
196         ishift = jpi - 2 * nn_hls
197         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
198            zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf)   ! jpi - 2*nn_hls + 1 -> jpi - nn_hls
199         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
200      ENDIF
201      !
202      IF( ln_timing ) CALL tic_tac(.TRUE.)
203      !
204      ! non-blocking send of the western/eastern side using local temporary arrays
205      IF( llsend_we )   CALL SENDROUTINE( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we )
206      IF( llsend_ea )   CALL SENDROUTINE( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea )
207      ! blocking receive of the western/eastern halo in local temporary arrays
208      IF( llrecv_we )   CALL RECVROUTINE( 2, zrcv_we(1,1,1,1,1), isize, nowe )
209      IF( llrecv_ea )   CALL RECVROUTINE( 1, zrcv_ea(1,1,1,1,1), isize, noea )
210      !
211      IF( ln_timing ) CALL tic_tac(.FALSE.)
212      !
213      !
214      ! ----------------------------------- !
215      !     2. Fill east and west halos     !
216      ! ----------------------------------- !
217      !
218      ! 2.1 fill weastern halo
219      ! ----------------------
220      ! ishift = 0                         ! fill halo from ji = 1 to nn_hls
221      SELECT CASE ( ifill_we )
222      CASE ( jpfillnothing )               ! no filling
223      CASE ( jpfillmpi   )                 ! use data received by MPI
224         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
225            ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf)   ! 1 -> nn_hls
226         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
227      CASE ( jpfillperio )                 ! use east-weast periodicity
228         ishift2 = jpi - 2 * nn_hls
229         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
230            ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
231         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
232      CASE ( jpfillcopy  )                 ! filling with inner domain values
233         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
234            ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf)
235         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
236      CASE ( jpfillcst   )                 ! filling with constant value
237         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
238            ARRAY_IN(ji,jj,jk,jl,jf) = zland
239         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
240      END SELECT
241      !
242      ! 2.2 fill eastern halo
243      ! ---------------------
244      ishift = jpi - nn_hls                ! fill halo from ji = jpi-nn_hls+1 to jpi
245      SELECT CASE ( ifill_ea )
246      CASE ( jpfillnothing )               ! no filling
247      CASE ( jpfillmpi   )                 ! use data received by MPI
248         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
249            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf)   ! jpi - nn_hls + 1 -> jpi
250         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
251      CASE ( jpfillperio )                 ! use east-weast periodicity
252         ishift2 = nn_hls
253         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
254            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
255         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
256      CASE ( jpfillcopy  )                 ! filling with inner domain values
257         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
258            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf)
259         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
260      CASE ( jpfillcst   )                 ! filling with constant value
261         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
262            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland
263         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
264      END SELECT
265      !
266      ! ------------------------------- !
267      !     3. north fold treatment     !
268      ! ------------------------------- !
269      !
270      ! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor
271      !
272      IF( lldo_nfd .AND. ifill_no /= jpfillnothing ) THEN
273         !
274         SELECT CASE ( jpni )
275         CASE ( 1 )     ;   CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:)                  OPT_K(:) )   ! only 1 northern proc, no mpp
276         CASE DEFAULT   ;   CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill_no, zland OPT_K(:) )   ! for all northern procs.
277         END SELECT
278         !
279         ifill_no = jpfillnothing  ! force to do nothing for the northern halo as we just done the north pole folding
280         !
281      ENDIF
282      !
283      ! ---------------------------------------------------- !
284      !     4. Do north and south MPI exchange if needed     !
285      ! ---------------------------------------------------- !
286      !
287      IF( llsend_so )   ALLOCATE( zsnd_so(jpi,nn_hls,ipk,ipl,ipf) )
288      IF( llsend_no )   ALLOCATE( zsnd_no(jpi,nn_hls,ipk,ipl,ipf) )
289      IF( llrecv_so )   ALLOCATE( zrcv_so(jpi,nn_hls,ipk,ipl,ipf) )
290      IF( llrecv_no )   ALLOCATE( zrcv_no(jpi,nn_hls,ipk,ipl,ipf) )
291      !
292      isize = jpi * nn_hls * ipk * ipl * ipf     
293
294      ! allocate local temporary arrays to be sent/received. Fill arrays to be sent
295      IF( llsend_so ) THEN   ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI
296         ishift = nn_hls
297         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
298            zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf)   ! nn_hls+1 -> 2*nn_hls
299         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
300      ENDIF
301      !
302      IF( llsend_no ) THEN   ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI
303         ishift = jpj - 2 * nn_hls
304         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
305            zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf)   ! jpj-2*nn_hls+1 -> jpj-nn_hls
306         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
307      ENDIF
308      !
309      IF( ln_timing ) CALL tic_tac(.TRUE.)
310      !
311      ! non-blocking send of the southern/northern side
312      IF( llsend_so )   CALL SENDROUTINE( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so )
313      IF( llsend_no )   CALL SENDROUTINE( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no )
314      ! blocking receive of the southern/northern halo
315      IF( llrecv_so )   CALL RECVROUTINE( 4, zrcv_so(1,1,1,1,1), isize, noso )
316      IF( llrecv_no )   CALL RECVROUTINE( 3, zrcv_no(1,1,1,1,1), isize, nono )
317      !
318      IF( ln_timing ) CALL tic_tac(.FALSE.)
319      !
320      ! ------------------------------------- !
321      !     5. Fill south and north halos     !
322      ! ------------------------------------- !
323      !
324      ! 5.1 fill southern halo
325      ! ----------------------
326      ! ishift = 0                         ! fill halo from jj = 1 to nn_hls
327      SELECT CASE ( ifill_so )
328      CASE ( jpfillnothing )               ! no filling
329      CASE ( jpfillmpi   )                 ! use data received by MPI
330         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
331            ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf)   ! 1 -> nn_hls
332         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
333      CASE ( jpfillperio )                 ! use north-south periodicity
334         ishift2 = jpj - 2 * nn_hls
335         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
336            ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
337         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
338      CASE ( jpfillcopy  )                 ! filling with inner domain values
339         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
340            ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,nn_hls+1,jk,jl,jf)
341         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
342      CASE ( jpfillcst   )                 ! filling with constant value
343         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi 
344            ARRAY_IN(ji,jj,jk,jl,jf) = zland
345         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
346      END SELECT
347      !
348      ! 5.2 fill northern halo
349      ! ----------------------
350      ishift = jpj - nn_hls                ! fill halo from jj = jpj-nn_hls+1 to jpj
351      SELECT CASE ( ifill_no )
352      CASE ( jpfillnothing )               ! no filling
353      CASE ( jpfillmpi   )                 ! use data received by MPI
354         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
355            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf)   ! jpj-nn_hls+1 -> jpj
356         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
357      CASE ( jpfillperio )                 ! use north-south periodicity
358         ishift2 = nn_hls
359         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
360            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
361         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
362      CASE ( jpfillcopy  )                 ! filling with inner domain values
363         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
364            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf)
365         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
366      CASE ( jpfillcst   )                 ! filling with constant value
367         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
368            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland
369         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
370      END SELECT
371      !
372      ! -------------------------------------------- !
373      !     6. deallocate local temporary arrays     !
374      ! -------------------------------------------- !
375      !
376      IF( llsend_we ) THEN
377         CALL mpi_wait(ireq_we, istat, ierr )
378         DEALLOCATE( zsnd_we )
379      ENDIF
380      IF( llsend_ea )  THEN
381         CALL mpi_wait(ireq_ea, istat, ierr )
382         DEALLOCATE( zsnd_ea )
383      ENDIF
384      IF( llsend_so ) THEN
385         CALL mpi_wait(ireq_so, istat, ierr )
386         DEALLOCATE( zsnd_so )
387      ENDIF
388      IF( llsend_no ) THEN
389         CALL mpi_wait(ireq_no, istat, ierr )
390         DEALLOCATE( zsnd_no )
391      ENDIF
392      !
393      IF( llrecv_we )   DEALLOCATE( zrcv_we )
394      IF( llrecv_ea )   DEALLOCATE( zrcv_ea )
395      IF( llrecv_so )   DEALLOCATE( zrcv_so )
396      IF( llrecv_no )   DEALLOCATE( zrcv_no )
397      !
398#endif
399   END SUBROUTINE ROUTINE_LNK
400#undef PRECISION
401#undef SENDROUTINE
402#undef RECVROUTINE
403#undef ARRAY_TYPE
404#undef NAT_IN
405#undef SGN_IN
406#undef ARRAY_IN
407#undef K_SIZE
408#undef L_SIZE
409#undef F_SIZE
410#undef OPT_K
Note: See TracBrowser for help on using the repository browser.