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

Context Navigation

source: branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90 @ 7953

Last change on this file since 7953 was 7904, checked in by gm, 7 years ago
#1880 (HPC-09): phase with branch dev_r7832_HPC08_lbclnk_3rd_dim
Property svn:keywords set to `Id`
File size: 30.4 KB

Rev	Line
[3]	1	MODULE lbclnk
	2	!!======================================================================
[232]	3	!! * MODULE lbclnk *
[7904]	4	!! NEMO : lateral boundary conditions
[3]	5	!!=====================================================================
[6140]	6	!! History : OPA ! 1997-06 (G. Madec) Original code
	7	!! NEMO 1.0 ! 2002-09 (G. Madec) F90: Free form and module
[2335]	8	!! 3.2 ! 2009-03 (R. Benshila) External north fold treatment
[6140]	9	!! 3.5 ! 2012 (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk
	10	!! 3.4 ! 2012-12 (R. Bourdalle-Badie, G. Reffray) add a C1D case
[6490]	11	!! 3.6 ! 2015-06 (O. Tintó and M. Castrillo) add lbc_lnk_multi
[7904]	12	!! 4.0 ! 2017-03 (G. Madec) automatique allocation of array size (use with any 3rd dim size)
	13	!! - ! 2017-04 (G. Madec) remove duplicated routines (lbc_lnk_2d_9, lbc_lnk_2d_multiple, lbc_lnk_3d_gather)
[1344]	14	!!----------------------------------------------------------------------
[3764]	15	#if defined key_mpp_mpi
[3]	16	!!----------------------------------------------------------------------
[2335]	17	!! 'key_mpp_mpi' MPI massively parallel processing library
[3]	18	!!----------------------------------------------------------------------
[7904]	19	!! define the generic interfaces of lib_mpp routines
[15]	20	!!----------------------------------------------------------------------
[7904]	21	!! lbc_lnk : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp
	22	!! lbc_sum : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d routines defined in lib_mpp
	23	!! lbc_lnk_e : generic interface for mpp_lnk_2d_e routine defined in lib_mpp
	24	!! lbc_bdy_lnk : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp
	25	!!----------------------------------------------------------------------
[6140]	26	USE lib_mpp ! distributed memory computing library
[3]	27
[5429]	28	INTERFACE lbc_lnk_multi
[6490]	29	MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple
[5429]	30	END INTERFACE
[6140]	31	!
[3]	32	INTERFACE lbc_lnk
[473]	33	MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d
[3]	34	END INTERFACE
[6140]	35	!
	36	INTERFACE lbc_sum
	37	MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d
	38	END INTERFACE
[6493]	39	!
[3680]	40	INTERFACE lbc_bdy_lnk
	41	MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d
	42	END INTERFACE
[6140]	43	!
[311]	44	INTERFACE lbc_lnk_e
	45	MODULE PROCEDURE mpp_lnk_2d_e
	46	END INTERFACE
[6140]	47	!
[4990]	48	INTERFACE lbc_lnk_icb
	49	MODULE PROCEDURE mpp_lnk_2d_icb
	50	END INTERFACE
	51
[7904]	52	PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions
	53	PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions
	54	PUBLIC lbc_sum ! sum across processors
	55	PUBLIC lbc_lnk_e ! extended ocean/ice lateral boundary conditions
[6140]	56	PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions
[7904]	57	PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions
[2335]	58
[3]	59	!!----------------------------------------------------------------------
[7904]	60	!! NEMO/OPA 4.0 , NEMO Consortium (2017)
[2335]	61	!! $Id$
	62	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
	63	!!----------------------------------------------------------------------
[3]	64	#else
	65	!!----------------------------------------------------------------------
	66	!! Default option shared memory computing
	67	!!----------------------------------------------------------------------
[7904]	68	!! routines setting the appropriate values
	69	!! on first and last row and column of the global domain
	70	!!----------------------------------------------------------------------
[6140]	71	!! lbc_sum : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d
	72	!! lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh
	73	!! lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh
	74	!! lbc_lnk : generic interface for lbc_lnk_3d and lbc_lnk_2d
	75	!! lbc_lnk_3d : set the lateral boundary condition on a 3D variable on ocean mesh
	76	!! lbc_lnk_2d : set the lateral boundary condition on a 2D variable on ocean mesh
	77	!! lbc_bdy_lnk : set the lateral BDY boundary condition
[3]	78	!!----------------------------------------------------------------------
[7904]	79	USE oce ! ocean dynamics and tracers
	80	USE dom_oce ! ocean space and time domain
	81	USE in_out_manager ! I/O manager
	82	USE lbcnfd ! north fold
[3]	83
	84	IMPLICIT NONE
	85	PRIVATE
	86
	87	INTERFACE lbc_lnk
[473]	88	MODULE PROCEDURE lbc_lnk_3d_gather, lbc_lnk_3d, lbc_lnk_2d
[3]	89	END INTERFACE
[6140]	90	!
	91	INTERFACE lbc_sum
[6493]	92	MODULE PROCEDURE lbc_lnk_sum_3d, lbc_lnk_sum_2d
[6140]	93	END INTERFACE
[7904]	94	!
[311]	95	INTERFACE lbc_lnk_e
[3609]	96	MODULE PROCEDURE lbc_lnk_2d_e
[311]	97	END INTERFACE
[6140]	98	!
[6490]	99	INTERFACE lbc_lnk_multi
	100	MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple
	101	END INTERFACE
[7904]	102	!
[3680]	103	INTERFACE lbc_bdy_lnk
	104	MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d
	105	END INTERFACE
[6140]	106	!
[4990]	107	INTERFACE lbc_lnk_icb
	108	MODULE PROCEDURE lbc_lnk_2d_e
	109	END INTERFACE
[6490]	110
	111	TYPE arrayptr
	112	REAL , DIMENSION (:,:), POINTER :: pt2d
	113	END TYPE arrayptr
[7904]	114	!
[6490]	115	PUBLIC arrayptr
[4990]	116
[2335]	117	PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions
[6493]	118	PUBLIC lbc_sum ! ocean/ice lateral boundary conditions (sum of the overlap region)
[7904]	119	PUBLIC lbc_lnk_e ! extended ocean/ice lateral boundary conditions
	120	PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions
[3680]	121	PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions
[7904]	122	PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions
[2335]	123
[3]	124	!!----------------------------------------------------------------------
[7904]	125	!! NEMO/OPA 4.0 , NEMO Consortium (2017)
[2335]	126	!! $Id$
	127	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
	128	!!----------------------------------------------------------------------
[3]	129	CONTAINS
	130
[3764]	131	# if defined key_c1d
	132	!!----------------------------------------------------------------------
	133	!! 'key_c1d' 1D configuration
	134	!!----------------------------------------------------------------------
[7904]	135	!! central point value replicated over the 8 surrounding points
	136	!!----------------------------------------------------------------------
[3764]	137
	138	SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval )
	139	!!---------------------------------------------------------------------
	140	!! * ROUTINE lbc_lnk_3d *
	141	!!
	142	!! ** Purpose : set lateral boundary conditions on a 3D array (C1D case)
	143	!!
	144	!! ** Method : 1D case, the central water column is set everywhere
	145	!!----------------------------------------------------------------------
[7904]	146	REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied
	147	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
	148	REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold
	149	CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing)
	150	REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries)
[3764]	151	!
	152	INTEGER :: jk ! dummy loop index
	153	REAL(wp) :: ztab ! local scalar
	154	!!----------------------------------------------------------------------
	155	!
[7904]	156	DO jk = 1, SIZE( pt3d, 3 )
[3764]	157	ztab = pt3d(2,2,jk)
	158	pt3d(:,:,jk) = ztab
	159	END DO
	160	!
	161	END SUBROUTINE lbc_lnk_3d
	162
	163
	164	SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
	165	!!---------------------------------------------------------------------
	166	!! * ROUTINE lbc_lnk_2d *
	167	!!
	168	!! ** Purpose : set lateral boundary conditions on a 2D array (non mpp case)
	169	!!
	170	!! ** Method : 1D case, the central water column is set everywhere
	171	!!----------------------------------------------------------------------
[7904]	172	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied
[3764]	173	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
[7904]	174	REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold
[3764]	175	CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing)
	176	REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries)
	177	!
	178	REAL(wp) :: ztab ! local scalar
	179	!!----------------------------------------------------------------------
	180	!
	181	ztab = pt2d(2,2)
	182	pt2d(:,:) = ztab
	183	!
	184	END SUBROUTINE lbc_lnk_2d
[6490]	185
[3764]	186	#else
	187	!!----------------------------------------------------------------------
	188	!! Default option 3D shared memory computing
	189	!!----------------------------------------------------------------------
[7904]	190	!! routines setting land point, or east-west cyclic,
	191	!! or north-south cyclic, or north fold values
	192	!! on first and last row and column of the global domain
	193	!!----------------------------------------------------------------------
[3764]	194
[888]	195	SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval )
[473]	196	!!---------------------------------------------------------------------
[3]	197	!! * ROUTINE lbc_lnk_3d *
	198	!!
[2335]	199	!! ** Purpose : set lateral boundary conditions on a 3D array (non mpp case)
[3]	200	!!
[2335]	201	!! ** Method : psign = -1 : change the sign across the north fold
	202	!! = 1 : no change of the sign across the north fold
	203	!! = 0 : no change of the sign across the north fold and
	204	!! strict positivity preserved: use inner row/column
	205	!! for closed boundaries.
	206	!!----------------------------------------------------------------------
[7904]	207	REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied
	208	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
	209	REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold
	210	CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing)
	211	REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries)
	212	!
[2335]	213	REAL(wp) :: zland
[3]	214	!!----------------------------------------------------------------------
[7904]	215	!
[2335]	216	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default)
[3764]	217	ELSE ; zland = 0._wp
[888]	218	ENDIF
[7904]	219	!
[888]	220	IF( PRESENT( cd_mpp ) ) THEN
[473]	221	! only fill the overlap area and extra allows
	222	! this is in mpp case. In this module, just do nothing
	223	ELSE
[1344]	224	! ! East-West boundaries
	225	! ! ======================
[3]	226	SELECT CASE ( nperio )
[1344]	227	!
	228	CASE ( 1 , 4 , 6 ) !** cyclic east-west
	229	pt3d( 1 ,:,:) = pt3d(jpim1,:,:) ! all points
	230	pt3d(jpi,:,:) = pt3d( 2 ,:,:)
	231	!
	232	CASE DEFAULT !** East closed -- West closed
[3]	233	SELECT CASE ( cd_type )
	234	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
[1344]	235	pt3d( 1 ,:,:) = zland
	236	pt3d(jpi,:,:) = zland
[3]	237	CASE ( 'F' ) ! F-point
[1344]	238	pt3d(jpi,:,:) = zland
[3]	239	END SELECT
[1344]	240	!
[3]	241	END SELECT
	242	! ! North-South boundaries
	243	! ! ======================
	244	SELECT CASE ( nperio )
[1344]	245	!
	246	CASE ( 2 ) !** South symmetric -- North closed
[3]	247	SELECT CASE ( cd_type )
	248	CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points
[1344]	249	pt3d(:, 1 ,:) = pt3d(:,3,:)
	250	pt3d(:,jpj,:) = zland
[3]	251	CASE ( 'V' , 'F' ) ! V-, F-points
[1344]	252	pt3d(:, 1 ,:) = psgn * pt3d(:,2,:)
	253	pt3d(:,jpj,:) = zland
[3]	254	END SELECT
[1344]	255	!
	256	CASE ( 3 , 4 , 5 , 6 ) !** North fold T or F-point pivot -- South closed
	257	SELECT CASE ( cd_type ) ! South : closed
	258	CASE ( 'T' , 'U' , 'V' , 'W' , 'I' ) ! all points except F-point
	259	pt3d(:, 1 ,:) = zland
[3]	260	END SELECT
[1344]	261	! ! North fold
	262	CALL lbc_nfd( pt3d(:,:,:), cd_type, psgn )
	263	!
	264	CASE DEFAULT !** North closed -- South closed
[3]	265	SELECT CASE ( cd_type )
[1344]	266	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
	267	pt3d(:, 1 ,:) = zland
	268	pt3d(:,jpj,:) = zland
[3]	269	CASE ( 'F' ) ! F-point
[1344]	270	pt3d(:,jpj,:) = zland
[3]	271	END SELECT
[1344]	272	!
	273	END SELECT
[2335]	274	!
[1344]	275	ENDIF
[2335]	276	!
[3]	277	END SUBROUTINE lbc_lnk_3d
	278
[6140]	279
[888]	280	SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
[3]	281	!!---------------------------------------------------------------------
	282	!! * ROUTINE lbc_lnk_2d *
	283	!!
[2335]	284	!! ** Purpose : set lateral boundary conditions on a 2D array (non mpp case)
[3]	285	!!
[2335]	286	!! ** Method : psign = -1 : change the sign across the north fold
	287	!! = 1 : no change of the sign across the north fold
	288	!! = 0 : no change of the sign across the north fold and
	289	!! strict positivity preserved: use inner row/column
	290	!! for closed boundaries.
	291	!!----------------------------------------------------------------------
	292	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
[2339]	293	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied
[7904]	294	REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold
[2335]	295	CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing)
	296	REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries)
[3]	297	!!
[2335]	298	REAL(wp) :: zland
[3]	299	!!----------------------------------------------------------------------
	300
[2335]	301	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default)
[3764]	302	ELSE ; zland = 0._wp
[888]	303	ENDIF
	304
[473]	305	IF (PRESENT(cd_mpp)) THEN
	306	! only fill the overlap area and extra allows
	307	! this is in mpp case. In this module, just do nothing
	308	ELSE
[1344]	309	! ! East-West boundaries
	310	! ! ====================
	311	SELECT CASE ( nperio )
	312	!
	313	CASE ( 1 , 4 , 6 ) !** cyclic east-west
	314	pt2d( 1 ,:) = pt2d(jpim1,:) ! all points
	315	pt2d(jpi,:) = pt2d( 2 ,:)
	316	!
	317	CASE DEFAULT !** East closed -- West closed
	318	SELECT CASE ( cd_type )
	319	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
	320	pt2d( 1 ,:) = zland
	321	pt2d(jpi,:) = zland
	322	CASE ( 'F' ) ! F-point
	323	pt2d(jpi,:) = zland
	324	END SELECT
	325	!
[3]	326	END SELECT
[1344]	327	! ! North-South boundaries
	328	! ! ======================
	329	SELECT CASE ( nperio )
	330	!
	331	CASE ( 2 ) !** South symmetric -- North closed
	332	SELECT CASE ( cd_type )
	333	CASE ( 'T' , 'U' , 'W' ) ! T-, U-, W-points
	334	pt2d(:, 1 ) = pt2d(:,3)
	335	pt2d(:,jpj) = zland
	336	CASE ( 'V' , 'F' ) ! V-, F-points
	337	pt2d(:, 1 ) = psgn * pt2d(:,2)
	338	pt2d(:,jpj) = zland
	339	END SELECT
	340	!
	341	CASE ( 3 , 4 , 5 , 6 ) !** North fold T or F-point pivot -- South closed
	342	SELECT CASE ( cd_type ) ! South : closed
	343	CASE ( 'T' , 'U' , 'V' , 'W' , 'I' ) ! all points except F-point
	344	pt2d(:, 1 ) = zland
	345	END SELECT
	346	! ! North fold
	347	CALL lbc_nfd( pt2d(:,:), cd_type, psgn )
	348	!
	349	CASE DEFAULT !** North closed -- South closed
	350	SELECT CASE ( cd_type )
	351	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
	352	pt2d(:, 1 ) = zland
	353	pt2d(:,jpj) = zland
	354	CASE ( 'F' ) ! F-point
	355	pt2d(:,jpj) = zland
	356	END SELECT
	357	!
[3]	358	END SELECT
[2335]	359	!
[473]	360	ENDIF
[2335]	361	!
[3]	362	END SUBROUTINE lbc_lnk_2d
[6490]	363
[7904]	364	#endif
	365
	366	!!----------------------------------------------------------------------
	367	!! identical routines in both C1D and shared memory computing cases
	368	!!----------------------------------------------------------------------
	369
	370	SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn )
	371	!!---------------------------------------------------------------------
	372	!! * ROUTINE lbc_lnk_3d_gather *
[6490]	373	!!
[7904]	374	!! ** Purpose : set lateral boundary conditions on two 3D arrays (C1D case)
	375	!!
	376	!! ** Method : call lbc_lnk_3d on pt3d1 and pt3d2
	377	!!----------------------------------------------------------------------
	378	REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d1 , pt3d2 ! 3D array on which the lbc is applied
	379	CHARACTER(len=1) , INTENT(in ) :: cd_type1, cd_type2 ! nature of pt3d1 & pt3d2 grid-points
	380	REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold
	381	!!----------------------------------------------------------------------
[6490]	382	!
[7904]	383	CALL lbc_lnk_3d( pt3d1, cd_type1, psgn)
	384	CALL lbc_lnk_3d( pt3d2, cd_type2, psgn)
[6490]	385	!
[7904]	386	END SUBROUTINE lbc_lnk_3d_gather
	387
	388
	389	SUBROUTINE lbc_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld )
	390	!!---------------------------------------------------------------------
	391	TYPE( arrayptr ), DIMENSION(:), INTENT(inout) :: pt2d_array ! pointer array of 2D fields
	392	CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! nature of ptab_array grid-points
	393	REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! sign used across the north fold boundary
	394	INTEGER , INTENT(in ) :: kfld ! number of 2D fields
	395	!
	396	INTEGER :: jf !dummy loop index
	397	!!---------------------------------------------------------------------
	398	!
	399	DO jf = 1, kfld
	400	CALL lbc_lnk_2d( pt2d_array(jf)%pt2d, type_array(jf), psgn_array(jf) )
[6490]	401	END DO
	402	!
	403	END SUBROUTINE lbc_lnk_2d_multiple
[3]	404
[7904]	405
	406	SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC, &
	407	& pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF, &
	408	& pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, &
	409	& cd_mpp, pval )
[6490]	410	!!---------------------------------------------------------------------
[7904]	411	REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA ! 2D arrays on which the lbc is applied
[6490]	412	REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE
	413	REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI
[7904]	414	CHARACTER(len=1) , INTENT(in ) :: cd_typeA ! nature of pt2D. array grid-points
[6490]	415	CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE
	416	CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI
[7904]	417	REAL(wp) , INTENT(in ) :: psgnA ! sign used across the north fold
[6490]	418	REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE
	419	REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI
	420	CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only
	421	REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries)
	422	!!
	423	!!---------------------------------------------------------------------
[7904]	424	!
	425	CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) ! The first array
	426	!
	427	IF( PRESENT (psgnB) ) CALL lbc_lnk( pt2dB, cd_typeB, psgnB ) ! Look if more arrays to process
	428	IF( PRESENT (psgnC) ) CALL lbc_lnk( pt2dC, cd_typeC, psgnC )
	429	IF( PRESENT (psgnD) ) CALL lbc_lnk( pt2dD, cd_typeD, psgnD )
	430	IF( PRESENT (psgnE) ) CALL lbc_lnk( pt2dE, cd_typeE, psgnE )
	431	IF( PRESENT (psgnF) ) CALL lbc_lnk( pt2dF, cd_typeF, psgnF )
	432	IF( PRESENT (psgnG) ) CALL lbc_lnk( pt2dG, cd_typeG, psgnG )
	433	IF( PRESENT (psgnH) ) CALL lbc_lnk( pt2dH, cd_typeH, psgnH )
	434	IF( PRESENT (psgnI) ) CALL lbc_lnk( pt2dI, cd_typeI, psgnI )
	435	!
	436	END SUBROUTINE lbc_lnk_2d_9
[6490]	437
	438
[7904]	439	SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy )
	440	!!---------------------------------------------------------------------
	441	!! * ROUTINE lbc_bdy_lnk *
	442	!!
	443	!! ** Purpose : wrapper rountine to 'lbc_lnk_3d'. This wrapper is used
	444	!! to maintain the same interface with regards to the mpp case
	445	!!----------------------------------------------------------------------
	446	REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied
	447	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
	448	REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold
	449	INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set
	450	!!----------------------------------------------------------------------
	451	!
	452	CALL lbc_lnk_3d( pt3d, cd_type, psgn)
	453	!
	454	END SUBROUTINE lbc_bdy_lnk_3d
[6490]	455
	456
[7904]	457	SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy )
	458	!!---------------------------------------------------------------------
	459	!! * ROUTINE lbc_bdy_lnk *
	460	!!
	461	!! ** Purpose : wrapper rountine to 'lbc_lnk_2d'. This wrapper is used
	462	!! to maintain the same interface with regards to the mpp case
	463	!!----------------------------------------------------------------------
	464	REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 3D array on which the lbc is applied
	465	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
	466	REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold
	467	INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set
	468	!!----------------------------------------------------------------------
	469	!
	470	CALL lbc_lnk_2d( pt2d, cd_type, psgn)
	471	!
	472	END SUBROUTINE lbc_bdy_lnk_2d
	473
	474
	475	SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, ki, kj )
	476	!!---------------------------------------------------------------------
	477	!! * ROUTINE lbc_lnk_2d *
	478	!!
	479	!! ** Purpose : set lateral boundary conditions on a 2D array (non mpp case)
	480	!! special dummy routine to allow for use of halo indexing in mpp case
	481	!!----------------------------------------------------------------------
	482	REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied
	483	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
	484	REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold
	485	INTEGER , INTENT(in ) :: ki, kj ! sizes of extra halo (not needed in non-mpp)
	486	!!----------------------------------------------------------------------
	487	!
	488	CALL lbc_lnk_2d( pt2d, cd_type, psgn )
	489	!
	490	END SUBROUTINE lbc_lnk_2d_e
	491
	492
[6493]	493	SUBROUTINE lbc_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval )
	494	!!---------------------------------------------------------------------
	495	!! * ROUTINE lbc_lnk_sum_2d *
	496	!!
	497	!! ** Purpose : set lateral boundary conditions on a 2D array (non mpp case)
	498	!!
	499	!! ** Comments: compute the sum of the common cell (overlap region) for the ice sheet/ocean
	500	!! coupling if conservation option activated. As no ice shelf are present along
	501	!! this line, nothing is done along the north fold.
	502	!!----------------------------------------------------------------------
	503	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
	504	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied
[7904]	505	REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold
[6493]	506	CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing)
	507	REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries)
	508	!!
	509	REAL(wp) :: zland
	510	!!----------------------------------------------------------------------
[7904]	511	!
[6493]	512	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default)
	513	ELSE ; zland = 0._wp
	514	ENDIF
[7904]	515	!
[6493]	516	IF (PRESENT(cd_mpp)) THEN
	517	! only fill the overlap area and extra allows
	518	! this is in mpp case. In this module, just do nothing
	519	ELSE
	520	! ! East-West boundaries
	521	! ! ====================
	522	SELECT CASE ( nperio )
	523	!
	524	CASE ( 1 , 4 , 6 ) !** cyclic east-west
	525	pt2d(jpim1,:) = pt2d(jpim1,:) + pt2d( 1 ,:)
	526	pt2d( 2 ,:) = pt2d( 2 ,:) + pt2d(jpi,:)
	527	pt2d( 1 ,:) = 0.0_wp ! all points
	528	pt2d(jpi,:) = 0.0_wp
	529	!
	530	CASE DEFAULT !** East closed -- West closed
	531	SELECT CASE ( cd_type )
	532	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
	533	pt2d( 1 ,:) = zland
	534	pt2d(jpi,:) = zland
	535	CASE ( 'F' ) ! F-point
	536	pt2d(jpi,:) = zland
	537	END SELECT
	538	!
	539	END SELECT
	540	! ! North-South boundaries
	541	! ! ======================
	542	! Nothing to do for the north fold, there is no ice shelf along this line.
	543	!
	544	END IF
[7904]	545	!
[6493]	546	END SUBROUTINE
	547
[7904]	548
[6493]	549	SUBROUTINE lbc_lnk_sum_3d( pt3d, cd_type, psgn, cd_mpp, pval )
	550	!!---------------------------------------------------------------------
	551	!! * ROUTINE lbc_lnk_sum_3d *
	552	!!
	553	!! ** Purpose : set lateral boundary conditions on a 3D array (non mpp case)
	554	!!
	555	!! ** Comments: compute the sum of the common cell (overlap region) for the ice sheet/ocean
	556	!! coupling if conservation option activated. As no ice shelf are present along
	557	!! this line, nothing is done along the north fold.
	558	!!----------------------------------------------------------------------
[7904]	559	REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the lbc is applied
	560	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
	561	REAL(wp) , INTENT(in ) :: psgn ! sign used across north fold
	562	CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing)
	563	REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (for closed boundaries)
	564	!
[6493]	565	REAL(wp) :: zland
	566	!!----------------------------------------------------------------------
[7904]	567	!
[6493]	568	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value (zero by default)
	569	ELSE ; zland = 0._wp
	570	ENDIF
[7904]	571	!
[6493]	572	IF( PRESENT( cd_mpp ) ) THEN
	573	! only fill the overlap area and extra allows
	574	! this is in mpp case. In this module, just do nothing
	575	ELSE
	576	! ! East-West boundaries
	577	! ! ======================
	578	SELECT CASE ( nperio )
	579	!
	580	CASE ( 1 , 4 , 6 ) !** cyclic east-west
	581	pt3d(jpim1,:,:) = pt3d(jpim1,:,:) + pt3d( 1 ,:,:)
	582	pt3d( 2 ,:,:) = pt3d( 2 ,:,:) + pt3d(jpi,:,:)
[7904]	583	pt3d( 1 ,:,:) = 0._wp
	584	pt3d(jpi,:,:) = 0._wp
[6493]	585	!
	586	CASE DEFAULT !** East closed -- West closed
	587	SELECT CASE ( cd_type )
	588	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
	589	pt3d( 1 ,:,:) = zland
	590	pt3d(jpi,:,:) = zland
	591	CASE ( 'F' ) ! F-point
	592	pt3d(jpi,:,:) = zland
	593	END SELECT
	594	!
	595	END SELECT
	596	! ! North-South boundaries
	597	! ! ======================
	598	! Nothing to do for the north fold, there is no ice shelf along this line.
	599	!
	600	END IF
[7904]	601	!
[6493]	602	END SUBROUTINE
	603
[4153]	604	#endif
	605
[3]	606	!!======================================================================
	607	END MODULE lbclnk
[6490]	608

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

Download in other formats: