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.
domain.F90 in branches/UKMO/test_moci_test_suite_namelist_read/NEMOGCM/NEMO/OPA_SRC/DOM – NEMO

source: branches/UKMO/test_moci_test_suite_namelist_read/NEMOGCM/NEMO/OPA_SRC/DOM/domain.F90 @ 9366

Last change on this file since 9366 was 9366, checked in by andmirek, 6 years ago

#2050 first version. Compiled OK in moci test suite

File size: 29.4 KB
Line 
1MODULE domain
2   !!==============================================================================
3   !!                       ***  MODULE domain   ***
4   !! Ocean initialization : domain initialization
5   !!==============================================================================
6   !! History :  OPA  !  1990-10  (C. Levy - G. Madec)  Original code
7   !!                 !  1992-01  (M. Imbard) insert time step initialization
8   !!                 !  1996-06  (G. Madec) generalized vertical coordinate
9   !!                 !  1997-02  (G. Madec) creation of domwri.F
10   !!                 !  2001-05  (E.Durand - G. Madec) insert closed sea
11   !!   NEMO     1.0  !  2002-08  (G. Madec)  F90: Free form and module
12   !!            2.0  !  2005-11  (V. Garnier) Surface pressure gradient organization
13   !!            3.3  !  2010-11  (G. Madec)  initialisation in C1D configuration
14   !!            3.6  !  2013     ( J. Simeon, C. Calone, G. Madec, C. Ethe ) Online coarsening of outputs
15   !!----------------------------------------------------------------------
16   
17   !!----------------------------------------------------------------------
18   !!   dom_init       : initialize the space and time domain
19   !!   dom_nam        : read and contral domain namelists
20   !!   dom_ctl        : control print for the ocean domain
21   !!----------------------------------------------------------------------
22   USE oce             ! ocean variables
23   USE dom_oce         ! domain: ocean
24   USE sbc_oce         ! surface boundary condition: ocean
25   USE phycst          ! physical constants
26   USE closea          ! closed seas
27   USE in_out_manager  ! I/O manager
28   USE lib_mpp         ! distributed memory computing library
29
30   USE domhgr          ! domain: set the horizontal mesh
31   USE domzgr          ! domain: set the vertical mesh
32   USE domstp          ! domain: set the time-step
33   USE dommsk          ! domain: set the mask system
34   USE domwri          ! domain: write the meshmask file
35   USE domvvl          ! variable volume
36   USE c1d             ! 1D vertical configuration
37   USE dyncor_c1d      ! Coriolis term (c1d case)         (cor_c1d routine)
38   USE timing          ! Timing
39   USE lbclnk          ! ocean lateral boundary condition (or mpp link)
40   USE iom_def, ONLY:lxios_read, lwxios, wxioso
41
42   IMPLICIT NONE
43   PRIVATE
44
45   PUBLIC   dom_init   ! called by opa.F90
46   PRIVATE  run_namelist, dom_namelist, cla_namelist
47#if defined key_netcdf4
48   PRIVATE  nc4_namelist
49#endif
50
51   !! * Substitutions
52#  include "domzgr_substitute.h90"
53   !!-------------------------------------------------------------------------
54   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
55   !! $Id$
56   !! Software governed by the CeCILL licence        (NEMOGCM/NEMO_CeCILL.txt)
57   !!-------------------------------------------------------------------------
58CONTAINS
59
60   SUBROUTINE dom_init
61      !!----------------------------------------------------------------------
62      !!                  ***  ROUTINE dom_init  ***
63      !!                   
64      !! ** Purpose :   Domain initialization. Call the routines that are
65      !!              required to create the arrays which define the space
66      !!              and time domain of the ocean model.
67      !!
68      !! ** Method  : - dom_msk: compute the masks from the bathymetry file
69      !!              - dom_hgr: compute or read the horizontal grid-point position
70      !!                         and scale factors, and the coriolis factor
71      !!              - dom_zgr: define the vertical coordinate and the bathymetry
72      !!              - dom_stp: defined the model time step
73      !!              - dom_wri: create the meshmask file if nmsh=1
74      !!              - 1D configuration, move Coriolis, u and v at T-point
75      !!----------------------------------------------------------------------
76      INTEGER ::   jk          ! dummy loop argument
77      INTEGER ::   iconf = 0   ! local integers
78      !!----------------------------------------------------------------------
79      !
80      IF( nn_timing == 1 )   CALL timing_start('dom_init')
81      !
82      IF(lwp) THEN
83         WRITE(numout,*)
84         WRITE(numout,*) 'dom_init : domain initialization'
85         WRITE(numout,*) '~~~~~~~~'
86      ENDIF
87      !
88                             CALL dom_nam      ! read namelist ( namrun, namdom, namcla )
89                             CALL dom_clo      ! Closed seas and lake
90                             CALL dom_hgr      ! Horizontal mesh
91                             CALL dom_zgr      ! Vertical mesh and bathymetry
92                             CALL dom_msk      ! Masks
93      IF( ln_sco )           CALL dom_stiff    ! Maximum stiffness ratio/hydrostatic consistency
94      !
95      ht_0(:,:) = 0.0_wp                       ! Reference ocean depth at T-points
96      hu_0(:,:) = 0.0_wp                       ! Reference ocean depth at U-points
97      hv_0(:,:) = 0.0_wp                       ! Reference ocean depth at V-points
98      DO jk = 1, jpk
99         ht_0(:,:) = ht_0(:,:) + e3t_0(:,:,jk) * tmask(:,:,jk)
100         hu_0(:,:) = hu_0(:,:) + e3u_0(:,:,jk) * umask(:,:,jk)
101         hv_0(:,:) = hv_0(:,:) + e3v_0(:,:,jk) * vmask(:,:,jk)
102      END DO
103      !
104      IF( lk_vvl )           CALL dom_vvl_init ! Vertical variable mesh
105      !
106      IF( lk_c1d         )   CALL cor_c1d      ! 1D configuration: Coriolis set at T-point
107      !
108      !
109      hu(:,:) = 0._wp                          ! Ocean depth at U-points
110      hv(:,:) = 0._wp                          ! Ocean depth at V-points
111      ht(:,:) = 0._wp                          ! Ocean depth at T-points
112      DO jk = 1, jpkm1
113         hu(:,:) = hu(:,:) + fse3u_n(:,:,jk) * umask(:,:,jk)
114         hv(:,:) = hv(:,:) + fse3v_n(:,:,jk) * vmask(:,:,jk)
115         ht(:,:) = ht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk)
116      END DO
117      !                                        ! Inverse of the local depth
118      hur(:,:) = 1._wp / ( hu(:,:) + 1._wp - umask_i(:,:) ) * umask_i(:,:)
119      hvr(:,:) = 1._wp / ( hv(:,:) + 1._wp - vmask_i(:,:) ) * vmask_i(:,:)
120
121                             CALL dom_stp      ! time step
122      IF( nmsh /= 0      )   CALL dom_wri      ! Create a domain file
123      IF( .NOT.ln_rstart )   CALL dom_ctl      ! Domain control
124      !
125      IF( nn_timing == 1 )   CALL timing_stop('dom_init')
126      !
127   END SUBROUTINE dom_init
128
129
130   SUBROUTINE dom_nam
131      !!----------------------------------------------------------------------
132      !!                     ***  ROUTINE dom_nam  ***
133      !!                   
134      !! ** Purpose :   read domaine namelists and print the variables.
135      !!
136      !! ** input   : - namrun namelist
137      !!              - namdom namelist
138      !!              - namcla namelist
139      !!              - namnc4 namelist   ! "key_netcdf4" only
140      !!----------------------------------------------------------------------
141      USE ioipsl
142      NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list,               &
143         &             nn_no   , cn_exp    , cn_ocerst_in, cn_ocerst_out, ln_rstart , ln_rstdate, nn_rstctl,   &
144         &             nn_it000, nn_itend  , nn_date0    , nn_leapy     , nn_istate , nn_stock ,   &
145         &             nn_write, ln_dimgnnn, ln_mskland  , ln_cfmeta    , ln_clobber, nn_chunksz, nn_euler, &
146         &             ln_xios_read, nn_wxios
147      NAMELIST/namdom/ nn_bathy, rn_bathy , rn_e3zps_min, rn_e3zps_rat, nn_msh, rn_hmin,   &
148         &             nn_acc   , rn_atfp     , rn_rdt      , rn_rdtmin ,                  &
149         &             rn_rdtmax, rn_rdth     , nn_closea , ln_crs,    &
150         &             jphgr_msh, &
151         &             ppglam0, ppgphi0, ppe1_deg, ppe2_deg, ppe1_m, ppe2_m, &
152         &             ppsur, ppa0, ppa1, ppkth, ppacr, ppdzmin, pphmax, ldbletanh, &
153         &             ppa2, ppkth2, ppacr2
154      NAMELIST/namcla/ nn_cla
155#if defined key_netcdf4
156      NAMELIST/namnc4/ nn_nchunks_i, nn_nchunks_j, nn_nchunks_k, ln_nc4zip
157#endif
158      INTEGER  ::   ios                 ! Local integer output status for namelist read
159      !!----------------------------------------------------------------------
160      ln_xios_read = .false.            ! set in case ln_xios_read is not in namelist
161      nn_wxios = 0
162      IF(lwm) THEN
163         REWIND( numnam_ref )              ! Namelist namrun in reference namelist : Parameters of the run
164         READ  ( numnam_ref, namrun, IOSTAT = ios, ERR = 901)
165901      IF( ios /= 0 ) CALL ctl_nam ( ios , 'namrun in reference namelist', lwm )
166         REWIND( numnam_cfg )              ! Namelist namrun in configuration namelist : Parameters of the run
167         READ  ( numnam_cfg, namrun, IOSTAT = ios, ERR = 902 )
168902      IF( ios /= 0 ) CALL ctl_nam ( ios , 'namrun in configuration namelist', lwm )
169      ENDIF
170
171      IF(lwm) WRITE ( numond, namrun )
172      !
173      CALL run_namelist()
174
175      IF(lwp) THEN                  ! control print
176         WRITE(numout,*)
177         WRITE(numout,*) 'dom_nam  : domain initialization through namelist read'
178         WRITE(numout,*) '~~~~~~~ '
179         WRITE(numout,*) '   Namelist namrun'
180         WRITE(numout,*) '      job number                      nn_no      = ', nn_no
181         WRITE(numout,*) '      experiment name for output      cn_exp     = ', cn_exp
182         WRITE(numout,*) '      file prefix restart input       cn_ocerst_in= ', cn_ocerst_in
183         WRITE(numout,*) '      restart input directory         cn_ocerst_indir= ', cn_ocerst_indir
184         WRITE(numout,*) '      file prefix restart output      cn_ocerst_out= ', cn_ocerst_out
185         WRITE(numout,*) '      restart output directory        cn_ocerst_outdir= ', cn_ocerst_outdir
186         WRITE(numout,*) '      restart logical                 ln_rstart  = ' , ln_rstart
187         WRITE(numout,*) '      datestamping of restarts        ln_rstdate  = ', ln_rstdate
188         WRITE(numout,*) '      start with forward time step    nn_euler   = ', nn_euler
189         WRITE(numout,*) '      control of time step            nn_rstctl  = ', nn_rstctl
190         WRITE(numout,*) '      number of the first time step   nn_it000   = ', nn_it000
191         WRITE(numout,*) '      number of the last time step    nn_itend   = ', nn_itend
192         WRITE(numout,*) '      initial calendar date aammjj    nn_date0   = ', nn_date0
193         WRITE(numout,*) '      leap year calendar (0/1)        nn_leapy   = ', nn_leapy
194         WRITE(numout,*) '      initial state output            nn_istate  = ', nn_istate
195         IF( ln_rst_list ) THEN
196            WRITE(numout,*) '      list of restart dump times      nn_stocklist   =', nn_stocklist
197         ELSE
198            WRITE(numout,*) '      frequency of restart file       nn_stock   = ', nn_stock
199         ENDIF
200         WRITE(numout,*) '      frequency of output file        nn_write   = ', nn_write
201         WRITE(numout,*) '      multi file dimgout              ln_dimgnnn = ', ln_dimgnnn
202         WRITE(numout,*) '      mask land points                ln_mskland = ', ln_mskland
203         WRITE(numout,*) '      additional CF standard metadata ln_cfmeta  = ', ln_cfmeta
204         WRITE(numout,*) '      overwrite an existing file      ln_clobber = ', ln_clobber
205         WRITE(numout,*) '      NetCDF chunksize (bytes)        nn_chunksz = ', nn_chunksz
206         WRITE(numout,*) '      READ restart for a single file using XIOS ln_xios_read =', ln_xios_read
207         WRITE(numout,*) '      Write restart using XIOS        nn_wxios   = ', nn_wxios
208      ENDIF
209
210      no = nn_no                    ! conversion DOCTOR names into model names (this should disappear soon)
211      cexper = cn_exp
212      nrstdt = nn_rstctl
213      nit000 = nn_it000
214      nitend = nn_itend
215      ndate0 = nn_date0
216      nleapy = nn_leapy
217      ninist = nn_istate
218      nstock = nn_stock
219      nstocklist = nn_stocklist
220      nwrite = nn_write
221      neuler = nn_euler
222      lxios_read = ln_xios_read.and.ln_rstart
223      IF ( neuler == 1 .AND. .NOT. ln_rstart ) THEN
224         WRITE(ctmp1,*) 'ln_rstart =.FALSE., nn_euler is forced to 0 '
225         CALL ctl_warn( ctmp1 )
226         neuler = 0
227      ENDIF
228
229      !                             ! control of output frequency
230      IF ( nstock == 0 .OR. nstock > nitend ) THEN
231         WRITE(ctmp1,*) 'nstock = ', nstock, ' it is forced to ', nitend
232         CALL ctl_warn( ctmp1 )
233         nstock = nitend
234      ENDIF
235      IF ( nwrite == 0 ) THEN
236         WRITE(ctmp1,*) 'nwrite = ', nwrite, ' it is forced to ', nitend
237         CALL ctl_warn( ctmp1 )
238         nwrite = nitend
239      ENDIF
240
241#if defined key_agrif
242      IF( Agrif_Root() ) THEN
243#endif
244      SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL
245      CASE (  1 ) 
246         CALL ioconf_calendar('gregorian')
247         IF(lwp) WRITE(numout,*) '   The IOIPSL calendar is "gregorian", i.e. leap year'
248      CASE (  0 )
249         CALL ioconf_calendar('noleap')
250         IF(lwp) WRITE(numout,*) '   The IOIPSL calendar is "noleap", i.e. no leap year'
251      CASE ( 30 )
252         CALL ioconf_calendar('360d')
253         IF(lwp) WRITE(numout,*) '   The IOIPSL calendar is "360d", i.e. 360 days in a year'
254      END SELECT
255#if defined key_agrif
256      ENDIF
257#endif
258      IF(lwm) THEN
259         REWIND( numnam_ref )              ! Namelist namdom in reference namelist : space & time domain (bathymetry, mesh, timestep)
260         READ  ( numnam_ref, namdom, IOSTAT = ios, ERR = 903)
261903      IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist', lwm )
262         REWIND( numnam_cfg )              ! Namelist namdom in configuration namelist : space & time domain (bathymetry, mesh, timestep)
263         READ  ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 )
264904      IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in configuration namelist', lwm )
265      ENDIF
266
267      IF(lwm) WRITE ( numond, namdom )
268 
269      CALL dom_namelist()
270
271      IF(lwp) THEN
272         WRITE(numout,*)
273         WRITE(numout,*) '   Namelist namdom : space & time domain'
274         WRITE(numout,*) '      flag read/compute bathymetry      nn_bathy     = ', nn_bathy
275         WRITE(numout,*) '      Depth (if =0 bathy=jpkm1)         rn_bathy     = ', rn_bathy
276         WRITE(numout,*) '      min depth of the ocean    (>0) or    rn_hmin   = ', rn_hmin
277         WRITE(numout,*) '      min number of ocean level (<0)       '
278         WRITE(numout,*) '      minimum thickness of partial      rn_e3zps_min = ', rn_e3zps_min, ' (m)'
279         WRITE(numout,*) '         step level                     rn_e3zps_rat = ', rn_e3zps_rat
280         WRITE(numout,*) '      create mesh/mask file(s)          nn_msh       = ', nn_msh
281         WRITE(numout,*) '           = 0   no file created           '
282         WRITE(numout,*) '           = 1   mesh_mask                 '
283         WRITE(numout,*) '           = 2   mesh and mask             '
284         WRITE(numout,*) '           = 3   mesh_hgr, msh_zgr and mask'
285         WRITE(numout,*) '      ocean time step                       rn_rdt    = ', rn_rdt
286         WRITE(numout,*) '      asselin time filter parameter         rn_atfp   = ', rn_atfp
287         WRITE(numout,*) '      acceleration of converge              nn_acc    = ', nn_acc
288         WRITE(numout,*) '        nn_acc=1: surface tracer rdt        rn_rdtmin = ', rn_rdtmin
289         WRITE(numout,*) '                  bottom  tracer rdt        rdtmax    = ', rn_rdtmax
290         WRITE(numout,*) '                  depth of transition       rn_rdth   = ', rn_rdth
291         WRITE(numout,*) '      suppression of closed seas (=0)       nn_closea = ', nn_closea
292         WRITE(numout,*) '      online coarsening of dynamical fields ln_crs    = ', ln_crs
293         WRITE(numout,*) '      type of horizontal mesh jphgr_msh           = ', jphgr_msh
294         WRITE(numout,*) '      longitude of first raw and column T-point ppglam0 = ', ppglam0
295         WRITE(numout,*) '      latitude  of first raw and column T-point ppgphi0 = ', ppgphi0
296         WRITE(numout,*) '      zonal      grid-spacing (degrees) ppe1_deg        = ', ppe1_deg
297         WRITE(numout,*) '      meridional grid-spacing (degrees) ppe2_deg        = ', ppe2_deg
298         WRITE(numout,*) '      zonal      grid-spacing (degrees) ppe1_m          = ', ppe1_m
299         WRITE(numout,*) '      meridional grid-spacing (degrees) ppe2_m          = ', ppe2_m
300         WRITE(numout,*) '      ORCA r4, r2 and r05 coefficients  ppsur           = ', ppsur
301         WRITE(numout,*) '                                        ppa0            = ', ppa0
302         WRITE(numout,*) '                                        ppa1            = ', ppa1
303         WRITE(numout,*) '                                        ppkth           = ', ppkth
304         WRITE(numout,*) '                                        ppacr           = ', ppacr
305         WRITE(numout,*) '      Minimum vertical spacing ppdzmin                  = ', ppdzmin
306         WRITE(numout,*) '      Maximum depth pphmax                              = ', pphmax
307         WRITE(numout,*) '      Use double tanf function for vertical coordinates ldbletanh = ', ldbletanh
308         WRITE(numout,*) '      Double tanh function parameters ppa2              = ', ppa2
309         WRITE(numout,*) '                                      ppkth2            = ', ppkth2
310         WRITE(numout,*) '                                      ppacr2            = ', ppacr2
311      ENDIF
312
313      ntopo     = nn_bathy          ! conversion DOCTOR names into model names (this should disappear soon)
314      e3zps_min = rn_e3zps_min
315      e3zps_rat = rn_e3zps_rat
316      nmsh      = nn_msh
317      nacc      = nn_acc
318      atfp      = rn_atfp
319      rdt       = rn_rdt
320      rdtmin    = rn_rdtmin
321      rdtmax    = rn_rdtmin
322      rdth      = rn_rdth
323      if (nn_wxios > 0) lwxios = .TRUE. 
324      wxioso = nn_wxios
325
326      IF(lwm) THEN
327         REWIND( numnam_ref )              ! Namelist namcla in reference namelist : Cross land advection
328         READ  ( numnam_ref, namcla, IOSTAT = ios, ERR = 905)
329905      IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcla in reference namelist', lwm )
330         REWIND( numnam_cfg )              ! Namelist namcla in configuration namelist : Cross land advection
331         READ  ( numnam_cfg, namcla, IOSTAT = ios, ERR = 906 )
332906      IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcla in configuration namelist', lwm )
333      ENDIF
334      IF(lwm) WRITE( numond, namcla )
335
336      CALL cla_namelist()
337
338      IF(lwp) THEN
339         WRITE(numout,*)
340         WRITE(numout,*) '   Namelist namcla'
341         WRITE(numout,*) '      cross land advection                 nn_cla    = ', nn_cla
342      ENDIF
343      IF ( nn_cla .EQ. 1 ) THEN
344         IF  ( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN   ! ORCA R2
345            CONTINUE
346         ELSE
347            CALL ctl_stop( 'STOP', 'Cross land advation iplemented only for ORCA2 configuration: cp_cfg = "orca" and jp_cfg = 2 ' )
348         ENDIF
349      ENDIF
350
351#if defined key_netcdf4
352      !                             ! NetCDF 4 case   ("key_netcdf4" defined)
353      IF(lwm) THEN
354         REWIND( numnam_ref )              ! Namelist namnc4 in reference namelist : NETCDF
355         READ  ( numnam_ref, namnc4, IOSTAT = ios, ERR = 907)
356907      IF( ios /= 0 ) CALL ctl_nam ( ios , 'namnc4 in reference namelist', lwm )
357         REWIND( numnam_cfg )              ! Namelist namnc4 in configuration namelist : NETCDF
358         READ  ( numnam_cfg, namnc4, IOSTAT = ios, ERR = 908 )
359908      IF( ios /= 0 ) CALL ctl_nam ( ios , 'namnc4 in configuration namelist', lwm )
360      ENDIF
361
362      IF(lwm) WRITE( numond, namnc4 )
363
364      CALL nc4_namelist()
365
366      IF(lwp) THEN                        ! control print
367         WRITE(numout,*)
368         WRITE(numout,*) '   Namelist namnc4 - Netcdf4 chunking parameters'
369         WRITE(numout,*) '      number of chunks in i-dimension      nn_nchunks_i   = ', nn_nchunks_i
370         WRITE(numout,*) '      number of chunks in j-dimension      nn_nchunks_j   = ', nn_nchunks_j
371         WRITE(numout,*) '      number of chunks in k-dimension      nn_nchunks_k   = ', nn_nchunks_k
372         WRITE(numout,*) '      apply netcdf4/hdf5 chunking & compression ln_nc4zip = ', ln_nc4zip
373      ENDIF
374
375      ! Put the netcdf4 settings into a simple structure (snc4set, defined in in_out_manager module)
376      ! Note the chunk size in the unlimited (time) dimension will be fixed at 1
377      snc4set%ni   = nn_nchunks_i
378      snc4set%nj   = nn_nchunks_j
379      snc4set%nk   = nn_nchunks_k
380      snc4set%luse = ln_nc4zip
381#else
382      snc4set%luse = .FALSE.        ! No NetCDF 4 case
383#endif
384      !
385   END SUBROUTINE dom_nam
386
387
388   SUBROUTINE dom_ctl
389      !!----------------------------------------------------------------------
390      !!                     ***  ROUTINE dom_ctl  ***
391      !!
392      !! ** Purpose :   Domain control.
393      !!
394      !! ** Method  :   compute and print extrema of masked scale factors
395      !!----------------------------------------------------------------------
396      INTEGER ::   iimi1, ijmi1, iimi2, ijmi2, iima1, ijma1, iima2, ijma2
397      INTEGER, DIMENSION(2) ::   iloc   !
398      REAL(wp) ::   ze1min, ze1max, ze2min, ze2max
399      !!----------------------------------------------------------------------
400      !
401      IF(lk_mpp) THEN
402         CALL mpp_minloc( e1t(:,:), tmask_i(:,:), ze1min, iimi1,ijmi1 )
403         CALL mpp_minloc( e2t(:,:), tmask_i(:,:), ze2min, iimi2,ijmi2 )
404         CALL mpp_maxloc( e1t(:,:), tmask_i(:,:), ze1max, iima1,ijma1 )
405         CALL mpp_maxloc( e2t(:,:), tmask_i(:,:), ze2max, iima2,ijma2 )
406      ELSE
407         ze1min = MINVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp )   
408         ze2min = MINVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp )   
409         ze1max = MAXVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp )   
410         ze2max = MAXVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp )   
411
412         iloc  = MINLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp )
413         iimi1 = iloc(1) + nimpp - 1
414         ijmi1 = iloc(2) + njmpp - 1
415         iloc  = MINLOC( e2t(:,:), mask = tmask_i(:,:) == 1._wp )
416         iimi2 = iloc(1) + nimpp - 1
417         ijmi2 = iloc(2) + njmpp - 1
418         iloc  = MAXLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp )
419         iima1 = iloc(1) + nimpp - 1
420         ijma1 = iloc(2) + njmpp - 1
421         iloc  = MAXLOC( e2t(:,:), mask = tmask_i(:,:) == 1._wp )
422         iima2 = iloc(1) + nimpp - 1
423         ijma2 = iloc(2) + njmpp - 1
424      ENDIF
425      IF(lwp) THEN
426         WRITE(numout,*)
427         WRITE(numout,*) 'dom_ctl : extrema of the masked scale factors'
428         WRITE(numout,*) '~~~~~~~'
429         WRITE(numout,"(14x,'e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, iima1, ijma1
430         WRITE(numout,"(14x,'e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, iimi1, ijmi1
431         WRITE(numout,"(14x,'e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, iima2, ijma2
432         WRITE(numout,"(14x,'e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, iimi2, ijmi2
433      ENDIF
434      !
435   END SUBROUTINE dom_ctl
436
437   SUBROUTINE dom_stiff
438      !!----------------------------------------------------------------------
439      !!                  ***  ROUTINE dom_stiff  ***
440      !!                     
441      !! ** Purpose :   Diagnose maximum grid stiffness/hydrostatic consistency
442      !!
443      !! ** Method  :   Compute Haney (1991) hydrostatic condition ratio
444      !!                Save the maximum in the vertical direction
445      !!                (this number is only relevant in s-coordinates)
446      !!
447      !!                Haney, R. L., 1991: On the pressure gradient force
448      !!                over steep topography in sigma coordinate ocean models.
449      !!                J. Phys. Oceanogr., 21, 610???619.
450      !!----------------------------------------------------------------------
451      INTEGER  ::   ji, jj, jk 
452      REAL(wp) ::   zrxmax
453      REAL(wp), DIMENSION(4) :: zr1
454      !!----------------------------------------------------------------------
455      rx1(:,:) = 0.e0
456      zrxmax   = 0.e0
457      zr1(:)   = 0.e0
458     
459      DO ji = 2, jpim1
460         DO jj = 2, jpjm1
461            DO jk = 1, jpkm1
462               zr1(1) = umask(ji-1,jj  ,jk) *abs( (gdepw_0(ji  ,jj  ,jk  )-gdepw_0(ji-1,jj  ,jk  )  & 
463                    &                         +gdepw_0(ji  ,jj  ,jk+1)-gdepw_0(ji-1,jj  ,jk+1)) &
464                    &                        /(gdepw_0(ji  ,jj  ,jk  )+gdepw_0(ji-1,jj  ,jk  )  &
465                    &                         -gdepw_0(ji  ,jj  ,jk+1)-gdepw_0(ji-1,jj  ,jk+1) + rsmall) )
466               zr1(2) = umask(ji  ,jj  ,jk) *abs( (gdepw_0(ji+1,jj  ,jk  )-gdepw_0(ji  ,jj  ,jk  )  &
467                    &                         +gdepw_0(ji+1,jj  ,jk+1)-gdepw_0(ji  ,jj  ,jk+1)) &
468                    &                        /(gdepw_0(ji+1,jj  ,jk  )+gdepw_0(ji  ,jj  ,jk  )  &
469                    &                         -gdepw_0(ji+1,jj  ,jk+1)-gdepw_0(ji  ,jj  ,jk+1) + rsmall) )
470               zr1(3) = vmask(ji  ,jj  ,jk) *abs( (gdepw_0(ji  ,jj+1,jk  )-gdepw_0(ji  ,jj  ,jk  )  &
471                    &                         +gdepw_0(ji  ,jj+1,jk+1)-gdepw_0(ji  ,jj  ,jk+1)) &
472                    &                        /(gdepw_0(ji  ,jj+1,jk  )+gdepw_0(ji  ,jj  ,jk  )  &
473                    &                         -gdepw_0(ji  ,jj+1,jk+1)-gdepw_0(ji  ,jj  ,jk+1) + rsmall) )
474               zr1(4) = vmask(ji  ,jj-1,jk) *abs( (gdepw_0(ji  ,jj  ,jk  )-gdepw_0(ji  ,jj-1,jk  )  &
475                    &                         +gdepw_0(ji  ,jj  ,jk+1)-gdepw_0(ji  ,jj-1,jk+1)) &
476                    &                        /(gdepw_0(ji  ,jj  ,jk  )+gdepw_0(ji  ,jj-1,jk  )  &
477                    &                         -gdepw_0(ji,  jj  ,jk+1)-gdepw_0(ji  ,jj-1,jk+1) + rsmall) )
478               zrxmax = MAXVAL(zr1(1:4))
479               rx1(ji,jj) = MAX(rx1(ji,jj), zrxmax)
480            END DO
481         END DO
482      END DO
483
484      CALL lbc_lnk( rx1, 'T', 1. )
485
486      zrxmax = MAXVAL(rx1)
487
488      IF( lk_mpp )   CALL mpp_max( zrxmax ) ! max over the global domain
489
490      IF(lwp) THEN
491         WRITE(numout,*)
492         WRITE(numout,*) 'dom_stiff : maximum grid stiffness ratio: ', zrxmax
493         WRITE(numout,*) '~~~~~~~~~'
494      ENDIF
495
496   END SUBROUTINE dom_stiff
497
498   SUBROUTINE run_namelist()
499     !!---------------------------------------------------------------------
500     !!                   ***  ROUTINE run_namelist  ***
501     !!                     
502     !! ** Purpose :   Broadcast namelist variables read by procesor lwm
503     !!
504     !! ** Method  :   use lib_mpp
505     !!----------------------------------------------------------------------
506#if defined key_mpp_mpi
507      CALL mpp_bcast(cn_ocerst_indir, lc)
508      CALL mpp_bcast(cn_ocerst_outdir, lc)
509      CALL mpp_bcast(nn_stocklist, 10)
510      CALL mpp_bcast(ln_rst_list)
511      CALL mpp_bcast(nn_no)
512      CALL mpp_bcast(cn_exp, lc)
513      CALL mpp_bcast(cn_ocerst_in, lc)
514      CALL mpp_bcast(cn_ocerst_out, lc)
515      CALL mpp_bcast(ln_rstart)
516      CALL mpp_bcast(ln_rstdate)
517      CALL mpp_bcast(nn_rstctl)
518      CALL mpp_bcast(nn_it000)
519      CALL mpp_bcast(nn_itend)
520      CALL mpp_bcast(nn_date0)
521      CALL mpp_bcast(nn_leapy)
522      CALL mpp_bcast(nn_istate)
523      CALL mpp_bcast(nn_stock)
524      CALL mpp_bcast(nn_write)
525      CALL mpp_bcast(ln_dimgnnn)
526      CALL mpp_bcast(ln_mskland)
527      CALL mpp_bcast(ln_cfmeta)
528      CALL mpp_bcast(ln_clobber)
529      CALL mpp_bcast(nn_chunksz)
530      CALL mpp_bcast(nn_euler)
531      CALL mpp_bcast(ln_xios_read)
532      CALL mpp_bcast(nn_wxios)
533#endif
534   END SUBROUTINE run_namelist
535
536   SUBROUTINE dom_namelist()
537     !!---------------------------------------------------------------------
538     !!                   ***  ROUTINE dom_namelist  ***
539     !!                     
540     !! ** Purpose :   Broadcast namelist variables read by procesor lwm
541     !!
542     !! ** Method  :   use lib_mpp
543     !!----------------------------------------------------------------------
544#if defined key_mpp_mpi
545      CALL mpp_bcast(nn_bathy)
546      CALL mpp_bcast(rn_bathy)
547      CALL mpp_bcast(rn_e3zps_min)
548      CALL mpp_bcast(rn_e3zps_rat)
549      CALL mpp_bcast(nn_msh)
550      CALL mpp_bcast(rn_hmin)
551      CALL mpp_bcast(nn_acc)
552      CALL mpp_bcast(rn_atfp)
553      CALL mpp_bcast(rn_rdt)
554      CALL mpp_bcast(rn_rdtmin)
555      CALL mpp_bcast(rn_rdtmax)
556      CALL mpp_bcast(rn_rdth)
557      CALL mpp_bcast(nn_closea)
558      CALL mpp_bcast(ln_crs)
559      CALL mpp_bcast(jphgr_msh)
560      CALL mpp_bcast(ppglam0)
561      CALL mpp_bcast(ppgphi0)
562      CALL mpp_bcast(ppe1_deg)
563      CALL mpp_bcast(ppe2_deg)
564      CALL mpp_bcast(ppe1_m)
565      CALL mpp_bcast(ppe2_m)
566      CALL mpp_bcast(ppsur)
567      CALL mpp_bcast(ppa0)
568      CALL mpp_bcast(ppa1)
569      CALL mpp_bcast(ppkth)
570      CALL mpp_bcast(ppacr)
571      CALL mpp_bcast(ppdzmin)
572      CALL mpp_bcast(pphmax)
573      CALL mpp_bcast(ldbletanh)
574      CALL mpp_bcast(ppa2)
575      CALL mpp_bcast(ppkth2)
576      CALL mpp_bcast(ppacr2)
577#endif
578   END SUBROUTINE dom_namelist
579
580   SUBROUTINE cla_namelist()
581     !!---------------------------------------------------------------------
582     !!                   ***  ROUTINE cla_namelist  ***
583     !!                     
584     !! ** Purpose :   Broadcast namelist variables read by procesor lwm
585     !!
586     !! ** Method  :   use lib_mpp
587     !!----------------------------------------------------------------------
588#if defined key_mpp_mpi
589      CALL mpp_bcast(nn_cla)
590#endif
591   END SUBROUTINE cla_namelist
592
593#if defined key_netcdf4
594   SUBROUTINE nc4_namelist()
595     !!---------------------------------------------------------------------
596     !!                   ***  ROUTINE nc4_namelist  ***
597     !!                     
598     !! ** Purpose :   Broadcast namelist variables read by procesor lwm
599     !!
600     !! ** Method  :   use lib_mpp
601     !!----------------------------------------------------------------------
602#if defined key_mpp_mpi
603      CALL mpp_bcast(nn_nchunks_i)
604      CALL mpp_bcast(nn_nchunks_j)
605      CALL mpp_bcast(nn_nchunks_k)
606      CALL mpp_bcast(ln_nc4zip)
607#endif
608   END SUBROUTINE nc4_namelist
609#endif
610   !!======================================================================
611END MODULE domain
Note: See TracBrowser for help on using the repository browser.