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

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

Last change on this file since 1633 was 1633, checked in by rblod, 15 years ago

Fix syntax error in obcini, see ticket #545

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