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.

lbcnfd.F90 in branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/LBC – NEMO

Context Navigation

source: branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/LBC/lbcnfd.F90 @ 8367

Last change on this file since 8367 was 8367, checked in by gm, 7 years ago
#1918 (ENHANCE-17): PART 1.1 - create NEMO/RK3_SRC as a copy of NEMO/OPA_SRC + SETTE changes associated with HPC09
Property svn:keywords set to `Id`
File size: 34.7 KB

Rev	Line
[1344]	1	MODULE lbcnfd
	2	!!======================================================================
	3	!! * MODULE lbcnfd *
	4	!! Ocean : north fold boundary conditions
	5	!!======================================================================
[2413]	6	!! History : 3.2 ! 2009-03 (R. Benshila) Original code
[8215]	7	!! 3.5 ! 2013-07 (I. Epicoco, S. Mocavero - CMCC) MPP optimization
	8	!! 4.0 ! 2017-04 (G. Madec) automatique allocation of array argument (use any 3rd dimension)
[1344]	9	!!----------------------------------------------------------------------
	10
[2413]	11	!!----------------------------------------------------------------------
	12	!! lbc_nfd : generic interface for lbc_nfd_3d and lbc_nfd_2d routines
	13	!! lbc_nfd_3d : lateral boundary condition: North fold treatment for a 3D arrays (lbc_nfd)
	14	!! lbc_nfd_2d : lateral boundary condition: North fold treatment for a 2D arrays (lbc_nfd)
[8215]	15	!! mpp_lbc_nfd_3d: North fold treatment for a 3D arrays optimized for MPP
	16	!! mpp_lbc_nfd_2d: North fold treatment for a 2D arrays optimized for MPP
[2413]	17	!!----------------------------------------------------------------------
	18	USE dom_oce ! ocean space and time domain
	19	USE in_out_manager ! I/O manager
	20
[1344]	21	IMPLICIT NONE
	22	PRIVATE
	23
	24	INTERFACE lbc_nfd
[2413]	25	MODULE PROCEDURE lbc_nfd_3d, lbc_nfd_2d
[1344]	26	END INTERFACE
[6140]	27	!
[4230]	28	INTERFACE mpp_lbc_nfd
	29	MODULE PROCEDURE mpp_lbc_nfd_3d, mpp_lbc_nfd_2d
	30	END INTERFACE
[2287]	31
[6140]	32	PUBLIC lbc_nfd ! north fold conditions
	33	PUBLIC mpp_lbc_nfd ! north fold conditions (parallel case)
[4230]	34
[6140]	35	INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 3 !:
	36	INTEGER, PUBLIC :: nsndto, nfsloop, nfeloop !:
	37	INTEGER, PUBLIC, DIMENSION (jpmaxngh) :: isendto !: processes to which communicate
[4230]	38
[1344]	39	!!----------------------------------------------------------------------
[2287]	40	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
	41	!! $Id$
[2413]	42	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[2287]	43	!!----------------------------------------------------------------------
[1344]	44	CONTAINS
	45
	46	SUBROUTINE lbc_nfd_3d( pt3d, cd_type, psgn )
	47	!!----------------------------------------------------------------------
	48	!! * routine lbc_nfd_3d *
	49	!!
	50	!! ** Purpose : 3D lateral boundary condition : North fold treatment
[2413]	51	!! without processor exchanges.
[1344]	52	!!
	53	!! ** Method :
	54	!!
[2413]	55	!! ** Action : pt3d with updated values along the north fold
[1344]	56	!!----------------------------------------------------------------------
[2413]	57	REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the boundary condition is applied
[8215]	58	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-point
	59	REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold
[2413]	60	!
[1344]	61	INTEGER :: ji, jk
	62	INTEGER :: ijt, iju, ijpj, ijpjm1
[2413]	63	!!----------------------------------------------------------------------
[8215]	64	!
[1344]	65	SELECT CASE ( jpni )
[2413]	66	CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction
	67	CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction
[1344]	68	END SELECT
	69	ijpjm1 = ijpj-1
	70
[8215]	71	DO jk = 1, SIZE( pt3d, 3 )
[2413]	72	!
[1344]	73	SELECT CASE ( npolj )
[2413]	74	!
[1344]	75	CASE ( 3 , 4 ) ! * North fold T-point pivot
[2413]	76	!
[1344]	77	SELECT CASE ( cd_type )
	78	CASE ( 'T' , 'W' ) ! T-, W-point
	79	DO ji = 2, jpiglo
	80	ijt = jpiglo-ji+2
	81	pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk)
	82	END DO
[4152]	83	pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-2,jk)
[1344]	84	DO ji = jpiglo/2+1, jpiglo
	85	ijt = jpiglo-ji+2
	86	pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk)
	87	END DO
	88	CASE ( 'U' ) ! U-point
	89	DO ji = 1, jpiglo-1
	90	iju = jpiglo-ji+1
	91	pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk)
	92	END DO
[4152]	93	pt3d( 1 ,ijpj,jk) = psgn * pt3d( 2 ,ijpj-2,jk)
	94	pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-2,jk)
[1344]	95	DO ji = jpiglo/2, jpiglo-1
	96	iju = jpiglo-ji+1
	97	pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk)
	98	END DO
	99	CASE ( 'V' ) ! V-point
	100	DO ji = 2, jpiglo
	101	ijt = jpiglo-ji+2
	102	pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk)
	103	pt3d(ji,ijpj ,jk) = psgn * pt3d(ijt,ijpj-3,jk)
	104	END DO
[4152]	105	pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-3,jk)
[1344]	106	CASE ( 'F' ) ! F-point
	107	DO ji = 1, jpiglo-1
	108	iju = jpiglo-ji+1
	109	pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk)
	110	pt3d(ji,ijpj ,jk) = psgn * pt3d(iju,ijpj-3,jk)
	111	END DO
[4152]	112	pt3d( 1 ,ijpj,jk) = psgn * pt3d( 2 ,ijpj-3,jk)
	113	pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-3,jk)
[1344]	114	END SELECT
[2413]	115	!
[1344]	116	CASE ( 5 , 6 ) ! * North fold F-point pivot
[2413]	117	!
[1344]	118	SELECT CASE ( cd_type )
	119	CASE ( 'T' , 'W' ) ! T-, W-point
	120	DO ji = 1, jpiglo
	121	ijt = jpiglo-ji+1
	122	pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk)
	123	END DO
	124	CASE ( 'U' ) ! U-point
	125	DO ji = 1, jpiglo-1
	126	iju = jpiglo-ji
	127	pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk)
	128	END DO
[4152]	129	pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-1,jk)
[1344]	130	CASE ( 'V' ) ! V-point
	131	DO ji = 1, jpiglo
	132	ijt = jpiglo-ji+1
	133	pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk)
	134	END DO
	135	DO ji = jpiglo/2+1, jpiglo
	136	ijt = jpiglo-ji+1
	137	pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk)
	138	END DO
	139	CASE ( 'F' ) ! F-point
	140	DO ji = 1, jpiglo-1
	141	iju = jpiglo-ji
	142	pt3d(ji,ijpj ,jk) = psgn * pt3d(iju,ijpj-2,jk)
	143	END DO
[4152]	144	pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-2,jk)
[1344]	145	DO ji = jpiglo/2+1, jpiglo-1
	146	iju = jpiglo-ji
	147	pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk)
	148	END DO
	149	END SELECT
[2413]	150	!
[1344]	151	CASE DEFAULT ! * closed : the code probably never go through
[2413]	152	!
[1344]	153	SELECT CASE ( cd_type)
	154	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
[8215]	155	pt3d(:, 1 ,jk) = 0._wp
	156	pt3d(:,ijpj,jk) = 0._wp
[1344]	157	CASE ( 'F' ) ! F-point
[8215]	158	pt3d(:,ijpj,jk) = 0._wp
[1344]	159	END SELECT
[2413]	160	!
[1344]	161	END SELECT ! npolj
[2413]	162	!
[1344]	163	END DO
[2413]	164	!
[1344]	165	END SUBROUTINE lbc_nfd_3d
	166
	167
	168	SUBROUTINE lbc_nfd_2d( pt2d, cd_type, psgn, pr2dj )
	169	!!----------------------------------------------------------------------
	170	!! * routine lbc_nfd_2d *
	171	!!
	172	!! ** Purpose : 2D lateral boundary condition : North fold treatment
	173	!! without processor exchanges.
	174	!!
	175	!! ** Method :
	176	!!
[2413]	177	!! ** Action : pt2d with updated values along the north fold
[1344]	178	!!----------------------------------------------------------------------
[2413]	179	REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied
[8215]	180	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d grid-point
	181	REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold
[2413]	182	INTEGER , OPTIONAL , INTENT(in ) :: pr2dj ! number of additional halos
	183	!
[1344]	184	INTEGER :: ji, jl, ipr2dj
	185	INTEGER :: ijt, iju, ijpj, ijpjm1
[2413]	186	!!----------------------------------------------------------------------
[1344]	187
	188	SELECT CASE ( jpni )
[2413]	189	CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction
	190	CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction
