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/2011/dev_NEMO_MERGE_2011/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/2011/dev_NEMO_MERGE_2011/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90 @ 3261

Last change on this file since 3261 was 3116, checked in by cetlod, 13 years ago
dev_NEMO_MERGE_2011: add in changes dev_NOC_UKMO_MERGE developments
Property svn:keywords set to `Id`
File size: 14.2 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
[1344]	7	!!----------------------------------------------------------------------
	8
[2413]	9	!!----------------------------------------------------------------------
	10	!! lbc_nfd : generic interface for lbc_nfd_3d and lbc_nfd_2d routines
	11	!! lbc_nfd_3d : lateral boundary condition: North fold treatment for a 3D arrays (lbc_nfd)
	12	!! lbc_nfd_2d : lateral boundary condition: North fold treatment for a 2D arrays (lbc_nfd)
	13	!!----------------------------------------------------------------------
	14	USE dom_oce ! ocean space and time domain
	15	USE in_out_manager ! I/O manager
	16
[1344]	17	IMPLICIT NONE
	18	PRIVATE
	19
	20	INTERFACE lbc_nfd
[2413]	21	MODULE PROCEDURE lbc_nfd_3d, lbc_nfd_2d
[1344]	22	END INTERFACE
	23
[2413]	24	PUBLIC lbc_nfd ! north fold conditions
[2287]	25
[1344]	26	!!----------------------------------------------------------------------
[2287]	27	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
	28	!! $Id$
[2413]	29	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[2287]	30	!!----------------------------------------------------------------------
[1344]	31	CONTAINS
	32
	33	SUBROUTINE lbc_nfd_3d( pt3d, cd_type, psgn )
	34	!!----------------------------------------------------------------------
	35	!! * routine lbc_nfd_3d *
	36	!!
	37	!! ** Purpose : 3D lateral boundary condition : North fold treatment
[2413]	38	!! without processor exchanges.
[1344]	39	!!
	40	!! ** Method :
	41	!!
[2413]	42	!! ** Action : pt3d with updated values along the north fold
[1344]	43	!!----------------------------------------------------------------------
[2413]	44	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
	45	! ! = T , U , V , F , W points
	46	REAL(wp) , INTENT(in ) :: psgn ! control of the sign change
	47	! ! = -1. , the sign is changed if north fold boundary
	48	! ! = 1. , the sign is kept if north fold boundary
	49	REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the boundary condition is applied
	50	!
[1344]	51	INTEGER :: ji, jk
	52	INTEGER :: ijt, iju, ijpj, ijpjm1
[2413]	53	!!----------------------------------------------------------------------
[1344]	54
	55	SELECT CASE ( jpni )
[2413]	56	CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction
	57	CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction
[1344]	58	END SELECT
	59	ijpjm1 = ijpj-1
	60
	61	DO jk = 1, jpk
[2413]	62	!
[1344]	63	SELECT CASE ( npolj )
[2413]	64	!
[1344]	65	CASE ( 3 , 4 ) ! * North fold T-point pivot
[2413]	66	!
[1344]	67	SELECT CASE ( cd_type )
	68	CASE ( 'T' , 'W' ) ! T-, W-point
	69	DO ji = 2, jpiglo
	70	ijt = jpiglo-ji+2
	71	pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk)
	72	END DO
	73	DO ji = jpiglo/2+1, jpiglo
	74	ijt = jpiglo-ji+2
	75	pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk)
	76	END DO
	77	CASE ( 'U' ) ! U-point
	78	DO ji = 1, jpiglo-1
	79	iju = jpiglo-ji+1
	80	pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk)
	81	END DO
	82	DO ji = jpiglo/2, jpiglo-1
	83	iju = jpiglo-ji+1
	84	pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk)
	85	END DO
	86	CASE ( 'V' ) ! V-point
	87	DO ji = 2, jpiglo
	88	ijt = jpiglo-ji+2
	89	pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk)
	90	pt3d(ji,ijpj ,jk) = psgn * pt3d(ijt,ijpj-3,jk)
	91	END DO
	92	CASE ( 'F' ) ! F-point
	93	DO ji = 1, jpiglo-1
	94	iju = jpiglo-ji+1
	95	pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk)
	96	pt3d(ji,ijpj ,jk) = psgn * pt3d(iju,ijpj-3,jk)
	97	END DO
	98	END SELECT
[2413]	99	!
[1344]	100	CASE ( 5 , 6 ) ! * North fold F-point pivot
[2413]	101	!
[1344]	102	SELECT CASE ( cd_type )
	103	CASE ( 'T' , 'W' ) ! T-, W-point
	104	DO ji = 1, jpiglo
	105	ijt = jpiglo-ji+1
	106	pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk)
	107	END DO
	108	CASE ( 'U' ) ! U-point
	109	DO ji = 1, jpiglo-1
	110	iju = jpiglo-ji
	111	pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk)
	112	END DO
	113	CASE ( 'V' ) ! V-point
	114	DO ji = 1, jpiglo
	115	ijt = jpiglo-ji+1
	116	pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk)
	117	END DO
	118	DO ji = jpiglo/2+1, jpiglo
	119	ijt = jpiglo-ji+1
	120	pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk)
	121	END DO
	122	CASE ( 'F' ) ! F-point
	123	DO ji = 1, jpiglo-1
	124	iju = jpiglo-ji
	125	pt3d(ji,ijpj ,jk) = psgn * pt3d(iju,ijpj-2,jk)
	126	END DO
	127	DO ji = jpiglo/2+1, jpiglo-1
	128	iju = jpiglo-ji
	129	pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk)
	130	END DO
	131	END SELECT
[2413]	132	!
[1344]	133	CASE DEFAULT ! * closed : the code probably never go through
[2413]	134	!
[1344]	135	SELECT CASE ( cd_type)
	136	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
	137	pt3d(:, 1 ,jk) = 0.e0
	138	pt3d(:,ijpj,jk) = 0.e0
	139	CASE ( 'F' ) ! F-point
	140	pt3d(:,ijpj,jk) = 0.e0
	141	END SELECT
[2413]	142	!
[1344]	143	END SELECT ! npolj
[2413]	144	!
[1344]	145	END DO
[2413]	146	!
[1344]	147	END SUBROUTINE lbc_nfd_3d
	148
	149
	150	SUBROUTINE lbc_nfd_2d( pt2d, cd_type, psgn, pr2dj )
	151	!!----------------------------------------------------------------------
	152	!! * routine lbc_nfd_2d *
	153	!!
	154	!! ** Purpose : 2D lateral boundary condition : North fold treatment
	155	!! without processor exchanges.
	156	!!
	157	!! ** Method :
	158	!!
[2413]	159	!! ** Action : pt2d with updated values along the north fold
[1344]	160	!!----------------------------------------------------------------------
[2413]	161	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
	162	! ! = T , U , V , F , W points
	163	REAL(wp) , INTENT(in ) :: psgn ! control of the sign change
	164	! ! = -1. , the sign is changed if north fold boundary
	165	! ! = 1. , the sign is kept if north fold boundary
	166	REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied
	167	INTEGER , OPTIONAL , INTENT(in ) :: pr2dj ! number of additional halos
	168	!
[1344]	169	INTEGER :: ji, jl, ipr2dj
	170	INTEGER :: ijt, iju, ijpj, ijpjm1
[2413]	171	!!----------------------------------------------------------------------
[1344]	172
	173	SELECT CASE ( jpni )
[2413]	174	CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction
	175	CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction
[1344]	176	END SELECT
[2413]	177	!
	178	IF( PRESENT(pr2dj) ) THEN ! use of additional halos
[1344]	179	ipr2dj = pr2dj
[2413]	180	IF( jpni > 1 ) ijpj = ijpj + ipr2dj
[1344]	181	ELSE
	182	ipr2dj = 0
	183	ENDIF
[2413]	184	!
[1344]	185	ijpjm1 = ijpj-1
	186
	187
	188	SELECT CASE ( npolj )
[2413]	189	!
[1344]	190	CASE ( 3, 4 ) ! * North fold T-point pivot
[2413]	191	!
[1344]	192	SELECT CASE ( cd_type )
[2413]	193	!
	194	CASE ( 'T' , 'W' ) ! T- , W-points
[1344]	195	DO jl = 0, ipr2dj
	196	DO ji = 2, jpiglo
	197	ijt=jpiglo-ji+2
	198	pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
	199	END DO
	200	END DO
	201	DO ji = jpiglo/2+1, jpiglo
	202	ijt=jpiglo-ji+2
	203	pt2d(ji,ijpj-1) = psgn * pt2d(ijt,ijpj-1)
	204	END DO
	205	CASE ( 'U' ) ! U-point
[2413]	206	DO jl = 0, ipr2dj
[1344]	207	DO ji = 1, jpiglo-1
	208	iju = jpiglo-ji+1
	209	pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl)
	210	END DO
	211	END DO
	212	DO ji = jpiglo/2, jpiglo-1
	213	iju = jpiglo-ji+1
	214	pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
	215	END DO
	216	CASE ( 'V' ) ! V-point
[2413]	217	DO jl = -1, ipr2dj
[1344]	218	DO ji = 2, jpiglo
	219	ijt = jpiglo-ji+2
	220	pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-3-jl)
	221	END DO
	222	END DO
[2413]	223	CASE ( 'F' ) ! F-point
	224	DO jl = -1, ipr2dj
[1344]	225	DO ji = 1, jpiglo-1
	226	iju = jpiglo-ji+1
	227	pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-3-jl)
	228	END DO
	229	END DO
[2413]	230	CASE ( 'I' ) ! ice U-V point (I-point)
	231	DO jl = 0, ipr2dj
[1344]	232	pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl)
	233	DO ji = 3, jpiglo
	234	iju = jpiglo - ji + 3
	235	pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
	236	END DO
	237	END DO
[3116]	238	CASE ( 'J' ) ! first ice U-V point
	239	DO jl =0, ipr2dj
	240	pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl)
	241	DO ji = 3, jpiglo
	242	iju = jpiglo - ji + 3
	243	pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
	244	END DO
	245	END DO
	246	CASE ( 'K' ) ! second ice U-V point
	247	DO jl =0, ipr2dj
	248	pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl)
	249	DO ji = 3, jpiglo
	250	iju = jpiglo - ji + 3
	251	pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
	252	END DO
	253	END DO
[1344]	254	END SELECT
[2413]	255	!
[1344]	256	CASE ( 5, 6 ) ! * North fold F-point pivot
[2413]	257	!
[1344]	258	SELECT CASE ( cd_type )
[2413]	259	CASE ( 'T' , 'W' ) ! T-, W-point
[1344]	260	DO jl = 0, ipr2dj
	261	DO ji = 1, jpiglo
	262	ijt = jpiglo-ji+1
	263	pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-1-jl)
	264	END DO
	265	END DO
	266	CASE ( 'U' ) ! U-point
	267	DO jl = 0, ipr2dj
	268	DO ji = 1, jpiglo-1
	269	iju = jpiglo-ji
	270	pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
	271	END DO
	272	END DO
	273	CASE ( 'V' ) ! V-point
	274	DO jl = 0, ipr2dj
	275	DO ji = 1, jpiglo
	276	ijt = jpiglo-ji+1
	277	pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
	278	END DO
	279	END DO
	280	DO ji = jpiglo/2+1, jpiglo
	281	ijt = jpiglo-ji+1
	282	pt2d(ji,ijpjm1) = psgn * pt2d(ijt,ijpjm1)
	283	END DO
[2413]	284	CASE ( 'F' ) ! F-point
[1344]	285	DO jl = 0, ipr2dj
	286	DO ji = 1, jpiglo-1
	287	iju = jpiglo-ji
	288	pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl)
	289	END DO
	290	END DO
	291	DO ji = jpiglo/2+1, jpiglo-1
	292	iju = jpiglo-ji
	293	pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
	294	END DO
[2413]	295	CASE ( 'I' ) ! ice U-V point (I-point)
[1344]	296	pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0
	297	DO jl = 0, ipr2dj
	298	DO ji = 2 , jpiglo-1
	299	ijt = jpiglo - ji + 2
	300	pt2d(ji,ijpj+jl)= 0.5 * ( pt2d(ji,ijpj-1-jl) + psgn * pt2d(ijt,ijpj-1-jl) )
	301	END DO
	302	END DO
[3116]	303	CASE ( 'J' ) ! first ice U-V point
	304	pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0
	305	DO jl = 0, ipr2dj
	306	DO ji = 2 , jpiglo-1
	307	ijt = jpiglo - ji + 2
	308	pt2d(ji,ijpj+jl)= pt2d(ji,ijpj-1-jl)
	309	END DO
	310	END DO
	311	CASE ( 'K' ) ! second ice U-V point
	312	pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0
	313	DO jl = 0, ipr2dj
	314	DO ji = 2 , jpiglo-1
	315	ijt = jpiglo - ji + 2
	316	pt2d(ji,ijpj+jl)= pt2d(ijt,ijpj-1-jl)
	317	END DO
	318	END DO
[1344]	319	END SELECT
[2413]	320	!
[1344]	321	CASE DEFAULT ! * closed : the code probably never go through
[2413]	322	!
[1344]	323	SELECT CASE ( cd_type)
	324	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
	325	pt2d(:, 1:1-ipr2dj ) = 0.e0
	326	pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
	327	CASE ( 'F' ) ! F-point
	328	pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
	329	CASE ( 'I' ) ! ice U-V point
	330	pt2d(:, 1:1-ipr2dj ) = 0.e0
	331	pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
[3116]	332	CASE ( 'J' ) ! first ice U-V point
	333	pt2d(:, 1:1-ipr2dj ) = 0.e0
	334	pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
	335	CASE ( 'K' ) ! second ice U-V point
	336	pt2d(:, 1:1-ipr2dj ) = 0.e0
	337	pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
[1344]	338	END SELECT
[2413]	339	!
[1344]	340	END SELECT
[2413]	341	!
[1344]	342	END SUBROUTINE lbc_nfd_2d
	343
	344	!!======================================================================
	345	END MODULE lbcnfd

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

Download in other formats: