source: branches/UKMO/dev_r5518_MEDUSA_optim_RH/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90 @ 7701

Last change on this file since 7701 was 7701, checked in by frrh, 4 years ago

Improve control of numstr unit.

In addition to only producing output, and doing the
related global sums when we really need them, we
need to restrict it to one instance on the master PE
in all circumstances and to explicitly close it at the
end of the run. (Currently if lwp = true you get a separate
file for every PE containing identical information and none
of the tracer.stat files are explicitly closed.)

File size: 39.5 KB
Line 
1MODULE nemogcm
2   !!======================================================================
3   !!                       ***  MODULE nemogcm   ***
4   !! Ocean system   : NEMO GCM (ocean dynamics, on-line tracers, biochemistry and sea-ice)
5   !!======================================================================
6   !! History :  OPA  ! 1990-10  (C. Levy, G. Madec)  Original code
7   !!            7.0  ! 1991-11  (M. Imbard, C. Levy, G. Madec)
8   !!            7.1  ! 1993-03  (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,
9   !!                             P. Delecluse, C. Perigaud, G. Caniaux, B. Colot, C. Maes) release 7.1
10   !!             -   ! 1992-06  (L.Terray)  coupling implementation
11   !!             -   ! 1993-11  (M.A. Filiberti) IGLOO sea-ice
12   !!            8.0  ! 1996-03  (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,
13   !!                             P. Delecluse, L.Terray, M.A. Filiberti, J. Vialar, A.M. Treguier, M. Levy) release 8.0
14   !!            8.1  ! 1997-06  (M. Imbard, G. Madec)
15   !!            8.2  ! 1999-11  (M. Imbard, H. Goosse)  LIM sea-ice model
16   !!                 ! 1999-12  (V. Thierry, A-M. Treguier, M. Imbard, M-A. Foujols)  OPEN-MP
17   !!                 ! 2000-07  (J-M Molines, M. Imbard)  Open Boundary Conditions  (CLIPPER)
18   !!   NEMO     1.0  ! 2002-08  (G. Madec)  F90: Free form and modules
19   !!             -   ! 2004-06  (R. Redler, NEC CCRLE, Germany) add OASIS[3/4] coupled interfaces
20   !!             -   ! 2004-08  (C. Talandier) New trends organization
21   !!             -   ! 2005-06  (C. Ethe) Add the 1D configuration possibility
22   !!             -   ! 2005-11  (V. Garnier) Surface pressure gradient organization
23   !!             -   ! 2006-03  (L. Debreu, C. Mazauric)  Agrif implementation
24   !!             -   ! 2006-04  (G. Madec, R. Benshila)  Step reorganization
25   !!             -   ! 2007-07  (J. Chanut, A. Sellar) Unstructured open boundaries (BDY)
26   !!            3.2  ! 2009-08  (S. Masson)  open/write in the listing file in mpp
27   !!            3.3  ! 2010-05  (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface
28   !!             -   ! 2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase
29   !!            3.3.1! 2011-01  (A. R. Porter, STFC Daresbury) dynamical allocation
30   !!            3.4  ! 2011-11  (C. Harris) decomposition changes for running with CICE
31   !!                 ! 2012-05  (C. Calone, J. Simeon, G. Madec, C. Ethe) Add grid coarsening
32   !!----------------------------------------------------------------------
33
34   !!----------------------------------------------------------------------
35   !!   nemo_gcm       : solve ocean dynamics, tracer, biogeochemistry and/or sea-ice
36   !!   nemo_init      : initialization of the NEMO system
37   !!   nemo_ctl       : initialisation of the contol print
38   !!   nemo_closefile : close remaining open files
39   !!   nemo_alloc     : dynamical allocation
40   !!   nemo_partition : calculate MPP domain decomposition
41   !!   factorise      : calculate the factors of the no. of MPI processes
42   !!----------------------------------------------------------------------
43   USE step_oce        ! module used in the ocean time stepping module
44   USE cla             ! cross land advection               (tra_cla routine)
45   USE domcfg          ! domain configuration               (dom_cfg routine)
46   USE mppini          ! shared/distributed memory setting (mpp_init routine)
47   USE domain          ! domain initialization             (dom_init routine)
48#if defined key_nemocice_decomp
49   USE ice_domain_size, only: nx_global, ny_global
50#endif
51   USE tideini         ! tidal components initialization   (tide_ini routine)
52   USE bdyini          ! open boundary cond. setting       (bdy_init routine)
53   USE bdydta          ! open boundary cond. setting   (bdy_dta_init routine)
54   USE bdytides        ! open boundary cond. setting   (bdytide_init routine)
55   USE istate          ! initial state setting          (istate_init routine)
56   USE ldfdyn          ! lateral viscosity setting      (ldfdyn_init routine)
57   USE ldftra          ! lateral diffusivity setting    (ldftra_init routine)
58   USE zdfini          ! vertical physics setting          (zdf_init routine)
59   USE phycst          ! physical constant                  (par_cst routine)
60   USE trdini          ! dyn/tra trends initialization     (trd_init routine)
61   USE asminc          ! assimilation increments     
62   USE asmbkg          ! writing out state trajectory
63   USE diaptr          ! poleward transports           (dia_ptr_init routine)
64   USE diadct          ! sections transports           (dia_dct_init routine)
65   USE diaobs          ! Observation diagnostics       (dia_obs_init routine)
66   USE lib_fortran     ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
67   USE step            ! NEMO time-stepping                 (stp     routine)
68   USE icbini          ! handle bergs, initialisation
69   USE icbstp          ! handle bergs, calving, themodynamics and transport
70   USE cpl_oasis3      ! OASIS3 coupling
71   USE c1d             ! 1D configuration
72   USE step_c1d        ! Time stepping loop for the 1D configuration
73   USE dyndmp          ! Momentum damping
74#if defined key_top
75   USE trcini          ! passive tracer initialisation
76   USE trc, ONLY: numstr  ! tracer stats unit number
77#endif
78   USE lib_mpp         ! distributed memory computing
79#if defined key_iomput
80   USE xios
81#endif
82   USE sbctide, ONLY: lk_tide
83   USE crsini          ! initialise grid coarsening utility
84   USE lbcnfd, ONLY: isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges
85   USE sbc_oce, ONLY: lk_oasis
86   USE stopar
87   USE stopts
88
89   IMPLICIT NONE
90   PRIVATE
91
92   PUBLIC   nemo_gcm    ! called by model.F90
93   PUBLIC   nemo_init   ! needed by AGRIF
94   PUBLIC   nemo_alloc  ! needed by TAM
95
96   CHARACTER(lc) ::   cform_aaa="( /, 'AAAAAAAA', / ) "     ! flag for output listing
97
98   !!----------------------------------------------------------------------
99   !! NEMO/OPA 4.0 , NEMO Consortium (2011)
100   !! $Id$
101   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
102   !!----------------------------------------------------------------------
103CONTAINS
104
105   SUBROUTINE nemo_gcm
106      !!----------------------------------------------------------------------
107      !!                     ***  ROUTINE nemo_gcm  ***
108      !!
109      !! ** Purpose :   NEMO solves the primitive equations on an orthogonal
110      !!              curvilinear mesh on the sphere.
111      !!
112      !! ** Method  : - model general initialization
113      !!              - launch the time-stepping (stp routine)
114      !!              - finalize the run by closing files and communications
115      !!
116      !! References : Madec, Delecluse, Imbard, and Levy, 1997:  internal report, IPSL.
117      !!              Madec, 2008, internal report, IPSL.
118      !!----------------------------------------------------------------------
119      INTEGER ::   istp       ! time step index
120      !!----------------------------------------------------------------------
121      !
122#if defined key_agrif
123      CALL Agrif_Init_Grids()      ! AGRIF: set the meshes
124#endif
125
126      !                            !-----------------------!
127      CALL nemo_init               !==  Initialisations  ==!
128      !                            !-----------------------!
129#if defined key_agrif
130      CALL Agrif_Declare_Var_dom   ! AGRIF: set the meshes for DOM
131      CALL Agrif_Declare_Var       !  "      "   "   "      "  DYN/TRA
132# if defined key_top
133      CALL Agrif_Declare_Var_top   !  "      "   "   "      "  TOP
134# endif
135# if defined key_lim2
136      CALL Agrif_Declare_Var_lim2  !  "      "   "   "      "  LIM
137# endif
138#endif
139      ! check that all process are still there... If some process have an error,
140      ! they will never enter in step and other processes will wait until the end of the cpu time!
141      IF( lk_mpp )   CALL mpp_max( nstop )
142
143      IF(lwp) WRITE(numout,cform_aaa)   ! Flag AAAAAAA
144
145      !                            !-----------------------!
146      !                            !==   time stepping   ==!
147      !                            !-----------------------!
148      istp = nit000
149#if defined key_c1d
150         DO WHILE ( istp <= nitend .AND. nstop == 0 )
151            CALL stp_c1d( istp )
152            istp = istp + 1
153         END DO
154#else
155          IF( lk_asminc ) THEN
156             IF( ln_bkgwri ) CALL asm_bkg_wri( nit000 - 1 )    ! Output background fields
157             IF( ln_asmdin ) THEN                        ! Direct initialization
158                IF( ln_trainc ) CALL tra_asm_inc( nit000 - 1 )    ! Tracers
159                IF( ln_dyninc ) CALL dyn_asm_inc( nit000 - 1 )    ! Dynamics
160                IF( ln_sshinc ) CALL ssh_asm_inc( nit000 - 1 )    ! SSH
161             ENDIF
162          ENDIF
163
164         DO WHILE ( istp <= nitend .AND. nstop == 0 )
165#if defined key_agrif
166            CALL Agrif_Step( stp )           ! AGRIF: time stepping
167#else
168            CALL stp( istp )                 ! standard time stepping
169#endif
170            istp = istp + 1
171            IF( lk_mpp )   CALL mpp_max( nstop )
172         END DO
173#endif
174
175      IF( lk_diaobs   )   CALL dia_obs_wri
176      !
177      IF( ln_icebergs )   CALL icb_end( nitend )
178
179      !                            !------------------------!
180      !                            !==  finalize the run  ==!
181      !                            !------------------------!
182      IF(lwp) WRITE(numout,cform_aaa)   ! Flag AAAAAAA
183      !
184      IF( nstop /= 0 .AND. lwp ) THEN   ! error print
185         WRITE(numout,cform_err)
186         WRITE(numout,*) nstop, ' error have been found'
187      ENDIF
188      !
189#if defined key_agrif
190      CALL Agrif_ParentGrid_To_ChildGrid()
191      IF( lk_diaobs ) CALL dia_obs_wri
192      IF( nn_timing == 1 )   CALL timing_finalize
193      CALL Agrif_ChildGrid_To_ParentGrid()
194#endif
195      IF( nn_timing == 1 )   CALL timing_finalize
196      !
197      CALL nemo_closefile
198      !
199#if defined key_iomput
200      CALL xios_finalize                ! end mpp communications with xios
201      IF( lk_oasis ) CALL cpl_finalize    ! end coupling and mpp communications with OASIS
202#else
203      IF( lk_oasis ) THEN
204         CALL cpl_finalize              ! end coupling and mpp communications with OASIS
205      ELSE
206         IF( lk_mpp )   CALL mppstop    ! end mpp communications
207      ENDIF
208#endif
209      !
210   END SUBROUTINE nemo_gcm
211
212
213   SUBROUTINE nemo_init
214      !!----------------------------------------------------------------------
215      !!                     ***  ROUTINE nemo_init  ***
216      !!
217      !! ** Purpose :   initialization of the NEMO GCM
218      !!----------------------------------------------------------------------
219      INTEGER ::   ji            ! dummy loop indices
220      INTEGER ::   ilocal_comm   ! local integer
221      INTEGER ::   ios
222      CHARACTER(len=80), DIMENSION(16) ::   cltxt
223      !
224      NAMELIST/namctl/ ln_ctl  , nn_print, nn_ictls, nn_ictle,   &
225         &             nn_isplt, nn_jsplt, nn_jctls, nn_jctle,   &
226         &             nn_bench, nn_timing
227      NAMELIST/namcfg/ cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, &
228         &             jpizoom, jpjzoom, jperio, ln_use_jattr
229      !!----------------------------------------------------------------------
230      !
231      cltxt = ''
232      cxios_context = 'nemo'
233      !
234      !                             ! Open reference namelist and configuration namelist files
235      CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
236      CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
237      !
238      REWIND( numnam_ref )              ! Namelist namctl in reference namelist : Control prints & Benchmark
239      READ  ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 )
240901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. )
241
242      REWIND( numnam_cfg )              ! Namelist namctl in confguration namelist : Control prints & Benchmark
243      READ  ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 )
244902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. )
245
246      !
247      REWIND( numnam_ref )              ! Namelist namcfg in reference namelist : Control prints & Benchmark
248      READ  ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 )
249903   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. )
250
251      REWIND( numnam_cfg )              ! Namelist namcfg in confguration namelist : Control prints & Benchmark
252      READ  ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 )
253904   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. )   
254
255! Force values for AGRIF zoom (cf. agrif_user.F90)
256#if defined key_agrif
257   IF( .NOT. Agrif_Root() ) THEN
258      jpiglo  = nbcellsx + 2 + 2*nbghostcells
259      jpjglo  = nbcellsy + 2 + 2*nbghostcells
260      jpi     = ( jpiglo-2*jpreci + (jpni-1+0) ) / jpni + 2*jpreci
261      jpj     = ( jpjglo-2*jprecj + (jpnj-1+0) ) / jpnj + 2*jprecj
262      jpidta  = jpiglo
263      jpjdta  = jpjglo
264      jpizoom = 1
265      jpjzoom = 1
266      nperio  = 0
267      jperio  = 0
268      ln_use_jattr = .false.
269   ENDIF
270#endif
271      !
272      !                             !--------------------------------------------!
273      !                             !  set communicator & select the local node  !
274      !                             !  NB: mynode also opens output.namelist.dyn !
275      !                             !      on unit number numond on first proc   !
276      !                             !--------------------------------------------!
277#if defined key_iomput
278      IF( Agrif_Root() ) THEN
279         IF( lk_oasis ) THEN
280            CALL cpl_init( "oceanx", ilocal_comm )                     ! nemo local communicator given by oasis
281            CALL xios_initialize( "not used",local_comm=ilocal_comm )    ! send nemo communicator to xios
282         ELSE
283            CALL  xios_initialize( "for_xios_mpi_id",return_comm=ilocal_comm )    ! nemo local communicator given by xios
284         ENDIF
285      ENDIF
286      ! Nodes selection (control print return in cltxt)
287      narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )
288#else
289      IF( lk_oasis ) THEN
290         IF( Agrif_Root() ) THEN
291            CALL cpl_init( "oceanx", ilocal_comm )                      ! nemo local communicator given by oasis
292         ENDIF
293         ! Nodes selection (control print return in cltxt)
294         narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )
295      ELSE
296         ilocal_comm = 0
297         ! Nodes selection (control print return in cltxt)
298         narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop )
299      ENDIF
300#endif
301      narea = narea + 1                                     ! mynode return the rank of proc (0 --> jpnij -1 )
302
303      lwm = (narea == 1)                                    ! control of output namelists
304      lwp = (narea == 1) .OR. ln_ctl                        ! control of all listing output print
305
306      IF(lwm) THEN
307         ! write merged namelists from earlier to output namelist now that the
308         ! file has been opened in call to mynode. nammpp has already been
309         ! written in mynode (if lk_mpp_mpi)
310         WRITE( numond, namctl )
311         WRITE( numond, namcfg )
312      ENDIF
313
314      ! If dimensions of processor grid weren't specified in the namelist file
315      ! then we calculate them here now that we have our communicator size
316      IF( (jpni < 1) .OR. (jpnj < 1) )THEN
317#if   defined key_mpp_mpi
318         IF( Agrif_Root() ) CALL nemo_partition(mppsize)
319#else
320         jpni  = 1
321         jpnj  = 1
322         jpnij = jpni*jpnj
323#endif
324      END IF
325
326      ! Calculate domain dimensions given calculated jpni and jpnj
327      ! This used to be done in par_oce.F90 when they were parameters rather
328      ! than variables
329      IF( Agrif_Root() ) THEN
330#if defined key_nemocice_decomp
331         jpi = ( nx_global+2-2*jpreci + (jpni-1) ) / jpni + 2*jpreci ! first  dim.
332         jpj = ( ny_global+2-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj ! second dim.
333#else
334         jpi = ( jpiglo-2*jpreci + (jpni-1) ) / jpni + 2*jpreci   ! first  dim.
335         jpj = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj   ! second dim.
336#endif
337      ENDIF
338         jpk = jpkdta                                             ! third dim
339         jpim1 = jpi-1                                            ! inner domain indices
340         jpjm1 = jpj-1                                            !   "           "
341         jpkm1 = jpk-1                                            !   "           "
342         jpij  = jpi*jpj                                          !  jpi x j
343
344      IF(lwp) THEN                            ! open listing units
345         !
346         CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
347         !
348         WRITE(numout,*)
349         WRITE(numout,*) '   CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC'
350         WRITE(numout,*) '                       NEMO team'
351         WRITE(numout,*) '            Ocean General Circulation Model'
352         WRITE(numout,*) '                  version 3.6  (2015) '
353         WRITE(numout,*)
354         WRITE(numout,*)
355         DO ji = 1, SIZE(cltxt)
356            IF( TRIM(cltxt(ji)) /= '' )   WRITE(numout,*) cltxt(ji)      ! control print of mynode
357         END DO
358         WRITE(numout,cform_aaa)                                         ! Flag AAAAAAA
359         !
360      ENDIF
361
362      ! Now we know the dimensions of the grid and numout has been set we can
363      ! allocate arrays
364      CALL nemo_alloc()
365
366      !                             !-------------------------------!
367      !                             !  NEMO general initialization  !
368      !                             !-------------------------------!
369
370      CALL nemo_ctl                          ! Control prints & Benchmark
371
372      !                                      ! Domain decomposition
373      IF( jpni*jpnj == jpnij ) THEN   ;   CALL mpp_init      ! standard cutting out
374      ELSE                            ;   CALL mpp_init2     ! eliminate land processors
375      ENDIF
376      !
377      IF( nn_timing == 1 )  CALL timing_init
378      !
379      !                                      ! General initialization
380                            CALL     phy_cst    ! Physical constants
381                            CALL     eos_init   ! Equation of state
382      IF( lk_c1d        )   CALL     c1d_init   ! 1D column configuration
383                            CALL     dom_cfg    ! Domain configuration
384                            CALL     dom_init   ! Domain
385
386      IF( ln_nnogather )    CALL nemo_northcomms   ! Initialise the northfold neighbour lists (must be done after the masks are defined)
387
388      IF( ln_ctl        )   CALL prt_ctl_init   ! Print control
389
390                            CALL  istate_init   ! ocean initial state (Dynamics and tracers)
391
392      IF( lk_tide       )   CALL    tide_init( nit000 )    ! Initialisation of the tidal harmonics
393
394                            CALL     sbc_init   ! Forcings : surface module (clem: moved here for bdy purpose)
395
396      IF( lk_bdy        )   CALL     bdy_init   ! Open boundaries initialisation
397      IF( lk_bdy        )   CALL bdy_dta_init   ! Open boundaries initialisation of external data arrays
398      IF( lk_bdy .AND. lk_tide )   &
399         &                  CALL bdytide_init   ! Open boundaries initialisation of tidal harmonic forcing
400
401                            CALL dyn_nept_init  ! simplified form of Neptune effect
402      !     
403      IF( ln_crs        )   CALL     crs_init   ! Domain initialization of coarsened grid
404      !
405                                ! Ocean physics
406      !                                         ! Vertical physics
407                            CALL     zdf_init      ! namelist read
408                            CALL zdf_bfr_init      ! bottom friction
409      IF( lk_zdfric     )   CALL zdf_ric_init      ! Richardson number dependent Kz
410      IF( lk_zdftke     )   CALL zdf_tke_init      ! TKE closure scheme
411      IF( lk_zdfgls     )   CALL zdf_gls_init      ! GLS closure scheme
412      IF( lk_zdfkpp     )   CALL zdf_kpp_init      ! KPP closure scheme
413      IF( lk_zdftmx     )   CALL zdf_tmx_init      ! tidal vertical mixing
414      IF( lk_zdfddm .AND. .NOT. lk_zdfkpp )   &
415         &                  CALL zdf_ddm_init      ! double diffusive mixing
416      !                                         ! Lateral physics
417                            CALL ldf_tra_init      ! Lateral ocean tracer physics
418                            CALL ldf_dyn_init      ! Lateral ocean momentum physics
419      IF( lk_ldfslp     )   CALL ldf_slp_init      ! slope of lateral mixing
420
421      !                                     ! Active tracers
422                            CALL tra_qsr_init   ! penetrative solar radiation qsr
423                            CALL tra_bbc_init   ! bottom heat flux
424      IF( lk_trabbl     )   CALL tra_bbl_init   ! advective (and/or diffusive) bottom boundary layer scheme
425                            CALL tra_dmp_init   ! internal damping trends- tracers
426                            CALL tra_adv_init   ! horizontal & vertical advection
427                            CALL tra_ldf_init   ! lateral mixing
428                            CALL tra_zdf_init   ! vertical mixing and after tracer fields
429
430      !                                     ! Dynamics
431      IF( lk_c1d        )   CALL dyn_dmp_init   ! internal damping trends- momentum
432                            CALL dyn_adv_init   ! advection (vector or flux form)
433                            CALL dyn_vor_init   ! vorticity term including Coriolis
434                            CALL dyn_ldf_init   ! lateral mixing
435                            CALL dyn_hpg_init   ! horizontal gradient of Hydrostatic pressure
436                            CALL dyn_zdf_init   ! vertical diffusion
437                            CALL dyn_spg_init   ! surface pressure gradient
438
439      !                                     ! Misc. options
440      IF( nn_cla == 1 .AND. cp_cfg == 'orca' .AND. jp_cfg == 2 )   CALL cla_init       ! Cross Land Advection
441                            CALL icb_init( rdt, nit000)   ! initialise icebergs instance
442                            CALL sto_par_init   ! Stochastic parametrization
443      IF( ln_sto_eos     )  CALL sto_pts_init   ! RRandom T/S fluctuations
444     
445#if defined key_top
446      !                                     ! Passive tracers
447                            CALL     trc_init
448#endif
449      !                                     ! Diagnostics
450      IF( lk_floats     )   CALL     flo_init   ! drifting Floats
451      IF( lk_diaar5     )   CALL dia_ar5_init   ! ar5 diag
452                            CALL dia_ptr_init   ! Poleward TRansports initialization
453      IF( lk_diadct     )   CALL dia_dct_init   ! Sections tranports
454                            CALL dia_hsb_init   ! heat content, salt content and volume budgets
455                            CALL     trd_init   ! Mixed-layer/Vorticity/Integral constraints trends
456      IF( lk_diaobs     ) THEN                  ! Observation & model comparison
457                            CALL dia_obs_init            ! Initialize observational data
458                            CALL dia_obs( nit000 - 1 )   ! Observation operator for restart
459      ENDIF
460
461      !                                     ! Assimilation increments
462      IF( lk_asminc     )   CALL asm_inc_init   ! Initialize assimilation increments
463      IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler
464      !
465   END SUBROUTINE nemo_init
466
467
468   SUBROUTINE nemo_ctl
469      !!----------------------------------------------------------------------
470      !!                     ***  ROUTINE nemo_ctl  ***
471      !!
472      !! ** Purpose :   control print setting
473      !!
474      !! ** Method  : - print namctl information and check some consistencies
475      !!----------------------------------------------------------------------
476      !
477      IF(lwp) THEN                  ! control print
478         WRITE(numout,*)
479         WRITE(numout,*) 'nemo_ctl: Control prints & Benchmark'
480         WRITE(numout,*) '~~~~~~~ '
481         WRITE(numout,*) '   Namelist namctl'
482         WRITE(numout,*) '      run control (for debugging)     ln_ctl     = ', ln_ctl
483         WRITE(numout,*) '      level of print                  nn_print   = ', nn_print
484         WRITE(numout,*) '      Start i indice for SUM control  nn_ictls   = ', nn_ictls
485         WRITE(numout,*) '      End i indice for SUM control    nn_ictle   = ', nn_ictle
486         WRITE(numout,*) '      Start j indice for SUM control  nn_jctls   = ', nn_jctls
487         WRITE(numout,*) '      End j indice for SUM control    nn_jctle   = ', nn_jctle
488         WRITE(numout,*) '      number of proc. following i     nn_isplt   = ', nn_isplt
489         WRITE(numout,*) '      number of proc. following j     nn_jsplt   = ', nn_jsplt
490         WRITE(numout,*) '      benchmark parameter (0/1)       nn_bench   = ', nn_bench
491         WRITE(numout,*) '      timing activated    (0/1)       nn_timing  = ', nn_timing
492      ENDIF
493      !
494      nprint    = nn_print          ! convert DOCTOR namelist names into OLD names
495      nictls    = nn_ictls
496      nictle    = nn_ictle
497      njctls    = nn_jctls
498      njctle    = nn_jctle
499      isplt     = nn_isplt
500      jsplt     = nn_jsplt
501      nbench    = nn_bench
502
503      IF(lwp) THEN                  ! control print
504         WRITE(numout,*)
505         WRITE(numout,*) 'namcfg  : configuration initialization through namelist read'
506         WRITE(numout,*) '~~~~~~~ '
507         WRITE(numout,*) '   Namelist namcfg'
508         WRITE(numout,*) '      configuration name              cp_cfg      = ', TRIM(cp_cfg)
509         WRITE(numout,*) '      configuration zoom name         cp_cfz      = ', TRIM(cp_cfz)
510         WRITE(numout,*) '      configuration resolution        jp_cfg      = ', jp_cfg
511         WRITE(numout,*) '      1st lateral dimension ( >= jpi ) jpidta     = ', jpidta
512         WRITE(numout,*) '      2nd    "         "    ( >= jpj ) jpjdta     = ', jpjdta
513         WRITE(numout,*) '      3nd    "         "               jpkdta     = ', jpkdta
514         WRITE(numout,*) '      1st dimension of global domain in i jpiglo  = ', jpiglo
515         WRITE(numout,*) '      2nd    -                  -    in j jpjglo  = ', jpjglo
516         WRITE(numout,*) '      left bottom i index of the zoom (in data domain) jpizoom = ', jpizoom
517         WRITE(numout,*) '      left bottom j index of the zoom (in data domain) jpizoom = ', jpjzoom
518         WRITE(numout,*) '      lateral cond. type (between 0 and 6) jperio = ', jperio   
519         WRITE(numout,*) '      use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr
520      ENDIF
521      !                             ! Parameter control
522      !
523      IF( ln_ctl ) THEN                 ! sub-domain area indices for the control prints
524         IF( lk_mpp .AND. jpnij > 1 ) THEN
525            isplt = jpni   ;   jsplt = jpnj   ;   ijsplt = jpni*jpnj   ! the domain is forced to the real split domain
526         ELSE
527            IF( isplt == 1 .AND. jsplt == 1  ) THEN
528               CALL ctl_warn( ' - isplt & jsplt are equal to 1',   &
529                  &           ' - the print control will be done over the whole domain' )
530            ENDIF
531            ijsplt = isplt * jsplt            ! total number of processors ijsplt
532         ENDIF
533         IF(lwp) WRITE(numout,*)'          - The total number of processors over which the'
534         IF(lwp) WRITE(numout,*)'            print control will be done is ijsplt : ', ijsplt
535         !
536         !                              ! indices used for the SUM control
537         IF( nictls+nictle+njctls+njctle == 0 )   THEN    ! print control done over the default area
538            lsp_area = .FALSE.
539         ELSE                                             ! print control done over a specific  area
540            lsp_area = .TRUE.
541            IF( nictls < 1 .OR. nictls > jpiglo )   THEN
542               CALL ctl_warn( '          - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
543               nictls = 1
544            ENDIF
545            IF( nictle < 1 .OR. nictle > jpiglo )   THEN
546               CALL ctl_warn( '          - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
547               nictle = jpiglo
548            ENDIF
549            IF( njctls < 1 .OR. njctls > jpjglo )   THEN
550               CALL ctl_warn( '          - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
551               njctls = 1
552            ENDIF
553            IF( njctle < 1 .OR. njctle > jpjglo )   THEN
554               CALL ctl_warn( '          - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
555               njctle = jpjglo
556            ENDIF
557         ENDIF
558      ENDIF
559      !
560      IF( nbench == 1 ) THEN              ! Benchmark
561         SELECT CASE ( cp_cfg )
562         CASE ( 'gyre' )   ;   CALL ctl_warn( ' The Benchmark is activated ' )
563         CASE DEFAULT      ;   CALL ctl_stop( ' The Benchmark is based on the GYRE configuration:',   &
564            &                                 ' cp_cfg = "gyre" in namelist &namcfg or set nbench = 0' )
565         END SELECT
566      ENDIF
567      !
568      IF( 1_wp /= SIGN(1._wp,-0._wp)  )   CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows ',  &
569         &                                               'f2003 standard. '                              ,  &
570         &                                               'Compile with key_nosignedzero enabled' )
571      !
572   END SUBROUTINE nemo_ctl
573
574
575   SUBROUTINE nemo_closefile
576      !!----------------------------------------------------------------------
577      !!                     ***  ROUTINE nemo_closefile  ***
578      !!
579      !! ** Purpose :   Close the files
580      !!----------------------------------------------------------------------
581      !
582      IF( lk_mpp )   CALL mppsync
583      !
584      CALL iom_close                                 ! close all input/output files managed by iom_*
585      !
586      IF( numstp          /= -1 )   CLOSE( numstp          )   ! time-step file
587      IF( numsol          /= -1 )   CLOSE( numsol          )   ! solver file
588      IF( numnam_ref      /= -1 )   CLOSE( numnam_ref      )   ! oce reference namelist
589      IF( numnam_cfg      /= -1 )   CLOSE( numnam_cfg      )   ! oce configuration namelist
590      IF( lwm.AND.numond  /= -1 )   CLOSE( numond          )   ! oce output namelist
591      IF( numnam_ice_ref  /= -1 )   CLOSE( numnam_ice_ref  )   ! ice reference namelist
592      IF( numnam_ice_cfg  /= -1 )   CLOSE( numnam_ice_cfg  )   ! ice configuration namelist
593      IF( lwm.AND.numoni  /= -1 )   CLOSE( numoni          )   ! ice output namelist
594      IF( numevo_ice      /= -1 )   CLOSE( numevo_ice      )   ! ice variables (temp. evolution)
595      IF( numout          /=  6 )   CLOSE( numout          )   ! standard model output file
596      IF( numdct_vol      /= -1 )   CLOSE( numdct_vol      )   ! volume transports
597      IF( numdct_heat     /= -1 )   CLOSE( numdct_heat     )   ! heat transports
598      IF( numdct_salt     /= -1 )   CLOSE( numdct_salt     )   ! salt transports
599      IF( numstr          /= -1 )   CLOSE( numstr          )   ! tracer statistics
600
601      !
602      numout = 6                                     ! redefine numout in case it is used after this point...
603      !
604   END SUBROUTINE nemo_closefile
605
606
607   SUBROUTINE nemo_alloc
608      !!----------------------------------------------------------------------
609      !!                     ***  ROUTINE nemo_alloc  ***
610      !!
611      !! ** Purpose :   Allocate all the dynamic arrays of the OPA modules
612      !!
613      !! ** Method  :
614      !!----------------------------------------------------------------------
615      USE diawri    , ONLY: dia_wri_alloc
616      USE dom_oce   , ONLY: dom_oce_alloc
617      USE ldfdyn_oce, ONLY: ldfdyn_oce_alloc
618      USE ldftra_oce, ONLY: ldftra_oce_alloc
619      USE trc_oce   , ONLY: trc_oce_alloc
620#if defined key_diadct 
621      USE diadct    , ONLY: diadct_alloc 
622#endif 
623#if defined key_bdy
624      USE bdy_oce   , ONLY: bdy_oce_alloc
625#endif
626      !
627      INTEGER :: ierr
628      !!----------------------------------------------------------------------
629      !
630      ierr =        oce_alloc       ()          ! ocean
631      ierr = ierr + dia_wri_alloc   ()
632      ierr = ierr + dom_oce_alloc   ()          ! ocean domain
633      ierr = ierr + ldfdyn_oce_alloc()          ! ocean lateral  physics : dynamics
634      ierr = ierr + ldftra_oce_alloc()          ! ocean lateral  physics : tracers
635      ierr = ierr + zdf_oce_alloc   ()          ! ocean vertical physics
636      !
637      ierr = ierr + trc_oce_alloc   ()          ! shared TRC / TRA arrays
638      !
639#if defined key_diadct 
640      ierr = ierr + diadct_alloc    ()          !
641#endif 
642#if defined key_bdy
643      ierr = ierr + bdy_oce_alloc   ()          ! bdy masks (incl. initialization)
644#endif
645      !
646      IF( lk_mpp    )   CALL mpp_sum( ierr )
647      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'nemo_alloc : unable to allocate standard ocean arrays' )
648      !
649   END SUBROUTINE nemo_alloc
650
651
652   SUBROUTINE nemo_partition( num_pes )
653      !!----------------------------------------------------------------------
654      !!                 ***  ROUTINE nemo_partition  ***
655      !!
656      !! ** Purpose :
657      !!
658      !! ** Method  :
659      !!----------------------------------------------------------------------
660      INTEGER, INTENT(in) ::   num_pes   ! The number of MPI processes we have
661      !
662      INTEGER, PARAMETER :: nfactmax = 20
663      INTEGER :: nfact ! The no. of factors returned
664      INTEGER :: ierr  ! Error flag
665      INTEGER :: ji
666      INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
667      INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
668      !!----------------------------------------------------------------------
669      !
670      ierr = 0
671      !
672      CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
673      !
674      IF( nfact <= 1 ) THEN
675         WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
676         WRITE (numout, *) '       : using grid of ',num_pes,' x 1'
677         jpnj = 1
678         jpni = num_pes
679      ELSE
680         ! Search through factors for the pair that are closest in value
681         mindiff = 1000000
682         imin    = 1
683         DO ji = 1, nfact-1, 2
684            idiff = ABS( ifact(ji) - ifact(ji+1) )
685            IF( idiff < mindiff ) THEN
686               mindiff = idiff
687               imin = ji
688            ENDIF
689         END DO
690         jpnj = ifact(imin)
691         jpni = ifact(imin + 1)
692      ENDIF
693      !
694      jpnij = jpni*jpnj
695      !
696   END SUBROUTINE nemo_partition
697
698
699   SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
700      !!----------------------------------------------------------------------
701      !!                     ***  ROUTINE factorise  ***
702      !!
703      !! ** Purpose :   return the prime factors of n.
704      !!                knfax factors are returned in array kfax which is of
705      !!                maximum dimension kmaxfax.
706      !! ** Method  :
707      !!----------------------------------------------------------------------
708      INTEGER                    , INTENT(in   ) ::   kn, kmaxfax
709      INTEGER                    , INTENT(  out) ::   kerr, knfax
710      INTEGER, DIMENSION(kmaxfax), INTENT(  out) ::   kfax
711      !
712      INTEGER :: ifac, jl, inu
713      INTEGER, PARAMETER :: ntest = 14
714      INTEGER :: ilfax(ntest)
715      !
716      ! lfax contains the set of allowed factors.
717      data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256,  &
718         &                            128,   64,   32,   16,    8,   4,   2  /
719      !!----------------------------------------------------------------------
720
721      ! Clear the error flag and initialise output vars
722      kerr = 0
723      kfax = 1
724      knfax = 0
725
726      ! Find the factors of n.
727      IF( kn == 1 )   GOTO 20
728
729      ! nu holds the unfactorised part of the number.
730      ! knfax holds the number of factors found.
731      ! l points to the allowed factor list.
732      ! ifac holds the current factor.
733
734      inu   = kn
735      knfax = 0
736
737      DO jl = ntest, 1, -1
738         !
739         ifac = ilfax(jl)
740         IF( ifac > inu )   CYCLE
741
742         ! Test whether the factor will divide.
743
744         IF( MOD(inu,ifac) == 0 ) THEN
745            !
746            knfax = knfax + 1            ! Add the factor to the list
747            IF( knfax > kmaxfax ) THEN
748               kerr = 6
749               write (*,*) 'FACTOR: insufficient space in factor array ', knfax
750               return
751            ENDIF
752            kfax(knfax) = ifac
753            ! Store the other factor that goes with this one
754            knfax = knfax + 1
755            kfax(knfax) = inu / ifac
756            !WRITE (*,*) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
757         ENDIF
758         !
759      END DO
760
761   20 CONTINUE      ! Label 20 is the exit point from the factor search loop.
762      !
763   END SUBROUTINE factorise
764
765#if defined key_mpp_mpi
766
767   SUBROUTINE nemo_northcomms
768      !!======================================================================
769      !!                     ***  ROUTINE  nemo_northcomms  ***
770      !! nemo_northcomms    :  Setup for north fold exchanges with explicit
771      !!                       point-to-point messaging
772      !!=====================================================================
773      !!----------------------------------------------------------------------
774      !!
775      !! ** Purpose :   Initialization of the northern neighbours lists.
776      !!----------------------------------------------------------------------
777      !!    1.0  ! 2011-10  (A. C. Coward, NOCS & J. Donners, PRACE)
778      !!    2.0  ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC)
779      !!----------------------------------------------------------------------
780
781      INTEGER  ::   sxM, dxM, sxT, dxT, jn
782      INTEGER  ::   njmppmax
783
784      njmppmax = MAXVAL( njmppt )
785   
786      !initializes the north-fold communication variables
787      isendto(:) = 0
788      nsndto = 0
789
790      !if I am a process in the north
791      IF ( njmpp == njmppmax ) THEN
792          !sxM is the first point (in the global domain) needed to compute the
793          !north-fold for the current process
794          sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1
795          !dxM is the last point (in the global domain) needed to compute the
796          !north-fold for the current process
797          dxM = jpiglo - nimppt(narea) + 2
798
799          !loop over the other north-fold processes to find the processes
800          !managing the points belonging to the sxT-dxT range
801 
802          DO jn = 1, jpni
803                !sxT is the first point (in the global domain) of the jn
804                !process
805                sxT = nfiimpp(jn, jpnj)
806                !dxT is the last point (in the global domain) of the jn
807                !process
808                dxT = nfiimpp(jn, jpnj) + nfilcit(jn, jpnj) - 1
809                IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN
810                   nsndto = nsndto + 1
811                     isendto(nsndto) = jn
812                ELSEIF ((sxM .le. sxT) .AND. (dxM .ge. dxT)) THEN
813                   nsndto = nsndto + 1
814                     isendto(nsndto) = jn
815                ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN
816                   nsndto = nsndto + 1
817                     isendto(nsndto) = jn
818                END IF
819          END DO
820          nfsloop = 1
821          nfeloop = nlci
822          DO jn = 2,jpni-1
823           IF(nfipproc(jn,jpnj) .eq. (narea - 1)) THEN
824              IF (nfipproc(jn - 1 ,jpnj) .eq. -1) THEN
825                 nfsloop = nldi
826              ENDIF
827              IF (nfipproc(jn + 1,jpnj) .eq. -1) THEN
828                 nfeloop = nlei
829              ENDIF
830           ENDIF
831        END DO
832
833      ENDIF
834      l_north_nogather = .TRUE.
835   END SUBROUTINE nemo_northcomms
836#else
837   SUBROUTINE nemo_northcomms      ! Dummy routine
838      WRITE(*,*) 'nemo_northcomms: You should not have seen this print! error?'
839   END SUBROUTINE nemo_northcomms
840#endif
841
842   !!======================================================================
843END MODULE nemogcm
844
845
Note: See TracBrowser for help on using the repository browser.