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/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC – NEMO

source: branches/2011/UKMO_MERCATOR_obc_bdy_merge/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90 @ 2814

Last change on this file since 2814 was 2814, checked in by davestorkey, 13 years ago
  1. Implement tidal harmonics forcing (UKMO version) in new structure.
  2. Other bug fixes and updates.
  • Property svn:keywords set to Id
File size: 29.1 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 : calculate MPP domain decomposition
39   !!   factorise      : calculate the factors of the no. of MPI processes
40   !!----------------------------------------------------------------------
41   USE step_oce        ! module used in the ocean time stepping module
42   USE sbc_oce         ! surface boundary condition: ocean
43   USE cla             ! cross land advection               (tra_cla routine)
44   USE domcfg          ! domain configuration               (dom_cfg routine)
45   USE mppini          ! shared/distributed memory setting (mpp_init routine)
46   USE domain          ! domain initialization             (dom_init routine)
47   USE obcini          ! open boundary cond. initialization (obc_init routine)
48   USE obcdta          ! open boundary cond. initialization (obc_dta_init routine)
49   USE obctides        ! open boundary cond. initialization (tide_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#if defined key_agrif
117      CALL Agrif_Declare_Var       ! AGRIF: set the meshes
118# if defined key_top
119      CALL Agrif_Declare_Var_Top   ! AGRIF: set the meshes
120# endif
121#endif
122      ! check that all process are still there... If some process have an error,
123      ! they will never enter in step and other processes will wait until the end of the cpu time!
124      IF( lk_mpp )   CALL mpp_max( nstop )
125
126      IF(lwp) WRITE(numout,cform_aaa)   ! Flag AAAAAAA
127
128      !                            !-----------------------!
129      !                            !==   time stepping   ==!
130      !                            !-----------------------!
131      istp = nit000
132#if defined key_c1d
133         DO WHILE ( istp <= nitend .AND. nstop == 0 )
134            CALL stp_c1d( istp )
135            istp = istp + 1
136         END DO
137#else
138          IF( lk_asminc ) THEN
139             IF( ln_bkgwri ) CALL asm_bkg_wri( nit000 - 1 )    ! Output background fields
140             IF( ln_trjwri ) CALL asm_trj_wri( nit000 - 1 )    ! Output trajectory fields
141             IF( ln_asmdin ) THEN                        ! Direct initialization
142                IF( ln_trainc ) CALL tra_asm_inc( nit000 - 1 )    ! Tracers
143                IF( ln_dyninc ) THEN
144                   CALL dyn_asm_inc( nit000 - 1 )    ! Dynamics
145                   IF ( ln_asmdin ) CALL ssh_wzv ( nit000 - 1 )      ! update vertical velocity
146                ENDIF
147                IF( ln_sshinc ) CALL ssh_asm_inc( nit000 - 1 )    ! SSH
148             ENDIF
149          ENDIF
150       
151         DO WHILE ( istp <= nitend .AND. nstop == 0 )
152#if defined key_agrif
153            CALL Agrif_Step( stp )           ! AGRIF: time stepping
154#else
155            CALL stp( istp )                 ! standard time stepping
156#endif
157            istp = istp + 1
158            IF( lk_mpp )   CALL mpp_max( nstop )
159         END DO
160#endif
161
162      IF( lk_diaobs ) CALL dia_obs_wri
163       
164      !                            !------------------------!
165      !                            !==  finalize the run  ==!
166      !                            !------------------------!
167      IF(lwp) WRITE(numout,cform_aaa)   ! Flag AAAAAAA
168      !
169      IF( nstop /= 0 .AND. lwp ) THEN   ! error print
170         WRITE(numout,cform_err)
171         WRITE(numout,*) nstop, ' error have been found' 
172      ENDIF
173      !
174      CALL nemo_closefile
175#if defined key_oasis3 || defined key_oasis4
176      CALL cpl_prism_finalize           ! end coupling and mpp communications with OASIS
177#else
178      IF( lk_mpp )   CALL mppstop       ! end mpp communications
179#endif
180      !
181   END SUBROUTINE nemo_gcm
182
183
184   SUBROUTINE nemo_init
185      !!----------------------------------------------------------------------
186      !!                     ***  ROUTINE nemo_init  ***
187      !!
188      !! ** Purpose :   initialization of the NEMO GCM
189      !!----------------------------------------------------------------------
190      INTEGER ::   ji            ! dummy loop indices
191      INTEGER ::   ilocal_comm   ! local integer
192      CHARACTER(len=80), DIMENSION(16) ::   cltxt
193      !!
194      NAMELIST/namctl/ ln_ctl  , nn_print, nn_ictls, nn_ictle,   &
195         &             nn_isplt, nn_jsplt, nn_jctls, nn_jctle, nn_bench
196      !!----------------------------------------------------------------------
197      !
198      cltxt = ''
199      !
200      !                             ! open Namelist file
201      CALL ctl_opn( numnam, 'namelist', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
202      !
203      READ( numnam, namctl )        ! Namelist namctl : Control prints & Benchmark
204      !
205      !                             !--------------------------------------------!
206      !                             !  set communicator & select the local node  !
207      !                             !--------------------------------------------!
208#if defined key_iomput
209      IF( Agrif_Root() ) THEN
210# if defined key_oasis3 || defined key_oasis4
211         CALL cpl_prism_init( ilocal_comm )                 ! nemo local communicator given by oasis
212# endif
213         CALL  init_ioclient( ilocal_comm )                 ! exchange io_server nemo local communicator with the io_server
214      ENDIF
215      narea = mynode( cltxt, numnam, nstop, ilocal_comm )   ! Nodes selection
216#else
217# if defined key_oasis3 || defined key_oasis4
218      IF( Agrif_Root() ) THEN
219         CALL cpl_prism_init( ilocal_comm )                 ! nemo local communicator given by oasis
220      ENDIF
221      narea = mynode( cltxt, numnam, nstop, ilocal_comm )   ! Nodes selection (control print return in cltxt)
222# else
223      ilocal_comm = 0
224      narea = mynode( cltxt, numnam, nstop )                 ! Nodes selection (control print return in cltxt)
225# endif
226#endif
227      narea = narea + 1                                     ! mynode return the rank of proc (0 --> jpnij -1 )
228
229      lwp = (narea == 1) .OR. ln_ctl                        ! control of all listing output print
230
231      ! If dimensions of processor grid weren't specified in the namelist file
232      ! then we calculate them here now that we have our communicator size
233      IF( (jpni < 1) .OR. (jpnj < 1) )THEN
234#if   defined key_mpp_mpi
235         IF( Agrif_Root() ) CALL nemo_partition(mppsize)
236#else
237         jpni  = 1
238         jpnj  = 1
239         jpnij = jpni*jpnj
240#endif
241      END IF
242
243      ! Calculate domain dimensions given calculated jpni and jpnj
244      ! This used to be done in par_oce.F90 when they were parameters rather
245      ! than variables
246      IF( Agrif_Root() ) THEN
247         jpi = ( jpiglo-2*jpreci + (jpni-1) ) / jpni + 2*jpreci   ! first  dim.
248         jpj = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj   ! second dim.
249         jpk = jpkdta                                             ! third dim
250         jpim1 = jpi-1                                            ! inner domain indices
251         jpjm1 = jpj-1                                            !   "           "
252         jpkm1 = jpk-1                                            !   "           "
253         jpij  = jpi*jpj                                          !  jpi x j
254      ENDIF
255
256      IF(lwp) THEN                            ! open listing units
257         !
258         CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
259         !
260         WRITE(numout,*)
261         WRITE(numout,*) '         CNRS - NERC - Met OFFICE - MERCATOR-ocean'
262         WRITE(numout,*) '                       NEMO team'
263         WRITE(numout,*) '            Ocean General Circulation Model'
264         WRITE(numout,*) '                  version 3.3  (2010) '
265         WRITE(numout,*)
266         WRITE(numout,*)
267         DO ji = 1, SIZE(cltxt) 
268            IF( TRIM(cltxt(ji)) /= '' )   WRITE(numout,*) cltxt(ji)      ! control print of mynode
269         END DO
270         WRITE(numout,cform_aaa)                                         ! Flag AAAAAAA
271         !
272      ENDIF
273
274      ! Now we know the dimensions of the grid and numout has been set we can
275      ! allocate arrays
276      CALL nemo_alloc()
277
278      !                             !-------------------------------!
279      !                             !  NEMO general initialization  !
280      !                             !-------------------------------!
281
282      CALL nemo_ctl                          ! Control prints & Benchmark
283
284      !                                      ! Domain decomposition
285      IF( jpni*jpnj == jpnij ) THEN   ;   CALL mpp_init      ! standard cutting out
286      ELSE                            ;   CALL mpp_init2     ! eliminate land processors
287      ENDIF
288      !
289      !                                      ! General initialization
290                            CALL     phy_cst    ! Physical constants
291                            CALL     eos_init   ! Equation of state
292                            CALL     dom_cfg    ! Domain configuration
293                            CALL     dom_init   ! Domain
294
295      IF( ln_ctl        )   CALL prt_ctl_init   ! Print control
296
297      IF( lk_obc        )   CALL     obc_init       ! Open boundaries initialisation
298      IF( lk_obc        )   CALL     obc_dta_init   ! Open boundaries initialisation of external data arrays
299      IF( lk_obc        )   CALL     tide_init      ! Open boundaries initialisation of tidal harmonic forcing
300
301                            CALL  istate_init   ! ocean initial state (Dynamics and tracers)
302
303      !                                     ! Ocean physics
304                            CALL     sbc_init   ! Forcings : surface module
305      !                                         ! Vertical physics
306                            CALL     zdf_init      ! namelist read
307                            CALL zdf_bfr_init      ! bottom friction
308      IF( lk_zdfric     )   CALL zdf_ric_init      ! Richardson number dependent Kz
309      IF( lk_zdftke     )   CALL zdf_tke_init      ! TKE closure scheme
310      IF( lk_zdfgls     )   CALL zdf_gls_init      ! GLS closure scheme
311      IF( lk_zdfkpp     )   CALL zdf_kpp_init      ! KPP closure scheme
312      IF( lk_zdftmx     )   CALL zdf_tmx_init      ! tidal vertical mixing
313      IF( lk_zdfddm .AND. .NOT. lk_zdfkpp )   & 
314         &                  CALL zdf_ddm_init      ! double diffusive mixing
315      !                                         ! Lateral physics
316                            CALL ldf_tra_init      ! Lateral ocean tracer physics
317                            CALL ldf_dyn_init      ! Lateral ocean momentum physics
318      IF( lk_ldfslp     )   CALL ldf_slp_init      ! slope of lateral mixing
319
320      !                                     ! Active tracers
321                            CALL tra_qsr_init   ! penetrative solar radiation qsr
322                            CALL tra_bbc_init   ! bottom heat flux
323      IF( lk_trabbl     )   CALL tra_bbl_init   ! advective (and/or diffusive) bottom boundary layer scheme
324      IF( lk_tradmp     )   CALL tra_dmp_init   ! internal damping trends
325                            CALL tra_adv_init   ! horizontal & vertical advection
326                            CALL tra_ldf_init   ! lateral mixing
327                            CALL tra_zdf_init   ! vertical mixing and after tracer fields
328
329      !                                     ! Dynamics
330                            CALL dyn_adv_init   ! advection (vector or flux form)
331                            CALL dyn_vor_init   ! vorticity term including Coriolis
332                            CALL dyn_ldf_init   ! lateral mixing
333                            CALL dyn_hpg_init   ! horizontal gradient of Hydrostatic pressure
334                            CALL dyn_zdf_init   ! vertical diffusion
335                            CALL dyn_spg_init   ! surface pressure gradient
336                           
337      !                                     ! Misc. options
338      IF( nn_cla == 1   )   CALL cla_init       ! Cross Land Advection
339     
340#if defined key_top
341      !                                     ! Passive tracers
342                            CALL     trc_init
343#endif
344      !                                     ! Diagnostics
345                            CALL     iom_init   ! iom_put initialization
346      IF( lk_floats     )   CALL     flo_init   ! drifting Floats
347      IF( lk_diaar5     )   CALL dia_ar5_init   ! ar5 diag
348                            CALL dia_ptr_init   ! Poleward TRansports initialization
349                            CALL dia_hsb_init   ! heat content, salt content and volume budgets
350                            CALL trd_mod_init   ! Mixed-layer/Vorticity/Integral constraints trends
351      IF( lk_diaobs     ) THEN                  ! Observation & model comparison
352                            CALL dia_obs_init            ! Initialize observational data
353                            CALL dia_obs( nit000 - 1 )   ! Observation operator for restart
354      ENDIF     
355      !                                     ! Assimilation increments
356      IF( lk_asminc     )   CALL asm_inc_init   ! Initialize assimilation increments
357      IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler
358      !
359   END SUBROUTINE nemo_init
360
361
362   SUBROUTINE nemo_ctl
363      !!----------------------------------------------------------------------
364      !!                     ***  ROUTINE nemo_ctl  ***
365      !!
366      !! ** Purpose :   control print setting
367      !!
368      !! ** Method  : - print namctl information and check some consistencies
369      !!----------------------------------------------------------------------
370      !
371      IF(lwp) THEN                  ! control print
372         WRITE(numout,*)
373         WRITE(numout,*) 'nemo_ctl: Control prints & Benchmark'
374         WRITE(numout,*) '~~~~~~~ '
375         WRITE(numout,*) '   Namelist namctl'
376         WRITE(numout,*) '      run control (for debugging)     ln_ctl     = ', ln_ctl
377         WRITE(numout,*) '      level of print                  nn_print   = ', nn_print
378         WRITE(numout,*) '      Start i indice for SUM control  nn_ictls   = ', nn_ictls
379         WRITE(numout,*) '      End i indice for SUM control    nn_ictle   = ', nn_ictle
380         WRITE(numout,*) '      Start j indice for SUM control  nn_jctls   = ', nn_jctls
381         WRITE(numout,*) '      End j indice for SUM control    nn_jctle   = ', nn_jctle
382         WRITE(numout,*) '      number of proc. following i     nn_isplt   = ', nn_isplt
383         WRITE(numout,*) '      number of proc. following j     nn_jsplt   = ', nn_jsplt
384         WRITE(numout,*) '      benchmark parameter (0/1)       nn_bench   = ', nn_bench
385      ENDIF
386      !
387      nprint    = nn_print          ! convert DOCTOR namelist names into OLD names
388      nictls    = nn_ictls
389      nictle    = nn_ictle
390      njctls    = nn_jctls
391      njctle    = nn_jctle
392      isplt     = nn_isplt
393      jsplt     = nn_jsplt
394      nbench    = nn_bench
395      !                             ! Parameter control
396      !
397      IF( ln_ctl ) THEN                 ! sub-domain area indices for the control prints
398         IF( lk_mpp ) THEN
399            isplt = jpni   ;   jsplt = jpnj   ;   ijsplt = jpni*jpnj   ! the domain is forced to the real split domain
400         ELSE
401            IF( isplt == 1 .AND. jsplt == 1  ) THEN
402               CALL ctl_warn( ' - isplt & jsplt are equal to 1',   &
403                  &           ' - the print control will be done over the whole domain' )
404            ENDIF
405            ijsplt = isplt * jsplt            ! total number of processors ijsplt
406         ENDIF
407         IF(lwp) WRITE(numout,*)'          - The total number of processors over which the'
408         IF(lwp) WRITE(numout,*)'            print control will be done is ijsplt : ', ijsplt
409         !
410         !                              ! indices used for the SUM control
411         IF( nictls+nictle+njctls+njctle == 0 )   THEN    ! print control done over the default area
412            lsp_area = .FALSE.                       
413         ELSE                                             ! print control done over a specific  area
414            lsp_area = .TRUE.
415            IF( nictls < 1 .OR. nictls > jpiglo )   THEN
416               CALL ctl_warn( '          - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
417               nictls = 1
418            ENDIF
419            IF( nictle < 1 .OR. nictle > jpiglo )   THEN
420               CALL ctl_warn( '          - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
421               nictle = jpiglo
422            ENDIF
423            IF( njctls < 1 .OR. njctls > jpjglo )   THEN
424               CALL ctl_warn( '          - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
425               njctls = 1
426            ENDIF
427            IF( njctle < 1 .OR. njctle > jpjglo )   THEN
428               CALL ctl_warn( '          - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
429               njctle = jpjglo
430            ENDIF
431         ENDIF
432      ENDIF
433      !
434      IF( nbench == 1 ) THEN              ! Benchmark
435         SELECT CASE ( cp_cfg )
436         CASE ( 'gyre' )   ;   CALL ctl_warn( ' The Benchmark is activated ' )
437         CASE DEFAULT      ;   CALL ctl_stop( ' The Benchmark is based on the GYRE configuration:',   &
438            &                                 ' key_gyre must be used or set nbench = 0' )
439         END SELECT
440      ENDIF
441      !
442      IF( lk_c1d .AND. .NOT.lk_iomput )   CALL ctl_stop( 'nemo_ctl: The 1D configuration must be used ',   &
443         &                                               'with the IOM Input/Output manager. '         ,   &
444         &                                               'Compile with key_iomput enabled' )
445      !
446   END SUBROUTINE nemo_ctl
447
448
449   SUBROUTINE nemo_closefile
450      !!----------------------------------------------------------------------
451      !!                     ***  ROUTINE nemo_closefile  ***
452      !!
453      !! ** Purpose :   Close the files
454      !!----------------------------------------------------------------------
455      !
456      IF( lk_mpp )   CALL mppsync
457      !
458      CALL iom_close                                 ! close all input/output files managed by iom_*
459      !
460      IF( numstp     /= -1 )   CLOSE( numstp     )   ! time-step file
461      IF( numsol     /= -1 )   CLOSE( numsol     )   ! solver file
462      IF( numnam     /= -1 )   CLOSE( numnam     )   ! oce namelist
463      IF( numnam_ice /= -1 )   CLOSE( numnam_ice )   ! ice namelist
464      IF( numevo_ice /= -1 )   CLOSE( numevo_ice )   ! ice variables (temp. evolution)
465      IF( numout     /=  6 )   CLOSE( numout     )   ! standard model output file
466      !
467      numout = 6                                     ! redefine numout in case it is used after this point...
468      !
469   END SUBROUTINE nemo_closefile
470
471
472   SUBROUTINE nemo_alloc
473      !!----------------------------------------------------------------------
474      !!                     ***  ROUTINE nemo_alloc  ***
475      !!
476      !! ** Purpose :   Allocate all the dynamic arrays of the OPA modules
477      !!
478      !! ** Method  :
479      !!----------------------------------------------------------------------
480      USE diawri    , ONLY: dia_wri_alloc
481      USE dom_oce   , ONLY: dom_oce_alloc
482      USE ldfdyn_oce, ONLY: ldfdyn_oce_alloc
483      USE ldftra_oce, ONLY: ldftra_oce_alloc
484      USE trc_oce   , ONLY: trc_oce_alloc
485      USE wrk_nemo  , ONLY: wrk_alloc
486      !
487      INTEGER :: ierr
488      !!----------------------------------------------------------------------
489      !
490      ierr =        oce_alloc       ()          ! ocean
491      ierr = ierr + dia_wri_alloc   ()
492      ierr = ierr + dom_oce_alloc   ()          ! ocean domain
493      ierr = ierr + ldfdyn_oce_alloc()          ! ocean lateral  physics : dynamics
494      ierr = ierr + ldftra_oce_alloc()          ! ocean lateral  physics : tracers
495      ierr = ierr + zdf_oce_alloc   ()          ! ocean vertical physics
496      !
497      ierr = ierr + lib_mpp_alloc   (numout)    ! mpp exchanges
498      ierr = ierr + trc_oce_alloc   ()          ! shared TRC / TRA arrays
499      !
500      ierr = ierr + wrk_alloc(numout, lwp)      ! workspace
501      !
502      IF( lk_mpp    )   CALL mpp_sum( ierr )
503      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'nemo_alloc : unable to allocate standard ocean arrays' )
504      !
505   END SUBROUTINE nemo_alloc
506
507
508   SUBROUTINE nemo_partition( num_pes )
509      !!----------------------------------------------------------------------
510      !!                 ***  ROUTINE nemo_partition  ***
511      !!
512      !! ** Purpose :   
513      !!
514      !! ** Method  :
515      !!----------------------------------------------------------------------
516      INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
517      !
518      INTEGER, PARAMETER :: nfactmax = 20
519      INTEGER :: nfact ! The no. of factors returned
520      INTEGER :: ierr  ! Error flag
521      INTEGER :: ji
522      INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
523      INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
524      !!----------------------------------------------------------------------
525
526      ierr = 0
527
528      CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
529
530      IF( nfact <= 1 ) THEN
531         WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
532         WRITE (numout, *) '       : using grid of ',num_pes,' x 1'
533         jpnj = 1
534         jpni = num_pes
535      ELSE
536         ! Search through factors for the pair that are closest in value
537         mindiff = 1000000
538         imin    = 1
539         DO ji = 1, nfact-1, 2
540            idiff = ABS( ifact(ji) - ifact(ji+1) )
541            IF( idiff < mindiff ) THEN
542               mindiff = idiff
543               imin = ji
544            ENDIF
545         END DO
546         jpnj = ifact(imin)
547         jpni = ifact(imin + 1)
548      ENDIF
549      !
550      jpnij = jpni*jpnj
551      !
552   END SUBROUTINE nemo_partition
553
554
555   SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
556      !!----------------------------------------------------------------------
557      !!                     ***  ROUTINE factorise  ***
558      !!
559      !! ** Purpose :   return the prime factors of n.
560      !!                knfax factors are returned in array kfax which is of
561      !!                maximum dimension kmaxfax.
562      !! ** Method  :
563      !!----------------------------------------------------------------------
564      INTEGER                    , INTENT(in   ) ::   kn, kmaxfax
565      INTEGER                    , INTENT(  out) ::   kerr, knfax
566      INTEGER, DIMENSION(kmaxfax), INTENT(  out) ::   kfax
567      !
568      INTEGER :: ifac, jl, inu
569      INTEGER, PARAMETER :: ntest = 14
570      INTEGER :: ilfax(ntest)
571
572      ! lfax contains the set of allowed factors.
573      data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256,  &
574         &                            128,   64,   32,   16,    8,   4,   2  /
575      !!----------------------------------------------------------------------
576
577      ! Clear the error flag and initialise output vars
578      kerr = 0
579      kfax = 1
580      knfax = 0
581
582      ! Find the factors of n.
583      IF( kn == 1 )   GOTO 20
584
585      ! nu holds the unfactorised part of the number.
586      ! knfax holds the number of factors found.
587      ! l points to the allowed factor list.
588      ! ifac holds the current factor.
589
590      inu   = kn
591      knfax = 0
592
593      DO jl = ntest, 1, -1
594         !
595         ifac = ilfax(jl)
596         IF( ifac > inu )   CYCLE
597
598         ! Test whether the factor will divide.
599
600         IF( MOD(inu,ifac) == 0 ) THEN
601            !
602            knfax = knfax + 1            ! Add the factor to the list
603            IF( knfax > kmaxfax ) THEN
604               kerr = 6
605               write (*,*) 'FACTOR: insufficient space in factor array ', knfax
606               return
607            ENDIF
608            kfax(knfax) = ifac
609            ! Store the other factor that goes with this one
610            knfax = knfax + 1
611            kfax(knfax) = inu / ifac
612            !WRITE (*,*) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
613         ENDIF
614         !
615      END DO
616
617   20 CONTINUE      ! Label 20 is the exit point from the factor search loop.
618      !
619   END SUBROUTINE factorise
620
621   !!======================================================================
622END MODULE nemogcm
Note: See TracBrowser for help on using the repository browser.