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