[1344]	191	END SELECT
[2413]	192	!
	193	IF( PRESENT(pr2dj) ) THEN ! use of additional halos
[1344]	194	ipr2dj = pr2dj
[2413]	195	IF( jpni > 1 ) ijpj = ijpj + ipr2dj
[1344]	196	ELSE
	197	ipr2dj = 0
	198	ENDIF
[2413]	199	!
[1344]	200	ijpjm1 = ijpj-1
	201
	202
	203	SELECT CASE ( npolj )
[2413]	204	!
[1344]	205	CASE ( 3, 4 ) ! * North fold T-point pivot
[2413]	206	!
[1344]	207	SELECT CASE ( cd_type )
[2413]	208	!
	209	CASE ( 'T' , 'W' ) ! T- , W-points
[1344]	210	DO jl = 0, ipr2dj
	211	DO ji = 2, jpiglo
	212	ijt=jpiglo-ji+2
	213	pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
	214	END DO
	215	END DO
[4152]	216	pt2d(1,ijpj) = psgn * pt2d(3,ijpj-2)
[1344]	217	DO ji = jpiglo/2+1, jpiglo
	218	ijt=jpiglo-ji+2
	219	pt2d(ji,ijpj-1) = psgn * pt2d(ijt,ijpj-1)
	220	END DO
	221	CASE ( 'U' ) ! U-point
[2413]	222	DO jl = 0, ipr2dj
[1344]	223	DO ji = 1, jpiglo-1
	224	iju = jpiglo-ji+1
	225	pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl)
	226	END DO
	227	END DO
[4152]	228	pt2d( 1 ,ijpj ) = psgn * pt2d( 2 ,ijpj-2)
	229	pt2d(jpiglo,ijpj ) = psgn * pt2d(jpiglo-1,ijpj-2)
	230	pt2d(1 ,ijpj-1) = psgn * pt2d(jpiglo ,ijpj-1)
[1344]	231	DO ji = jpiglo/2, jpiglo-1
	232	iju = jpiglo-ji+1
	233	pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
	234	END DO
	235	CASE ( 'V' ) ! V-point
[2413]	236	DO jl = -1, ipr2dj
[1344]	237	DO ji = 2, jpiglo
	238	ijt = jpiglo-ji+2
	239	pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-3-jl)
	240	END DO
	241	END DO
[4152]	242	pt2d( 1 ,ijpj) = psgn * pt2d( 3 ,ijpj-3)
[2413]	243	CASE ( 'F' ) ! F-point
	244	DO jl = -1, ipr2dj
[1344]	245	DO ji = 1, jpiglo-1
	246	iju = jpiglo-ji+1
	247	pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-3-jl)
	248	END DO
	249	END DO
[4152]	250	pt2d( 1 ,ijpj) = psgn * pt2d( 2 ,ijpj-3)
	251	pt2d(jpiglo,ijpj) = psgn * pt2d(jpiglo-1,ijpj-3)
	252	pt2d(jpiglo,ijpj-1) = psgn * pt2d(jpiglo-1,ijpj-2)
	253	pt2d( 1 ,ijpj-1) = psgn * pt2d( 2 ,ijpj-2)
[2413]	254	CASE ( 'I' ) ! ice U-V point (I-point)
	255	DO jl = 0, ipr2dj
[1344]	256	pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl)
	257	DO ji = 3, jpiglo
	258	iju = jpiglo - ji + 3
	259	pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
	260	END DO
	261	END DO
	262	END SELECT
[2413]	263	!
[1344]	264	CASE ( 5, 6 ) ! * North fold F-point pivot
[2413]	265	!
[1344]	266	SELECT CASE ( cd_type )
[2413]	267	CASE ( 'T' , 'W' ) ! T-, W-point
[1344]	268	DO jl = 0, ipr2dj
	269	DO ji = 1, jpiglo
	270	ijt = jpiglo-ji+1
	271	pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-1-jl)
	272	END DO
	273	END DO
	274	CASE ( 'U' ) ! U-point
	275	DO jl = 0, ipr2dj
	276	DO ji = 1, jpiglo-1
	277	iju = jpiglo-ji
	278	pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
	279	END DO
	280	END DO
[4152]	281	pt2d(jpiglo,ijpj) = psgn * pt2d(1,ijpj-1)
[1344]	282	CASE ( 'V' ) ! V-point
	283	DO jl = 0, ipr2dj
	284	DO ji = 1, jpiglo
	285	ijt = jpiglo-ji+1
	286	pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
	287	END DO
	288	END DO
	289	DO ji = jpiglo/2+1, jpiglo
	290	ijt = jpiglo-ji+1
	291	pt2d(ji,ijpjm1) = psgn * pt2d(ijt,ijpjm1)
	292	END DO
[2413]	293	CASE ( 'F' ) ! F-point
[1344]	294	DO jl = 0, ipr2dj
	295	DO ji = 1, jpiglo-1
	296	iju = jpiglo-ji
	297	pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl)
	298	END DO
	299	END DO
[4152]	300	pt2d(jpiglo,ijpj) = psgn * pt2d(1,ijpj-2)
[1344]	301	DO ji = jpiglo/2+1, jpiglo-1
	302	iju = jpiglo-ji
	303	pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
	304	END DO
[2413]	305	CASE ( 'I' ) ! ice U-V point (I-point)
[8215]	306	pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0._wp
[1344]	307	DO jl = 0, ipr2dj
	308	DO ji = 2 , jpiglo-1
	309	ijt = jpiglo - ji + 2
	310	pt2d(ji,ijpj+jl)= 0.5 * ( pt2d(ji,ijpj-1-jl) + psgn * pt2d(ijt,ijpj-1-jl) )
	311	END DO
	312	END DO
	313	END SELECT
[2413]	314	!
[1344]	315	CASE DEFAULT ! * closed : the code probably never go through
[2413]	316	!
[1344]	317	SELECT CASE ( cd_type)
	318	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
[8215]	319	pt2d(:, 1:1-ipr2dj ) = 0._wp
	320	pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp
[1344]	321	CASE ( 'F' ) ! F-point
[8215]	322	pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp
[1344]	323	CASE ( 'I' ) ! ice U-V point
[8215]	324	pt2d(:, 1:1-ipr2dj ) = 0._wp
	325	pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp
[1344]	326	END SELECT
[2413]	327	!
[1344]	328	END SELECT
[2413]	329	!
[1344]	330	END SUBROUTINE lbc_nfd_2d
	331
[4230]	332
	333	SUBROUTINE mpp_lbc_nfd_3d( pt3dl, pt3dr, cd_type, psgn )
	334	!!----------------------------------------------------------------------
	335	!! * routine mpp_lbc_nfd_3d *
	336	!!
	337	!! ** Purpose : 3D lateral boundary condition : North fold treatment
	338	!! without processor exchanges.
	339	!!
	340	!! ** Method :
	341	!!
	342	!! ** Action : pt3d with updated values along the north fold
	343	!!----------------------------------------------------------------------
[6140]	344	REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3dl ! 3D array on which the boundary condition is applied
	345	REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pt3dr ! 3D array on which the boundary condition is applied
[8215]	346	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d(l/r) grid-point
	347	REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold
[4230]	348	!
[8215]	349	INTEGER :: ji, jk ! dummy loop indices
	350	INTEGER :: ipk ! 3rd dimension of the input array
[4230]	351	INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop
	352	!!----------------------------------------------------------------------
[6140]	353	!
[8215]	354	ipk = SIZE( pt3dl, 3 )
	355	!
[4230]	356	SELECT CASE ( jpni )
	357	CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction
	358	CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction
	359	END SELECT
	360	ijpjm1 = ijpj-1
[8215]	361	!
	362	!
	363	SELECT CASE ( npolj )
	364	!
	365	CASE ( 3 , 4 ) ! * North fold T-point pivot
[4230]	366	!
[8215]	367	SELECT CASE ( cd_type )
[4230]	368	CASE ( 'T' , 'W' ) ! T-, W-point
[8215]	369	IF ( nimpp /= 1 ) THEN ; startloop = 1
	370	ELSE ; startloop = 2
[4230]	371	ENDIF
[8215]	372	!
	373	DO jk = 1, ipk
[4230]	374	DO ji = startloop, nlci
[4671]	375	ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
[4230]	376	pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk)
	377	END DO
[4686]	378	IF(nimpp .eq. 1) THEN
	379	pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-2,jk)
	380	ENDIF
[4230]	381	END DO
	382
[8215]	383	IF( nimpp >= jpiglo/2+1 ) THEN
[4230]	384	startloop = 1
[8215]	385	ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
[4230]	386	startloop = jpiglo/2+1 - nimpp + 1
	387	ELSE
	388	startloop = nlci + 1
	389	ENDIF
[8215]	390	IF(startloop <= nlci) THEN
	391	DO jk = 1, ipk
[4230]	392	DO ji = startloop, nlci
[4671]	393	ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
[4230]	394	jia = ji + nimpp - 1
	395	ijta = jpiglo - jia + 2
[8215]	396	IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN
[4230]	397	pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijta-nimpp+1,ijpjm1,jk)
	398	ELSE
	399	pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk)
	400	ENDIF
	401	END DO
	402	END DO
	403	ENDIF
[8215]	404	!
[4230]	405	CASE ( 'U' ) ! U-point
[8215]	406	IF( nimpp + nlci - 1 /= jpiglo ) THEN
[4230]	407	endloop = nlci
	408	ELSE
	409	endloop = nlci - 1
	410	ENDIF
[8215]	411	DO jk = 1, ipk
[4230]	412	DO ji = 1, endloop
[4671]	413	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
[4230]	414	pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-2,jk)
	415	END DO
[4686]	416	IF(nimpp .eq. 1) THEN
	417	pt3dl( 1 ,ijpj,jk) = psgn * pt3dl( 2 ,ijpj-2,jk)
	418	ENDIF
	419	IF((nimpp + nlci - 1) .eq. jpiglo) THEN
	420	pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-2,jk)
	421	ENDIF
[4230]	422	END DO
[8215]	423	!
	424	IF( nimpp + nlci - 1 /= jpiglo ) THEN
[4230]	425	endloop = nlci
	426	ELSE
	427	endloop = nlci - 1
	428	ENDIF
[8215]	429	IF( nimpp >= jpiglo/2 ) THEN
[4230]	430	startloop = 1
[8215]	431	ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN
[4230]	432	startloop = jpiglo/2 - nimpp + 1
	433	ELSE
	434	startloop = endloop + 1
	435	ENDIF
[8215]	436	IF( startloop <= endloop ) THEN
	437	DO jk = 1, ipk
[4230]	438	DO ji = startloop, endloop
[4671]	439	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
[4230]	440	jia = ji + nimpp - 1
	441	ijua = jpiglo - jia + 1
[8215]	442	IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN
[4230]	443	pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijua-nimpp+1,ijpjm1,jk)
	444	ELSE
	445	pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk)
	446	ENDIF
	447	END DO
	448	END DO
	449	ENDIF
[8215]	450	!
[4230]	451	CASE ( 'V' ) ! V-point
[8215]	452	IF( nimpp /= 1 ) THEN
[4230]	453	startloop = 1
	454	ELSE
	455	startloop = 2
	456	ENDIF
[8215]	457	DO jk = 1, ipk
[4230]	458	DO ji = startloop, nlci
[4671]	459	ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
[4230]	460	pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(ijt,ijpj-2,jk)
	461	pt3dl(ji,ijpj ,jk) = psgn * pt3dr(ijt,ijpj-3,jk)
	462	END DO
[4686]	463	IF(nimpp .eq. 1) THEN
	464	pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-3,jk)
	465	ENDIF
[4230]	466	END DO
	467	CASE ( 'F' ) ! F-point
[8215]	468	IF( nimpp + nlci - 1 /= jpiglo ) THEN
[4230]	469	endloop = nlci
	470	ELSE
	471	endloop = nlci - 1
	472	ENDIF
[8215]	473	DO jk = 1, ipk
[4230]	474	DO ji = 1, endloop
[4671]	475	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
[4230]	476	pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(iju,ijpj-2,jk)
	477	pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-3,jk)
	478	END DO
[4686]	479	IF(nimpp .eq. 1) THEN
	480	pt3dl( 1 ,ijpj,jk) = psgn * pt3dl( 2 ,ijpj-3,jk)
	481	ENDIF
	482	IF((nimpp + nlci - 1) .eq. jpiglo) THEN
	483	pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-3,jk)
	484	ENDIF
[4230]	485	END DO
[8215]	486	END SELECT
	487	!
	488	CASE ( 5 , 6 ) ! * North fold F-point pivot
	489	!
	490	SELECT CASE ( cd_type )
[4230]	491	CASE ( 'T' , 'W' ) ! T-, W-point
[8215]	492	DO jk = 1, ipk
[4230]	493	DO ji = 1, nlci
[4671]	494	ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
[4230]	495	pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-1,jk)
	496	END DO
	497	END DO
[8215]	498	!
[4230]	499	CASE ( 'U' ) ! U-point
[8215]	500	IF( nimpp + nlci - 1 /= jpiglo ) THEN
[4230]	501	endloop = nlci
	502	ELSE
	503	endloop = nlci - 1
	504	ENDIF
[8215]	505	DO jk = 1, ipk
[4230]	506	DO ji = 1, endloop
[4671]	507	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
[4230]	508	pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-1,jk)
	509	END DO
[4686]	510	IF((nimpp + nlci - 1) .eq. jpiglo) THEN
	511	pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-1,jk)
	512	ENDIF
[4230]	513	END DO
[8215]	514	!
[4230]	515	CASE ( 'V' ) ! V-point
[8215]	516	DO jk = 1, ipk
[4230]	517	DO ji = 1, nlci
[4671]	518	ijt = jpiglo - ji- nimpp - nfiimpp(isendto(1),jpnj) + 3
[4230]	519	pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk)
	520	END DO
	521	END DO
[8215]	522	!
	523	IF( nimpp >= jpiglo/2+1 ) THEN
[4230]	524	startloop = 1
[8215]	525	ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
[4230]	526	startloop = jpiglo/2+1 - nimpp + 1
	527	ELSE
	528	startloop = nlci + 1
	529	ENDIF
[8215]	530	IF( startloop <= nlci ) THEN
	531	DO jk = 1, ipk
[4230]	532	DO ji = startloop, nlci
[4671]	533	ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
[4230]	534	pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk)
	535	END DO
	536	END DO
	537	ENDIF
[8215]	538	!
[4230]	539	CASE ( 'F' ) ! F-point
[8215]	540	IF( nimpp + nlci - 1 /= jpiglo ) THEN
[4230]	541	endloop = nlci
	542	ELSE
	543	endloop = nlci - 1
	544	ENDIF
[8215]	545	DO jk = 1, ipk
[4230]	546	DO ji = 1, endloop
[4671]	547	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
[4230]	548	pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-2,jk)
	549	END DO
[4686]	550	IF((nimpp + nlci - 1) .eq. jpiglo) THEN
	551	pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-2,jk)
	552	ENDIF
[4230]	553	END DO
[8215]	554	!
	555	IF( nimpp + nlci - 1 /= jpiglo ) THEN
[4230]	556	endloop = nlci
	557	ELSE
	558	endloop = nlci - 1
	559	ENDIF
[8215]	560	IF( nimpp >= jpiglo/2+1 ) THEN
[4230]	561	startloop = 1
[8215]	562	ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
[4230]	563	startloop = jpiglo/2+1 - nimpp + 1
	564	ELSE
	565	startloop = endloop + 1
	566	ENDIF
[8215]	567	IF( startloop <= endloop ) THEN
	568	DO jk = 1, ipk
[4230]	569	DO ji = startloop, endloop
[4671]	570	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
[4230]	571	pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk)
	572	END DO
	573	END DO
	574	ENDIF
[8215]	575	!
	576	END SELECT
	577	!
	578	CASE DEFAULT ! * closed : the code probably never go through
	579	!
	580	SELECT CASE ( cd_type)
[4230]	581	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
[8215]	582	pt3dl(:, 1 ,jk) = 0._wp
	583	pt3dl(:,ijpj,jk) = 0._wp
[4230]	584	CASE ( 'F' ) ! F-point
[8215]	585	pt3dl(:,ijpj,jk) = 0._wp
	586	END SELECT
[4230]	587	!
[8215]	588	END SELECT ! npolj
[4230]	589	!
	590	END SUBROUTINE mpp_lbc_nfd_3d
	591
	592
	593	SUBROUTINE mpp_lbc_nfd_2d( pt2dl, pt2dr, cd_type, psgn )
	594	!!----------------------------------------------------------------------
	595	!! * routine mpp_lbc_nfd_2d *
	596	!!
	597	!! ** Purpose : 2D lateral boundary condition : North fold treatment
[8215]	598	!! without processor exchanges.
[4230]	599	!!
	600	!! ** Method :
	601	!!
[8215]	602	!! ** Action : pt2dl with updated values along the north fold
[4230]	603	!!----------------------------------------------------------------------
[6140]	604	REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2dl ! 2D array on which the boundary condition is applied
	605	REAL(wp), DIMENSION(:,:), INTENT(in ) :: pt2dr ! 2D array on which the boundary condition is applied
[8215]	606	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d(l/r) grid-point
	607	REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold
[4230]	608	!
	609	INTEGER :: ji
	610	INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop
	611	!!----------------------------------------------------------------------
	612
	613	SELECT CASE ( jpni )
	614	CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction
	615	CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction
	616	END SELECT
	617	!
	618	ijpjm1 = ijpj-1
[8215]	619	!
	620	!
[4230]	621	SELECT CASE ( npolj )
	622	!
	623	CASE ( 3, 4 ) ! * North fold T-point pivot
	624	!
	625	SELECT CASE ( cd_type )
	626	!
	627	CASE ( 'T' , 'W' ) ! T- , W-points
[8215]	628	IF( nimpp /= 1 ) THEN
[4230]	629	startloop = 1
	630	ELSE
	631	startloop = 2
	632	ENDIF
	633	DO ji = startloop, nlci
[4671]	634	ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
[4230]	635	pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1)
	636	END DO
[8215]	637	IF( nimpp == 1 ) THEN
	638	pt2dl(1,ijpj) = psgn * pt2dl(3,ijpj-2)
[4686]	639	ENDIF
[8215]	640	!
	641	IF( nimpp >= jpiglo/2+1 ) THEN
[4230]	642	startloop = 1
[8215]	643	ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
[4230]	644	startloop = jpiglo/2+1 - nimpp + 1
	645	ELSE
	646	startloop = nlci + 1
	647	ENDIF
	648	DO ji = startloop, nlci
[8215]	649	ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
[4230]	650	jia = ji + nimpp - 1
	651	ijta = jpiglo - jia + 2
[8215]	652	IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN
[4230]	653	pt2dl(ji,ijpjm1) = psgn * pt2dl(ijta-nimpp+1,ijpjm1)
	654	ELSE
	655	pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1)
	656	ENDIF
	657	END DO
[8215]	658	!
[4230]	659	CASE ( 'U' ) ! U-point
[8215]	660	IF( nimpp + nlci - 1 /= jpiglo ) THEN
[4230]	661	endloop = nlci
	662	ELSE
	663	endloop = nlci - 1
	664	ENDIF
	665	DO ji = 1, endloop
[4671]	666	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
[4230]	667	pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1)
	668	END DO
[8215]	669	!
[4686]	670	IF (nimpp .eq. 1) THEN
	671	pt2dl( 1 ,ijpj ) = psgn * pt2dl( 2 ,ijpj-2)
	672	pt2dl(1 ,ijpj-1) = psgn * pt2dr(jpiglo - nfiimpp(isendto(1), jpnj) + 1, ijpj-1)
	673	ENDIF
	674	IF((nimpp + nlci - 1) .eq. jpiglo) THEN
	675	pt2dl(nlci,ijpj ) = psgn * pt2dl(nlci-1,ijpj-2)
	676	ENDIF
[8215]	677	!
	678	IF( nimpp + nlci - 1 /= jpiglo ) THEN
[4230]	679	endloop = nlci
	680	ELSE
	681	endloop = nlci - 1
	682	ENDIF
[8215]	683	IF( nimpp >= jpiglo/2 ) THEN
[4230]	684	startloop = 1
[8215]	685	ELSEIF( nimpp+nlci-1 >= jpiglo/2 .AND. nimpp < jpiglo/2 ) THEN
[4230]	686	startloop = jpiglo/2 - nimpp + 1
	687	ELSE
	688	startloop = endloop + 1
	689	ENDIF
	690	DO ji = startloop, endloop
[4671]	691	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
[4230]	692	jia = ji + nimpp - 1
	693	ijua = jpiglo - jia + 1
[8215]	694	IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN
[4230]	695	pt2dl(ji,ijpjm1) = psgn * pt2dl(ijua-nimpp+1,ijpjm1)
	696	ELSE
	697	pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1)
	698	ENDIF
	699	END DO
[8215]	700	!
[4230]	701	CASE ( 'V' ) ! V-point
[8215]	702	IF( nimpp /= 1 ) THEN
[4230]	703	startloop = 1
	704	ELSE
	705	startloop = 2
	706	ENDIF
	707	DO ji = startloop, nlci
[4671]	708	ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
[4230]	709	pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1-1)
	710	pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-2)
	711	END DO
[4686]	712	IF (nimpp .eq. 1) THEN
	713	pt2dl( 1 ,ijpj) = psgn * pt2dl( 3 ,ijpj-3)
	714	ENDIF
[8215]	715	!
[4230]	716	CASE ( 'F' ) ! F-point
[8215]	717	IF( nimpp + nlci - 1 /= jpiglo ) THEN
[4230]	718	endloop = nlci
	719	ELSE
	720	endloop = nlci - 1
	721	ENDIF
	722	DO ji = 1, endloop
[4671]	723	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
[4230]	724	pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1-1)
	725	pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-2)
	726	END DO
[4686]	727	IF (nimpp .eq. 1) THEN
	728	pt2dl( 1 ,ijpj) = psgn * pt2dl( 2 ,ijpj-3)
	729	pt2dl( 1 ,ijpj-1) = psgn * pt2dl( 2 ,ijpj-2)
	730	ENDIF
	731	IF((nimpp + nlci - 1) .eq. jpiglo) THEN
	732	pt2dl(nlci,ijpj) = psgn * pt2dl(nlci-1,ijpj-3)
	733	pt2dl(nlci,ijpj-1) = psgn * pt2dl(nlci-1,ijpj-2)
	734	ENDIF
[8215]	735	!
[4230]	736	CASE ( 'I' ) ! ice U-V point (I-point)
[8215]	737	IF( nimpp /= 1 ) THEN
[4230]	738	startloop = 1
	739	ELSE
	740	startloop = 3
	741	pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1)
	742	ENDIF
	743	DO ji = startloop, nlci
[4671]	744	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5
[4230]	745	pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1)
	746	END DO
[8215]	747	!
[4230]	748	END SELECT
	749	!
	750	CASE ( 5, 6 ) ! * North fold F-point pivot
	751	!
	752	SELECT CASE ( cd_type )
	753	CASE ( 'T' , 'W' ) ! T-, W-point
	754	DO ji = 1, nlci
[4671]	755	ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
[4230]	756	pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1)
	757	END DO
[8215]	758	!
[4230]	759	CASE ( 'U' ) ! U-point
[8215]	760	IF( nimpp + nlci - 1 /= jpiglo ) THEN
[4230]	761	endloop = nlci
	762	ELSE
	763	endloop = nlci - 1
	764	ENDIF
	765	DO ji = 1, endloop
[4671]	766	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
[4230]	767	pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1)
	768	END DO
[4686]	769	IF((nimpp + nlci - 1) .eq. jpiglo) THEN
	770	pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-1)
	771	ENDIF
[8215]	772	!
[4230]	773	CASE ( 'V' ) ! V-point
	774	DO ji = 1, nlci
[4671]	775	ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
[4230]	776	pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1)
	777	END DO
[8215]	778	IF( nimpp >= jpiglo/2+1 ) THEN
[4230]	779	startloop = 1
[8215]	780	ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
[4230]	781	startloop = jpiglo/2+1 - nimpp + 1
	782	ELSE
	783	startloop = nlci + 1
	784	ENDIF
	785	DO ji = startloop, nlci
[4671]	786	ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
[4230]	787	pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1)
	788	END DO
[8215]	789	!
[4230]	790	CASE ( 'F' ) ! F-point
[8215]	791	IF( nimpp + nlci - 1 /= jpiglo ) THEN
[4230]	792	endloop = nlci
	793	ELSE
	794	endloop = nlci - 1
	795	ENDIF
	796	DO ji = 1, endloop
[4671]	797	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
[4230]	798	pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1)
	799	END DO
[4686]	800	IF((nimpp + nlci - 1) .eq. jpiglo) THEN
	801	pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-2)
	802	ENDIF
[8215]	803	!
	804	IF( nimpp + nlci - 1 /= jpiglo ) THEN
[4230]	805	endloop = nlci
	806	ELSE
	807	endloop = nlci - 1
	808	ENDIF
[8215]	809	IF( nimpp >= jpiglo/2+1 ) THEN
[4230]	810	startloop = 1
[8215]	811	ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
[4230]	812	startloop = jpiglo/2+1 - nimpp + 1
	813	ELSE
	814	startloop = endloop + 1
	815	ENDIF
[8215]	816	!
[4230]	817	DO ji = startloop, endloop
[4671]	818	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
[4230]	819	pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1)
	820	END DO
[8215]	821	!
[4230]	822	CASE ( 'I' ) ! ice U-V point (I-point)
[8215]	823	IF( nimpp /= 1 ) THEN
[4230]	824	startloop = 1
	825	ELSE
	826	startloop = 2
	827	ENDIF
[8215]	828	IF( nimpp + nlci - 1 /= jpiglo ) THEN
[4230]	829	endloop = nlci
	830	ELSE
	831	endloop = nlci - 1
	832	ENDIF
	833	DO ji = startloop , endloop
[4671]	834	ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
[8215]	835	pt2dl(ji,ijpj) = 0.5 * (pt2dl(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1))
[4230]	836	END DO
[8215]	837	!
[4230]	838	END SELECT
	839	!
	840	CASE DEFAULT ! * closed : the code probably never go through
	841	!
	842	SELECT CASE ( cd_type)
	843	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
[8215]	844	pt2dl(:, 1 ) = 0._wp
	845	pt2dl(:,ijpj) = 0._wp
[4230]	846	CASE ( 'F' ) ! F-point
[8215]	847	pt2dl(:,ijpj) = 0._wp
[4230]	848	CASE ( 'I' ) ! ice U-V point
[8215]	849	pt2dl(:, 1 ) = 0._wp
	850	pt2dl(:,ijpj) = 0._wp
[4230]	851	END SELECT
	852	!
	853	END SELECT
	854	!
	855	END SUBROUTINE mpp_lbc_nfd_2d
	856
[6140]	857	!!======================================================================
[1344]	858	END MODULE lbcnfd

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

Download in other formats: