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

Context Navigation

source: branches/2015/dev_r5546_CNRS19_HPC_scalability/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90 @ 6052

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

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

Download in other formats: