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

Context Navigation

source: trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90 @ 2787

Last change on this file since 2787 was 2715, checked in by rblod, 13 years ago
First attempt to put dynamic allocation on the trunk
Property svn:keywords set to `Id`
File size: 12.6 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
	238	END SELECT
[2413]	239	!
[1344]	240	CASE ( 5, 6 ) ! * North fold F-point pivot
[2413]	241	!
[1344]	242	SELECT CASE ( cd_type )
[2413]	243	CASE ( 'T' , 'W' ) ! T-, W-point
[1344]	244	DO jl = 0, ipr2dj
	245	DO ji = 1, jpiglo
	246	ijt = jpiglo-ji+1
	247	pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-1-jl)
	248	END DO
	249	END DO
	250	CASE ( 'U' ) ! U-point
	251	DO jl = 0, ipr2dj
	252	DO ji = 1, jpiglo-1
	253	iju = jpiglo-ji
	254	pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
	255	END DO
	256	END DO
	257	CASE ( 'V' ) ! V-point
	258	DO jl = 0, ipr2dj
	259	DO ji = 1, jpiglo
	260	ijt = jpiglo-ji+1
	261	pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
	262	END DO
	263	END DO
	264	DO ji = jpiglo/2+1, jpiglo
	265	ijt = jpiglo-ji+1
	266	pt2d(ji,ijpjm1) = psgn * pt2d(ijt,ijpjm1)
	267	END DO
[2413]	268	CASE ( 'F' ) ! F-point
[1344]	269	DO jl = 0, ipr2dj
	270	DO ji = 1, jpiglo-1
	271	iju = jpiglo-ji
	272	pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl)
	273	END DO
	274	END DO
	275	DO ji = jpiglo/2+1, jpiglo-1
	276	iju = jpiglo-ji
	277	pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
	278	END DO
[2413]	279	CASE ( 'I' ) ! ice U-V point (I-point)
[1344]	280	pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0
	281	DO jl = 0, ipr2dj
	282	DO ji = 2 , jpiglo-1
	283	ijt = jpiglo - ji + 2
	284	pt2d(ji,ijpj+jl)= 0.5 * ( pt2d(ji,ijpj-1-jl) + psgn * pt2d(ijt,ijpj-1-jl) )
	285	END DO
	286	END DO
	287	END SELECT
[2413]	288	!
[1344]	289	CASE DEFAULT ! * closed : the code probably never go through
[2413]	290	!
[1344]	291	SELECT CASE ( cd_type)
	292	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
	293	pt2d(:, 1:1-ipr2dj ) = 0.e0
	294	pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
	295	CASE ( 'F' ) ! F-point
	296	pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
	297	CASE ( 'I' ) ! ice U-V point
	298	pt2d(:, 1:1-ipr2dj ) = 0.e0
	299	pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
	300	END SELECT
[2413]	301	!
[1344]	302	END SELECT
[2413]	303	!
[1344]	304	END SUBROUTINE lbc_nfd_2d
	305
	306	!!======================================================================
	307	END MODULE lbcnfd

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

Download in other formats: