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.

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

Context Navigation

source: NEMO/trunk/src/OCE/LBC/mpp_lnk_generic.h90 @ 14072

Last change on this file since 14072 was 14072, checked in by laurent, 3 years ago
Merging branch "2020/dev_r13648_ASINTER-04_laurent_bulk_ice", ticket #2369
Property svn:keywords set to `Id` Property svn:mime-type set to `text/x-fortran`
File size: 21.1 KB

Rev	Line
[8586]	1	#if defined MULTI
[14072]	2	# define NAT_IN(k) cd_nat(k)
[8586]	3	# define SGN_IN(k) psgn(k)
	4	# define F_SIZE(ptab) kfld
	5	# define OPT_K(k) ,ipf
	6	# if defined DIM_2d
[13226]	7	# if defined SINGLE_PRECISION
	8	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f)
	9	# else
	10	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f)
	11	# endif
[8586]	12	# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j)
	13	# define K_SIZE(ptab) 1
	14	# define L_SIZE(ptab) 1
	15	# endif
	16	# if defined DIM_3d
[13226]	17	# if defined SINGLE_PRECISION
	18	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f)
	19	# else
	20	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f)
	21	# endif
[8586]	22	# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k)
	23	# define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3)
	24	# define L_SIZE(ptab) 1
	25	# endif
	26	# if defined DIM_4d
[13226]	27	# if defined SINGLE_PRECISION
	28	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f)
	29	# else
	30	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f)
	31	# endif
[8586]	32	# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l)
	33	# define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3)
	34	# define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4)
	35	# endif
	36	#else
[13226]	37	# if defined SINGLE_PRECISION
	38	# define ARRAY_TYPE(i,j,k,l,f) REAL(sp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f)
	39	# else
	40	# define ARRAY_TYPE(i,j,k,l,f) REAL(dp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f)
	41	# endif
[8586]	42	# define NAT_IN(k) cd_nat
	43	# define SGN_IN(k) psgn
	44	# define F_SIZE(ptab) 1
[14072]	45	# define OPT_K(k)
[8586]	46	# if defined DIM_2d
	47	# define ARRAY_IN(i,j,k,l,f) ptab(i,j)
	48	# define K_SIZE(ptab) 1
	49	# define L_SIZE(ptab) 1
	50	# endif
	51	# if defined DIM_3d
	52	# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k)
	53	# define K_SIZE(ptab) SIZE(ptab,3)
	54	# define L_SIZE(ptab) 1
	55	# endif
	56	# if defined DIM_4d
	57	# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l)
	58	# define K_SIZE(ptab) SIZE(ptab,3)
	59	# define L_SIZE(ptab) SIZE(ptab,4)
	60	# endif
	61	#endif
	62
[13226]	63	# if defined SINGLE_PRECISION
	64	# define PRECISION sp
	65	# define SENDROUTINE mppsend_sp
	66	# define RECVROUTINE mpprecv_sp
	67	# else
	68	# define PRECISION dp
	69	# define SENDROUTINE mppsend_dp
	70	# define RECVROUTINE mpprecv_dp
	71	# endif
	72
[8586]	73	#if defined MULTI
[13982]	74	SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten )
[11536]	75	INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
[8586]	76	#else
[13982]	77	SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv, ncsten )
[8586]	78	#endif
	79	ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied
[11536]	80	CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine
	81	CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points
	82	REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary
	83	INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant)
	84	REAL(wp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries)
	85	LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc
[13982]	86	LOGICAL, OPTIONAL, INTENT(in ) :: ncsten ! 5-point or 9-point stencil
[8586]	87	!
[11536]	88	INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices
[8586]	89	INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
[11536]	90	INTEGER :: isize, ishift, ishift2 ! local integers
	91	INTEGER :: ireq_we, ireq_ea, ireq_so, ireq_no ! mpi_request id
[10425]	92	INTEGER :: ierr
[11536]	93	INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no
[13286]	94	REAL(wp) :: zland
[11536]	95	INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend
[13226]	96	REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos
	97	REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos
[11536]	98	LOGICAL :: llsend_we, llsend_ea, llsend_no, llsend_so ! communication send
[14072]	99	LOGICAL :: llrecv_we, llrecv_ea, llrecv_no, llrecv_so ! communication receive
[11536]	100	LOGICAL :: lldo_nfd ! do north pole folding
[8586]	101	!!----------------------------------------------------------------------
	102	!
[13982]	103	#if defined key_mpi3
	104	# if defined MULTI
	105	CALL lbc_lnk_nc ( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten )
	106	# else
	107	CALL lbc_lnk_nc_multi(cdname, ptab, cd_nat, psgn, kfillmode=kfillmode, pfillval=pfillval, lsend=lsend, lrecv=lrecv, ncsten=ncsten)
	108	# endif
	109	#else
	110
[11536]	111	! ----------------------------------------- !
	112	! 0. local variables initialization !
	113	! ----------------------------------------- !
	114	!
[8586]	115	ipk = K_SIZE(ptab) ! 3rd dimension
	116	ipl = L_SIZE(ptab) ! 4th -
	117	ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)
	118	!
[10425]	119	IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
[8586]	120	!
[11536]	121	IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN
	122	llsend_we = lsend(1) ; llsend_ea = lsend(2) ; llsend_so = lsend(3) ; llsend_no = lsend(4)
	123	llrecv_we = lrecv(1) ; llrecv_ea = lrecv(2) ; llrecv_so = lrecv(3) ; llrecv_no = lrecv(4)
	124	ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN
	125	WRITE(ctmp1,*) ' E R R O R : Routine ', cdname, ' is calling lbc_lnk with only one of the two arguments lsend or lrecv'
	126	WRITE(ctmp2,*) ' ========== '
	127	CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' )
	128	ELSE ! send and receive with every neighbour
	129	llsend_we = nbondi == 1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini
	130	llsend_ea = nbondi == -1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini
	131	llsend_so = nbondj == 1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini
	132	llsend_no = nbondj == -1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini
	133	llrecv_we = llsend_we ; llrecv_ea = llsend_ea ; llrecv_so = llsend_so ; llrecv_no = llsend_no
	134	END IF
[14072]	135
	136
[11536]	137	lldo_nfd = npolj /= 0 ! keep for compatibility, should be defined in mppini
[8586]	138
[11536]	139	zland = 0._wp ! land filling value: zero by default
	140	IF( PRESENT( pfillval ) ) zland = pfillval ! set land value
	141
	142	! define the method we will use to fill the halos in each direction
	143	IF( llrecv_we ) THEN ; ifill_we = jpfillmpi
	144	ELSEIF( l_Iperio ) THEN ; ifill_we = jpfillperio
	145	ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_we = kfillmode
	146	ELSE ; ifill_we = jpfillcst
	147	END IF
[8586]	148	!
[11536]	149	IF( llrecv_ea ) THEN ; ifill_ea = jpfillmpi
	150	ELSEIF( l_Iperio ) THEN ; ifill_ea = jpfillperio
	151	ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_ea = kfillmode
	152	ELSE ; ifill_ea = jpfillcst
	153	END IF
	154	!
	155	IF( llrecv_so ) THEN ; ifill_so = jpfillmpi
	156	ELSEIF( l_Jperio ) THEN ; ifill_so = jpfillperio
	157	ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_so = kfillmode
	158	ELSE ; ifill_so = jpfillcst
	159	END IF
	160	!
	161	IF( llrecv_no ) THEN ; ifill_no = jpfillmpi
	162	ELSEIF( l_Jperio ) THEN ; ifill_no = jpfillperio
	163	ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_no = kfillmode
	164	ELSE ; ifill_no = jpfillcst
	165	END IF
	166	!
	167	#if defined PRINT_CAUTION
	168	!
	169	! ================================================================================== !
	170	! CAUTION: semi-column notation is often impossible because of the cpp preprocessing !
	171	! ================================================================================== !
	172	!
	173	#endif
	174	!
	175	! -------------------------------------------------- !
	176	! 1. Do east and west MPI exchange if needed !
	177	! -------------------------------------------------- !
	178	!
	179	! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg
[14072]	180	isize = nn_hls * jpj * ipk * ipl * ipf
[11536]	181	!
	182	! Allocate local temporary arrays to be sent/received. Fill arrays to be sent
[13286]	183	IF( llsend_we ) ALLOCATE( zsnd_we(nn_hls,jpj,ipk,ipl,ipf) )
	184	IF( llsend_ea ) ALLOCATE( zsnd_ea(nn_hls,jpj,ipk,ipl,ipf) )
	185	IF( llrecv_we ) ALLOCATE( zrcv_we(nn_hls,jpj,ipk,ipl,ipf) )
	186	IF( llrecv_ea ) ALLOCATE( zrcv_ea(nn_hls,jpj,ipk,ipl,ipf) )
[11536]	187	!
	188	IF( llsend_we ) THEN ! copy western side of the inner mpi domain in local temporary array to be sent by MPI
[13286]	189	ishift = nn_hls
	190	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
	191	zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! nn_hls + 1 -> 2*nn_hls
[11536]	192	END DO ; END DO ; END DO ; END DO ; END DO
[8586]	193	ENDIF
	194	!
[11536]	195	IF(llsend_ea ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI
[13286]	196	ishift = jpi - 2 * nn_hls
	197	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
	198	zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2*nn_hls + 1 -> jpi - nn_hls
[11536]	199	END DO ; END DO ; END DO ; END DO ; END DO
	200	ENDIF
[10425]	201	!
	202	IF( ln_timing ) CALL tic_tac(.TRUE.)
	203	!
[11536]	204	! non-blocking send of the western/eastern side using local temporary arrays
[13226]	205	IF( llsend_we ) CALL SENDROUTINE( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we )
	206	IF( llsend_ea ) CALL SENDROUTINE( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea )
[11536]	207	! blocking receive of the western/eastern halo in local temporary arrays
[13226]	208	IF( llrecv_we ) CALL RECVROUTINE( 2, zrcv_we(1,1,1,1,1), isize, nowe )
	209	IF( llrecv_ea ) CALL RECVROUTINE( 1, zrcv_ea(1,1,1,1,1), isize, noea )
[8586]	210	!
[10425]	211	IF( ln_timing ) CALL tic_tac(.FALSE.)
	212	!
[8586]	213	!
[11536]	214	! ----------------------------------- !
	215	! 2. Fill east and west halos !
	216	! ----------------------------------- !
	217	!
	218	! 2.1 fill weastern halo
	219	! ----------------------
[13286]	220	! ishift = 0 ! fill halo from ji = 1 to nn_hls
[11536]	221	SELECT CASE ( ifill_we )
[14072]	222	CASE ( jpfillnothing ) ! no filling
	223	CASE ( jpfillmpi ) ! use data received by MPI
[13286]	224	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
	225	ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> nn_hls
	226	END DO ; END DO ; END DO ; END DO ; END DO
[11536]	227	CASE ( jpfillperio ) ! use east-weast periodicity
[13286]	228	ishift2 = jpi - 2 * nn_hls
	229	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
[11536]	230	ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
[13286]	231	END DO ; END DO ; END DO ; END DO ; END DO
[11536]	232	CASE ( jpfillcopy ) ! filling with inner domain values
[13286]	233	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
	234	ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf)
	235	END DO ; END DO ; END DO ; END DO ; END DO
[11536]	236	CASE ( jpfillcst ) ! filling with constant value
[13286]	237	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
	238	ARRAY_IN(ji,jj,jk,jl,jf) = zland
	239	END DO ; END DO ; END DO ; END DO ; END DO
[8586]	240	END SELECT
[10425]	241	!
[11536]	242	! 2.2 fill eastern halo
	243	! ---------------------
[14072]	244	ishift = jpi - nn_hls ! fill halo from ji = jpi-nn_hls+1 to jpi
[11536]	245	SELECT CASE ( ifill_ea )
[14072]	246	CASE ( jpfillnothing ) ! no filling
	247	CASE ( jpfillmpi ) ! use data received by MPI
[13286]	248	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
	249	ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - nn_hls + 1 -> jpi
[11536]	250	END DO ; END DO ; END DO ; END DO ; END DO
	251	CASE ( jpfillperio ) ! use east-weast periodicity
[13286]	252	ishift2 = nn_hls
	253	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
[11536]	254	ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
	255	END DO ; END DO ; END DO ; END DO ; END DO
	256	CASE ( jpfillcopy ) ! filling with inner domain values
[13286]	257	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
[11536]	258	ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf)
	259	END DO ; END DO ; END DO ; END DO ; END DO
	260	CASE ( jpfillcst ) ! filling with constant value
[13286]	261	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
[11536]	262	ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland
[13286]	263	END DO ; END DO ; END DO ; END DO ; END DO
[11536]	264	END SELECT
[10542]	265	!
	266	! ------------------------------- !
	267	! 3. north fold treatment !
	268	! ------------------------------- !
[11536]	269	!
[10542]	270	! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor
[11536]	271	!
	272	IF( lldo_nfd .AND. ifill_no /= jpfillnothing ) THEN
[10542]	273	!
	274	SELECT CASE ( jpni )
[13286]	275	CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp
	276	CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill_no, zland OPT_K(:) ) ! for all northern procs.
[10542]	277	END SELECT
	278	!
[11536]	279	ifill_no = jpfillnothing ! force to do nothing for the northern halo as we just done the north pole folding
	280	!
[10542]	281	ENDIF
	282	!
[11536]	283	! ---------------------------------------------------- !
	284	! 4. Do north and south MPI exchange if needed !
	285	! ---------------------------------------------------- !
[8586]	286	!
[13286]	287	IF( llsend_so ) ALLOCATE( zsnd_so(jpi,nn_hls,ipk,ipl,ipf) )
	288	IF( llsend_no ) ALLOCATE( zsnd_no(jpi,nn_hls,ipk,ipl,ipf) )
	289	IF( llrecv_so ) ALLOCATE( zrcv_so(jpi,nn_hls,ipk,ipl,ipf) )
	290	IF( llrecv_no ) ALLOCATE( zrcv_no(jpi,nn_hls,ipk,ipl,ipf) )
[10425]	291	!
[14072]	292	isize = jpi * nn_hls * ipk * ipl * ipf
[11536]	293
	294	! allocate local temporary arrays to be sent/received. Fill arrays to be sent
	295	IF( llsend_so ) THEN ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI
[13286]	296	ishift = nn_hls
	297	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
	298	zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! nn_hls+1 -> 2*nn_hls
[11536]	299	END DO ; END DO ; END DO ; END DO ; END DO
	300	ENDIF
[8586]	301	!
[11536]	302	IF( llsend_no ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI
[13286]	303	ishift = jpj - 2 * nn_hls
	304	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
	305	zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2*nn_hls+1 -> jpj-nn_hls
[11536]	306	END DO ; END DO ; END DO ; END DO ; END DO
	307	ENDIF
[8586]	308	!
[10425]	309	IF( ln_timing ) CALL tic_tac(.TRUE.)
[8586]	310	!
[11536]	311	! non-blocking send of the southern/northern side
[13226]	312	IF( llsend_so ) CALL SENDROUTINE( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so )
	313	IF( llsend_no ) CALL SENDROUTINE( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no )
[11536]	314	! blocking receive of the southern/northern halo
[13226]	315	IF( llrecv_so ) CALL RECVROUTINE( 4, zrcv_so(1,1,1,1,1), isize, noso )
	316	IF( llrecv_no ) CALL RECVROUTINE( 3, zrcv_no(1,1,1,1,1), isize, nono )
[11536]	317	!
[10425]	318	IF( ln_timing ) CALL tic_tac(.FALSE.)
[8586]	319	!
[11536]	320	! ------------------------------------- !
	321	! 5. Fill south and north halos !
	322	! ------------------------------------- !
	323	!
	324	! 5.1 fill southern halo
	325	! ----------------------
[13286]	326	! ishift = 0 ! fill halo from jj = 1 to nn_hls
[11536]	327	SELECT CASE ( ifill_so )
[14072]	328	CASE ( jpfillnothing ) ! no filling
	329	CASE ( jpfillmpi ) ! use data received by MPI
[13286]	330	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
	331	ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> nn_hls
	332	END DO ; END DO ; END DO ; END DO ; END DO
[11536]	333	CASE ( jpfillperio ) ! use north-south periodicity
[13286]	334	ishift2 = jpj - 2 * nn_hls
	335	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
[11536]	336	ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
[13286]	337	END DO ; END DO ; END DO ; END DO ; END DO
[11536]	338	CASE ( jpfillcopy ) ! filling with inner domain values
[13286]	339	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
	340	ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,nn_hls+1,jk,jl,jf)
	341	END DO ; END DO ; END DO ; END DO ; END DO
[11536]	342	CASE ( jpfillcst ) ! filling with constant value
[14072]	343	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
[13286]	344	ARRAY_IN(ji,jj,jk,jl,jf) = zland
	345	END DO ; END DO ; END DO ; END DO ; END DO
[8586]	346	END SELECT
[10425]	347	!
[11536]	348	! 5.2 fill northern halo
	349	! ----------------------
[14072]	350	ishift = jpj - nn_hls ! fill halo from jj = jpj-nn_hls+1 to jpj
[11536]	351	SELECT CASE ( ifill_no )
[14072]	352	CASE ( jpfillnothing ) ! no filling
	353	CASE ( jpfillmpi ) ! use data received by MPI
[13286]	354	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
	355	ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj-nn_hls+1 -> jpj
[11536]	356	END DO ; END DO ; END DO ; END DO ; END DO
	357	CASE ( jpfillperio ) ! use north-south periodicity
[13286]	358	ishift2 = nn_hls
	359	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
[11536]	360	ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
[13286]	361	END DO ; END DO ; END DO ; END DO ; END DO
[11536]	362	CASE ( jpfillcopy ) ! filling with inner domain values
[13286]	363	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
[11536]	364	ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf)
[13286]	365	END DO ; END DO ; END DO ; END DO ; END DO
[11536]	366	CASE ( jpfillcst ) ! filling with constant value
[13286]	367	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
[11536]	368	ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland
[13286]	369	END DO ; END DO ; END DO ; END DO ; END DO
[11536]	370	END SELECT
[8586]	371	!
[11536]	372	! -------------------------------------------- !
	373	! 6. deallocate local temporary arrays !
	374	! -------------------------------------------- !
	375	!
	376	IF( llsend_we ) THEN
	377	CALL mpi_wait(ireq_we, istat, ierr )
	378	DEALLOCATE( zsnd_we )
	379	ENDIF
	380	IF( llsend_ea ) THEN
	381	CALL mpi_wait(ireq_ea, istat, ierr )
	382	DEALLOCATE( zsnd_ea )
	383	ENDIF
	384	IF( llsend_so ) THEN
	385	CALL mpi_wait(ireq_so, istat, ierr )
	386	DEALLOCATE( zsnd_so )
	387	ENDIF
	388	IF( llsend_no ) THEN
	389	CALL mpi_wait(ireq_no, istat, ierr )
	390	DEALLOCATE( zsnd_no )
	391	ENDIF
	392	!
	393	IF( llrecv_we ) DEALLOCATE( zrcv_we )
	394	IF( llrecv_ea ) DEALLOCATE( zrcv_ea )
	395	IF( llrecv_so ) DEALLOCATE( zrcv_so )
	396	IF( llrecv_no ) DEALLOCATE( zrcv_no )
	397	!
[13982]	398	#endif
[8586]	399	END SUBROUTINE ROUTINE_LNK
[13286]	400	#undef PRECISION
	401	#undef SENDROUTINE
	402	#undef RECVROUTINE
[8586]	403	#undef ARRAY_TYPE
	404	#undef NAT_IN
	405	#undef SGN_IN
	406	#undef ARRAY_IN
	407	#undef K_SIZE
	408	#undef L_SIZE
	409	#undef F_SIZE
	410	#undef OPT_K

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

Download in other formats: