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 @ 14587

Last change on this file since 14587 was 14433, checked in by smasson, 3 years ago
trunk: merge dev_r14312_MPI_Interface into the trunk, #2598
Property svn:keywords set to `Id` Property svn:mime-type set to `text/x-fortran`
File size: 15.4 KB

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

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

Download in other formats: