source: trunk/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90 @ 2758

Last change on this file since 2758 was 2758, checked in by cetlod, 10 years ago

Minor modifications on zdfmxl.F90 in order to be used when running in OFFLINE mode, see ticket #820

File size: 22.0 KB
Line 
1MODULE nemogcm
2   !!======================================================================
3   !!                       ***  MODULE nemogcm   ***
4   !! Off-line Ocean   : passive tracer evolution, dynamics read in files
5   !!======================================================================
6   !! History :  3.3  ! 2010-05  (C. Ethe)  Full reorganization of the off-line: phasing with the on-line
7   !!            4.0  ! 2011-01  (C. Ethe, A. R. Porter, STFC Daresbury) dynamical allocation
8   !!----------------------------------------------------------------------
9
10   !!----------------------------------------------------------------------
11   !!   nemo_gcm        : off-line: solve ocean tracer only
12   !!   nemo_init       : initialization of the nemo model
13   !!   nemo_ctl        : initialisation of algorithm flag
14   !!   nemo_closefile  : close remaining files
15   !!----------------------------------------------------------------------
16   USE dom_oce         ! ocean space domain variables
17   USE oce             ! dynamics and tracers variables
18   USE c1d             ! 1D configuration
19   USE domcfg          ! domain configuration               (dom_cfg routine)
20   USE domain          ! domain initialization             (dom_init routine)
21   USE istate          ! initial state setting          (istate_init routine)
22   USE eosbn2          ! equation of state            (eos bn2 routine)
23   !              ! ocean physics
24   USE ldftra          ! lateral diffusivity setting    (ldf_tra_init routine)
25   USE ldfslp          ! slopes of neutral surfaces     (ldf_slp_init routine)
26   USE traqsr          ! solar radiation penetration    (tra_qsr_init routine)
27   USE trabbl          ! bottom boundary layer          (tra_bbl_init routine)
28   USE zdfini          ! vertical physics: initialization
29   USE sbcmod          ! surface boundary condition       (sbc_init     routine)
30   USE phycst          ! physical constant                  (par_cst routine)
31   USE dtadyn          ! Lecture and Interpolation of the dynamical fields
32   USE trcini          ! Initilization of the passive tracers
33   USE daymod          ! calendar                         (day     routine)
34   USE trcstp          ! passive tracer time-stepping      (trc_stp routine)
35   USE dtadyn          ! Lecture and interpolation of the dynamical fields
36   USE stpctl          ! time stepping control            (stp_ctl routine)
37   !              ! I/O & MPP
38   USE iom             ! I/O library
39   USE in_out_manager  ! I/O manager
40   USE mppini          ! shared/distributed memory setting (mpp_init routine)
41   USE lib_mpp         ! distributed memory computing
42#if defined key_iomput
43   USE mod_ioclient
44#endif
45   USE prtctl           ! Print control                    (prt_ctl_init routine)
46
47   IMPLICIT NONE
48   PRIVATE
49   
50   PUBLIC   nemo_gcm   ! called by nemo.F90
51
52   CHARACTER (len=64) ::   cform_aaa="( /, 'AAAAAAAA', / ) "   ! flag for output listing
53
54   !!----------------------------------------------------------------------
55   !! NEMO/OFF 3.3 , NEMO Consortium (2010)
56   !! $Id: nemogcm.F90 2528 2010-12-27 17:33:53Z rblod $
57   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
58   !!----------------------------------------------------------------------
59CONTAINS
60
61   SUBROUTINE nemo_gcm
62      !!----------------------------------------------------------------------
63      !!                     ***  ROUTINE nemo_gcm  ***
64      !!
65      !! ** Purpose :   nemo solves the primitive equations on an orthogonal
66      !!      curvilinear mesh on the sphere.
67      !!
68      !! ** Method  : - model general initialization
69      !!              - launch the time-stepping (dta_dyn and trc_stp)
70      !!              - finalize the run by closing files and communications
71      !!
72      !! References : Madec, Delecluse,Imbard, and Levy, 1997:  internal report, IPSL.
73      !!              Madec, 2008, internal report, IPSL.
74      !!----------------------------------------------------------------------
75      INTEGER :: istp, indic       ! time step index
76      !!----------------------------------------------------------------------
77
78      CALL nemo_init  ! Initializations
79
80      IF( lk_mpp )   CALL mpp_max( nstop )
81
82      ! check that all process are still there... If some process have an error,
83      ! they will never enter in step and other processes will wait until the end of the cpu time!
84      IF( lk_mpp )   CALL mpp_max( nstop )
85
86      !                            !-----------------------!
87      !                            !==   time stepping   ==!
88      !                            !-----------------------!
89      istp = nit000
90         !
91      DO WHILE ( istp <= nitend .AND. nstop == 0 )    ! time stepping
92         !
93         IF( istp /= nit000 )   CALL day      ( istp )         ! Calendar (day was already called at nit000 in day_init)
94                                CALL iom_setkt( istp )         ! say to iom that we are at time step kstp
95                                CALL dta_dyn  ( istp )         ! Interpolation of the dynamical fields
96                                CALL trc_stp  ( istp )         ! time-stepping
97                                CALL stp_ctl  ( istp, indic )  ! Time loop: control and print
98         istp = istp + 1
99         IF( lk_mpp )   CALL mpp_max( nstop )
100      END DO
101
102      !                            !------------------------!
103      !                            !==  finalize the run  ==!
104      !                            !------------------------!
105      IF(lwp) WRITE(numout,cform_aaa)                 ! Flag AAAAAAA
106
107      IF( nstop /= 0 .AND. lwp ) THEN                 ! error print
108         WRITE(numout,cform_err)
109         WRITE(numout,*) nstop, ' error have been found'
110      ENDIF
111      !
112      CALL nemo_closefile
113      !
114      IF( lk_mpp )   CALL mppstop                          ! Close all files (mpp)
115      !
116   END SUBROUTINE nemo_gcm
117
118
119   SUBROUTINE nemo_init
120      !!----------------------------------------------------------------------
121      !!                     ***  ROUTINE nemo_init ***
122      !!
123      !! ** Purpose :   initialization of the nemo model in off-line mode
124      !!----------------------------------------------------------------------
125      INTEGER ::   ji            ! dummy loop indices
126      INTEGER ::   ilocal_comm   ! local integer
127      CHARACTER(len=80), DIMENSION(16) ::   cltxt = ''
128      !!
129      NAMELIST/namctl/ ln_ctl  , nn_print, nn_ictls, nn_ictle,   &
130         &             nn_isplt, nn_jsplt, nn_jctls, nn_jctle, nn_bench
131      !!----------------------------------------------------------------------
132      !
133      !                             ! open Namelist file     
134      CALL ctl_opn( numnam, 'namelist', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
135      !
136      READ( numnam, namctl )        ! Namelist namctl : Control prints & Benchmark
137      !
138      !                             !--------------------------------------------!
139      !                             !  set communicator & select the local node  !
140      !                             !--------------------------------------------!
141#if defined key_iomput
142      CALL  init_ioclient( ilocal_comm )                 ! exchange io_server nemo local communicator with the io_server
143      narea = mynode( cltxt, numnam, nstop, ilocal_comm )   ! Nodes selection
144#else
145      ilocal_comm = 0
146      narea = mynode( cltxt, numnam, nstop )                 ! Nodes selection (control print return in cltxt)
147#endif
148
149      narea = narea + 1                       ! mynode return the rank of proc (0 --> jpnij -1 )
150
151      lwp = (narea == 1) .OR. ln_ctl          ! control of all listing output print
152
153      ! If dimensions of processor grid weren't specified in the namelist file
154      ! then we calculate them here now that we have our communicator size
155      IF( (jpni < 1) .OR. (jpnj < 1) )THEN
156#if   defined key_mpp_mpi   ||   defined key_mpp_shmem
157         CALL nemo_partition(mppsize)
158#else
159         jpni = 1
160         jpnj = 1
161         jpnij = jpni*jpnj
162#endif
163      END IF
164
165      ! Calculate domain dimensions given calculated jpni and jpnj
166      ! This used to be done in par_oce.F90 when they were parameters rather
167      ! than variables
168      jpi = ( jpiglo-2*jpreci + (jpni-1) ) / jpni + 2*jpreci   ! first  dim.
169      jpj = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj   ! second dim.
170      jpk = jpkdta                                             ! third dim
171      jpim1 = jpi-1                                            ! inner domain indices
172      jpjm1 = jpj-1                                            !   "           "
173      jpkm1 = jpk-1                                            !   "           "
174      jpij  = jpi*jpj                                          !  jpi x j
175
176
177      IF(lwp) THEN                            ! open listing units
178         !
179         CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
180         !
181         WRITE(numout,*)
182         WRITE(numout,*) '         CNRS - NERC - Met OFFICE - MERCATOR-ocean'
183         WRITE(numout,*) '                       NEMO team'
184         WRITE(numout,*) '            Ocean General Circulation Model'
185         WRITE(numout,*) '                  version 3.3  (2010) '
186         WRITE(numout,*)
187         WRITE(numout,*)
188         DO ji = 1, SIZE(cltxt) 
189            IF( TRIM(cltxt(ji)) /= '' )   WRITE(numout,*) cltxt(ji)      ! control print of mynode
190         END DO
191         WRITE(numout,cform_aaa)                                         ! Flag AAAAAAA
192         !
193      ENDIF
194
195      ! Now we know the dimensions of the grid and numout has been set we can
196      ! allocate arrays
197      CALL nemo_alloc()
198
199      !                             !--------------------------------!
200      !                             !  Model general initialization  !
201      !                             !--------------------------------!
202
203      CALL nemo_ctl                           ! Control prints & Benchmark
204
205      !                                      ! Domain decomposition
206      IF( jpni*jpnj == jpnij ) THEN   ;   CALL mpp_init      ! standard cutting out
207      ELSE                            ;   CALL mpp_init2     ! eliminate land processors
208      ENDIF
209      !
210      !                                      ! General initialization
211                            CALL     phy_cst    ! Physical constants
212                            CALL     eos_init   ! Equation of state
213                            CALL     dom_cfg    ! Domain configuration
214                            CALL     dom_init   ! Domain
215                            CALL  istate_init   ! ocean initial state (Dynamics and tracers)
216
217
218      IF( ln_ctl        )   CALL prt_ctl_init   ! Print control
219
220      !                                     ! Ocean physics
221                            CALL     sbc_init   ! Forcings : surface module
222#if ! defined key_degrad
223                            CALL ldf_tra_init   ! Lateral ocean tracer physics
224#endif
225      IF( lk_ldfslp )       CALL ldf_slp_init   ! slope of lateral mixing
226
227      !                                     ! Active tracers
228                            CALL tra_qsr_init   ! penetrative solar radiation qsr
229      IF( lk_trabbl     )   CALL tra_bbl_init   ! advective (and/or diffusive) bottom boundary layer scheme
230
231      !                                     ! Passive tracers
232                            CALL     trc_init   ! Passive tracers initialization
233      !                                     ! Dynamics
234                            CALL dta_dyn_init   ! Initialization for the dynamics
235                            CALL     iom_init       ! iom_put initialization
236
237      IF(lwp) WRITE(numout,cform_aaa)       ! Flag AAAAAAA
238      !
239   END SUBROUTINE nemo_init
240
241
242   SUBROUTINE nemo_ctl
243      !!----------------------------------------------------------------------
244      !!                     ***  ROUTINE nemo_ctl  ***
245      !!
246      !! ** Purpose :   control print setting
247      !!
248      !! ** Method  : - print namctl information and check some consistencies
249      !!----------------------------------------------------------------------
250      !
251      IF(lwp) THEN                  ! Parameter print
252         WRITE(numout,*)
253         WRITE(numout,*) 'nemo_flg: Control prints & Benchmark'
254         WRITE(numout,*) '~~~~~~~ '
255         WRITE(numout,*) '   Namelist namctl'
256         WRITE(numout,*) '      run control (for debugging)     ln_ctl     = ', ln_ctl
257         WRITE(numout,*) '      level of print                  nn_print   = ', nn_print
258         WRITE(numout,*) '      Start i indice for SUM control  nn_ictls   = ', nn_ictls
259         WRITE(numout,*) '      End i indice for SUM control    nn_ictle   = ', nn_ictle
260         WRITE(numout,*) '      Start j indice for SUM control  nn_jctls   = ', nn_jctls
261         WRITE(numout,*) '      End j indice for SUM control    nn_jctle   = ', nn_jctle
262         WRITE(numout,*) '      number of proc. following i     nn_isplt   = ', nn_isplt
263         WRITE(numout,*) '      number of proc. following j     nn_jsplt   = ', nn_jsplt
264         WRITE(numout,*) '      benchmark parameter (0/1)       nn_bench   = ', nn_bench
265      ENDIF
266      !
267      nprint    = nn_print          ! convert DOCTOR namelist names into OLD names
268      nictls    = nn_ictls
269      nictle    = nn_ictle
270      njctls    = nn_jctls
271      njctle    = nn_jctle
272      isplt     = nn_isplt
273      jsplt     = nn_jsplt
274      nbench    = nn_bench
275      !                             ! Parameter control
276      !
277      IF( ln_ctl ) THEN                 ! sub-domain area indices for the control prints
278         IF( lk_mpp ) THEN
279            isplt = jpni   ;   jsplt = jpnj   ;   ijsplt = jpni*jpnj   ! the domain is forced to the real splitted domain
280         ELSE
281            IF( isplt == 1 .AND. jsplt == 1  ) THEN
282               CALL ctl_warn( ' - isplt & jsplt are equal to 1',   &
283                  &           ' - the print control will be done over the whole domain' )
284            ENDIF
285            ijsplt = isplt * jsplt            ! total number of processors ijsplt
286         ENDIF
287         IF(lwp) WRITE(numout,*)'          - The total number of processors over which the'
288         IF(lwp) WRITE(numout,*)'            print control will be done is ijsplt : ', ijsplt
289         !
290         !                              ! indices used for the SUM control
291         IF( nictls+nictle+njctls+njctle == 0 )   THEN    ! print control done over the default area
292            lsp_area = .FALSE.
293         ELSE                                             ! print control done over a specific  area
294            lsp_area = .TRUE.
295            IF( nictls < 1 .OR. nictls > jpiglo )   THEN
296               CALL ctl_warn( '          - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
297               nictls = 1
298            ENDIF
299            IF( nictle < 1 .OR. nictle > jpiglo )   THEN
300               CALL ctl_warn( '          - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
301               nictle = jpiglo
302            ENDIF
303            IF( njctls < 1 .OR. njctls > jpjglo )   THEN
304               CALL ctl_warn( '          - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
305               njctls = 1
306            ENDIF
307            IF( njctle < 1 .OR. njctle > jpjglo )   THEN
308               CALL ctl_warn( '          - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
309               njctle = jpjglo
310            ENDIF
311         ENDIF
312      ENDIF
313      !
314      IF( nbench == 1 )   THEN            ! Benchmark
315         SELECT CASE ( cp_cfg )
316         CASE ( 'gyre' )   ;   CALL ctl_warn( ' The Benchmark is activated ' )
317         CASE DEFAULT      ;   CALL ctl_stop( ' The Benchmark is based on the GYRE configuration:',   &
318            &                                 ' key_gyre must be used or set nbench = 0' )
319         END SELECT
320      ENDIF
321      !
322      IF( lk_c1d .AND. .NOT.lk_iomput )   CALL ctl_stop( 'nemo_ctl: The 1D configuration must be used ',   &
323         &                                               'with the IOM Input/Output manager. '        ,   &
324         &                                               'Compile with key_iomput enabled' )
325      !
326   END SUBROUTINE nemo_ctl
327
328
329   SUBROUTINE nemo_closefile
330      !!----------------------------------------------------------------------
331      !!                     ***  ROUTINE nemo_closefile  ***
332      !!
333      !! ** Purpose :   Close the files
334      !!----------------------------------------------------------------------
335      !
336      IF ( lk_mpp ) CALL mppsync
337      !
338      CALL iom_close                                 ! close all input/output files managed by iom_*
339      !
340      IF( numstp     /= -1 )   CLOSE( numstp     )   ! time-step file
341      IF( numnam     /= -1 )   CLOSE( numnam     )   ! oce namelist
342      IF( numout     /=  6 )   CLOSE( numout     )   ! standard model output file
343      numout = 6                                     ! redefine numout in case it is used after this point...
344      !
345   END SUBROUTINE nemo_closefile
346
347
348   SUBROUTINE nemo_alloc
349      !!----------------------------------------------------------------------
350      !!                     ***  ROUTINE nemo_alloc  ***
351      !!
352      !! ** Purpose :   Allocate all the dynamic arrays of the OPA modules
353      !!
354      !! ** Method  :
355      !!----------------------------------------------------------------------
356      USE diawri,       ONLY: dia_wri_alloc
357      USE dom_oce,      ONLY: dom_oce_alloc
358      USE zdf_oce,      ONLY: zdf_oce_alloc
359      USE ldftra_oce,   ONLY: ldftra_oce_alloc
360      USE trc_oce,      ONLY: trc_oce_alloc
361      USE wrk_nemo,    ONLY: wrk_alloc
362      !
363      INTEGER :: ierr
364      !!----------------------------------------------------------------------
365      !
366      ierr =        oce_alloc       ()          ! ocean
367      ierr = ierr + dia_wri_alloc   ()
368      ierr = ierr + dom_oce_alloc   ()          ! ocean domain
369      ierr = ierr + ldftra_oce_alloc()          ! ocean lateral  physics : tracers
370      ierr = ierr + zdf_oce_alloc   ()          ! ocean vertical physics
371      !
372      ierr = ierr + lib_mpp_alloc   (numout)    ! mpp exchanges
373      ierr = ierr + trc_oce_alloc   ()          ! shared TRC / TRA arrays
374      ierr = ierr + wrk_alloc(numout, lwp)
375      !
376      IF( lk_mpp    )   CALL mpp_sum( ierr )
377      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'nemo_alloc: unable to allocate standard ocean arrays' )
378      !
379   END SUBROUTINE nemo_alloc
380
381
382   SUBROUTINE nemo_partition( num_pes )
383      !!----------------------------------------------------------------------
384      !!                 ***  ROUTINE nemo_partition  ***
385      !!
386      !! ** Purpose :   
387      !!
388      !! ** Method  :
389      !!----------------------------------------------------------------------
390      INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
391      !
392      INTEGER, PARAMETER :: nfactmax = 20
393      INTEGER :: nfact ! The no. of factors returned
394      INTEGER :: ierr  ! Error flag
395      INTEGER :: ji
396      INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
397      INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
398      !!----------------------------------------------------------------------
399
400      ierr = 0
401
402      CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
403
404      IF( nfact <= 1 ) THEN
405         WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
406         WRITE (numout, *) '       : using grid of ',num_pes,' x 1'
407         jpnj = 1
408         jpni = num_pes
409      ELSE
410         ! Search through factors for the pair that are closest in value
411         mindiff = 1000000
412         imin    = 1
413         DO ji = 1, nfact-1, 2
414            idiff = ABS( ifact(ji) - ifact(ji+1) )
415            IF( idiff < mindiff ) THEN
416               mindiff = idiff
417               imin = ji
418            ENDIF
419         END DO
420         jpnj = ifact(imin)
421         jpni = ifact(imin + 1)
422      ENDIF
423      !
424      jpnij = jpni*jpnj
425      !
426   END SUBROUTINE nemo_partition
427
428
429   SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
430      !!----------------------------------------------------------------------
431      !!                     ***  ROUTINE factorise  ***
432      !!
433      !! ** Purpose :   return the prime factors of n.
434      !!                knfax factors are returned in array kfax which is of
435      !!                maximum dimension kmaxfax.
436      !! ** Method  :
437      !!----------------------------------------------------------------------
438      INTEGER                    , INTENT(in   ) ::   kn, kmaxfax
439      INTEGER                    , INTENT(  out) ::   kerr, knfax
440      INTEGER, DIMENSION(kmaxfax), INTENT(  out) ::   kfax
441      !
442      INTEGER :: ifac, jl, inu
443      INTEGER, PARAMETER :: ntest = 14
444      INTEGER :: ilfax(ntest)
445      !
446      ! lfax contains the set of allowed factors.
447      data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256,  &
448         &                            128,   64,   32,   16,    8,   4,   2  /
449      !!----------------------------------------------------------------------
450
451      ! Clear the error flag and initialise output vars
452      kerr = 0
453      kfax = 1
454      knfax = 0
455
456      ! Find the factors of n.
457      IF( kn == 1 )   GOTO 20
458
459      ! nu holds the unfactorised part of the number.
460      ! knfax holds the number of factors found.
461      ! l points to the allowed factor list.
462      ! ifac holds the current factor.
463
464      inu   = kn
465      knfax = 0
466
467      DO jl = ntest, 1, -1
468         !
469         ifac = ilfax(jl)
470         IF( ifac > inu )   CYCLE
471
472         ! Test whether the factor will divide.
473
474         IF( MOD(inu,ifac) == 0 ) THEN
475            !
476            knfax = knfax + 1            ! Add the factor to the list
477            IF( knfax > kmaxfax ) THEN
478               kerr = 6
479               write (*,*) 'FACTOR: insufficient space in factor array ', knfax
480               return
481            ENDIF
482            kfax(knfax) = ifac
483            ! Store the other factor that goes with this one
484            knfax = knfax + 1
485            kfax(knfax) = inu / ifac
486            !WRITE (*,*) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
487         ENDIF
488         !
489      END DO
490
491   20 CONTINUE      ! Label 20 is the exit point from the factor search loop.
492      !
493   END SUBROUTINE factorise
494
495   !!======================================================================
496END MODULE nemogcm
Note: See TracBrowser for help on using the repository browser.