source: NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/mpp_lnk_icb_generic.h90 @ 13266

Last change on this file since 13266 was 13247, checked in by francesca, 5 months ago

dev_r12558_HPC-08_epico_Extra_Halo: merge with trunk@13227, see #2366

File size: 9.6 KB
Line 
1# if defined SINGLE_PRECISION
2#    define PRECISION sp
3#    define SENDROUTINE mppsend_sp
4#    define RECVROUTINE mpprecv_sp
5#    define LBCNORTH mpp_lbc_north_icb_sp
6# else
7#    define PRECISION dp
8#    define SENDROUTINE mppsend_dp
9#    define RECVROUTINE mpprecv_dp
10#    define LBCNORTH mpp_lbc_north_icb_dp
11# endif
12
13   SUBROUTINE ROUTINE_LNK( cdname, pt2d, cd_type, psgn, kexti, kextj )
14      !!----------------------------------------------------------------------
15      !!                  ***  routine mpp_lnk_2d_icb  ***
16      !!
17      !! ** Purpose :   Message passing management for 2d array (with extra halo for icebergs)
18      !!                This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj)
19      !!                array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls.
20      !!
21      !! ** Method  :   Use mppsend and mpprecv function for passing mask
22      !!      between processors following neighboring subdomains.
23      !!            domain parameters
24      !!                    jpi    : first dimension of the local subdomain
25      !!                    jpj    : second dimension of the local subdomain
26      !!                    kexti  : number of columns for extra outer halo
27      !!                    kextj  : number of rows for extra outer halo
28      !!                    nbondi : mark for "east-west local boundary"
29      !!                    nbondj : mark for "north-south local boundary"
30      !!                    noea   : number for local neighboring processors
31      !!                    nowe   : number for local neighboring processors
32      !!                    noso   : number for local neighboring processors
33      !!                    nono   : number for local neighboring processors
34      !!----------------------------------------------------------------------
35      CHARACTER(len=*)                                        , INTENT(in   ) ::   cdname      ! name of the calling subroutine
36      REAL(PRECISION), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
37      CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points
38      REAL(wp)                                                , INTENT(in   ) ::   psgn     ! sign used across the north fold
39      INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width
40      INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width
41      !
42      INTEGER  ::   jl   ! dummy loop indices
43      INTEGER  ::   imigr, iihom, ijhom        ! local integers
44      INTEGER  ::   ipreci, iprecj             !   -       -
45      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
46      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
47      !!
48      REAL(PRECISION), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) ::   r2dns, r2dsn
49      REAL(PRECISION), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) ::   r2dwe, r2dew
50      !!----------------------------------------------------------------------
51      ipreci = nn_hls + kexti      ! take into account outer extra 2D overlap area
52      iprecj = nn_hls + kextj
53
54      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. )
55
56      ! 1. standard boundary treatment
57      ! ------------------------------
58      ! Order matters Here !!!!
59      !
60      !                                      ! East-West boundaries
61      !                                           !* Cyclic east-west
62      IF( l_Iperio ) THEN
63         pt2d(1-kexti:     1   ,:) = pt2d(jpim1-kexti: jpim1 ,:)       ! east
64         pt2d(  jpi  :jpi+kexti,:) = pt2d(     2     :2+kexti,:)       ! west
65         !
66      ELSE                                        !* closed
67# if defined SINGLE_PRECISION
68         IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls   ,:) = 0._sp    ! east except at F-point
69                                      pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._sp    ! west
70# else
71         IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls   ,:) = 0._dp    ! east except at F-point
72                                      pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._dp    ! west
73# endif
74      ENDIF
75      !                                      ! North-South boundaries
76      IF( l_Jperio ) THEN                         !* cyclic (only with no mpp j-split)
77         pt2d(:,1-kextj:     1   ) = pt2d(:,jpjm1-kextj:  jpjm1)       ! north
78         pt2d(:,  jpj  :jpj+kextj) = pt2d(:,     2     :2+kextj)       ! south
79      ELSE                                        !* closed
80# if defined SINGLE_PRECISION
81         IF( .NOT. cd_type == 'F' )   pt2d(:,  1-kextj   :nn_hls   ) = 0._sp    ! north except at F-point
82                                      pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._sp    ! south
83# else
84         IF( .NOT. cd_type == 'F' )   pt2d(:,  1-kextj   :nn_hls   ) = 0._dp    ! north except at F-point
85                                      pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._dp    ! south
86# endif
87      ENDIF
88      !
89
90      ! north fold treatment
91      ! -----------------------
92      IF( npolj /= 0 ) THEN
93         !
94         SELECT CASE ( jpni )
95                   CASE ( 1 )     ;   CALL lbc_nfd         ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
96                   CASE DEFAULT   ;   CALL LBCNORTH        ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
97         END SELECT
98         !
99      ENDIF
100
101      ! 2. East and west directions exchange
102      ! ------------------------------------
103      ! we play with the neigbours AND the row number because of the periodicity
104      !
105      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
106      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
107         iihom = jpi - (2 * nn_hls) -kexti
108         DO jl = 1, ipreci
109            r2dew(:,jl,1) = pt2d(nn_hls+jl,:)
110            r2dwe(:,jl,1) = pt2d(iihom +jl,:)
111         END DO
112      END SELECT
113      !
114      !                           ! Migrations
115      imigr = ipreci * ( jpj + 2*kextj )
116      !
117      !                           ! Migrations
118      imigr = ipreci * ( jpj + 2*kextj )
119      !
120      IF( ln_timing ) CALL tic_tac(.TRUE.)
121      !
122      SELECT CASE ( nbondi )
123      CASE ( -1 )
124         CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 )
125         CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, noea )
126         CALL mpi_wait(ml_req1,ml_stat,ml_err)
127      CASE ( 0 )
128         CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )
129         CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 )
130         CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, noea )
131         CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, nowe )
132         CALL mpi_wait(ml_req1,ml_stat,ml_err)
133         CALL mpi_wait(ml_req2,ml_stat,ml_err)
134      CASE ( 1 )
135         CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )
136         CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, nowe )
137         CALL mpi_wait(ml_req1,ml_stat,ml_err)
138      END SELECT
139      !
140      IF( ln_timing ) CALL tic_tac(.FALSE.)
141      !
142      !                           ! Write Dirichlet lateral conditions
143      iihom = jpi - nn_hls
144      !
145      SELECT CASE ( nbondi )
146      CASE ( -1 )
147         DO jl = 1, ipreci
148            pt2d(iihom+jl,:) = r2dew(:,jl,2)
149         END DO
150      CASE ( 0 )
151         DO jl = 1, ipreci
152            pt2d(jl-kexti,:) = r2dwe(:,jl,2)
153            pt2d(iihom+jl,:) = r2dew(:,jl,2)
154         END DO
155      CASE ( 1 )
156         DO jl = 1, ipreci
157            pt2d(jl-kexti,:) = r2dwe(:,jl,2)
158         END DO
159      END SELECT
160
161
162      ! 3. North and south directions
163      ! -----------------------------
164      ! always closed : we play only with the neigbours
165      !
166      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
167         ijhom = jpj - (2 * nn_hls) - kextj
168         DO jl = 1, iprecj
169            r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
170            r2dns(:,jl,1) = pt2d(:,nn_hls+jl)
171         END DO
172      ENDIF
173      !
174      !                           ! Migrations
175      imigr = iprecj * ( jpi + 2*kexti )
176      !
177      IF( ln_timing ) CALL tic_tac(.TRUE.)
178      !
179      SELECT CASE ( nbondj )
180      CASE ( -1 )
181         CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 )
182         CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, nono )
183         CALL mpi_wait(ml_req1,ml_stat,ml_err)
184      CASE ( 0 )
185         CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )
186         CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 )
187         CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, nono )
188         CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, noso )
189         CALL mpi_wait(ml_req1,ml_stat,ml_err)
190         CALL mpi_wait(ml_req2,ml_stat,ml_err)
191      CASE ( 1 )
192         CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )
193         CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, noso )
194         CALL mpi_wait(ml_req1,ml_stat,ml_err)
195      END SELECT
196      !
197      IF( ln_timing ) CALL tic_tac(.FALSE.)
198      !
199      !                           ! Write Dirichlet lateral conditions
200      ijhom = jpj - nn_hls
201      !
202      SELECT CASE ( nbondj )
203      CASE ( -1 )
204         DO jl = 1, iprecj
205            pt2d(:,ijhom+jl) = r2dns(:,jl,2)
206         END DO
207      CASE ( 0 )
208         DO jl = 1, iprecj
209            pt2d(:,jl-kextj) = r2dsn(:,jl,2)
210            pt2d(:,ijhom+jl) = r2dns(:,jl,2)
211         END DO
212      CASE ( 1 )
213         DO jl = 1, iprecj
214            pt2d(:,jl-kextj) = r2dsn(:,jl,2)
215         END DO
216      END SELECT
217      !
218   END SUBROUTINE ROUTINE_LNK
219
220#    undef LBCNORTH
221#    undef PRECISION
222#    undef SENDROUTINE
223#    undef RECVROUTINE
Note: See TracBrowser for help on using the repository browser.