New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

lbc_lnk_pt2pt_generic.h90 in NEMO/trunk/src/OCE/LBC – NEMO

Context Navigation

source: NEMO/trunk/src/OCE/LBC/lbc_lnk_pt2pt_generic.h90 @ 15296

Last change on this file since 15296 was 15050, checked in by smasson, 3 years ago
trunk: minor bugfix in lbc_lnk, #2704
Property svn:keywords set to `Id` Property svn:mime-type set to `text/x-fortran`
File size: 15.3 KB

Line
1
2	#if ! defined BLOCK_ISEND && ! defined BLOCK_FILL
3	SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only )
4	CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine
5	TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.
6	CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points
7	REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary
8	INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
9	INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant)
10	REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries)
11	INTEGER , OPTIONAL, INTENT(in ) :: khls ! halo size, default = nn_hls
12	LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc
13	LOGICAL, OPTIONAL, INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners)
14	!
15	INTEGER :: ji, jj, jk, jl, jf, jn ! dummy loop indices
16	INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
17	INTEGER :: ip0i, ip1i, im0i, im1i
18	INTEGER :: ip0j, ip1j, im0j, im1j
19	INTEGER :: ishti, ishtj, ishti2, ishtj2
20	INTEGER :: ifill_nfd, icomm, ierr
21	INTEGER :: ihls, idxs, idxr, iszS, iszR
22	INTEGER, DIMENSION(4) :: iwewe, issnn
23	INTEGER, DIMENSION(8) :: isizei, ishtSi, ishtRi, ishtPi
24	INTEGER, DIMENSION(8) :: isizej, ishtSj, ishtRj, ishtPj
25	INTEGER, DIMENSION(8) :: ifill, iszall, ishtS, ishtR
26	INTEGER, DIMENSION(8) :: ireq ! mpi_request id
27	INTEGER, DIMENSION(8) :: iStag, iRtag ! Send and Recv mpi_tag id
28	REAL(PRECISION) :: zland
29	LOGICAL, DIMENSION(8) :: llsend, llrecv
30	LOGICAL :: ll4only ! default: 8 neighbourgs
31	!!----------------------------------------------------------------------
32	!
33	! ----------------------------------------- !
34	! 1. local variables initialization !
35	! ----------------------------------------- !
36	!
37	ipi = SIZE(ptab(1)%pt4d,1)
38	ipj = SIZE(ptab(1)%pt4d,2)
39	ipk = SIZE(ptab(1)%pt4d,3)
40	ipl = SIZE(ptab(1)%pt4d,4)
41	ipf = kfld
42	!
43	IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
44	!
45	idxs = 1 ! initalize index for send buffer
46	idxr = 1 ! initalize index for recv buffer
47	icomm = mpi_comm_oce ! shorter name
48	!
49	! take care of optional parameters
50	!
51	ihls = nn_hls ! default definition
52	IF( PRESENT( khls ) ) ihls = khls
53	IF( ihls > n_hlsmax ) THEN
54	WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with khls > n_hlsmax : ', khls, '>', n_hlsmax
55	CALL ctl_stop( 'STOP', ctmp1 )
56	ENDIF
57	IF( ipi /= Ni_0+2*ihls ) THEN
58	WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along i: ', ipi, ihls, Ni_0
59	CALL ctl_stop( 'STOP', ctmp1 )
60	ENDIF
61	IF( ipj /= Nj_0+2*ihls ) THEN
62	WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along j:', ipj, ihls , Nj_0
63	CALL ctl_stop( 'STOP', ctmp1 )
64	ENDIF
65	!
66	ll4only = .FALSE. ! default definition
67	IF( PRESENT(ld4only) ) ll4only = ld4only
68	!
69	zland = 0._wp ! land filling value: zero by default
70	IF( PRESENT( pfillval ) ) zland = pfillval ! set land value
71	!
72	! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not.
73	IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs
74	llsend(1:4) = lsend(1:4) ; llrecv(1:4) = lrecv(1:4)
75	ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN
76	WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv'
77	CALL ctl_stop( 'STOP', ctmp1 )
78	ELSE ! default neighbours
79	llsend(:) = mpiSnei(ihls,:) >= 0
80	IF( ll4only ) llsend(5:8) = .FALSE. ! exclude corners
81	llrecv(:) = mpiRnei(ihls,:) >= 0
82	IF( ll4only ) llrecv(5:8) = .FALSE. ! exclude corners
83	ENDIF
84	!
85	! define ifill: which method should be used to fill each parts (sides+corners) of the halos
86	! default definition
87	DO jn = 1, 4
88	IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication
89	ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity
90	ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined
91	ELSE ; ifill(jn) = jpfillcst ! constant value (zland)
92	ENDIF
93	END DO
94	DO jn = 5, 8
95	IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication
96	ELSE ; ifill(jn) = jpfillnothing! do nothing
97	ENDIF
98	END DO
99	!
100	! north fold treatment
101	IF( l_IdoNFold ) THEN
102	ifill_nfd = ifill(jpno) ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false.
103	ifill( (/jpno/) ) = jpfillnothing ! we do north fold -> do nothing for northern halo
104	ENDIF
105
106	! We first define the localization and size of the parts of the array that will be sent (s), received (r)
107	! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions.
108	! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array
109	!
110	! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls
111	! ! ________________________
112	ip0i = 0 ! im0j = inner \|__\|__\|__________\|__\|__\|
113	ip1i = ihls ! im1j = inner - halo \|__\|__\|__________\|__\|__\|
114	im1i = ipi-2*ihls ! \| \| \| \| \| \|
115	im0i = ipi - ihls ! \| \| \| \| \| \|
116	ip0j = 0 ! \| \| \| \| \| \|
117	ip1j = ihls ! \|__\|__\|__________\|__\|__\|
118	im1j = ipj-2*ihls ! ip1j = halo \|__\|__\|__________\|__\|__\|
119	im0j = ipj - ihls ! ip0j = 0 \|__\|__\|__________\|__\|__\|
120	! ! ip0i ip1i im1i im0i
121	!
122	iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /)
123	!cd sides: west east south north ; corners: so-we, so-ea, no-we, no-ea
124	isizei(1:4) = (/ ihls, ihls, ipi, ipi /) ; isizei(5:8) = ihls ! i- count
125	isizej(1:4) = (/ ipj, ipj, ihls, ihls /) ; isizej(5:8) = ihls ! j- count
126	ishtSi(1:4) = (/ ip1i, im1i, ip0i, ip0i /) ; ishtSi(5:8) = ishtSi( iwewe ) ! i- shift send data
127	ishtSj(1:4) = (/ ip0j, ip0j, ip1j, im1j /) ; ishtSj(5:8) = ishtSj( issnn ) ! j- shift send data
128	ishtRi(1:4) = (/ ip0i, im0i, ip0i, ip0i /) ; ishtRi(5:8) = ishtRi( iwewe ) ! i- shift received data location
129	ishtRj(1:4) = (/ ip0j, ip0j, ip0j, im0j /) ; ishtRj(5:8) = ishtRj( issnn ) ! j- shift received data location
130	ishtPi(1:4) = (/ im1i, ip1i, ip0i, ip0i /) ; ishtPi(5:8) = ishtPi( iwewe ) ! i- shift data used for periodicity
131	ishtPj(1:4) = (/ ip0j, ip0j, im1j, ip1j /) ; ishtPj(5:8) = ishtPj( issnn ) ! j- shift data used for periodicity
132	!
133	! -------------------------------- !
134	! 2. Prepare MPI exchanges !
135	! -------------------------------- !
136	!
137	iStag = (/ 1, 2, 3, 4, 5, 6, 7, 8 /) ! any value but each one must be different
138	! define iRtag with the corresponding iStag, e.g. data received at west where sent at east.
139	iRtag(jpwe) = iStag(jpea) ; iRtag(jpea) = iStag(jpwe) ; iRtag(jpso) = iStag(jpno) ; iRtag(jpno) = iStag(jpso)
140	iRtag(jpsw) = iStag(jpne) ; iRtag(jpse) = iStag(jpnw) ; iRtag(jpnw) = iStag(jpse) ; iRtag(jpne) = iStag(jpsw)
141	!
142	iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf
143	ishtS(1) = 0
144	DO jn = 2, 8
145	ishtS(jn) = ishtS(jn-1) + iszall(jn-1) * COUNT( (/llsend(jn-1)/) )
146	END DO
147	ishtR(1) = 0
148	DO jn = 2, 8
149	ishtR(jn) = ishtR(jn-1) + iszall(jn-1) * COUNT( (/llrecv(jn-1)/) )
150	END DO
151
152	! Allocate buffer arrays to be sent/received if needed
153	iszS = SUM(iszall, mask = llsend) ! send buffer size
154	IF( ALLOCATED(BUFFSND) ) THEN
155	CALL mpi_waitall(8, nreq_p2p, MPI_STATUSES_IGNORE, ierr) ! wait for Isend from the PREVIOUS call
156	IF( SIZE(BUFFSND) < iszS ) DEALLOCATE(BUFFSND) ! send buffer is too small
157	ENDIF
158	IF( .NOT. ALLOCATED(BUFFSND) ) ALLOCATE( BUFFSND(iszS) )
159	iszR = SUM(iszall, mask = llrecv) ! recv buffer size
160	IF( ALLOCATED(BUFFRCV) ) THEN
161	IF( SIZE(BUFFRCV) < iszR ) DEALLOCATE(BUFFRCV) ! recv buffer is too small
162	ENDIF
163	IF( .NOT. ALLOCATED(BUFFRCV) ) ALLOCATE( BUFFRCV(iszR) )
164	!
165	! default definition when no communication is done. understood by mpi_waitall
166	nreq_p2p(:) = MPI_REQUEST_NULL ! WARNING: Must be done after the call to mpi_waitall just above
167	!
168	! ----------------------------------------------- !
169	! 3. Do east and west MPI_Isend if needed !
170	! ----------------------------------------------- !
171	!
172	DO jn = 1, 2
173	#define BLOCK_ISEND
174	# include "lbc_lnk_pt2pt_generic.h90"
175	#undef BLOCK_ISEND
176	END DO
177	!
178	! ----------------------------------- !
179	! 4. Fill east and west halos !
180	! ----------------------------------- !
181	!
182	DO jn = 1, 2
183	#define BLOCK_FILL
184	# include "lbc_lnk_pt2pt_generic.h90"
185	#undef BLOCK_FILL
186	END DO
187	!
188	! ------------------------------------------------- !
189	! 5. Do north and south MPI_Isend if needed !
190	! ------------------------------------------------- !
191	!
192	DO jn = 3, 4
193	#define BLOCK_ISEND
194	# include "lbc_lnk_pt2pt_generic.h90"
195	#undef BLOCK_ISEND
196	END DO
197	!
198	! ------------------------------- !
199	! 6. north fold treatment !
200	! ------------------------------- !
201	!
202	! Must be done after receiving data from East/West neighbourgs (as it is coded in mpp_nfd, to be changed one day...)
203	! Do it after MPI_iSend to south/north neighbourgs so they won't wait (too much) to receive their data
204	! Do if before MPI_Recv from south/north neighbourgs so we have more time to receive data
205	!
206	IF( l_IdoNFold ) THEN
207	IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ihls, ipf ) ! self NFold
208	ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ihls, ipf ) ! mpi NFold
209	ENDIF
210	ENDIF
211	!
212	! ------------------------------------- !
213	! 7. Fill south and north halos !
214	! ------------------------------------- !
215	!
216	DO jn = 3, 4
217	#define BLOCK_FILL
218	# include "lbc_lnk_pt2pt_generic.h90"
219	#undef BLOCK_FILL
220	END DO
221	!
222	! ----------------------------------------------- !
223	! 8. Specific problem in corner treatment !
224	! ( very rate case... ) !
225	! ----------------------------------------------- !
226	!
227	DO jn = 5, 8
228	#define BLOCK_ISEND
229	# include "lbc_lnk_pt2pt_generic.h90"
230	#undef BLOCK_ISEND
231	END DO
232	DO jn = 5, 8
233	#define BLOCK_FILL
234	# include "lbc_lnk_pt2pt_generic.h90"
235	#undef BLOCK_FILL
236	END DO
237	!
238	! -------------------------------------------- !
239	! 9. deallocate local temporary arrays !
240	! if they areg larger than jpi*jpj ! <- arbitrary max size...
241	! -------------------------------------------- !
242	!
243	IF( iszR > jpi*jpj ) DEALLOCATE(BUFFRCV) ! blocking receive -> can directly deallocate
244	IF( iszS > jpi*jpj ) THEN
245	CALL mpi_waitall(8, nreq_p2p, MPI_STATUSES_IGNORE, ierr) ! must wait before deallocate send buffer
246	DEALLOCATE(BUFFSND)
247	ENDIF
248	!
249	END SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION
250	#endif
251
252	#if defined BLOCK_ISEND
253	IF( llsend(jn) ) THEN
254	ishti = ishtSi(jn)
255	ishtj = ishtSj(jn)
256	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
257	BUFFSND(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl)
258	idxs = idxs + 1
259	END DO ; END DO ; END DO ; END DO ; END DO
260	#if ! defined key_mpi_off
261	IF( ln_timing ) CALL tic_tac(.TRUE.)
262	! non-blocking send of the west/east side using local buffer
263	CALL MPI_ISEND( BUFFSND(ishtS(jn)+1), iszall(jn), MPI_TYPE, mpiSnei(ihls,jn), iStag(jn), icomm, nreq_p2p(jn), ierr )
264	IF( ln_timing ) CALL tic_tac(.FALSE.)
265	#endif
266	ENDIF
267	#endif
268
269	#if defined BLOCK_FILL
270	ishti = ishtRi(jn)
271	ishtj = ishtRj(jn)
272	SELECT CASE ( ifill(jn) )
273	CASE ( jpfillnothing ) ! no filling
274	CASE ( jpfillmpi ) ! fill with data received by MPI
275	#if ! defined key_mpi_off
276	IF( ln_timing ) CALL tic_tac(.TRUE.)
277	! ! blocking receive of the west/east halo in local temporary arrays
278	CALL MPI_RECV( BUFFRCV(ishtR(jn)+1), iszall(jn), MPI_TYPE, mpiRnei(ihls,jn), iRtag(jn), icomm, MPI_STATUS_IGNORE, ierr )
279	IF( ln_timing ) CALL tic_tac(.FALSE.)
280	#endif
281	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
282	ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idxr)
283	idxr = idxr + 1
284	END DO ; END DO ; END DO ; END DO ; END DO
285	CASE ( jpfillperio ) ! use periodicity
286	ishti2 = ishtPi(jn)
287	ishtj2 = ishtPj(jn)
288	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
289	ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
290	END DO ; END DO ; END DO ; END DO ; END DO
291	CASE ( jpfillcopy ) ! filling with inner domain values
292	ishti2 = ishtSi(jn)
293	ishtj2 = ishtSj(jn)
294	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
295	ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
296	END DO ; END DO ; END DO ; END DO ; END DO
297	CASE ( jpfillcst ) ! filling with constant value
298	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
299	ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland
300	END DO ; END DO ; END DO ; END DO ; END DO
301	END SELECT
302	#endif

Note: See TracBrowser for help on using the repository browser.

Download in other formats: