source: NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/mpp_lnk_generic.h90 @ 11719

Last change on this file since 11719 was 11719, checked in by francesca, 12 months ago

add extra halo support- ticket #2009

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