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 @ 2528

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

Update NEMOGCM from branch nemo_v3_3_beta

  • 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   !! 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_west ) THEN ! ... West open boundary lateral surface
441         DO ji = niw0, niw1
442            DO jj = 1, jpj 
443               obcsurftot = obcsurftot+hu(ji,jj)*e2u(ji,jj)*uwmsk(jj,1) * MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) )
444            END DO
445         END DO
446      END IF
447
448      IF( lp_obc_north ) THEN ! ... North open boundary lateral surface
449         DO jj = njn0, njn1
450            DO ji = 1, jpi
451               obcsurftot = obcsurftot+hv(ji,jj)*e1v(ji,jj)*vnmsk(ji,1) * MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) )
452            END DO
453         END DO
454      END IF
455
456      IF( lp_obc_south ) THEN ! ... South open boundary lateral surface
457         DO jj = njs0, njs1
458            DO ji = 1, jpi
459               obcsurftot = obcsurftot+hv(ji,jj)*e1v(ji,jj)*vsmsk(ji,1) * MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) )
460            END DO
461         END DO
462      END IF
463
464      IF( lk_mpp )   CALL mpp_sum( obcsurftot )   ! sum over the global domain
465
466      ! 5. Control print on mask
467      !    The extremities of the open boundaries must be in land
468      !    or else correspond to an "ocean corner" between two open boundaries.
469      !    corner 1 is southwest, 2 is south east, 3 is northeast, 4 is northwest.
470      ! --------------------------------------------------------------------------
471
472      icorner(:)=0
473
474      ! ... control of the west boundary
475      IF( lp_obc_west ) THEN
476         IF( jpiwob < 2 .OR.  jpiwob >= jpiglo-2 ) THEN
477            WRITE(ctmp1,*) ' jpiwob exceed ', jpiglo-2, 'or less than 2'
478            CALL ctl_stop( ctmp1 )
479         END IF
480         ztestmask(:)=0.
481         DO ji=niw0,niw1
482            IF( (njw0 + njmpp - 1) == jpjwd ) ztestmask(1)=ztestmask(1)+ tmask(ji,njw0,1)
483            IF( (njw1 + njmpp - 1) == jpjwf ) ztestmask(2)=ztestmask(2)+ tmask(ji,njw1,1)
484         END DO
485         IF( lk_mpp )   CALL mpp_sum( ztestmask, 2 )   ! sum over the global domain
486
487         IF( ztestmask(1) /= 0. ) icorner(1)=icorner(1)+1
488         IF( ztestmask(2) /= 0. ) icorner(4)=icorner(4)+1
489      END IF
490
491      ! ... control of the east boundary
492      IF( lp_obc_east ) THEN
493         IF( jpieob < 4 .OR.  jpieob >= jpiglo ) THEN
494            WRITE(ctmp1,*) ' jpieob exceed ', jpiglo, ' or less than 4'
495            CALL ctl_stop( ctmp1 )
496         END IF
497         ztestmask(:)=0.
498         DO ji=nie0p1,nie1p1
499            IF( (nje0 + njmpp - 1) == jpjed ) ztestmask(1)=ztestmask(1)+ tmask(ji,nje0,1)
500            IF( (nje1 + njmpp - 1) == jpjef ) ztestmask(2)=ztestmask(2)+ tmask(ji,nje1,1)
501         END DO
502         IF( lk_mpp )   CALL mpp_sum( ztestmask, 2 )   ! sum over the global domain
503
504        IF( ztestmask(1) /= 0. ) icorner(2)=icorner(2)+1
505        IF( ztestmask(2) /= 0. ) icorner(3)=icorner(3)+1
506      END IF
507
508      ! ... control of the north boundary
509      IF( lp_obc_north ) THEN
510         IF( jpjnob < 4 .OR.  jpjnob >= jpjglo ) THEN
511            WRITE(ctmp1,*) 'jpjnob exceed ', jpjglo, ' or less than 4'
512            CALL ctl_stop( ctmp1 )
513         END IF
514         ztestmask(:)=0.
515         DO jj=njn0p1,njn1p1
516            IF( (nin0 + nimpp - 1) == jpind ) ztestmask(1)=ztestmask(1)+ tmask(nin0,jj,1)
517            IF( (nin1 + nimpp - 1) == jpinf ) ztestmask(2)=ztestmask(2)+ tmask(nin1,jj,1)
518         END DO
519         IF( lk_mpp )   CALL mpp_sum( ztestmask, 2 )   ! sum over the global domain
520
521         IF( ztestmask(1) /= 0. ) icorner(4)=icorner(4)+1
522         IF( ztestmask(2) /= 0. ) icorner(3)=icorner(3)+1
523      END IF
524
525      ! ... control of the south boundary
526      IF( lp_obc_south ) THEN
527         IF( jpjsob < 2 .OR.  jpjsob >= jpjglo-2 ) THEN
528            WRITE(ctmp1,*) ' jpjsob exceed ', jpjglo-2, ' or less than 2'
529            CALL ctl_stop( ctmp1 )
530         END IF
531         ztestmask(:)=0.
532         DO jj=njs0,njs1
533            IF( (nis0 + nimpp - 1) == jpisd ) ztestmask(1)=ztestmask(1)+ tmask(nis0,jj,1)
534            IF( (nis1 + nimpp - 1) == jpisf ) ztestmask(2)=ztestmask(2)+ tmask(nis1,jj,1)
535         END DO
536         IF( lk_mpp )   CALL mpp_sum( ztestmask, 2 )   ! sum over the global domain
537
538         IF( ztestmask(1) /= 0. ) icorner(1)=icorner(1)+1
539         IF( ztestmask(2) /= 0. ) icorner(2)=icorner(2)+1
540      END IF
541
542      IF( icorner(1) == 2 ) THEN
543         IF(lwp) WRITE(numout,*)
544         IF(lwp) WRITE(numout,*) ' South West ocean corner, two open boudaries'
545         IF(lwp) WRITE(numout,*) ' ========== '
546         IF(lwp) WRITE(numout,*)
547         IF( jpisd /= jpiwob.OR.jpjsob /= jpjwd ) &
548              &   CALL ctl_stop( ' Open boundaries do not fit, we stop' )
549
550      ELSE IF( icorner(1) == 1 ) THEN
551         CALL ctl_stop( ' Open boundaries do not fit at SW corner, we stop' )
552      END IF
553
554      IF( icorner(2) == 2 ) THEN
555          IF(lwp) WRITE(numout,*)
556          IF(lwp) WRITE(numout,*) ' South East ocean corner, two open boudaries'
557          IF(lwp) WRITE(numout,*) ' ========== '
558          IF(lwp) WRITE(numout,*)
559          IF( jpisf /= jpieob+1.OR.jpjsob /= jpjed ) &
560               &   CALL ctl_stop( ' Open boundaries do not fit, we stop' )
561      ELSE IF( icorner(2) == 1 ) THEN
562         CALL ctl_stop( ' Open boundaries do not fit at SE corner, we stop' )
563      END IF
564
565      IF( icorner(3) == 2 ) THEN
566         IF(lwp) WRITE(numout,*)
567         IF(lwp) WRITE(numout,*) ' North East ocean corner, two open boudaries'
568         IF(lwp) WRITE(numout,*) ' ========== '
569         IF(lwp) WRITE(numout,*)
570         IF( jpinf /= jpieob+1 .OR. jpjnob+1 /= jpjef ) &
571              &   CALL ctl_stop( ' Open boundaries do not fit, we stop' )
572       ELSE IF( icorner(3) == 1 ) THEN
573          CALL ctl_stop( ' Open boundaries do not fit at NE corner, we stop' )
574       END IF
575
576      IF( icorner(4) == 2 ) THEN
577         IF(lwp) WRITE(numout,*)
578         IF(lwp) WRITE(numout,*) ' North West ocean corner, two open boudaries'
579         IF(lwp) WRITE(numout,*) ' ========== '
580         IF(lwp) WRITE(numout,*)
581         IF( jpind /= jpiwob.OR.jpjnob+1 /= jpjwf ) &
582              &   CALL ctl_stop( ' Open boundaries do not fit, we stop' )
583       ELSE IF( icorner(4) == 1 ) THEN
584          CALL ctl_stop( ' Open boundaries do not fit at NW corner, we stop' )
585       END IF 
586
587      ! 6. Initialization of open boundary variables (u, v, t, s)
588      ! --------------------------------------------------------------
589      !   only if at least one boundary is  radiative
590      IF ( inumfbc < nbobc .AND.  ln_rstart ) THEN
591         !  Restart from restart.obc
592         CALL obc_rst_read
593      ELSE
594
595!         ! ... Initialization to zero of radiation arrays.
596!         !     Those have dimensions of local subdomains
597
598          uebnd(:,:,:,:) = 0.e0   ;   unbnd(:,:,:,:) = 0.e0
599          vebnd(:,:,:,:) = 0.e0   ;   vnbnd(:,:,:,:) = 0.e0
600          tebnd(:,:,:,:) = 0.e0   ;   tnbnd(:,:,:,:) = 0.e0
601          sebnd(:,:,:,:) = 0.e0   ;   snbnd(:,:,:,:) = 0.e0
602
603          uwbnd(:,:,:,:) = 0.e0   ;   usbnd(:,:,:,:) = 0.e0
604          vwbnd(:,:,:,:) = 0.e0   ;   vsbnd(:,:,:,:) = 0.e0
605          twbnd(:,:,:,:) = 0.e0   ;   tsbnd(:,:,:,:) = 0.e0
606          swbnd(:,:,:,:) = 0.e0   ;   ssbnd(:,:,:,:) = 0.e0
607
608      END IF
609
610      ! 7. Control print
611      ! -----------------------------------------------------------------
612
613      ! ... control of the east boundary
614      IF( lp_obc_east ) THEN
615         istop = 0
616         IF( jpieob < 4 .OR.  jpieob >= jpiglo ) THEN
617            IF(lwp) WRITE(numout,cform_err)
618            IF(lwp) WRITE(numout,*) '            jpieob exceed ', jpim1, ' or less than 4'
619            istop = istop + 1
620         END IF
621
622         IF( lk_mpp ) THEN
623            ! ...
624            IF( nimpp > jpieob-5) THEN
625               IF(lwp) WRITE(numout,cform_err)
626               IF(lwp) WRITE(numout,*) '        A sub-domain is too close to the East OBC'
627               IF(lwp) WRITE(numout,*) '        nimpp must be < jpieob-5'
628               istop = istop + 1
629            ENDIF
630         ELSE
631
632            ! ... stop if  e r r o r (s)   detected
633            IF( istop /= 0 ) THEN
634               WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop'
635               CALL ctl_stop( ctmp1 )
636            ENDIF
637         ENDIF
638      ENDIF
639
640      ! ... control of the west boundary
641      IF( lp_obc_west ) THEN
642         istop = 0
643         IF( jpiwob < 2 .OR.  jpiwob >= jpiglo ) THEN
644            IF(lwp) WRITE(numout,cform_err)
645            IF(lwp) WRITE(numout,*) '            jpiwob exceed ', jpim1, ' or less than 2'
646            istop = istop + 1
647         END IF
648
649         IF( lk_mpp ) THEN
650            IF( (nimpp < jpiwob+5) .AND. (nimpp > 1) ) THEN
651               IF(lwp) WRITE(numout,cform_err)
652               IF(lwp) WRITE(numout,*) '        A sub-domain is too close to the West OBC'
653               IF(lwp) WRITE(numout,*) '        nimpp must be > jpiwob-5 or =1'
654               istop = istop + 1
655            ENDIF
656         ELSE
657   
658            ! ... stop if  e r r o r (s)   detected
659            IF( istop /= 0 ) THEN
660               WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop'
661               CALL ctl_stop( ctmp1 )
662            ENDIF
663         ENDIF
664      ENDIF
665
666      ! control of the north boundary
667      IF( lp_obc_north ) THEN
668         istop = 0
669         IF( jpjnob < 4 .OR.  jpjnob >= jpjglo ) THEN
670            IF(lwp) WRITE(numout,cform_err)
671            IF(lwp) WRITE(numout,*) '          jpjnob exceed ', jpjm1,' or less than 4'
672            istop = istop + 1
673         END IF
674
675         IF( lk_mpp ) THEN
676            IF( njmpp > jpjnob-5) THEN
677               IF(lwp) WRITE(numout,cform_err)
678               IF(lwp) WRITE(numout,*) '        A sub-domain is too close to the North OBC'
679               IF(lwp) WRITE(numout,*) '        njmpp must be < jpjnob-5'
680               istop = istop + 1
681            ENDIF
682         ELSE
683   
684            ! ... stop if  e r r o r (s)   detected
685            IF( istop /= 0 ) THEN
686                WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop'
687               CALL ctl_stop( ctmp1 )
688           ENDIF
689         ENDIF
690      ENDIF
691
692      ! control of the south boundary
693      IF( lp_obc_south ) THEN
694         istop = 0
695         IF( jpjsob < 2 .OR. jpjsob >= jpjglo ) THEN
696            IF(lwp) WRITE(numout,cform_err)
697            IF(lwp) WRITE(numout,*) '          jpjsob exceed ', jpjm1,' or less than 2'
698            istop = istop + 1
699         END IF
700
701         IF( lk_mpp ) THEN
702            IF( (njmpp < jpjsob+5) .AND. (njmpp > 1) ) THEN
703               IF(lwp) WRITE(numout,cform_err)
704               IF(lwp) WRITE(numout,*) '        A sub-domain is too close to the South OBC'
705               IF(lwp) WRITE(numout,*) '        njmpp must be > jpjsob+5 or =1'
706               istop = istop + 1
707            ENDIF
708         ELSE
709   
710            ! ... stop if  e r r o r (s)   detected
711            IF( istop /= 0 ) THEN
712               WRITE(ctmp1,*) istop,' obcini : E R R O R (S) detected : stop'
713               CALL ctl_stop( ctmp1 )
714            ENDIF
715         ENDIF
716      ENDIF
717
718   END SUBROUTINE obc_init
719
720#else
721   !!---------------------------------------------------------------------------------
722   !!   Dummy module                                                NO open boundaries
723   !!---------------------------------------------------------------------------------
724CONTAINS
725   SUBROUTINE obc_init      ! Dummy routine
726   END SUBROUTINE obc_init
727#endif
728
729   !!=================================================================================
730END MODULE obcini
Note: See TracBrowser for help on using the repository browser.