source: NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/LBC/mpp_lnk_generic.h90 @ 12603

Last change on this file since 12603 was 12603, checked in by orioltp, 8 months ago

Adding several interfaces to work with both single and double precision

  • Property svn:keywords set to Id
  • Property svn:mime-type set to text/x-fortran
File size: 21.5 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, ihlcom )
75      INTEGER             , INTENT(in   ) ::   kfld        ! number of pt3d arrays
76#else
77   SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn      , kfillmode, pfillval, lsend, lrecv, ihlcom )
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      INTEGER              ,OPTIONAL, INTENT(in   ) ::   ihlcom        ! number of ranks and rows to be communicated
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      INTEGER  ::   ihl                          ! number of ranks and rows to be communicated
95      REAL(PRECISION) ::   zland
96      INTEGER , DIMENSION(MPI_STATUS_SIZE)        ::   istat          ! for mpi_isend
97      REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsnd_we, zrcv_we, zsnd_ea, zrcv_ea   ! east -west  & west - east  halos
98      REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsnd_so, zrcv_so, zsnd_no, zrcv_no   ! north-south & south-north  halos
99      LOGICAL  ::   llsend_we, llsend_ea, llsend_no, llsend_so       ! communication send
100      LOGICAL  ::   llrecv_we, llrecv_ea, llrecv_no, llrecv_so       ! communication receive
101      LOGICAL  ::   lldo_nfd                                     ! do north pole folding
102      !!----------------------------------------------------------------------
103      !
104      ! ----------------------------------------- !
105      !     0. local variables initialization     !
106      ! ----------------------------------------- !
107      !
108      ipk = K_SIZE(ptab)   ! 3rd dimension
109      ipl = L_SIZE(ptab)   ! 4th    -
110      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers)
111      !
112      IF( PRESENT(ihlcom) ) THEN   ;   ihl = ihlcom
113      ELSE                         ;   ihl = 1
114      END IF
115      !
116      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
117      !
118      IF     ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN
119         llsend_we = lsend(1)   ;   llsend_ea = lsend(2)   ;   llsend_so = lsend(3)   ;   llsend_no = lsend(4)
120         llrecv_we = lrecv(1)   ;   llrecv_ea = lrecv(2)   ;   llrecv_so = lrecv(3)   ;   llrecv_no = lrecv(4)
121      ELSE IF( PRESENT(lsend) .OR.  PRESENT(lrecv) ) THEN
122         WRITE(ctmp1,*) ' E R R O R : Routine ', cdname, '  is calling lbc_lnk with only one of the two arguments lsend or lrecv'
123         WRITE(ctmp2,*) ' ========== '
124         CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' )
125      ELSE   ! send and receive with every neighbour
126         llsend_we = nbondi ==  1 .OR. nbondi == 0   ! keep for compatibility, should be defined in mppini
127         llsend_ea = nbondi == -1 .OR. nbondi == 0   ! keep for compatibility, should be defined in mppini
128         llsend_so = nbondj ==  1 .OR. nbondj == 0   ! keep for compatibility, should be defined in mppini
129         llsend_no = nbondj == -1 .OR. nbondj == 0   ! keep for compatibility, should be defined in mppini
130         llrecv_we = llsend_we   ;   llrecv_ea = llsend_ea   ;   llrecv_so = llsend_so   ;   llrecv_no = llsend_no
131      END IF
132         
133         
134      lldo_nfd = npolj /= 0                      ! keep for compatibility, should be defined in mppini
135
136      zland = 0._wp                                     ! land filling value: zero by default
137      IF( PRESENT( pfillval ) )   zland = pfillval      ! set land value
138
139      ! define the method we will use to fill the halos in each direction
140      IF(              llrecv_we ) THEN   ;   ifill_we = jpfillmpi
141      ELSEIF(           l_Iperio ) THEN   ;   ifill_we = jpfillperio
142      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_we = kfillmode
143      ELSE                                ;   ifill_we = jpfillcst
144      END IF
145      !
146      IF(              llrecv_ea ) THEN   ;   ifill_ea = jpfillmpi
147      ELSEIF(           l_Iperio ) THEN   ;   ifill_ea = jpfillperio
148      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_ea = kfillmode
149      ELSE                                ;   ifill_ea = jpfillcst
150      END IF
151      !
152      IF(              llrecv_so ) THEN   ;   ifill_so = jpfillmpi
153      ELSEIF(           l_Jperio ) THEN   ;   ifill_so = jpfillperio
154      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_so = kfillmode
155      ELSE                                ;   ifill_so = jpfillcst
156      END IF
157      !
158      IF(              llrecv_no ) THEN   ;   ifill_no = jpfillmpi
159      ELSEIF(           l_Jperio ) THEN   ;   ifill_no = jpfillperio
160      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_no = kfillmode
161      ELSE                                ;   ifill_no = jpfillcst
162      END IF
163      !
164#if defined PRINT_CAUTION
165      !
166      ! ================================================================================== !
167      ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing !
168      ! ================================================================================== !
169      !
170#endif
171      !
172      ! -------------------------------------------------- !
173      !     1. Do east and west MPI exchange if needed     !
174      ! -------------------------------------------------- !
175      !
176      ! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg
177      isize = ihl * jpj * ipk * ipl * ipf     
178      !
179      ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent
180      IF( llsend_we )   ALLOCATE( zsnd_we(ihl,jpj,ipk,ipl,ipf) )
181      IF( llsend_ea )   ALLOCATE( zsnd_ea(ihl,jpj,ipk,ipl,ipf) )
182      IF( llrecv_we )   ALLOCATE( zrcv_we(ihl,jpj,ipk,ipl,ipf) )
183      IF( llrecv_ea )   ALLOCATE( zrcv_ea(ihl,jpj,ipk,ipl,ipf) )
184      !
185      IF( llsend_we ) THEN   ! copy western side of the inner mpi domain in local temporary array to be sent by MPI
186         ishift = ihl
187         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl
188            zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf)   ! ihl + 1 -> 2*ihl
189         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
190      ENDIF
191      !
192      IF(llsend_ea  ) THEN   ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI
193         ishift = jpi - 2 * ihl
194         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl
195            zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf)   ! jpi - 2*ihl + 1 -> jpi - ihl
196         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
197      ENDIF
198      !
199      IF( ln_timing ) CALL tic_tac(.TRUE.)
200      !
201      ! non-blocking send of the western/eastern side using local temporary arrays
202      IF( llsend_we )   CALL SENDROUTINE( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we )
203      IF( llsend_ea )   CALL SENDROUTINE( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea )
204      ! blocking receive of the western/eastern halo in local temporary arrays
205      IF( llrecv_we )   CALL RECVROUTINE( 2, zrcv_we(1,1,1,1,1), isize, nowe )
206      IF( llrecv_ea )   CALL RECVROUTINE( 1, zrcv_ea(1,1,1,1,1), isize, noea )
207      !
208      IF( ln_timing ) CALL tic_tac(.FALSE.)
209      !
210      !
211      ! ----------------------------------- !
212      !     2. Fill east and west halos     !
213      ! ----------------------------------- !
214      !
215      ! 2.1 fill weastern halo
216      ! ----------------------
217      ! ishift = 0                         ! fill halo from ji = 1 to ihl
218      SELECT CASE ( ifill_we )
219      CASE ( jpfillnothing )               ! no filling
220      CASE ( jpfillmpi   )                 ! use data received by MPI
221         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl
222            ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf)   ! 1 -> ihl
223         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO
224      CASE ( jpfillperio )                 ! use east-weast periodicity
225         ishift2 = jpi - 2 * ihl
226         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl
227            ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
228         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO
229      CASE ( jpfillcopy  )                 ! filling with inner domain values
230         DO jf = 1, ipf                               ! number of arrays to be treated
231            IF( .NOT. NAT_IN(jf) == 'F' ) THEN        ! do nothing for F point
232               DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl
233                  ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ihl+1,jj,jk,jl,jf)
234               END DO   ;   END DO   ;   END DO   ;   END DO
235            ENDIF
236         END DO
237      CASE ( jpfillcst   )                 ! filling with constant value
238         DO jf = 1, ipf                               ! number of arrays to be treated
239            IF( .NOT. NAT_IN(jf) == 'F' ) THEN        ! do nothing for F point
240               DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl
241                  ARRAY_IN(ji,jj,jk,jl,jf) = zland
242               END DO;   END DO   ;   END DO   ;   END DO
243            ENDIF
244         END DO
245      END SELECT
246      !
247      ! 2.2 fill eastern halo
248      ! ---------------------
249      ishift = jpi - ihl                ! fill halo from ji = jpi-ihl+1 to jpi
250      SELECT CASE ( ifill_ea )
251      CASE ( jpfillnothing )               ! no filling
252      CASE ( jpfillmpi   )                 ! use data received by MPI
253         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl
254            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf)   ! jpi - ihl + 1 -> jpi
255         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
256      CASE ( jpfillperio )                 ! use east-weast periodicity
257         ishift2 = ihl
258         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl
259            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
260         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
261      CASE ( jpfillcopy  )                 ! filling with inner domain values
262         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl
263            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf)
264         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
265      CASE ( jpfillcst   )                 ! filling with constant value
266         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl
267            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland
268         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO
269      END SELECT
270      !
271      ! ------------------------------- !
272      !     3. north fold treatment     !
273      ! ------------------------------- !
274      !
275      ! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor
276      !
277      IF( lldo_nfd .AND. ifill_no /= jpfillnothing ) THEN
278         !
279         SELECT CASE ( jpni )
280         CASE ( 1 )     ;   CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! only 1 northern proc, no mpp
281         CASE DEFAULT   ;   CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! for all northern procs.
282         END SELECT
283         !
284         ifill_no = jpfillnothing  ! force to do nothing for the northern halo as we just done the north pole folding
285         !
286      ENDIF
287      !
288      ! ---------------------------------------------------- !
289      !     4. Do north and south MPI exchange if needed     !
290      ! ---------------------------------------------------- !
291      !
292      IF( llsend_so )   ALLOCATE( zsnd_so(jpi,ihl,ipk,ipl,ipf) )
293      IF( llsend_no )   ALLOCATE( zsnd_no(jpi,ihl,ipk,ipl,ipf) )
294      IF( llrecv_so )   ALLOCATE( zrcv_so(jpi,ihl,ipk,ipl,ipf) )
295      IF( llrecv_no )   ALLOCATE( zrcv_no(jpi,ihl,ipk,ipl,ipf) )
296      !
297      isize = jpi * ihl * ipk * ipl * ipf     
298
299      ! allocate local temporary arrays to be sent/received. Fill arrays to be sent
300      IF( llsend_so ) THEN   ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI
301         ishift = ihl
302         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi
303            zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf)   ! ihl+1 -> 2*ihl
304         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
305      ENDIF
306      !
307      IF( llsend_no ) THEN   ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI
308         ishift = jpj - 2 * ihl
309         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi
310            zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf)   ! jpj-2*ihl+1 -> jpj-ihl
311         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
312      ENDIF
313      !
314      IF( ln_timing ) CALL tic_tac(.TRUE.)
315      !
316      ! non-blocking send of the southern/northern side
317      IF( llsend_so )   CALL SENDROUTINE( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so )
318      IF( llsend_no )   CALL SENDROUTINE( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no )
319      ! blocking receive of the southern/northern halo
320      IF( llrecv_so )   CALL RECVROUTINE( 4, zrcv_so(1,1,1,1,1), isize, noso )
321      IF( llrecv_no )   CALL RECVROUTINE( 3, zrcv_no(1,1,1,1,1), isize, nono )
322      !
323      IF( ln_timing ) CALL tic_tac(.FALSE.)
324      !
325      ! ------------------------------------- !
326      !     5. Fill south and north halos     !
327      ! ------------------------------------- !
328      !
329      ! 5.1 fill southern halo
330      ! ----------------------
331      ! ishift = 0                         ! fill halo from jj = 1 to ihl
332      SELECT CASE ( ifill_so )
333      CASE ( jpfillnothing )               ! no filling
334      CASE ( jpfillmpi   )                 ! use data received by MPI
335         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi
336            ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf)   ! 1 -> ihl
337         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO
338      CASE ( jpfillperio )                 ! use north-south periodicity
339         ishift2 = jpj - 2 * ihl
340         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi
341            ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
342         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO
343      CASE ( jpfillcopy  )                 ! filling with inner domain values
344         DO jf = 1, ipf                               ! number of arrays to be treated
345            IF( .NOT. NAT_IN(jf) == 'F' ) THEN        ! do nothing for F point
346               DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi
347                  ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ihl+1,jk,jl,jf)
348               END DO   ;   END DO   ;   END DO   ;   END DO
349            ENDIF
350         END DO
351      CASE ( jpfillcst   )                 ! filling with constant value
352         DO jf = 1, ipf                               ! number of arrays to be treated
353            IF( .NOT. NAT_IN(jf) == 'F' ) THEN        ! do nothing for F point
354               DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
355                  ARRAY_IN(ji,jj,jk,jl,jf) = zland
356               END DO;   END DO   ;   END DO   ;   END DO
357            ENDIF
358         END DO
359      END SELECT
360      !
361      ! 5.2 fill northern halo
362      ! ----------------------
363      ishift = jpj - ihl                ! fill halo from jj = jpj-ihl+1 to jpj
364      SELECT CASE ( ifill_no )
365      CASE ( jpfillnothing )               ! no filling
366      CASE ( jpfillmpi   )                 ! use data received by MPI
367         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi
368            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf)   ! jpj-ihl+1 -> jpj
369         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
370      CASE ( jpfillperio )                 ! use north-south periodicity
371         ishift2 = ihl
372         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi
373            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
374         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO
375      CASE ( jpfillcopy  )                 ! filling with inner domain values
376         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi
377            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf)
378         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO
379      CASE ( jpfillcst   )                 ! filling with constant value
380         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi
381            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland
382         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO
383      END SELECT
384      !
385      ! -------------------------------------------- !
386      !     6. deallocate local temporary arrays     !
387      ! -------------------------------------------- !
388      !
389      IF( llsend_we ) THEN
390         CALL mpi_wait(ireq_we, istat, ierr )
391         DEALLOCATE( zsnd_we )
392      ENDIF
393      IF( llsend_ea )  THEN
394         CALL mpi_wait(ireq_ea, istat, ierr )
395         DEALLOCATE( zsnd_ea )
396      ENDIF
397      IF( llsend_so ) THEN
398         CALL mpi_wait(ireq_so, istat, ierr )
399         DEALLOCATE( zsnd_so )
400      ENDIF
401      IF( llsend_no ) THEN
402         CALL mpi_wait(ireq_no, istat, ierr )
403         DEALLOCATE( zsnd_no )
404      ENDIF
405      !
406      IF( llrecv_we )   DEALLOCATE( zrcv_we )
407      IF( llrecv_ea )   DEALLOCATE( zrcv_ea )
408      IF( llrecv_so )   DEALLOCATE( zrcv_so )
409      IF( llrecv_no )   DEALLOCATE( zrcv_no )
410      !
411   END SUBROUTINE ROUTINE_LNK
412
413#undef ARRAY_TYPE
414#undef NAT_IN
415#undef SGN_IN
416#undef ARRAY_IN
417#undef K_SIZE
418#undef L_SIZE
419#undef F_SIZE
420#undef OPT_K
Note: See TracBrowser for help on using the repository browser.