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.

obcini.F90 in branches/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC/OBC – NEMO

Context Navigation

source: branches/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC/OBC/obcini.F90 @ 4147

Last change on this file since 4147 was 4147, checked in by cetlod, 10 years ago
merge in dev_LOCEAN_2013, the 1st development branch dev_r3853_CNRS9_Confsetting, from its starting point ( r3853 ) on the trunk: see ticket #1169
Property svn:keywords set to `Id`
File size: 30.5 KB

Line
1	MODULE obcini
2	!!======================================================================
3	!! * MODULE obcini *
4	!! OBC initial state : Open boundary initial state
5	!!======================================================================
6	!! History : 8.0 ! 97-07 (J.M. Molines, G. Madec) Original code
7	!! NEMO 1.0 ! 02-11 (C. Talandier, A-M. Treguier) Free surface, F90
8	!! 2.0 ! 05-11 (V. Garnier) Surface pressure gradient organization
9	!!----------------------------------------------------------------------
10	#if defined key_obc
11	!!----------------------------------------------------------------------
12	!! 'key_obc' Open Boundary Conditions
13	!!----------------------------------------------------------------------
14	!! obc_init : initialization for the open boundary condition
15	!!----------------------------------------------------------------------
16	USE oce ! ocean dynamics and tracers variables
17	USE dom_oce ! ocean space and time domain variables
18	USE lbclnk ! ocean lateral boundary conditions (or mpp link)
19	USE phycst ! physical constants
20	USE obc_oce ! open boundary condition: ocean
21	USE obcdta ! open boundary condition: data
22	USE in_out_manager ! I/O units
23	USE lib_mpp ! MPP library
24	USE dynspg_oce ! flag lk_dynspg_flt
25
26	IMPLICIT NONE
27	PRIVATE
28
29	PUBLIC obc_init ! routine called by opa.F90
30
31	!! * Substitutions
32	# include "obc_vectopt_loop_substitute.h90"
33	!!----------------------------------------------------------------------
34	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
35	!! $Id$
36	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
37	!!----------------------------------------------------------------------
38	CONTAINS
39
40	SUBROUTINE obc_init
41	!!----------------------------------------------------------------------
42	!! * ROUTINE obc_init *
43	!!
44	!! ** Purpose : Initialization of the dynamics and tracer fields at
45	!! the open boundaries.
46	!!
47	!! ** Method : initialization of open boundary variables
48	!! (u, v) over 3 time step and 3 rows
49	!! (t, s) over 2 time step and 2 rows
50	!! if ln_rstart = .FALSE. : no restart, fields set to zero
51	!! if ln_rstart = .TRUE. : restart, fields are read in a file
52	!! if rdpxxx = 0 then lfbc is set true for this boundary.
53	!!
54	!! ** Input : restart.obc file, restart file for open boundaries
55	!!----------------------------------------------------------------------
56	USE obcrst, ONLY : obc_rst_read ! Make obc_rst_read routine available
57	!!
58	INTEGER :: ji, jj, istop , inumfbc
59	INTEGER :: ios ! Local integer output status for namelist read
60	INTEGER, DIMENSION(4) :: icorner
61	REAL(wp), DIMENSION(2) :: ztestmask
62	!!
63	NAMELIST/namobc/ rn_dpein, rn_dpwin, rn_dpnin, rn_dpsin, &
64	& rn_dpeob, rn_dpwob, rn_dpnob, rn_dpsob, &
65	& rn_volemp, nn_obcdta, cn_obcdta, &
66	& ln_obc_clim, ln_vol_cst, ln_obc_fla
67	!!----------------------------------------------------------------------
68
69	REWIND( numnam_ref ) ! Namelist namobc in reference namelist : Open boundaries
70	READ ( numnam_ref, namobc, IOSTAT = ios, ERR = 901)
71	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobc in reference namelist', lwp )
72
73	REWIND( numnam_cfg ) ! Namelist namobc in configuration namelist : Open boundaries
74	READ ( numnam_cfg, namobc, IOSTAT = ios, ERR = 902 )
75	902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobc in configuration namelist', lwp )
76	WRITE ( numond, namobc )
77
78	! convert DOCTOR namelist name into the OLD names
79	nobc_dta = nn_obcdta
80	cffile = cn_obcdta
81	rdpein = rn_dpein
82	rdpwin = rn_dpwin
83	rdpsin = rn_dpsin
84	rdpnin = rn_dpnin
85	rdpeob = rn_dpeob
86	rdpwob = rn_dpwob
87	rdpsob = rn_dpsob
88	rdpnob = rn_dpnob
89	volemp = rn_volemp
90
91	! ! allocate obc arrays
92	IF( obc_oce_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'obc_init : unable to allocate obc_oce arrays' )
93	IF( obc_dta_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'obc_init : unable to allocate obc_dta arrays' )
94
95	! By security we set rdpxin and rdpxob respectively to 1. and 15. if the corresponding OBC is not activated
96	IF( .NOT.lp_obc_east ) THEN ; rdpein = 1. ; rdpeob = 15. ; END IF
97	IF( .NOT.lp_obc_west ) THEN ; rdpwin = 1. ; rdpwob = 15. ; END IF
98	IF( .NOT.lp_obc_north ) THEN ; rdpnin = 1. ; rdpnob = 15. ; END IF
99	IF( .NOT.lp_obc_south ) THEN ; rdpsin = 1. ; rdpsob = 15. ; END IF
100
101	! number of open boudaries and open boundary indicators
102	nbobc = 0
103	IF( lp_obc_east ) nbobc = nbobc + 1
104	IF( lp_obc_west ) nbobc = nbobc + 1
105	IF( lp_obc_north ) nbobc = nbobc + 1
106	IF( lp_obc_south ) nbobc = nbobc + 1
107
108	IF(lwp) WRITE(numout,*)
109	IF(lwp) WRITE(numout,*) 'obc_init : initialization of open boundaries'
110	IF(lwp) WRITE(numout,*) '~~~~~~~~'
111	IF(lwp) WRITE(numout,*) ' Number of open boundaries nbobc = ', nbobc
112	IF(lwp) WRITE(numout,*)
113
114	! control prints
115	IF(lwp) WRITE(numout,*) ' Namelist namobc'
116	IF(lwp) WRITE(numout,*) ' data in file (=1) or initial state used (=0) nn_obcdta = ', nn_obcdta
117	IF(lwp) WRITE(numout,*) ' climatology (true) or not ln_obc_clim = ', ln_obc_clim
118	IF(lwp) WRITE(numout,*) ' vol_cst (true) or not: ln_vol_cst = ', ln_vol_cst
119	IF(lwp) WRITE(numout,*) ' '
120	IF(lwp) WRITE(numout,*) ' WARNING '
121	IF(lwp) WRITE(numout,*) ' Flather"s algorithm is applied with explicit free surface scheme '
122	IF(lwp) WRITE(numout,*) ' or with free surface time-splitting scheme '
123	IF(lwp) WRITE(numout,*) ' Nor radiation neither relaxation is allowed with explicit free surface scheme: '
124	IF(lwp) WRITE(numout,*) ' Radiation and/or relaxation is allowed with free surface time-splitting scheme '
125	IF(lwp) WRITE(numout,*) ' depending of the choice of rdpXin = rdpXob = 0. for open boundaries '
126	IF(lwp) WRITE(numout,*)
127	IF(lwp) WRITE(numout,*) ' For the filtered free surface case, '
128	IF(lwp) WRITE(numout,*) ' radiation, relaxation or presciption of data can be applied '
129	IF(lwp) WRITE(numout,*)
130
131	IF( lwp.AND.lp_obc_east ) THEN
132	WRITE(numout,*) ' East open boundary :'
133	WRITE(numout,*) ' i index jpieob = ', jpieob
134	WRITE(numout,*) ' damping time scale (days) rn_dpeob = ', rn_dpeob
135	WRITE(numout,*) ' damping time scale (days) rn_dpein = ', rn_dpein
136	ENDIF
137
138	IF( lwp.AND.lp_obc_west ) THEN
139	WRITE(numout,*) ' West open boundary :'
140	WRITE(numout,*) ' i index jpiwob = ', jpiwob
141	WRITE(numout,*) ' damping time scale (days) rn_dpwob = ', rn_dpwob
142	WRITE(numout,*) ' damping time scale (days) rn_dpwin = ', rn_dpwin
143	ENDIF
144
145	IF( lwp.AND.lp_obc_north ) THEN
146	WRITE(numout,*) ' North open boundary :'
147	WRITE(numout,*) ' j index jpjnob = ', jpjnob
148	WRITE(numout,*) ' damping time scale (days) rn_dpnob = ', rn_dpnob
149	WRITE(numout,*) ' damping time scale (days) rn_dpnin = ', rn_dpnin
150	ENDIF
151
152	IF( lwp.AND.lp_obc_south ) THEN
153	WRITE(numout,*) ' South open boundary :'
154	WRITE(numout,*) ' j index jpjsob = ', jpjsob
155	WRITE(numout,*) ' damping time scale (days) rn_dpsob = ', rn_dpsob
156	WRITE(numout,*) ' damping time scale (days) rn_dpsin = ', rn_dpsin
157	WRITE(numout,*)
158	ENDIF
159
160	IF( nbobc >= 2 .AND. jperio /= 0 ) &
161	& CALL ctl_stop( ' Cyclic or symmetric, and open boundary condition are not compatible' )
162
163	! 1. Initialisation of constants
164	! ------------------------------
165	! ... convert rdp$ob in seconds
166	! Fixed Bdy flag inbound outbound
167	lfbceast = .FALSE. ; rdpein = rdpein * rday ; rdpeob = rdpeob * rday
168	lfbcwest = .FALSE. ; rdpwin = rdpwin * rday ; rdpwob = rdpwob * rday
169	lfbcnorth = .FALSE. ; rdpnin = rdpnin * rday ; rdpnob = rdpnob * rday
170	lfbcsouth = .FALSE. ; rdpsin = rdpsin * rday ; rdpsob = rdpsob * rday
171	inumfbc = 0
172	! ... look for Fixed Boundaries (rdp = 0 )
173	! ... When specified, lbcxxx flags are set to TRUE and rdpxxx are set to
174	! ... a small arbitrary value, (to avoid division by zero further on).
175	! ... rdpxxx is not used anymore.
176	IF( lp_obc_east ) THEN
177	IF( (rdpein+rdpeob) == 0 ) THEN
178	lfbceast = .TRUE. ; rdpein = 1e-3 ; rdpeob = 1e-3
179	inumfbc = inumfbc+1
180	ELSEIF ( (rdpein*rdpeob) == 0 ) THEN
181	CALL ctl_stop( 'obc_init : rn_dpein & rn_dpeob must be both zero or non zero' )
182	END IF
183	END IF
184
185	IF( lp_obc_west ) THEN
186	IF( (rdpwin + rdpwob) == 0 ) THEN
187	lfbcwest = .TRUE. ; rdpwin = 1e-3 ; rdpwob = 1e-3
188	inumfbc = inumfbc+1
189	ELSEIF ( (rdpwin*rdpwob) == 0 ) THEN
190	CALL ctl_stop( 'obc_init : rn_dpwin & rn_dpwob must be both zero or non zero' )
191	END IF
192	END IF
193	IF( lp_obc_north ) THEN
194	IF( (rdpnin + rdpnob) == 0 ) THEN
195	lfbcnorth = .TRUE. ; rdpnin = 1e-3 ; rdpnob = 1e-3
196	inumfbc = inumfbc+1
197	ELSEIF ( (rdpnin*rdpnob) == 0 ) THEN
198	CALL ctl_stop( 'obc_init : rn_dpnin & rn_dpnob must be both zero or non zero' )
199	END IF
200	END IF
201	IF( lp_obc_south ) THEN
202	IF( (rdpsin + rdpsob) == 0 ) THEN
203	lfbcsouth = .TRUE. ; rdpsin = 1e-3 ; rdpsob = 1e-3
204	inumfbc = inumfbc+1
205	ELSEIF ( (rdpsin*rdpsob) == 0 ) THEN
206	CALL ctl_stop( 'obc_init : rn_dpsin & rn_dpsob must be both zero or non zero' )
207	END IF
208	END IF
209
210	! 2. Clever mpp indices for loops on the open boundaries.
211	! The loops will be performed only on the processors
212	! that contain a given open boundary.
213	! --------------------------------------------------------
214
215	IF( lp_obc_east ) THEN
216	! ... mpp initialization
217	nie0 = max( 1, min(jpieob - nimpp+1, jpi ) )
218	nie1 = max( 0, min(jpieob - nimpp+1, jpi - 1 ) )
219	nie0p1 = max( 1, min(jpieob+1 - nimpp+1, jpi ) )
220	nie1p1 = max( 0, min(jpieob+1 - nimpp+1, jpi - 1 ) )
221	nie0m1 = max( 1, min(jpieob-1 - nimpp+1, jpi ) )
222	nie1m1 = max( 0, min(jpieob-1 - nimpp+1, jpi - 1 ) )
223	nje0 = max( 2, min(jpjed - njmpp+1, jpj ) )
224	nje1 = max( 0, min(jpjef - njmpp+1, jpj - 1 ) )
225	nje0p1 = max( 1, min(jpjedp1 - njmpp+1, jpj ) )
226	nje0m1 = max( 1, min(jpjed - njmpp+1, jpj ) )
227	nje1m1 = max( 0, min(jpjefm1 - njmpp+1, jpj - 1 ) )
228	nje1m2 = max( 0, min(jpjefm1-1- njmpp+1, jpj - 1 ) )
229	IF(lwp) THEN
230	IF( lfbceast ) THEN
231	WRITE(numout,*)' '
232	WRITE(numout,*)' Specified East Open Boundary'
233	ELSE
234	WRITE(numout,*)' '
235	WRITE(numout,*)' Radiative East Open Boundary'
236	END IF
237	END IF
238	END IF
239
240	IF( lp_obc_west ) THEN
241	! ... mpp initialization
242	niw0 = max( 1, min(jpiwob - nimpp+1, jpi ) )
243	niw1 = max( 0, min(jpiwob - nimpp+1, jpi - 1 ) )
244	niw0p1 = max( 1, min(jpiwob+1 - nimpp+1, jpi ) )
245	niw1p1 = max( 0, min(jpiwob+1 - nimpp+1, jpi - 1 ) )
246	njw0 = max( 2, min(jpjwd - njmpp+1, jpj ) )
247	njw1 = max( 0, min(jpjwf - njmpp+1, jpj - 1 ) )
248	njw0p1 = max( 1, min(jpjwdp1 - njmpp+1, jpj ) )
249	njw0m1 = max( 1, min(jpjwd - njmpp+1, jpj ) )
250	njw1m1 = max( 0, min(jpjwfm1 - njmpp+1, jpj - 1 ) )
251	njw1m2 = max( 0, min(jpjwfm1-1- njmpp+1, jpj - 1 ) )
252	IF(lwp) THEN
253	IF( lfbcwest ) THEN
254	WRITE(numout,*)' '
255	WRITE(numout,*)' Specified West Open Boundary'
256	ELSE
257	WRITE(numout,*)' '
258	WRITE(numout,*)' Radiative West Open Boundary'
259	END IF
260	END IF
261	END IF
262
263	IF( lp_obc_north ) THEN
264	! ... mpp initialization
265	nin0 = max( 2, min(jpind - nimpp+1, jpi ) )
266	nin1 = max( 0, min(jpinf - nimpp+1, jpi - 1 ) )
267	nin0p1 = max( 1, min(jpindp1 - nimpp+1, jpi ) )
268	nin0m1 = max( 1, min(jpind - nimpp+1, jpi ) )
269	nin1m1 = max( 0, min(jpinfm1 - nimpp+1, jpi - 1 ) )
270	nin1m2 = max( 0, min(jpinfm1-1- nimpp+1, jpi - 1 ) )
271	njn0 = max( 1, min(jpjnob - njmpp+1, jpj ) )
272	njn1 = max( 0, min(jpjnob - njmpp+1, jpj - 1 ) )
273	njn0p1 = max( 1, min(jpjnob+1 - njmpp+1, jpj ) )
274	njn1p1 = max( 0, min(jpjnob+1 - njmpp+1, jpj - 1 ) )
275	njn0m1 = max( 1, min(jpjnob-1 - njmpp+1, jpj ) )
276	njn1m1 = max( 0, min(jpjnob-1 - njmpp+1, jpj - 1 ) )
277	IF(lwp) THEN
278	IF( lfbcnorth ) THEN
279	WRITE(numout,*)' '
280	WRITE(numout,*)' Specified North Open Boundary'
281	ELSE
282	WRITE(numout,*)' '
283	WRITE(numout,*)' Radiative North Open Boundary'
284	END IF
285	END IF
286	END IF
287
288	IF( lp_obc_south ) THEN
289	! ... mpp initialization
290	nis0 = max( 2, min(jpisd - nimpp+1, jpi ) )
291	nis1 = max( 0, min(jpisf - nimpp+1, jpi - 1 ) )
292	nis0p1 = max( 1, min(jpisdp1 - nimpp+1, jpi ) )
293	nis0m1 = max( 1, min(jpisd - nimpp+1, jpi ) )
294	nis1m1 = max( 0, min(jpisfm1 - nimpp+1, jpi - 1 ) )
295	nis1m2 = max( 0, min(jpisfm1-1- nimpp+1, jpi - 1 ) )
296	njs0 = max( 1, min(jpjsob - njmpp+1, jpj ) )
297	njs1 = max( 0, min(jpjsob - njmpp+1, jpj - 1 ) )
298	njs0p1 = max( 1, min(jpjsob+1 - njmpp+1, jpj ) )
299	njs1p1 = max( 0, min(jpjsob+1 - njmpp+1, jpj - 1 ) )
300	IF(lwp) THEN
301	IF( lfbcsouth ) THEN
302	WRITE(numout,*)' '
303	WRITE(numout,*)' Specified South Open Boundary'
304	ELSE
305	WRITE(numout,*)' '
306	WRITE(numout,*)' Radiative South Open Boundary'
307	END IF
308	END IF
309	END IF
310
311	! 3. mask correction for OBCs
312	! ---------------------------
313
314	IF( lp_obc_east ) THEN
315	!... (jpjed,jpjefm1),jpieob
316	bmask(nie0p1:nie1p1,nje0:nje1m1) = 0.e0
317
318	! ... initilization to zero
319	uemsk(:,:) = 0.e0 ; vemsk(:,:) = 0.e0 ; temsk(:,:) = 0.e0
320
321	! ... set 2D mask on East OBC, Vopt
322	DO ji = fs_nie0, fs_nie1
323	DO jj = nje0, nje1
324	uemsk(jj,:) = umask(ji, jj,:) * tmask_i(ji,jj) * tmask_i(ji+1,jj)
325	vemsk(jj,:) = vmask(ji+1,jj,:) * tmask_i(ji+1,jj)
326	temsk(jj,:) = tmask(ji+1,jj,:) * tmask_i(ji+1,jj)
327	END DO
328	END DO
329
330	END IF
331
332	IF( lp_obc_west ) THEN
333	! ... (jpjwd,jpjwfm1),jpiwob
334	bmask(niw0:niw1,njw0:njw1m1) = 0.e0
335
336	! ... initilization to zero
337	uwmsk(:,:) = 0.e0 ; vwmsk(:,:) = 0.e0 ; twmsk(:,:) = 0.e0
338
339	! ... set 2D mask on West OBC, Vopt
340	DO ji = fs_niw0, fs_niw1
341	DO jj = njw0, njw1
342	uwmsk(jj,:) = umask(ji,jj,:) * tmask_i(ji,jj) * tmask_i(ji+1,jj)
343	vwmsk(jj,:) = vmask(ji,jj,:) * tmask_i(ji,jj)
344	twmsk(jj,:) = tmask(ji,jj,:) * tmask_i(ji,jj)
345	END DO
346	END DO
347
348	END IF
349
350	IF( lp_obc_north ) THEN
351	! ... jpjnob,(jpind,jpisfm1)
352	bmask(nin0:nin1m1,njn0p1:njn1p1) = 0.e0
353
354	! ... initilization to zero
355	unmsk(:,:) = 0.e0 ; vnmsk(:,:) = 0.e0 ; tnmsk(:,:) = 0.e0
356
357	! ... set 2D mask on North OBC, Vopt
358	DO jj = fs_njn0, fs_njn1
359	DO ji = nin0, nin1
360	unmsk(ji,:) = umask(ji,jj+1,:) * tmask_i(ji,jj+1)
361	vnmsk(ji,:) = vmask(ji,jj ,:) * tmask_i(ji,jj) * tmask_i(ji,jj+1)
362	tnmsk(ji,:) = tmask(ji,jj+1,:) * tmask_i(ji,jj+1)
363	END DO
364	END DO
365
366	END IF
367
368	IF( lp_obc_south ) THEN
369	! ... jpjsob,(jpisd,jpisfm1)
370	bmask(nis0:nis1m1,njs0:njs1) = 0.e0
371
372	! ... initilization to zero
373	usmsk(:,:) = 0.e0 ; vsmsk(:,:) = 0.e0 ; tsmsk(:,:) = 0.e0
374
375	! ... set 2D mask on South OBC, Vopt
376	DO jj = fs_njs0, fs_njs1
377	DO ji = nis0, nis1
378	usmsk(ji,:) = umask(ji,jj,:) * tmask_i(ji,jj)
379	vsmsk(ji,:) = vmask(ji,jj,:) * tmask_i(ji,jj) * tmask_i(ji,jj+1)
380	tsmsk(ji,:) = tmask(ji,jj,:) * tmask_i(ji,jj)
381	END DO
382	END DO
383
384	END IF
385
386	! ... Initialize obcumask and obcvmask for the Force filtering
387	! boundary condition in dynspg_flt
388	obcumask(:,:) = umask(:,:,1)
389	obcvmask(:,:) = vmask(:,:,1)
390
391	! ... Initialize obctmsk on overlap region and obcs. This mask
392	! is used in obcvol.F90 to calculate cumulate flux E-P.
393	! obc Tracer point are outside the domain ( U/V obc points) ==> masked by obctmsk
394	! - no flux E-P on obcs and overlap region (jpreci = jprecj = 1)
395	obctmsk(:,:) = tmask_i(:,:)
396
397	IF( lp_obc_east ) THEN
398	! ... East obc Force filtering mask for the grad D
399	obcumask(nie0 :nie1 ,nje0p1:nje1m1) = 0.e0
400	obcvmask(nie0p1:nie1p1,nje0p1:nje1m1) = 0.e0
401	! ... set to 0 on East OBC
402	obctmsk(nie0p1:nie1p1,nje0:nje1) = 0.e0
403	END IF
404
405	IF( lp_obc_west ) THEN
406	! ... West obc Force filtering mask for the grad D
407	obcumask(niw0:niw1,njw0:njw1) = 0.e0
408	obcvmask(niw0:niw1,njw0:njw1) = 0.e0
409	! ... set to 0 on West OBC
410	obctmsk(niw0:niw1,njw0:njw1) = 0.e0
411	END IF
412
413	IF( lp_obc_north ) THEN
414	! ... North obc Force filtering mask for the grad D
415	obcumask(nin0p1:nin1m1,njn0p1:njn1p1) = 0.e0
416	obcvmask(nin0p1:nin1m1,njn0 :njn1 ) = 0.e0
417	! ... set to 0 on North OBC
418	obctmsk(nin0:nin1,njn0p1:njn1p1) = 0.e0
419	END IF
420
421	IF( lp_obc_south ) THEN
422	! ... South obc Force filtering mask for the grad D
423	obcumask(nis0p1:nis1m1,njs0:njs1) = 0.e0
424	obcvmask(nis0p1:nis1m1,njs0:njs1) = 0.e0
425	! ... set to 0 on South OBC
426	obctmsk(nis0:nis1,njs0:njs1) = 0.e0
427	END IF
428
429	! 3.1 Total lateral surface
430	! -------------------------
431	obcsurftot = 0.e0
432
433	IF( lp_obc_east ) THEN ! ... East open boundary lateral surface
434	DO ji = nie0, nie1
435	DO jj = 1, jpj
436	obcsurftot = obcsurftot+hu(ji,jj)e2u(ji,jj)uemsk(jj,1) * MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) )
437	END DO
438	END DO
439	END IF
440
441	IF( lp_obc_west ) THEN ! ... West open boundary lateral surface
442	DO ji = niw0, niw1
443	DO jj = 1, jpj
444	obcsurftot = obcsurftot+hu(ji,jj)e2u(ji,jj)uwmsk(jj,1) * MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) )
445	END DO
446	END DO
447	END IF
448
449	IF( lp_obc_north ) THEN ! ... North open boundary lateral surface
450	DO jj = njn0, njn1
451	DO ji = 1, jpi
452	obcsurftot = obcsurftot+hv(ji,jj)e1v(ji,jj)vnmsk(ji,1) * MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) )
453	END DO
454	END DO
455	END IF
456
457	IF( lp_obc_south ) THEN ! ... South open boundary lateral surface
458	DO jj = njs0, njs1
459	DO ji = 1, jpi
460	obcsurftot = obcsurftot+hv(ji,jj)e1v(ji,jj)vsmsk(ji,1) * MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) )
461	END DO
462	END DO
463	END IF
464
465	IF( lk_mpp ) CALL mpp_sum( obcsurftot ) ! sum over the global domain
466
467	! 5. Control print on mask
468	! The extremities of the open boundaries must be in land
469	! or else correspond to an "ocean corner" between two open boundaries.
470	! corner 1 is southwest, 2 is south east, 3 is northeast, 4 is northwest.
471	! --------------------------------------------------------------------------
472
473	icorner(:)=0
474
475	! ... control of the west boundary
476	IF( lp_obc_west ) THEN
477	IF( jpiwob < 2 .OR. jpiwob >= jpiglo-2 ) THEN
478	WRITE(ctmp1,*) ' jpiwob exceed ', jpiglo-2, 'or less than 2'
479	CALL ctl_stop( ctmp1 )
480	END IF
481	ztestmask(:)=0.
482	DO ji=niw0,niw1
483	IF( (njw0 + njmpp - 1) == jpjwd ) ztestmask(1)=ztestmask(1)+ tmask(ji,njw0,1)
484	IF( (njw1 + njmpp - 1) == jpjwf ) ztestmask(2)=ztestmask(2)+ tmask(ji,njw1,1)
485	END DO
486	IF( lk_mpp ) CALL mpp_sum( ztestmask, 2 ) ! sum over the global domain
487
488	IF( ztestmask(1) /= 0. ) icorner(1)=icorner(1)+1
489	IF( ztestmask(2) /= 0. ) icorner(4)=icorner(4)+1
490	END IF
491
492	! ... control of the east boundary
493	IF( lp_obc_east ) THEN
494	IF( jpieob < 4 .OR. jpieob >= jpiglo ) THEN
495	WRITE(ctmp1,*) ' jpieob exceed ', jpiglo, ' or less than 4'
496	CALL ctl_stop( ctmp1 )
497	END IF
498	ztestmask(:)=0.
499	DO ji=nie0p1,nie1p1
500	IF( (nje0 + njmpp - 1) == jpjed ) ztestmask(1)=ztestmask(1)+ tmask(ji,nje0,1)
501	IF( (nje1 + njmpp - 1) == jpjef ) ztestmask(2)=ztestmask(2)+ tmask(ji,nje1,1)
502	END DO
503	IF( lk_mpp ) CALL mpp_sum( ztestmask, 2 ) ! sum over the global domain
504
505	IF( ztestmask(1) /= 0. ) icorner(2)=icorner(2)+1
506	IF( ztestmask(2) /= 0. ) icorner(3)=icorner(3)+1
507	END IF
508
509	! ... control of the north boundary
510	IF( lp_obc_north ) THEN
511	IF( jpjnob < 4 .OR. jpjnob >= jpjglo ) THEN
512	WRITE(ctmp1,*) 'jpjnob exceed ', jpjglo, ' or less than 4'
513	CALL ctl_stop( ctmp1 )
514	END IF
515	ztestmask(:)=0.
516	DO jj=njn0p1,njn1p1
517	IF( (nin0 + nimpp - 1) == jpind ) ztestmask(1)=ztestmask(1)+ tmask(nin0,jj,1)
518	IF( (nin1 + nimpp - 1) == jpinf ) ztestmask(2)=ztestmask(2)+ tmask(nin1,jj,1)
519	END DO
520	IF( lk_mpp ) CALL mpp_sum( ztestmask, 2 ) ! sum over the global domain
521
522	IF( ztestmask(1) /= 0. ) icorner(4)=icorner(4)+1
523	IF( ztestmask(2) /= 0. ) icorner(3)=icorner(3)+1
524	END IF
525
526	! ... control of the south boundary
527	IF( lp_obc_south ) THEN
528	IF( jpjsob < 2 .OR. jpjsob >= jpjglo-2 ) THEN
529	WRITE(ctmp1,*) ' jpjsob exceed ', jpjglo-2, ' or less than 2'
530	CALL ctl_stop( ctmp1 )
531	END IF
532	ztestmask(:)=0.
533	DO jj=njs0,njs1
534	IF( (nis0 + nimpp - 1) == jpisd ) ztestmask(1)=ztestmask(1)+ tmask(nis0,jj,1)
535	IF( (nis1 + nimpp - 1) == jpisf ) ztestmask(2)=ztestmask(2)+ tmask(nis1,jj,1)
536	END DO
537	IF( lk_mpp ) CALL mpp_sum( ztestmask, 2 ) ! sum over the global domain
538
539	IF( ztestmask(1) /= 0. ) icorner(1)=icorner(1)+1
540	IF( ztestmask(2) /= 0. ) icorner(2)=icorner(2)+1
541	END IF
542
543	IF( icorner(1) == 2 ) THEN
544	IF(lwp) WRITE(numout,*)
545	IF(lwp) WRITE(numout,*) ' South West ocean corner, two open boudaries'
546	IF(lwp) WRITE(numout,*) ' ========== '
547	IF(lwp) WRITE(numout,*)
548	IF( jpisd /= jpiwob.OR.jpjsob /= jpjwd ) &
549	& CALL ctl_stop( ' Open boundaries do not fit, we stop' )
550
551	ELSE IF( icorner(1) == 1 ) THEN
552	CALL ctl_stop( ' Open boundaries do not fit at SW corner, we stop' )
553	END IF
554
555	IF( icorner(2) == 2 ) THEN
556	IF(lwp) WRITE(numout,*)
557	IF(lwp) WRITE(numout,*) ' South East ocean corner, two open boudaries'
558	IF(lwp) WRITE(numout,*) ' ========== '
559	IF(lwp) WRITE(numout,*)
560	IF( jpisf /= jpieob+1.OR.jpjsob /= jpjed ) &
561	& CALL ctl_stop( ' Open boundaries do not fit, we stop' )
562	ELSE IF( icorner(2) == 1 ) THEN
563	CALL ctl_stop( ' Open boundaries do not fit at SE corner, we stop' )
564	END IF
565
566	IF( icorner(3) == 2 ) THEN
567	IF(lwp) WRITE(numout,*)
568	IF(lwp) WRITE(numout,*) ' North East ocean corner, two open boudaries'
569	IF(lwp) WRITE(numout,*) ' ========== '
570	IF(lwp) WRITE(numout,*)
571	IF( jpinf /= jpieob+1 .OR. jpjnob+1 /= jpjef ) &
572	& CALL ctl_stop( ' Open boundaries do not fit, we stop' )
573	ELSE IF( icorner(3) == 1 ) THEN
574	CALL ctl_stop( ' Open boundaries do not fit at NE corner, we stop' )
575	END IF
576
577	IF( icorner(4) == 2 ) THEN
578	IF(lwp) WRITE(numout,*)
579	IF(lwp) WRITE(numout,*) ' North West ocean corner, two open boudaries'
580	IF(lwp) WRITE(numout,*) ' ========== '
581	IF(lwp) WRITE(numout,*)
582	IF( jpind /= jpiwob.OR.jpjnob+1 /= jpjwf ) &
583	& CALL ctl_stop( ' Open boundaries do not fit, we stop' )
584	ELSE IF( icorner(4) == 1 ) THEN
585	CALL ctl_stop( ' Open boundaries do not fit at NW corner, we stop' )
586	END IF
587
588	! 6. Initialization of open boundary variables (u, v, t, s)
589	! --------------------------------------------------------------
590	! only if at least one boundary is radiative
591	IF ( inumfbc < nbobc .AND. ln_rstart ) THEN
592	! Restart from restart.obc
593	CALL obc_rst_read
594	ELSE
595
596	! ! ... Initialization to zero of radiation arrays.
597	! ! Those have dimensions of local subdomains
598
599	uebnd(:,:,:,:) = 0.e0 ; unbnd(:,:,:,:) = 0.e0
600	vebnd(:,:,:,:) = 0.e0 ; vnbnd(:,:,:,:) = 0.e0
601	tebnd(:,:,:,:) = 0.e0 ; tnbnd(:,:,:,:) = 0.e0
602	sebnd(:,:,:,:) = 0.e0 ; snbnd(:,:,:,:) = 0.e0
603
604	uwbnd(:,:,:,:) = 0.e0 ; usbnd(:,:,:,:) = 0.e0
605	vwbnd(:,:,:,:) = 0.e0 ; vsbnd(:,:,:,:) = 0.e0
606	twbnd(:,:,:,:) = 0.e0 ; tsbnd(:,:,:,:) = 0.e0
607	swbnd(:,:,:,:) = 0.e0 ; ssbnd(:,:,:,:) = 0.e0
608
609	END IF
610
611	! 7. Control print
612	! -----------------------------------------------------------------
613
614	! ... control of the east boundary
615	IF( lp_obc_east ) THEN
616	istop = 0
617	IF( jpieob < 4 .OR. jpieob >= jpiglo ) THEN
618	IF(lwp) WRITE(numout,cform_err)
619	IF(lwp) WRITE(numout,*) ' jpieob exceed ', jpim1, ' or less than 4'
620	istop = istop + 1
621	END IF
622
623	IF( lk_mpp ) THEN
624	! ...
625	IF( nimpp > jpieob-5) THEN
626	IF(lwp) WRITE(numout,cform_err)
627	IF(lwp) WRITE(numout,*) ' A sub-domain is too close to the East OBC'
628	IF(lwp) WRITE(numout,*) ' nimpp must be < jpieob-5'
629	istop = istop + 1
630	ENDIF
631	ELSE
632
633	! ... stop if e r r o r (s) detected
634	IF( istop /= 0 ) THEN
635	WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop'
636	CALL ctl_stop( ctmp1 )
637	ENDIF
638	ENDIF
639	ENDIF
640
641	! ... control of the west boundary
642	IF( lp_obc_west ) THEN
643	istop = 0
644	IF( jpiwob < 2 .OR. jpiwob >= jpiglo ) THEN
645	IF(lwp) WRITE(numout,cform_err)
646	IF(lwp) WRITE(numout,*) ' jpiwob exceed ', jpim1, ' or less than 2'
647	istop = istop + 1
648	END IF
649
650	IF( lk_mpp ) THEN
651	IF( (nimpp < jpiwob+5) .AND. (nimpp > 1) ) THEN
652	IF(lwp) WRITE(numout,cform_err)
653	IF(lwp) WRITE(numout,*) ' A sub-domain is too close to the West OBC'
654	IF(lwp) WRITE(numout,*) ' nimpp must be > jpiwob-5 or =1'
655	istop = istop + 1
656	ENDIF
657	ELSE
658
659	! ... stop if e r r o r (s) detected
660	IF( istop /= 0 ) THEN
661	WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop'
662	CALL ctl_stop( ctmp1 )
663	ENDIF
664	ENDIF
665	ENDIF
666
667	! control of the north boundary
668	IF( lp_obc_north ) THEN
669	istop = 0
670	IF( jpjnob < 4 .OR. jpjnob >= jpjglo ) THEN
671	IF(lwp) WRITE(numout,cform_err)
672	IF(lwp) WRITE(numout,*) ' jpjnob exceed ', jpjm1,' or less than 4'
673	istop = istop + 1
674	END IF
675
676	IF( lk_mpp ) THEN
677	IF( njmpp > jpjnob-5) THEN
678	IF(lwp) WRITE(numout,cform_err)
679	IF(lwp) WRITE(numout,*) ' A sub-domain is too close to the North OBC'
680	IF(lwp) WRITE(numout,*) ' njmpp must be < jpjnob-5'
681	istop = istop + 1
682	ENDIF
683	ELSE
684
685	! ... stop if e r r o r (s) detected
686	IF( istop /= 0 ) THEN
687	WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop'
688	CALL ctl_stop( ctmp1 )
689	ENDIF
690	ENDIF
691	ENDIF
692
693	! control of the south boundary
694	IF( lp_obc_south ) THEN
695	istop = 0
696	IF( jpjsob < 2 .OR. jpjsob >= jpjglo ) THEN
697	IF(lwp) WRITE(numout,cform_err)
698	IF(lwp) WRITE(numout,*) ' jpjsob exceed ', jpjm1,' or less than 2'
699	istop = istop + 1
700	END IF
701
702	IF( lk_mpp ) THEN
703	IF( (njmpp < jpjsob+5) .AND. (njmpp > 1) ) THEN
704	IF(lwp) WRITE(numout,cform_err)
705	IF(lwp) WRITE(numout,*) ' A sub-domain is too close to the South OBC'
706	IF(lwp) WRITE(numout,*) ' njmpp must be > jpjsob+5 or =1'
707	istop = istop + 1
708	ENDIF
709	ELSE
710
711	! ... stop if e r r o r (s) detected
712	IF( istop /= 0 ) THEN
713	WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop'
714	CALL ctl_stop( ctmp1 )
715	ENDIF
716	ENDIF
717	ENDIF
718
719	END SUBROUTINE obc_init
720
721	#else
722	!!---------------------------------------------------------------------------------
723	!! Dummy module NO open boundaries
724	!!---------------------------------------------------------------------------------
725	CONTAINS
726	SUBROUTINE obc_init ! Dummy routine
727	END SUBROUTINE obc_init
728	#endif
729
730	!!=================================================================================
731	END MODULE obcini

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

Download in other formats: