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

Context Navigation

source: trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90 @ 6490

Last change on this file since 6490 was 6490, checked in by mcastril, 8 years ago
Merging of branch dev_r5546_CNRS19_HPC_scalability
Property svn:keywords set to `Id`
File size: 28.5 KB

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

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

Download in other formats: