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.

lbclnk.F90 in branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90 @ 3211

Last change on this file since 3211 was 3211, checked in by spickles2, 12 years ago

Stephen Pickles, 11 Dec 2011

Commit to bring the rest of the DCSE NEMO development branch
in line with the latest development version. This includes
array index re-ordering of all OPA_SRC/.

Property svn:keywords set to Id

File size: 13.1 KB

Rev	Line
[3]	1	MODULE lbclnk
	2	!!======================================================================
[232]	3	!! * MODULE lbclnk *
[3]	4	!! Ocean : lateral boundary conditions
	5	!!=====================================================================
[2335]	6	!! History : OPA ! 1997-06 (G. Madec) Original code
	7	!! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module
	8	!! 3.2 ! 2009-03 (R. Benshila) External north fold treatment
[1344]	9	!!----------------------------------------------------------------------
[2335]	10	#if defined key_mpp_mpi
[3]	11	!!----------------------------------------------------------------------
[2335]	12	!! 'key_mpp_mpi' MPI massively parallel processing library
[3]	13	!!----------------------------------------------------------------------
[2335]	14	!! lbc_lnk : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp
	15	!! lbc_lnk_e : generic interface for mpp_lnk_2d_e routine defined in lib_mpp
[15]	16	!!----------------------------------------------------------------------
[3]	17	USE lib_mpp ! distributed memory computing library
	18
	19	INTERFACE lbc_lnk
[473]	20	MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d
[3]	21	END INTERFACE
	22
[311]	23	INTERFACE lbc_lnk_e
	24	MODULE PROCEDURE mpp_lnk_2d_e
	25	END INTERFACE
	26
[3]	27	PUBLIC lbc_lnk ! ocean lateral boundary conditions
[311]	28	PUBLIC lbc_lnk_e
[2335]	29
[3]	30	!!----------------------------------------------------------------------
[2335]	31	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
	32	!! $Id$
	33	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
	34	!!----------------------------------------------------------------------
[3]	35
	36	#else
	37	!!----------------------------------------------------------------------
	38	!! Default option shared memory computing
	39	!!----------------------------------------------------------------------
	40	!! lbc_lnk : generic interface for lbc_lnk_3d and lbc_lnk_2d
[2335]	41	!! lbc_lnk_3d : set the lateral boundary condition on a 3D variable on ocean mesh
	42	!! lbc_lnk_2d : set the lateral boundary condition on a 2D variable on ocean mesh
[3]	43	!!----------------------------------------------------------------------
	44	USE oce ! ocean dynamics and tracers
	45	USE dom_oce ! ocean space and time domain
	46	USE in_out_manager ! I/O manager
[1344]	47	USE lbcnfd ! north fold
[3]	48
	49	IMPLICIT NONE
	50	PRIVATE
	51
	52	INTERFACE lbc_lnk
[473]	53	MODULE PROCEDURE lbc_lnk_3d_gather, lbc_lnk_3d, lbc_lnk_2d
[3]	54	END INTERFACE
	55
[311]	56	INTERFACE lbc_lnk_e
	57	MODULE PROCEDURE lbc_lnk_2d
	58	END INTERFACE
	59
[2335]	60	PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions
	61	PUBLIC lbc_lnk_e
[3211]	62
	63	!! * Control permutation of array indices
	64	# include "oce_ftrans.h90"
	65	# include "dom_oce_ftrans.h90"
	66
[3]	67	!!----------------------------------------------------------------------
[2335]	68	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
	69	!! $Id$
	70	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
	71	!!----------------------------------------------------------------------
[3]	72	CONTAINS
	73
[473]	74	SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn )
[3]	75	!!---------------------------------------------------------------------
[473]	76	!! * ROUTINE lbc_lnk_3d_gather *
	77	!!
[2335]	78	!! ** Purpose : set lateral boundary conditions on two 3D arrays (non mpp case)
[473]	79	!!
[2335]	80	!! ** Method : psign = -1 : change the sign across the north fold
	81	!! = 1 : no change of the sign across the north fold
	82	!! = 0 : no change of the sign across the north fold and
	83	!! strict positivity preserved: use inner row/column
	84	!! for closed boundaries.
[473]	85	!!----------------------------------------------------------------------
[2335]	86	CHARACTER(len=1) , INTENT(in ) :: cd_type1, cd_type2 ! nature of pt3d grid-points
[3211]	87	!FTRANS pt3d1 :I :I :z
	88	!FTRANS pt3d2 :I :I :z
	89	! DCSE_NEMO: work around a deficiency in ftrans
	90	! REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d1 , pt3d2 ! 3D array on which the lbc is applied
	91	REAL(wp), INTENT(inout) :: pt3d1(jpi,jpj,jpk) , pt3d2(jpi,jpj,jpk)
	92	REAL(wp), INTENT(in ) :: psgn ! control of the sign
[2335]	93	!!----------------------------------------------------------------------
	94	!
[1344]	95	CALL lbc_lnk_3d( pt3d1, cd_type1, psgn)
	96	CALL lbc_lnk_3d( pt3d2, cd_type2, psgn)
[2335]	97	!
[473]	98	END SUBROUTINE lbc_lnk_3d_gather
	99
	100
[888]	101	SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval )
[473]	102	!!---------------------------------------------------------------------
[3]	103	!! * ROUTINE lbc_lnk_3d *
	104	!!
[2335]	105	!! ** Purpose : set lateral boundary conditions on a 3D array (non mpp case)
[3]	106	!!
[2335]	107	!! ** Method : psign = -1 : change the sign across the north fold
	108	!! = 1 : no change of the sign across the north fold
	109	!! = 0 : no change of the sign across the north fold and
	110	!! strict positivity preserved: use inner row/column
	111	!! for closed boundaries.
	112	!!----------------------------------------------------------------------
	113	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
[3211]	114	!FTRANS pt3d :I :I :z
	115	!! DCSE_NEMO: work around a deficiency in ftrans
	116	! REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied
	117	REAL(wp), INTENT(inout) :: pt3d(jpi,jpj,jpk)
[2335]	118	REAL(wp) , INTENT(in ) :: psgn ! control of the sign
	119	CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing)
	120	REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries)
[3]	121	!!
[2335]	122	REAL(wp) :: zland
[3]	123	!!----------------------------------------------------------------------
	124
[2335]	125	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default)
	126	ELSE ; zland = 0.e0
[888]	127	ENDIF
	128
	129
	130	IF( PRESENT( cd_mpp ) ) THEN
[473]	131	! only fill the overlap area and extra allows
	132	! this is in mpp case. In this module, just do nothing
	133	ELSE
[2335]	134	!
[1344]	135	! ! East-West boundaries
	136	! ! ======================
[3]	137	SELECT CASE ( nperio )
[1344]	138	!
	139	CASE ( 1 , 4 , 6 ) !** cyclic east-west
	140	pt3d( 1 ,:,:) = pt3d(jpim1,:,:) ! all points
	141	pt3d(jpi,:,:) = pt3d( 2 ,:,:)
	142	!
	143	CASE DEFAULT !** East closed -- West closed
[3]	144	SELECT CASE ( cd_type )
	145	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
[1344]	146	pt3d( 1 ,:,:) = zland
	147	pt3d(jpi,:,:) = zland
[3]	148	CASE ( 'F' ) ! F-point
[1344]	149	pt3d(jpi,:,:) = zland
[3]	150	END SELECT
[1344]	151	!
[3]	152	END SELECT
[2335]	153	!
[3]	154	! ! North-South boundaries
	155	! ! ======================
	156	SELECT CASE ( nperio )
[1344]	157	!
	158	CASE ( 2 ) !** South symmetric -- North closed
[3]	159	SELECT CASE ( cd_type )
	160	CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points
[1344]	161	pt3d(:, 1 ,:) = pt3d(:,3,:)
	162	pt3d(:,jpj,:) = zland
[3]	163	CASE ( 'V' , 'F' ) ! V-, F-points
[1344]	164	pt3d(:, 1 ,:) = psgn * pt3d(:,2,:)
	165	pt3d(:,jpj,:) = zland
[3]	166	END SELECT
[1344]	167	!
	168	CASE ( 3 , 4 , 5 , 6 ) !** North fold T or F-point pivot -- South closed
	169	SELECT CASE ( cd_type ) ! South : closed
	170	CASE ( 'T' , 'U' , 'V' , 'W' , 'I' ) ! all points except F-point
	171	pt3d(:, 1 ,:) = zland
[3]	172	END SELECT
[1344]	173	! ! North fold
	174	pt3d( 1 ,jpj,:) = zland
	175	pt3d(jpi,jpj,:) = zland
	176	CALL lbc_nfd( pt3d(:,:,:), cd_type, psgn )
	177	!
	178	CASE DEFAULT !** North closed -- South closed
[3]	179	SELECT CASE ( cd_type )
[1344]	180	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
	181	pt3d(:, 1 ,:) = zland
	182	pt3d(:,jpj,:) = zland
[3]	183	CASE ( 'F' ) ! F-point
[1344]	184	pt3d(:,jpj,:) = zland
[3]	185	END SELECT
[1344]	186	!
	187	END SELECT
[2335]	188	!
[1344]	189	ENDIF
[2335]	190	!
[3]	191	END SUBROUTINE lbc_lnk_3d
	192
	193
[888]	194	SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
[3]	195	!!---------------------------------------------------------------------
	196	!! * ROUTINE lbc_lnk_2d *
	197	!!
[2335]	198	!! ** Purpose : set lateral boundary conditions on a 2D array (non mpp case)
[3]	199	!!
[2335]	200	!! ** Method : psign = -1 : change the sign across the north fold
	201	!! = 1 : no change of the sign across the north fold
	202	!! = 0 : no change of the sign across the north fold and
	203	!! strict positivity preserved: use inner row/column
	204	!! for closed boundaries.
	205	!!----------------------------------------------------------------------
	206	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
[2339]	207	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied
[2335]	208	REAL(wp) , INTENT(in ) :: psgn ! control of the sign
	209	CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing)
	210	REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries)
[3]	211	!!
[2335]	212	REAL(wp) :: zland
[3]	213	!!----------------------------------------------------------------------
	214
[2335]	215	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default)
	216	ELSE ; zland = 0.e0
[888]	217	ENDIF
	218
[473]	219	IF (PRESENT(cd_mpp)) THEN
	220	! only fill the overlap area and extra allows
	221	! this is in mpp case. In this module, just do nothing
	222	ELSE
[2335]	223	!
[1344]	224	! ! East-West boundaries
	225	! ! ====================
	226	SELECT CASE ( nperio )
	227	!
	228	CASE ( 1 , 4 , 6 ) !** cyclic east-west
	229	pt2d( 1 ,:) = pt2d(jpim1,:) ! all points
	230	pt2d(jpi,:) = pt2d( 2 ,:)
	231	!
	232	CASE DEFAULT !** East closed -- West closed
	233	SELECT CASE ( cd_type )
	234	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
	235	pt2d( 1 ,:) = zland
	236	pt2d(jpi,:) = zland
	237	CASE ( 'F' ) ! F-point
	238	pt2d(jpi,:) = zland
	239	END SELECT
	240	!
[3]	241	END SELECT
[2335]	242	!
[1344]	243	! ! North-South boundaries
	244	! ! ======================
	245	SELECT CASE ( nperio )
	246	!
	247	CASE ( 2 ) !** South symmetric -- North closed
	248	SELECT CASE ( cd_type )
	249	CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points
	250	pt2d(:, 1 ) = pt2d(:,3)
	251	pt2d(:,jpj) = zland
	252	CASE ( 'V' , 'F' ) ! V-, F-points
	253	pt2d(:, 1 ) = psgn * pt2d(:,2)
	254	pt2d(:,jpj) = zland
	255	END SELECT
	256	!
	257	CASE ( 3 , 4 , 5 , 6 ) !** North fold T or F-point pivot -- South closed
	258	SELECT CASE ( cd_type ) ! South : closed
	259	CASE ( 'T' , 'U' , 'V' , 'W' , 'I' ) ! all points except F-point
	260	pt2d(:, 1 ) = zland
	261	END SELECT
	262	! ! North fold
	263	pt2d( 1 ,1 ) = zland
	264	pt2d( 1 ,jpj) = zland
	265	pt2d(jpi,jpj) = zland
	266	CALL lbc_nfd( pt2d(:,:), cd_type, psgn )
	267	!
	268	CASE DEFAULT !** North closed -- South closed
	269	SELECT CASE ( cd_type )
	270	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
	271	pt2d(:, 1 ) = zland
	272	pt2d(:,jpj) = zland
	273	CASE ( 'F' ) ! F-point
	274	pt2d(:,jpj) = zland
	275	END SELECT
	276	!
[3]	277	END SELECT
[2335]	278	!
[473]	279	ENDIF
[2335]	280	!
[3]	281	END SUBROUTINE lbc_lnk_2d
	282
	283	#endif
	284
	285	!!======================================================================
	286	END MODULE lbclnk

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

Download in other formats: