source: NEMO/trunk/src/OCE/LBC/mpp_lnk_icb_generic.h90 @ 15033

Last change on this file since 15033 was 15033, checked in by smasson, 5 months ago

trunk: suppress jpim1 et jpjm1, #2699

File size: 8.4 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      !!                    mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg)
27      !!                    kexti  : number of columns for extra outer halo
28      !!                    kextj  : number of rows for extra outer halo
29      !!----------------------------------------------------------------------
30      CHARACTER(len=*)                                        , INTENT(in   ) ::   cdname      ! name of the calling subroutine
31      REAL(PRECISION), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
32      CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points
33      REAL(PRECISION)                                         , INTENT(in   ) ::   psgn     ! sign used across the north fold
34      INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width
35      INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width
36      !
37      INTEGER  ::   jl   ! dummy loop indices
38      INTEGER  ::   imigr, iihom, ijhom        ! local integers
39      INTEGER  ::   ipreci, iprecj             !   -       -
40      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
41      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
42      !!
43      REAL(PRECISION), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) ::   r2dns, r2dsn
44      REAL(PRECISION), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) ::   r2dwe, r2dew
45      !!----------------------------------------------------------------------
46      ipreci = nn_hls + kexti      ! take into account outer extra 2D overlap area
47      iprecj = nn_hls + kextj
48
49      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. )
50
51      ! 1. standard boundary treatment
52      ! ------------------------------
53      ! Order matters Here !!!!
54      !
55      !                                      ! East-West boundaries
56      !                                           !* Cyclic east-west
57      IF( l_Iperio ) THEN
58         pt2d(1-kexti:     1   ,:) = pt2d(jpi-1-kexti: jpi-1 ,:)       ! east
59         pt2d(  jpi  :jpi+kexti,:) = pt2d(     2     :2+kexti,:)       ! west
60         !
61      ELSE                                        !* closed
62# if defined SINGLE_PRECISION
63         IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls   ,:) = 0._sp    ! east except at F-point
64                                      pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._sp    ! west
65# else
66         IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls   ,:) = 0._dp    ! east except at F-point
67                                      pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._dp    ! west
68# endif
69      ENDIF
70      !                                      ! North-South boundaries
71      IF( l_Jperio ) THEN                         !* cyclic (only with no mpp j-split)
72         pt2d(:,1-kextj:     1   ) = pt2d(:,jpj-1-kextj:  jpj-1)       ! north
73         pt2d(:,  jpj  :jpj+kextj) = pt2d(:,     2     :2+kextj)       ! south
74      ELSE                                        !* closed
75# if defined SINGLE_PRECISION
76         IF( .NOT. cd_type == 'F' )   pt2d(:,  1-kextj   :nn_hls   ) = 0._sp    ! north except at F-point
77                                      pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._sp    ! south
78# else
79         IF( .NOT. cd_type == 'F' )   pt2d(:,  1-kextj   :nn_hls   ) = 0._dp    ! north except at F-point
80                                      pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._dp    ! south
81# endif
82      ENDIF
83      !
84
85      ! north fold treatment
86      ! -----------------------
87      IF( l_IdoNFold ) THEN
88         !
89         SELECT CASE ( jpni )
90                   CASE ( 1 )     ;   CALL lbc_nfd         ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
91                   CASE DEFAULT   ;   CALL LBCNORTH        ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
92         END SELECT
93         !
94      ENDIF
95
96      ! 2. East and west directions exchange
97      ! ------------------------------------
98      ! we play with the neigbours AND the row number because of the periodicity
99      !
100      IF( mpinei(jpwe) >= 0 .OR. mpinei(jpea) >= 0 ) THEN   ! Read Dirichlet lateral conditions: all exept 2 (i.e. close case)
101         iihom = jpi - (2 * nn_hls) -kexti
102         DO jl = 1, ipreci
103            r2dew(:,jl,1) = pt2d(nn_hls+jl,:)
104            r2dwe(:,jl,1) = pt2d(iihom +jl,:)
105         END DO
106      ENDIF
107      !
108      !                           ! Migrations
109      imigr = ipreci * ( jpj + 2*kextj )
110      !
111      !                           ! Migrations
112      imigr = ipreci * ( jpj + 2*kextj )
113      !
114      IF( ln_timing ) CALL tic_tac(.TRUE.)
115      !
116      IF( mpinei(jpwe) >= 0  )   CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, mpinei(jpwe), ml_req1 )
117      IF( mpinei(jpea) >= 0  )   CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, mpinei(jpea), ml_req2 )
118      IF( mpinei(jpwe) >= 0  )   CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, mpinei(jpwe) )
119      IF( mpinei(jpea) >= 0  )   CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, mpinei(jpea) )
120      IF( mpinei(jpwe) >= 0  )   CALL mpi_wait(ml_req1,ml_stat,ml_err)
121      IF( mpinei(jpea) >= 0  )   CALL mpi_wait(ml_req2,ml_stat,ml_err)
122      !
123      IF( ln_timing ) CALL tic_tac(.FALSE.)
124      !
125      !                           ! Write Dirichlet lateral conditions
126      iihom = jpi - nn_hls
127      IF( mpinei(jpwe) >= 0  ) THEN
128         DO jl = 1, ipreci
129            pt2d(jl-kexti,:) = r2dwe(:,jl,2)
130         END DO
131      ENDIF
132      IF( mpinei(jpea) >= 0  ) THEN
133         DO jl = 1, ipreci
134            pt2d(iihom+jl,:) = r2dew(:,jl,2)
135         END DO
136      ENDIF
137
138      ! 3. North and south directions
139      ! -----------------------------
140      ! always closed : we play only with the neigbours
141      !
142      IF( mpinei(jpso) >= 0 .OR. mpinei(jpno) >= 0 ) THEN   ! Read Dirichlet lateral conditions: all exept 2 (i.e. close case)
143         ijhom = jpj - (2 * nn_hls) - kextj
144         DO jl = 1, iprecj
145            r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
146            r2dns(:,jl,1) = pt2d(:,nn_hls+jl)
147         END DO
148      ENDIF
149      !
150      !                           ! Migrations
151      imigr = iprecj * ( jpi + 2*kexti )
152      !
153      IF( ln_timing ) CALL tic_tac(.TRUE.)
154      !
155      IF( mpinei(jpso) >= 0  )   CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, mpinei(jpso), ml_req1 )
156      IF( mpinei(jpno) >= 0  )   CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, mpinei(jpno), ml_req2 )
157      IF( mpinei(jpso) >= 0  )   CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, mpinei(jpso) )
158      IF( mpinei(jpno) >= 0  )   CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, mpinei(jpno) )
159      IF( mpinei(jpso) >= 0  )   CALL mpi_wait(ml_req1,ml_stat,ml_err)
160      IF( mpinei(jpno) >= 0  )   CALL mpi_wait(ml_req2,ml_stat,ml_err)
161      !
162      IF( ln_timing ) CALL tic_tac(.FALSE.)
163      !
164      !                           ! Write Dirichlet lateral conditions
165      ijhom = jpj - nn_hls
166      !
167      IF( mpinei(jpso) >= 0  ) THEN
168         DO jl = 1, iprecj
169            pt2d(:,jl-kextj) = r2dsn(:,jl,2)
170         END DO
171      ENDIF
172       IF( mpinei(jpno) >= 0  ) THEN
173        DO jl = 1, iprecj
174            pt2d(:,ijhom+jl) = r2dns(:,jl,2)
175         END DO
176      ENDIF
177      !
178   END SUBROUTINE ROUTINE_LNK
179
180#    undef LBCNORTH
181#    undef PRECISION
182#    undef SENDROUTINE
183#    undef RECVROUTINE
Note: See TracBrowser for help on using the repository browser.