source: trunk/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90 @ 4624

Last change on this file since 4624 was 4624, checked in by acc, 7 years ago

#1305. Fix slow start-up problems on some systems by introducing and using lwm logical to restrict output of merged namelists to the first (or only) processor. lwm is true only on the first processor regardless of ln_ctl. Small changes to all flavours of nemogcm.F90 are also required to write namctl and namcfg after the call to mynode which now opens output.namelist.dyn and writes nammpp.

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