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.
nemogcm.F90 in branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC – NEMO

source: branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90 @ 2607

Last change on this file since 2607 was 2607, checked in by trackstand2, 13 years ago

Made module arrays allocatable and added calls to _alloc()s in nemo_alloc()
  • Property svn:keywords set to Id
File size: 37.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   !!            4.0  ! 2011-01  (A. R. Porter, STFC Daresbury) dynamical allocation
30   !!----------------------------------------------------------------------
31
32   !!----------------------------------------------------------------------
33   !!   nemo_gcm       : solve ocean dynamics, tracer, biogeochemistry and/or sea-ice
34   !!   nemo_init      : initialization of the NEMO system
35   !!   nemo_ctl       : initialisation of the contol print
36   !!   nemo_closefile : close remaining open files
37   !!   nemo_alloc     : dynamical allocation
38   !!   nemo_partition : ???
39   !!   nemo_partition : ???
40   !!   factorise      : ???
41   !!----------------------------------------------------------------------
42   USE step_oce        ! module used in the ocean time stepping module
43   USE sbc_oce         ! surface boundary condition: ocean
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   USE obcini          ! open boundary cond. initialization (obc_ini routine)
49   USE bdyini          ! unstructured open boundary cond. initialization (bdy_init routine)
50   USE istate          ! initial state setting          (istate_init routine)
51   USE ldfdyn          ! lateral viscosity setting      (ldfdyn_init routine)
52   USE ldftra          ! lateral diffusivity setting    (ldftra_init routine)
53   USE zdfini          ! vertical physics setting          (zdf_init routine)
54   USE phycst          ! physical constant                  (par_cst routine)
55   USE trdmod          ! momentum/tracers trends       (trd_mod_init routine)
56   USE asminc          ! assimilation increments       (asm_inc_init routine)
57   USE asmtrj          ! writing out state trajectory
58   USE sshwzv          ! vertical velocity used in asm
59   USE diaptr          ! poleward transports           (dia_ptr_init routine)
60   USE diaobs          ! Observation diagnostics       (dia_obs_init routine)
61   USE step            ! NEMO time-stepping                 (stp     routine)
62#if defined key_oasis3
63   USE cpl_oasis3      ! OASIS3 coupling
64#elif defined key_oasis4
65   USE cpl_oasis4      ! OASIS4 coupling (not working)
66#endif
67   USE c1d             ! 1D configuration
68   USE step_c1d        ! Time stepping loop for the 1D configuration
69#if defined key_top
70   USE trcini          ! passive tracer initialisation
71#endif
72   USE lib_mpp         ! distributed memory computing
73#if defined key_iomput
74   USE mod_ioclient
75#endif
76
77   IMPLICIT NONE
78   PRIVATE
79
80   PUBLIC   nemo_gcm    ! called by model.F90
81   PUBLIC   nemo_init   ! needed by AGRIF
82
83   CHARACTER(lc) ::   cform_aaa="( /, 'AAAAAAAA', / ) "     ! flag for output listing
84
85   !!----------------------------------------------------------------------
86   !! NEMO/OPA 4.0 , NEMO Consortium (2011)
87   !! $Id$
88   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
89   !!----------------------------------------------------------------------
90CONTAINS
91
92   SUBROUTINE nemo_gcm
93      !!----------------------------------------------------------------------
94      !!                     ***  ROUTINE nemo_gcm  ***
95      !!
96      !! ** Purpose :   NEMO solves the primitive equations on an orthogonal
97      !!              curvilinear mesh on the sphere.
98      !!
99      !! ** Method  : - model general initialization
100      !!              - launch the time-stepping (stp routine)
101      !!              - finalize the run by closing files and communications
102      !!
103      !! References : Madec, Delecluse,Imbard, and Levy, 1997:  internal report, IPSL.
104      !!              Madec, 2008, internal report, IPSL.
105      !!----------------------------------------------------------------------
106      INTEGER ::   istp       ! time step index
107      !!----------------------------------------------------------------------
108      !
109#if defined key_agrif
110      CALL Agrif_Init_Grids()      ! AGRIF: set the meshes
111#endif
112
113      !                            !-----------------------!
114      CALL nemo_init               !==  Initialisations  ==!
115      !                            !-----------------------!
116
117      ! check that all process are still there... If some process have an error,
118      ! they will never enter in step and other processes will wait until the end of the cpu time!
119      IF( lk_mpp )   CALL mpp_max( nstop )
120
121      IF(lwp) WRITE(numout,cform_aaa)   ! Flag AAAAAAA
122
123      !                            !-----------------------!
124      !                            !==   time stepping   ==!
125      !                            !-----------------------!
126      istp = nit000
127#if defined key_c1d
128         DO WHILE ( istp <= nitend .AND. nstop == 0 )
129            CALL stp_c1d( istp )
130            istp = istp + 1
131         END DO
132#else
133          IF( lk_asminc ) THEN
134             IF( ln_bkgwri ) CALL asm_bkg_wri( nit000 - 1 )    ! Output background fields
135             IF( ln_trjwri ) CALL asm_trj_wri( nit000 - 1 )    ! Output trajectory fields
136             IF( ln_asmdin ) THEN                        ! Direct initialization
137                IF( ln_trainc ) CALL tra_asm_inc( nit000 - 1 )    ! Tracers
138                IF( ln_dyninc ) THEN
139                   CALL dyn_asm_inc( nit000 - 1 )    ! Dynamics
140                   IF ( ln_asmdin ) CALL ssh_wzv ( nit000 - 1 )      ! update vertical velocity
141                ENDIF
142                IF( ln_sshinc ) CALL ssh_asm_inc( nit000 - 1 )    ! SSH
143             ENDIF
144          ENDIF
145       
146         DO WHILE ( istp <= nitend .AND. nstop == 0 )
147#if defined key_agrif
148            CALL Agrif_Step( stp )           ! AGRIF: time stepping
149#else
150            CALL stp( istp )                 ! standard time stepping
151#endif
152            istp = istp + 1
153            IF( lk_mpp )   CALL mpp_max( nstop )
154         END DO
155#endif
156
157      IF( lk_diaobs ) CALL dia_obs_wri
158       
159      !                            !------------------------!
160      !                            !==  finalize the run  ==!
161      !                            !------------------------!
162      IF(lwp) WRITE(numout,cform_aaa)   ! Flag AAAAAAA
163      !
164      IF( nstop /= 0 .AND. lwp ) THEN   ! error print
165         WRITE(numout,cform_err)
166         WRITE(numout,*) nstop, ' error have been found' 
167      ENDIF
168      !
169      CALL nemo_closefile
170#if defined key_oasis3 || defined key_oasis4
171      CALL cpl_prism_finalize           ! end coupling and mpp communications with OASIS
172#else
173      IF( lk_mpp )   CALL mppstop       ! end mpp communications
174#endif
175      !
176   END SUBROUTINE nemo_gcm
177
178
179   SUBROUTINE nemo_init
180      !!----------------------------------------------------------------------
181      !!                     ***  ROUTINE nemo_init  ***
182      !!
183      !! ** Purpose :   initialization of the NEMO GCM
184      !!----------------------------------------------------------------------
185      INTEGER ::   ji          ! dummy loop indices
186      INTEGER :: ilocal_comm   ! local integer
187      CHARACTER(len=80), DIMENSION(10) ::   cltxt
188      !!
189      NAMELIST/namctl/ ln_ctl  , nn_print, nn_ictls, nn_ictle,   &
190         &             nn_isplt, nn_jsplt, nn_jctls, nn_jctle, nn_bench
191      !!----------------------------------------------------------------------
192      !
193      cltxt = ''
194      !
195      !                             ! open Namelist file
196      CALL ctl_opn( numnam, 'namelist', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
197      !
198      READ( numnam, namctl )        ! Namelist namctl : Control prints & Benchmark
199      !
200      !                             !--------------------------------------------!
201      !                             !  set communicator & select the local node  !
202      !                             !--------------------------------------------!
203#if defined key_iomput
204      IF( Agrif_Root() ) THEN
205# if defined key_oasis3 || defined key_oasis4
206         CALL cpl_prism_init( ilocal_comm )   ! nemo local communicator given by oasis
207# endif
208         CALL  init_ioclient( ilocal_comm )   ! exchange io_server nemo local communicator with the io_server
209      ENDIF
210      narea = mynode( cltxt, ilocal_comm )    ! Nodes selection
211#else
212# if defined key_oasis3 || defined key_oasis4
213      IF( Agrif_Root() ) THEN
214         CALL cpl_prism_init( ilocal_comm )   ! nemo local communicator given by oasis
215      ENDIF
216      narea = mynode( cltxt, ilocal_comm )    ! Nodes selection (control print return in cltxt)
217# else
218      ilocal_comm = 0
219      narea = mynode( cltxt )                 ! Nodes selection (control print return in cltxt)
220# endif
221#endif
222      narea = narea + 1                       ! mynode return the rank of proc (0 --> jpnij -1 )
223
224      lwp = (narea == 1) .OR. ln_ctl          ! control of all listing output print
225
226      ! Decide on size of grid now that we have our communicator size
227      ! If we're not using dynamic memory then mpp_partition does nothing.
228
229#if   defined key_mpp_mpi   ||   defined key_mpp_shmem
230      CALL nemo_partition(mppsize)
231#else
232      jpni = 1
233      jpnj = 1
234      jpnij = jpni*jpnj
235#endif
236      ! Calculate domain dimensions given calculated jpni and jpnj
237      ! This used to be done in par_oce.F90 when they were parameters rather
238      ! than variables
239      jpi = ( jpiglo-2*jpreci + (jpni-1) ) / jpni + 2*jpreci !: first  dim.
240      jpj = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj !: second dim.
241      jpim1 = jpi-1                                          !: inner domain indices
242      jpjm1 = jpj-1                                          !:   "           "
243      jpkm1 = jpk-1                                          !:   "           "
244      jpij  = jpi*jpj                                        !:  jpi x j
245
246      ! Now we know the dimensions of the grid, allocate arrays
247      CALL nemo_alloc()
248
249      IF(lwp) THEN                            ! open listing units
250         !
251         CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
252         !
253         WRITE(numout,*)
254         WRITE(numout,*) '         CNRS - NERC - Met OFFICE - MERCATOR-ocean'
255         WRITE(numout,*) '                       NEMO team'
256         WRITE(numout,*) '            Ocean General Circulation Model'
257         WRITE(numout,*) '                  version 3.3  (2010) '
258         WRITE(numout,*)
259         WRITE(numout,*)
260         DO ji = 1, SIZE(cltxt) 
261            IF( TRIM(cltxt(ji)) /= '' )   WRITE(numout,*) cltxt(ji)      ! control print of mynode
262         END DO
263         WRITE(numout,cform_aaa)                                         ! Flag AAAAAAA
264         !
265      ENDIF
266      !                             !-------------------------------!
267      !                             !  NEMO general initialization  !
268      !                             !-------------------------------!
269
270      CALL nemo_ctl                          ! Control prints & Benchmark
271
272      !                                      ! Domain decomposition
273      IF( jpni*jpnj == jpnij ) THEN   ;   CALL mpp_init      ! standard cutting out
274      ELSE                            ;   CALL mpp_init2     ! eliminate land processors
275      ENDIF
276      !
277      !                                      ! General initialization
278                            CALL     phy_cst    ! Physical constants
279                            CALL     eos_init   ! Equation of state
280                            CALL     dom_cfg    ! Domain configuration
281                            CALL     dom_init   ! Domain
282
283      IF( ln_ctl        )   CALL prt_ctl_init   ! Print control
284
285      IF( lk_obc        )   CALL     obc_init   ! Open boundaries
286      IF( lk_bdy        )   CALL     bdy_init   ! Unstructured open boundaries
287
288                            CALL  istate_init   ! ocean initial state (Dynamics and tracers)
289
290      !                                     ! Ocean physics
291                            CALL     sbc_init   ! Forcings : surface module
292      !                                         ! Vertical physics
293                            CALL     zdf_init      ! namelist read
294                            CALL zdf_bfr_init      ! bottom friction
295      IF( lk_zdfric     )   CALL zdf_ric_init      ! Richardson number dependent Kz
296      IF( lk_zdftke     )   CALL zdf_tke_init      ! TKE closure scheme
297      IF( lk_zdfgls     )   CALL zdf_gls_init      ! GLS closure scheme
298      IF( lk_zdfkpp     )   CALL zdf_kpp_init      ! KPP closure scheme
299      IF( lk_zdftmx     )   CALL zdf_tmx_init      ! tidal vertical mixing
300      IF( lk_zdfddm .AND. .NOT. lk_zdfkpp )   & 
301         &                  CALL zdf_ddm_init      ! double diffusive mixing
302      !                                         ! Lateral physics
303                            CALL ldf_tra_init      ! Lateral ocean tracer physics
304                            CALL ldf_dyn_init      ! Lateral ocean momentum physics
305      IF( lk_ldfslp     )   CALL ldf_slp_init      ! slope of lateral mixing
306
307      !                                     ! Active tracers
308                            CALL tra_qsr_init   ! penetrative solar radiation qsr
309                            CALL tra_bbc_init   ! bottom heat flux
310      IF( lk_trabbl     )   CALL tra_bbl_init   ! advective (and/or diffusive) bottom boundary layer scheme
311      IF( lk_tradmp     )   CALL tra_dmp_init   ! internal damping trends
312                            CALL tra_adv_init   ! horizontal & vertical advection
313                            CALL tra_ldf_init   ! lateral mixing
314                            CALL tra_zdf_init   ! vertical mixing and after tracer fields
315
316      !                                     ! Dynamics
317                            CALL dyn_adv_init   ! advection (vector or flux form)
318                            CALL dyn_vor_init   ! vorticity term including Coriolis
319                            CALL dyn_ldf_init   ! lateral mixing
320                            CALL dyn_hpg_init   ! horizontal gradient of Hydrostatic pressure
321                            CALL dyn_zdf_init   ! vertical diffusion
322                            CALL dyn_spg_init   ! surface pressure gradient
323                           
324      !                                     ! Misc. options
325      IF( nn_cla == 1   )   CALL cla_init       ! Cross Land Advection
326     
327#if defined key_top
328      !                                     ! Passive tracers
329                            CALL     trc_init
330#endif
331      !                                     ! Diagnostics
332                            CALL     iom_init   ! iom_put initialization
333      IF( lk_floats     )   CALL     flo_init   ! drifting Floats
334      IF( lk_diaar5     )   CALL dia_ar5_init   ! ar5 diag
335                            CALL dia_ptr_init   ! Poleward TRansports initialization
336                            CALL dia_hsb_init   ! heat content, salt content and volume budgets
337                            CALL trd_mod_init   ! Mixed-layer/Vorticity/Integral constraints trends
338      IF( lk_diaobs     ) THEN                  ! Observation & model comparison
339                            CALL dia_obs_init            ! Initialize observational data
340                            CALL dia_obs( nit000 - 1 )   ! Observation operator for restart
341      ENDIF     
342      !                                     ! Assimilation increments
343      IF( lk_asminc     )   CALL asm_inc_init   ! Initialize assimilation increments
344      IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler
345      !
346   END SUBROUTINE nemo_init
347
348
349   SUBROUTINE nemo_ctl
350      !!----------------------------------------------------------------------
351      !!                     ***  ROUTINE nemo_ctl  ***
352      !!
353      !! ** Purpose :   control print setting
354      !!
355      !! ** Method  : - print namctl information and check some consistencies
356      !!----------------------------------------------------------------------
357      !
358      IF(lwp) THEN                  ! control print
359         WRITE(numout,*)
360         WRITE(numout,*) 'nemo_ctl: Control prints & Benchmark'
361         WRITE(numout,*) '~~~~~~~ '
362         WRITE(numout,*) '   Namelist namctl'
363         WRITE(numout,*) '      run control (for debugging)     ln_ctl     = ', ln_ctl
364         WRITE(numout,*) '      level of print                  nn_print   = ', nn_print
365         WRITE(numout,*) '      Start i indice for SUM control  nn_ictls   = ', nn_ictls
366         WRITE(numout,*) '      End i indice for SUM control    nn_ictle   = ', nn_ictle
367         WRITE(numout,*) '      Start j indice for SUM control  nn_jctls   = ', nn_jctls
368         WRITE(numout,*) '      End j indice for SUM control    nn_jctle   = ', nn_jctle
369         WRITE(numout,*) '      number of proc. following i     nn_isplt   = ', nn_isplt
370         WRITE(numout,*) '      number of proc. following j     nn_jsplt   = ', nn_jsplt
371         WRITE(numout,*) '      benchmark parameter (0/1)       nn_bench   = ', nn_bench
372      ENDIF
373      !
374      nprint    = nn_print          ! convert DOCTOR namelist names into OLD names
375      nictls    = nn_ictls
376      nictle    = nn_ictle
377      njctls    = nn_jctls
378      njctle    = nn_jctle
379      isplt     = nn_isplt
380      jsplt     = nn_jsplt
381      nbench    = nn_bench
382      !                             ! Parameter control
383      !
384      IF( ln_ctl ) THEN                 ! sub-domain area indices for the control prints
385         IF( lk_mpp ) THEN
386            isplt = jpni   ;   jsplt = jpnj   ;   ijsplt = jpni*jpnj   ! the domain is forced to the real split domain
387         ELSE
388            IF( isplt == 1 .AND. jsplt == 1  ) THEN
389               CALL ctl_warn( ' - isplt & jsplt are equal to 1',   &
390                  &           ' - the print control will be done over the whole domain' )
391            ENDIF
392            ijsplt = isplt * jsplt            ! total number of processors ijsplt
393         ENDIF
394         IF(lwp) WRITE(numout,*)'          - The total number of processors over which the'
395         IF(lwp) WRITE(numout,*)'            print control will be done is ijsplt : ', ijsplt
396         !
397         !                              ! indices used for the SUM control
398         IF( nictls+nictle+njctls+njctle == 0 )   THEN    ! print control done over the default area
399            lsp_area = .FALSE.                       
400         ELSE                                             ! print control done over a specific  area
401            lsp_area = .TRUE.
402            IF( nictls < 1 .OR. nictls > jpiglo )   THEN
403               CALL ctl_warn( '          - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
404               nictls = 1
405            ENDIF
406            IF( nictle < 1 .OR. nictle > jpiglo )   THEN
407               CALL ctl_warn( '          - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
408               nictle = jpiglo
409            ENDIF
410            IF( njctls < 1 .OR. njctls > jpjglo )   THEN
411               CALL ctl_warn( '          - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
412               njctls = 1
413            ENDIF
414            IF( njctle < 1 .OR. njctle > jpjglo )   THEN
415               CALL ctl_warn( '          - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
416               njctle = jpjglo
417            ENDIF
418         ENDIF
419      ENDIF
420      !
421      IF( nbench == 1 ) THEN              ! Benchmark
422         SELECT CASE ( cp_cfg )
423         CASE ( 'gyre' )   ;   CALL ctl_warn( ' The Benchmark is activated ' )
424         CASE DEFAULT      ;   CALL ctl_stop( ' The Benchmark is based on the GYRE configuration:',   &
425            &                                 ' key_gyre must be used or set nbench = 0' )
426         END SELECT
427      ENDIF
428      !
429      IF( lk_c1d .AND. .NOT.lk_iomput )   CALL ctl_stop( 'nemo_ctl: The 1D configuration must be used ',   &
430         &                                               'with the IOM Input/Output manager. '         ,   &
431         &                                               'Compile with key_iomput enabled' )
432      !
433   END SUBROUTINE nemo_ctl
434
435
436   SUBROUTINE nemo_closefile
437      !!----------------------------------------------------------------------
438      !!                     ***  ROUTINE nemo_closefile  ***
439      !!
440      !! ** Purpose :   Close the files
441      !!----------------------------------------------------------------------
442      !
443      IF( lk_mpp )   CALL mppsync
444      !
445      CALL iom_close                                 ! close all input/output files managed by iom_*
446      !
447      IF( numstp     /= -1 )   CLOSE( numstp     )   ! time-step file
448      IF( numsol     /= -1 )   CLOSE( numsol     )   ! solver file
449      IF( numnam     /= -1 )   CLOSE( numnam     )   ! oce namelist
450      IF( numnam_ice /= -1 )   CLOSE( numnam_ice )   ! ice namelist
451      IF( numevo_ice /= -1 )   CLOSE( numevo_ice )   ! ice variables (temp. evolution)
452      IF( numout     /=  6 )   CLOSE( numout     )   ! standard model output file
453      !
454      numout = 6                                     ! redefine numout in case it is used after this point...
455      !
456   END SUBROUTINE nemo_closefile
457
458   !!======================================================================
459
460   SUBROUTINE nemo_alloc
461     !!----------------------------------------------------------------------
462     !!                     ***  ROUTINE nemo_alloc  ***
463     !!
464     !! ** Purpose :   Allocate all the dynamic arrays in the modules
465     !!
466     !! ** Method  :
467     !!
468     !! History :
469     !!   9.0  !  01-11  (A. R. Porter, STFC Daresbury)
470     !!----------------------------------------------------------------------
471#if defined key_lim2
472     USE dom_ice_2,    ONLY: dom_ice_alloc_2
473     USE ice_2,        ONLY: ice_alloc_2
474     USE limdia_2,     ONLY: lim_dia_alloc_2
475     USE limhdf_2,     ONLY: lim_hdf_alloc_2
476     USE limsbc_2,     ONLY: lim_sbc_alloc_2
477     USE limwri_2,     ONLY: lim_wri_alloc_2
478     USE thd_ice_2,    ONLY: thd_ice_alloc_2
479#endif
480#if defined key_lim3 || (  defined key_lim2 && ! defined key_lim2_vp )
481     USE limrhg,       ONLY: lim_rhg_alloc
482#endif
483#if defined key_lim3
484     USE dom_ice,      ONLY: dom_ice_alloc
485     USE limitd_me,    ONLY: lim_itd_me_alloc
486     USE thd_ice,      ONLY: thd_ice_alloc
487#endif
488#if defined key_bdy 
489     USE bdy_oce,      ONLY: bdy_oce_alloc
490#endif
491#if defined key_diaar5
492     USE diaar5,       ONLY: dia_ar5_alloc
493#endif
494# if defined key_dimgout
495     USE diadimg,      ONLY: dia_wri_dimg_alloc
496#endif
497#if   defined key_diahth   ||   defined key_esopa
498     USE diahth,       ONLY: dia_hth_alloc
499#endif
500     USE diaptr,       ONLY: dia_ptr_alloc
501     USE diawri,       ONLY: dia_wri_alloc
502     USE divcur,       ONLY: div_cur_alloc
503     USE dom_oce,      ONLY: dom_oce_alloc
504#if defined key_vvl
505     USE domvvl,       ONLY: dom_vvl_alloc
506#endif
507     USE domwri,       ONLY: dom_wri_alloc
508#if defined key_dtasal   ||   defined key_esopa
509     USE dtasal,       ONLY: dta_sal_alloc
510#endif
511#if defined key_dtatem   ||   defined key_esopa
512     USE dtatem,       ONLY: dta_tem_alloc
513#endif
514#if defined key_ldfslp   ||   defined key_esopa
515     USE dynldf_bilapg,ONLY: dyn_ldf_bilapg_alloc
516#endif
517#if defined key_ldfslp   ||   defined key_esopa
518     USE dynldf_iso,   ONLY: dyn_ldf_iso_alloc
519#endif
520#if   defined key_dynspg_ts   ||   defined key_vvl   ||   defined key_esopa
521     USE dynspg_oce,   ONLY: dynspg_oce_alloc
522#endif
523     USE dynvor,       ONLY: dyn_vor_alloc
524     USE dynzdf_exp,   ONLY: dyn_zdf_exp_alloc
525#if   defined key_floats   ||   defined key_esopa
526     USE flo_oce,      ONLY: flo_oce_alloc
527#endif
528#if   defined key_floats   ||   defined key_esopa
529     USE flowri,       ONLY: flo_wri_alloc
530#endif
531     USE geo2ocean,    ONLY: geo2oce_alloc
532     USE ldfdyn_oce,   ONLY: ldfdyn_oce_alloc
533#if   defined key_ldfslp   ||   defined key_esopa
534     USE ldfslp,       ONLY: ldf_slp_alloc
535#endif
536     USE ldftra_oce,   ONLY: ldftra_oce_alloc
537#if   defined key_mpp_mpi 
538     USE lib_mpp,      ONLY: lib_mpp_alloc
539#endif
540#if defined key_obc
541     USE obcdta,      ONLY: obc_dta_alloc
542     USE obc_oce,      ONLY: obc_oce_alloc
543#endif
544     USE oce,          ONLY: oce_alloc
545     USE sbcblk_clio,  ONLY: sbc_blk_clio_alloc
546#if defined key_oasis3 || defined key_oasis4
547     USE sbccpl,       ONLY: sbc_cpl_init_alloc
548#endif
549     USE sbcdcy,       ONLY: sbc_dcy_alloc
550     USE sbcfwb,       ONLY: sbc_fwb_alloc
551#if defined key_lim3 || defined key_lim2
552     USE sbc_ice,      ONLY: sbc_ice_alloc
553#endif
554     USE sbc_oce,      ONLY: sbc_oce_alloc
555     USE sbcrnf,       ONLY: sbc_rnf_alloc
556     USE sbcssr,       ONLY: sbc_ssr_alloc
557     USE sol_oce,      ONLY: sol_oce_alloc
558     USE solmat,       ONLY: sol_mat_alloc
559     USE traadv,       ONLY: tra_adv_alloc
560     USE traadv_cen2,  ONLY: tra_adv_cen2_alloc
561#if   defined key_trabbl   ||   defined key_esopa
562     USE trabbl,       ONLY: tra_bbl_alloc
563#endif
564#if   defined key_tradmp   ||   defined key_esopa
565     USE tradmp,       ONLY: tra_dmp_alloc
566#endif
567     USE traldf,       ONLY: tra_ldf_alloc
568#if   defined key_ldfslp   ||   defined key_esopa
569     USE traldf_iso_grif,ONLY: tra_ldf_iso_grif_alloc
570#endif
571     USE traldf_lap,   ONLY: tra_ldf_lap_alloc
572     USE tranxt,       ONLY: tra_nxt_alloc
573     USE trazdf,       ONLY: tra_zdf_alloc
574
575     ! TOP-related alloc routines...
576#if defined key_top
577     USE trcadv,       ONLY: trc_adv_alloc
578     USE trc,          ONLY: trc_alloc
579     USE trcnxt,       ONLY: trc_nxt_alloc
580     USE trczdf,       ONLY: trc_zdf_alloc
581     USE trdmod_trc_oce,ONLY: trd_mod_trc_oce_alloc
582#endif
583#if defined key_top && ! defined key_iomput
584     USE trcdia,       ONLY: trc_dia_alloc
585#endif
586#if  defined key_top && defined key_trcdmp 
587     USE trcdmp,       ONLY: trc_dmp_alloc
588#endif
589#if  defined key_top  &&  defined key_dtatrc
590     USE trcdta,       ONLY: trc_dta_alloc
591#endif
592     ! ...end of TOP-related alloc routines
593
594     ! LOBSTER-related alloc routines...
595     USE sms_lobster,  ONLY: sms_lobster_alloc
596     ! ...end of LOBSTER-related alloc routines
597
598     USE trc_oce,      ONLY: trc_oce_alloc
599#if   defined key_trdmld   ||   defined key_esopa
600     USE trdmld,       ONLY: trd_mld_alloc
601#endif
602     USE trdmld_oce,   ONLY: trdmld_oce_alloc
603#if  defined key_trdtra || defined key_trdmld || defined key_trdmld_trc 
604     USE trdtra,       ONLY: trd_tra_alloc
605#endif
606#if defined key_trdvor   ||   defined key_esopa
607     USE trdvor,       ONLY: trd_vor_alloc
608#endif
609     USE wrk_nemo,     ONLY: wrk_alloc
610     USE zdfbfr,       ONLY: zdf_bfr_alloc
611#if defined key_zdfddm   ||   defined key_esopa
612     USE zdfddm,       ONLY: zdf_ddm_alloc
613#endif
614#if defined key_zdfkpp   ||   defined key_esopa
615     USE zdfkpp,       ONLY: zdf_kpp_alloc
616#endif
617#if defined key_zdfgls   ||   defined key_esopa
618     USE zdfgls,       ONLY: zdf_gls_alloc
619#endif
620     USE zdfmxl,       ONLY: zdf_mxl_alloc
621     USE zdf_oce,      ONLY: zdf_oce_alloc
622#if defined key_zdfric   ||   defined key_esopa
623     USE zdfric,       ONLY: zdf_ric_alloc
624#endif
625#if defined key_zdftke   ||   defined key_esopa
626     USE zdftke,       ONLY: zdf_tke_alloc
627#endif
628#if defined key_zdftmx
629     USE zdftmx,       ONLY: zdf_tmx_alloc
630#endif
631     IMPLICIT none
632     INTEGER :: ierr
633     INTEGER :: i
634     !!----------------------------------------------------------------------
635
636     ierr = 0
637
638     !! Calls to the _alloc() routines should be in the same order as the
639     !! modules are USE'd above
640#if defined key_lim2
641     ierr = ierr + dom_ice_alloc_2()
642     ierr = ierr + ice_alloc_2()
643     ierr = ierr + lim_dia_alloc_2()
644     ierr = ierr + lim_hdf_alloc_2()
645     ierr = ierr + lim_sbc_alloc_2()
646     ierr = ierr + lim_wri_alloc_2()
647     ierr = ierr + thd_ice_alloc_2()
648#endif
649#if defined key_lim3 || (  defined key_lim2 && ! defined key_lim2_vp )
650     ierr = ierr + lim_rhg_alloc()
651#endif
652#if defined key_lim3
653     ierr = ierr + dom_ice_alloc()
654     ierr = ierr + lim_itd_me_alloc()
655     ierr = ierr + thd_ice_alloc()
656#endif
657     ! End of ice-related allocations
658#if  defined key_bdy
659     ierr = ierr + bdy_oce_alloc()
660#endif
661#if defined key_diaar5
662     ierr = ierr + dia_ar5_alloc()
663#endif
664# if defined key_dimgout
665     ierr = ierr + dia_wri_dimg_alloc()
666#endif
667     ierr = ierr + div_cur_alloc()
668#if   defined key_diahth   ||   defined key_esopa
669     ierr = ierr + dia_hth_alloc()
670#endif
671     ierr = ierr + dia_ptr_alloc()
672     ierr = ierr + dia_wri_alloc()
673     ierr = ierr + dom_oce_alloc()
674#if defined key_vvl
675     ierr = ierr + dom_vvl_alloc()
676#endif
677     ierr = ierr + dom_wri_alloc()
678#if defined key_dtasal   ||   defined key_esopa
679     ierr = ierr + dta_sal_alloc()
680#endif
681#if defined key_ldfslp   ||   defined key_esopa
682     ierr = ierr + dyn_ldf_bilapg_alloc()
683#endif
684#if defined key_dtasal   ||   defined key_esopa
685     ierr = ierr + dta_sal_alloc()
686#endif
687#if defined key_dtatem   ||   defined key_esopa
688     ierr = ierr + dta_tem_alloc()
689#endif
690#if defined key_ldfslp   ||   defined key_esopa
691     ierr = ierr + dyn_ldf_iso_alloc()
692#endif
693#if   defined key_dynspg_ts   ||   defined key_vvl   ||   defined key_esopa
694     ierr = ierr + dynspg_oce_alloc()
695#endif
696     ierr = ierr + dyn_vor_alloc()
697     ierr = ierr + dyn_zdf_exp_alloc()
698#if   defined key_floats   ||   defined key_esopa
699     ierr = ierr + flo_oce_alloc()
700#endif
701#if   defined key_floats   ||   defined key_esopa
702     ierr = ierr + flo_wri_alloc()
703#endif
704     ierr = ierr + geo2oce_alloc()
705     ierr = ierr + ldfdyn_oce_alloc()
706#if   defined key_ldfslp   ||   defined key_esopa
707     ierr = ierr + ldf_slp_alloc()
708#endif
709     ierr = ierr + ldftra_oce_alloc()
710#if defined key_mpp_mpi 
711     ierr = ierr + lib_mpp_alloc()
712#endif
713#if defined key_obc
714     ierr = ierr + obc_dta_alloc()
715     ierr = ierr + obc_oce_alloc()
716#endif
717     ierr = ierr + oce_alloc()
718     ierr = ierr + sbc_blk_clio_alloc()
719#if defined key_oasis3 || defined key_oasis4
720     ierr = ierr + sbc_cpl_init_alloc()
721#endif
722     ierr = ierr + sbc_dcy_alloc()
723     ierr = ierr + sbc_fwb_alloc()
724#if defined key_lim3 || defined key_lim2
725     ierr = ierr + sbc_ice_alloc()
726#endif
727     ierr = ierr + sbc_oce_alloc()
728     ierr = ierr + sbc_rnf_alloc()
729     ierr = ierr + sbc_ssr_alloc()
730     ierr = ierr + sol_oce_alloc()
731     ierr = ierr + sol_mat_alloc()
732     ierr = ierr + tra_adv_alloc()
733     ierr = ierr + tra_adv_cen2_alloc()
734#if   defined key_trabbl   ||   defined key_esopa
735     ierr = ierr + tra_bbl_alloc()
736#endif
737#if   defined key_tradmp   ||   defined key_esopa
738     ierr = ierr + tra_dmp_alloc()
739#endif
740     ierr = ierr + tra_ldf_alloc()
741#if   defined key_ldfslp   ||   defined key_esopa
742     ierr = ierr + tra_ldf_iso_grif_alloc()
743#endif
744     ierr = ierr + tra_ldf_lap_alloc()
745     ierr = ierr + tra_nxt_alloc()
746     ierr = ierr + tra_zdf_alloc()
747
748     ! Start of TOP-related alloc routines...
749#if defined key_top
750     ierr = ierr + trc_adv_alloc()
751     ierr = ierr + trc_alloc()
752     ierr = ierr + trc_nxt_alloc()
753     ierr = ierr + trc_zdf_alloc()
754     ierr = ierr + trd_mod_trc_oce_alloc()
755#endif
756#if defined key_top && ! defined key_iomput
757     ierr = ierr + trc_dia_alloc()
758#endif
759#if  defined key_top && defined key_trcdmp 
760     ierr = ierr + trc_dmp_alloc()
761#endif
762#if  defined key_top  &&  defined key_dtatrc
763     ierr = ierr + trc_dta_alloc()
764#endif
765     ! ...end of TOP-related alloc routines
766
767     ! Start of LOBSTER-related alloc routines
768     ierr = ierr + sms_lobster_alloc()
769     ! ...end of LOBSTER-related alloc routines
770
771     ierr = ierr + trc_oce_alloc()
772#if   defined key_trdmld   ||   defined key_esopa
773     ierr = ierr + trd_mld_alloc()
774#endif
775     ierr = ierr + trdmld_oce_alloc()
776#if  defined key_trdtra || defined key_trdmld || defined key_trdmld_trc 
777     ierr = ierr + trd_tra_alloc()
778#endif
779#if defined key_trdvor   ||   defined key_esopa
780     ierr = ierr + trd_vor_alloc()
781#endif
782     ierr = ierr + wrk_alloc()
783     ierr = ierr + zdf_bfr_alloc()
784#if defined key_zdfddm   ||   defined key_esopa
785     ierr = ierr + zdf_ddm_alloc()
786#endif
787#if defined key_zdfkpp   ||   defined key_esopa
788     ierr = ierr + zdf_kpp_alloc()
789#endif
790#if defined key_zdfgls   ||   defined key_esopa
791     ierr = ierr + zdf_gls_alloc()
792#endif
793     ierr = ierr + zdf_mxl_alloc()
794     ierr = ierr + zdf_oce_alloc()
795#if defined key_zdfric   ||   defined key_esopa
796     ierr = ierr + zdf_ric_alloc()
797#endif
798#if defined key_zdftke   ||   defined key_esopa
799     ierr = ierr + zdf_tke_alloc()
800#endif
801#if defined key_zdftmx
802     ierr = ierr + zdf_tmx_alloc()
803#endif
804
805     IF( lk_mpp ) CALL mpp_sum(ierr)
806
807     IF(ierr > 0)THEN
808        WRITE(numout,*) 
809        WRITE(numout,*) 'ERROR: Allocation of memory failed in nemo_alloc'
810        IF( lk_mpp ) CALL mppstop()
811        STOP
812     END IF
813
814   END SUBROUTINE nemo_alloc
815
816   !!======================================================================
817
818   SUBROUTINE nemo_partition(num_pes)
819     USE par_oce
820     IMPLICIT none
821     INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
822     ! Local variables
823     INTEGER, PARAMETER :: nfactmax = 20
824     INTEGER :: nfact ! The no. of factors returned
825     INTEGER :: ierr  ! Error flag
826     INTEGER :: i
827     INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are
828                                     ! closest in value
829     INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
830     ierr = 0
831
832     CALL factorise(ifact, nfactmax, nfact, num_pes, ierr)
833
834     IF(nfact <= 1)THEN
835        WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
836        WRITE (numout, *) '       : using grid of ',num_pes,' x 1'
837        jpnj = 1
838        jpni = num_pes
839     ELSE
840        ! Search through factors for the pair that are closest in value
841        mindiff = 1000000
842        imin    = 1
843        DO i=1,nfact-1,2
844           idiff = ABS(ifact(i) - ifact(i+1))
845           IF(idiff < mindiff)THEN
846              mindiff = idiff
847              imin = i
848           END IF
849        END DO
850        jpnj = ifact(imin)
851        jpni = ifact(imin + 1)
852     ENDIF
853     jpnij = jpni*jpnj
854
855     WRITE(*,*) 'ARPDBG: jpni = ',jpni,'jpnj = ',jpnj,'jpnij = ',jpnij
856
857   END SUBROUTINE nemo_partition
858
859   !!======================================================================
860
861   SUBROUTINE factorise ( ifax, maxfax, nfax, n, ierr )
862
863     ! Subroutine to return the prime factors of n.
864     ! nfax factors are returned in array ifax which is of maximum
865     ! dimension maxfax.
866
867     IMPLICIT none
868
869     ! Subroutine arguments
870     INTEGER, INTENT(in)  :: n, maxfax
871     INTEGER, INTENT(Out) :: ierr, nfax
872     INTEGER, INTENT(out) :: ifax(maxfax)
873     ! Local variables.
874     INTEGER :: i, ifac, l, nu
875     INTEGER, PARAMETER :: ntest = 14
876     INTEGER :: lfax(ntest)
877
878     ! lfax contains the set of allowed factors.
879     data (lfax(i),i=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, &
880                             256, 128, 64, 32, 16, 8, 4, 2  /
881
882     ! Clear the error flag and initialise output vars
883     ierr = 0
884     ifax = 1
885     nfax = 0
886
887     ! Find the factors of n.
888     if ( n.eq.1 ) goto 20
889
890     ! nu holds the unfactorised part of the number.
891     ! nfax holds the number of factors found.
892     ! l points to the allowed factor list.
893     ! ifac holds the current factor.
894
895      nu = n
896      nfax = 0
897
898      DO l=ntest,1,-1
899
900         ifac = lfax(l)
901         IF(ifac > nu)CYCLE
902
903         ! Test whether the factor will divide.
904
905         If ( mod(nu,ifac).eq.0 ) then
906
907            ! Add the factor to the list.
908
909            nfax = nfax+1
910            if ( nfax.gt.maxfax ) then
911               ierr = 6
912               write (*,*) 'FACTOR: insufficient space in factor array ',nfax
913               return
914            endif
915            ifax(nfax) = ifac
916            ! Store the other factor that goes with this one
917            nfax = nfax + 1
918            ifax(nfax) = nu/ifac
919            !WRITE (*,*) 'ARPDBG, factors ',nfax-1,' & ',nfax,' are ', &
920            !            ifax(nfax-1),' and ',ifax(nfax)
921         END IF
922
923      END DO
924
925      ! Label 20 is the exit point from the factor search loop.
926   20 continue
927
928      return
929
930  END SUBROUTINE factorise
931
932  !!======================================================================
933
934END MODULE nemogcm
Note: See TracBrowser for help on using the repository browser.