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

source: trunk/NEMOGCM/NEMO/OPA_SRC/OBC/obcini.F90 @ 2565

Last change on this file since 2565 was 2565, checked in by rblod, 12 years ago

Suppress duplicated code in obcini, see ticket #788

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