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

Context Navigation

source: trunk/NEMO/OPA_SRC/OBC/obcini.F90 @ 1596

Last change on this file since 1596 was 1528, checked in by rblod, 15 years ago
Suppress rigid-lid option, see ticket #486
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 30.0 KB

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

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

Download in other formats: