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

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

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

File size: 29.1 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 xios
44#endif
45   USE prtctl          ! Print control                    (prt_ctl_init routine)
46   USE timing          ! Timing
47   USE lib_fortran     ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
48   USE lbcnfd, ONLY: isendto, nsndto
49
50   USE trc
51   USE trcnam
52   USE trcrst
53
54   IMPLICIT NONE
55   PRIVATE
56   
57   PUBLIC   nemo_gcm   ! called by nemo.F90
58
59   CHARACTER (len=64) ::   cform_aaa="( /, 'AAAAAAAA', / ) "   ! flag for output listing
60
61   !!----------------------------------------------------------------------
62   !! NEMO/OFF 3.3 , NEMO Consortium (2010)
63   !! $Id: nemogcm.F90 2528 2010-12-27 17:33:53Z rblod $
64   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
65   !!----------------------------------------------------------------------
66CONTAINS
67
68   SUBROUTINE nemo_gcm
69      !!----------------------------------------------------------------------
70      !!                     ***  ROUTINE nemo_gcm  ***
71      !!
72      !! ** Purpose :   nemo solves the primitive equations on an orthogonal
73      !!      curvilinear mesh on the sphere.
74      !!
75      !! ** Method  : - model general initialization
76      !!              - launch the time-stepping (dta_dyn and trc_stp)
77      !!              - finalize the run by closing files and communications
78      !!
79      !! References : Madec, Delecluse,Imbard, and Levy, 1997:  internal report, IPSL.
80      !!              Madec, 2008, internal report, IPSL.
81      !!----------------------------------------------------------------------
82      INTEGER :: istp, indic       ! time step index
83      !!----------------------------------------------------------------------
84
85      CALL nemo_init  ! Initializations
86
87      ! check that all process are still there... If some process have an error,
88      ! they will never enter in step and other processes will wait until the end of the cpu time!
89      IF( lk_mpp )   CALL mpp_max( nstop )
90
91      !                            !-----------------------!
92      !                            !==   time stepping   ==!
93      !                            !-----------------------!
94      istp = nit000
95      !
96      CALL iom_init( "nemo" )            ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS)
97      !
98      DO WHILE ( istp <= nitend .AND. nstop == 0 )    ! time stepping
99         !
100         IF( istp /= nit000 )   CALL day      ( istp )         ! Calendar (day was already called at nit000 in day_init)
101                                CALL iom_setkt( istp - nit000 + 1, "nemo" )   ! say to iom that we are at time step kstp
102                                CALL dta_dyn  ( istp )         ! Interpolation of the dynamical fields
103                                CALL trc_stp  ( istp )         ! time-stepping
104                                CALL stp_ctl  ( istp, indic )  ! Time loop: control and print
105         istp = istp + 1
106         IF( lk_mpp )   CALL mpp_max( nstop )
107      END DO
108#if defined key_iomput
109      CALL iom_context_finalize( "nemo" ) ! needed for XIOS+AGRIF
110#endif
111
112      !                            !------------------------!
113      !                            !==  finalize the run  ==!
114      !                            !------------------------!
115      IF(lwp) WRITE(numout,cform_aaa)                 ! Flag AAAAAAA
116
117      IF( nstop /= 0 .AND. lwp ) THEN                 ! error print
118         WRITE(numout,cform_err)
119         WRITE(numout,*) nstop, ' error have been found'
120      ENDIF
121      !
122      IF( nn_timing == 1 )   CALL timing_finalize
123      !
124      CALL nemo_closefile
125      !
126# if defined key_iomput
127      CALL xios_finalize             ! end mpp communications
128# else
129      IF( lk_mpp )   CALL mppstop       ! end mpp communications
130# endif
131      !
132   END SUBROUTINE nemo_gcm
133
134
135   SUBROUTINE nemo_init
136      !!----------------------------------------------------------------------
137      !!                     ***  ROUTINE nemo_init ***
138      !!
139      !! ** Purpose :   initialization of the nemo model in off-line mode
140      !!----------------------------------------------------------------------
141      INTEGER ::   ji            ! dummy loop indices
142      INTEGER ::   ilocal_comm   ! local integer
143      INTEGER ::   ios
144      CHARACTER(len=80), DIMENSION(16) ::   cltxt
145      !!
146      NAMELIST/namctl/ ln_ctl  , nn_print, nn_ictls, nn_ictle,   &
147         &             nn_isplt, nn_jsplt, nn_jctls, nn_jctle,   &
148         &             nn_bench, nn_timing
149      NAMELIST/namcfg/ cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, &
150         &             jpizoom, jpjzoom, jperio
151      !!----------------------------------------------------------------------
152      cltxt = ''
153      !
154      !                             ! Open reference namelist and configuration namelist files
155      CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
156      CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
157      !
158      REWIND( numnam_ref )              ! Namelist namctl in reference namelist : Control prints & Benchmark
159      READ  ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 )
160901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. )
161
162      REWIND( numnam_cfg )              ! Namelist namctl in confguration namelist : Control prints & Benchmark
163      READ  ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 )
164902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. )
165
166      !
167      REWIND( numnam_ref )              ! Namelist namcfg in reference namelist : Control prints & Benchmark
168      READ  ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 )
169903   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. )
170
171      REWIND( numnam_cfg )              ! Namelist namcfg in confguration namelist : Control prints & Benchmark
172      READ  ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 )
173904   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. )   
174
175      !
176      !                             !--------------------------------------------!
177      !                             !  set communicator & select the local node  !
178      !                             !  NB: mynode also opens output.namelist.dyn !
179      !                             !      on unit number numond on first proc   !
180      !                             !--------------------------------------------!
181#if defined key_iomput
182      CALL  xios_initialize( "nemo",return_comm=ilocal_comm )
183      narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )   ! Nodes selection
184#else
185      ilocal_comm = 0
186      narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop )                ! Nodes selection (control print return in cltxt)
187#endif
188
189      narea = narea + 1                       ! mynode return the rank of proc (0 --> jpnij -1 )
190
191      lwm = (narea == 1)                      ! control of output namelists
192      lwp = (narea == 1) .OR. ln_ctl          ! control of all listing output print
193
194      IF(lwm) THEN
195         ! write merged namelists from earlier to output namelist now that the
196         ! file has been opened in call to mynode. nammpp has already been
197         ! written in mynode (if lk_mpp_mpi)
198         WRITE( numond, namctl )
199         WRITE( numond, namcfg )
200      ENDIF
201
202      ! If dimensions of processor grid weren't specified in the namelist file
203      ! then we calculate them here now that we have our communicator size
204      IF( (jpni < 1) .OR. (jpnj < 1) )THEN
205#if   defined key_mpp_mpi
206         CALL nemo_partition(mppsize)
207#else
208         jpni = 1
209         jpnj = 1
210         jpnij = jpni*jpnj
211#endif
212      END IF
213
214      ! Calculate domain dimensions given calculated jpni and jpnj
215      ! This used to be done in par_oce.F90 when they were parameters rather
216      ! than variables
217      jpi = ( jpiglo-2*jpreci + (jpni-1) ) / jpni + 2*jpreci   ! first  dim.
218      jpj = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj   ! second dim.
219      jpk = jpkdta                                             ! third dim
220      jpim1 = jpi-1                                            ! inner domain indices
221      jpjm1 = jpj-1                                            !   "           "
222      jpkm1 = jpk-1                                            !   "           "
223      jpij  = jpi*jpj                                          !  jpi x j
224
225
226      IF(lwp) THEN                            ! open listing units
227         !
228         CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
229         !
230         WRITE(numout,*)
231         WRITE(numout,*) '   CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC'
232         WRITE(numout,*) '                       NEMO team'
233         WRITE(numout,*) '            Ocean General Circulation Model'
234         WRITE(numout,*) '                  version 3.5  (2012) '
235         WRITE(numout,*)
236         WRITE(numout,*)
237         DO ji = 1, SIZE(cltxt) 
238            IF( TRIM(cltxt(ji)) /= '' )   WRITE(numout,*) cltxt(ji)      ! control print of mynode
239         END DO
240         WRITE(numout,cform_aaa)                                         ! Flag AAAAAAA
241         !
242      ENDIF
243
244      ! Now we know the dimensions of the grid and numout has been set we can
245      ! allocate arrays
246      CALL nemo_alloc()
247
248      !                             !--------------------------------!
249      !                             !  Model general initialization  !
250      !                             !--------------------------------!
251
252      CALL nemo_ctl                           ! Control prints & Benchmark
253
254      !                                      ! Domain decomposition
255      IF( jpni*jpnj == jpnij ) THEN   ;   CALL mpp_init      ! standard cutting out
256      ELSE                            ;   CALL mpp_init2     ! eliminate land processors
257      ENDIF
258      !
259      IF( nn_timing == 1 )  CALL timing_init
260      !
261
262      !                                      ! General initialization
263      IF( nn_timing == 1 )  CALL timing_start( 'nemo_init')
264      !
265                            CALL     phy_cst    ! Physical constants
266                            CALL     eos_init   ! Equation of state
267                            CALL     dom_cfg    ! Domain configuration
268                            CALL     dom_init   ! Domain
269                            CALL  istate_init   ! ocean initial state (Dynamics and tracers)
270
271      IF( ln_nnogather )    CALL nemo_northcomms   ! Initialise the northfold neighbour lists (must be done after the masks are defined)
272
273      IF( ln_ctl        )   CALL prt_ctl_init   ! Print control
274
275      !                                     ! Ocean physics
276                            CALL     sbc_init   ! Forcings : surface module
277#if ! defined key_degrad
278                            CALL ldf_tra_init   ! Lateral ocean tracer physics
279#endif
280      IF( lk_ldfslp )       CALL ldf_slp_init   ! slope of lateral mixing
281
282      !                                     ! Active tracers
283                            CALL tra_qsr_init   ! penetrative solar radiation qsr
284      IF( lk_trabbl     )   CALL tra_bbl_init   ! advective (and/or diffusive) bottom boundary layer scheme
285
286                            CALL trc_nam_run  ! Needed to get restart parameters for passive tracers
287      IF( ln_rsttr ) THEN
288        neuler = 1   ! Set time-step indicator at nit000 (leap-frog)
289        CALL trc_rst_cal( nit000, 'READ' )   ! calendar
290      ELSE
291        neuler = 0                  ! Set time-step indicator at nit000 (euler)
292        CALL day_init               ! set calendar
293      ENDIF
294      !                                     ! Dynamics
295                            CALL dta_dyn_init   ! Initialization for the dynamics
296
297      !                                     ! Passive tracers
298                            CALL     trc_init   ! Passive tracers initialization
299
300      IF(lwp) WRITE(numout,cform_aaa)       ! Flag AAAAAAA
301      !
302      IF( nn_timing == 1 )  CALL timing_stop( 'nemo_init')
303      !
304   END SUBROUTINE nemo_init
305
306
307   SUBROUTINE nemo_ctl
308      !!----------------------------------------------------------------------
309      !!                     ***  ROUTINE nemo_ctl  ***
310      !!
311      !! ** Purpose :   control print setting
312      !!
313      !! ** Method  : - print namctl information and check some consistencies
314      !!----------------------------------------------------------------------
315      !
316      IF(lwp) THEN                  ! Parameter print
317         WRITE(numout,*)
318         WRITE(numout,*) 'nemo_flg: Control prints & Benchmark'
319         WRITE(numout,*) '~~~~~~~ '
320         WRITE(numout,*) '   Namelist namctl'
321         WRITE(numout,*) '      run control (for debugging)     ln_ctl     = ', ln_ctl
322         WRITE(numout,*) '      level of print                  nn_print   = ', nn_print
323         WRITE(numout,*) '      Start i indice for SUM control  nn_ictls   = ', nn_ictls
324         WRITE(numout,*) '      End i indice for SUM control    nn_ictle   = ', nn_ictle
325         WRITE(numout,*) '      Start j indice for SUM control  nn_jctls   = ', nn_jctls
326         WRITE(numout,*) '      End j indice for SUM control    nn_jctle   = ', nn_jctle
327         WRITE(numout,*) '      number of proc. following i     nn_isplt   = ', nn_isplt
328         WRITE(numout,*) '      number of proc. following j     nn_jsplt   = ', nn_jsplt
329         WRITE(numout,*) '      benchmark parameter (0/1)       nn_bench   = ', nn_bench
330      ENDIF
331      !
332      nprint    = nn_print          ! convert DOCTOR namelist names into OLD names
333      nictls    = nn_ictls
334      nictle    = nn_ictle
335      njctls    = nn_jctls
336      njctle    = nn_jctle
337      isplt     = nn_isplt
338      jsplt     = nn_jsplt
339      nbench    = nn_bench
340     IF(lwp) THEN                  ! control print
341         WRITE(numout,*)
342         WRITE(numout,*) 'namcfg  : configuration initialization through namelist read'
343         WRITE(numout,*) '~~~~~~~ '
344         WRITE(numout,*) '   Namelist namcfg'
345         WRITE(numout,*) '      configuration name              cp_cfg      = ', TRIM(cp_cfg)
346         WRITE(numout,*) '      configuration resolution        jp_cfg      = ', jp_cfg
347         WRITE(numout,*) '      1st lateral dimension ( >= jpi ) jpidta     = ', jpidta
348         WRITE(numout,*) '      2nd    "         "    ( >= jpj ) jpjdta     = ', jpjdta
349         WRITE(numout,*) '      3nd    "         "               jpkdta     = ', jpkdta
350         WRITE(numout,*) '      1st dimension of global domain in i jpiglo  = ', jpiglo
351         WRITE(numout,*) '      2nd    -                  -    in j jpjglo  = ', jpjglo
352         WRITE(numout,*) '      left bottom i index of the zoom (in data domain) jpizoom = ', jpizoom
353         WRITE(numout,*) '      left bottom j index of the zoom (in data domain) jpizoom = ', jpjzoom
354         WRITE(numout,*) '      lateral cond. type (between 0 and 6) jperio = ', jperio   
355      ENDIF
356      !                             ! Parameter control
357      !
358      IF( ln_ctl ) THEN                 ! sub-domain area indices for the control prints
359         IF( lk_mpp ) THEN
360            isplt = jpni   ;   jsplt = jpnj   ;   ijsplt = jpni*jpnj   ! the domain is forced to the real splitted domain
361         ELSE
362            IF( isplt == 1 .AND. jsplt == 1  ) THEN
363               CALL ctl_warn( ' - isplt & jsplt are equal to 1',   &
364                  &           ' - the print control will be done over the whole domain' )
365            ENDIF
366            ijsplt = isplt * jsplt            ! total number of processors ijsplt
367         ENDIF
368         IF(lwp) WRITE(numout,*)'          - The total number of processors over which the'
369         IF(lwp) WRITE(numout,*)'            print control will be done is ijsplt : ', ijsplt
370         !
371         !                              ! indices used for the SUM control
372         IF( nictls+nictle+njctls+njctle == 0 )   THEN    ! print control done over the default area
373            lsp_area = .FALSE.
374         ELSE                                             ! print control done over a specific  area
375            lsp_area = .TRUE.
376            IF( nictls < 1 .OR. nictls > jpiglo )   THEN
377               CALL ctl_warn( '          - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
378               nictls = 1
379            ENDIF
380            IF( nictle < 1 .OR. nictle > jpiglo )   THEN
381               CALL ctl_warn( '          - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
382               nictle = jpiglo
383            ENDIF
384            IF( njctls < 1 .OR. njctls > jpjglo )   THEN
385               CALL ctl_warn( '          - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
386               njctls = 1
387            ENDIF
388            IF( njctle < 1 .OR. njctle > jpjglo )   THEN
389               CALL ctl_warn( '          - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
390               njctle = jpjglo
391            ENDIF
392         ENDIF
393      ENDIF
394      !
395      IF( nbench == 1 )   THEN            ! Benchmark
396         SELECT CASE ( cp_cfg )
397         CASE ( 'gyre' )   ;   CALL ctl_warn( ' The Benchmark is activated ' )
398         CASE DEFAULT      ;   CALL ctl_stop( ' The Benchmark is based on the GYRE configuration:',   &
399            &                                 ' cp_cfg="gyre" in namelsit &namcfg or set nbench = 0' )
400         END SELECT
401      ENDIF
402      !
403      IF( lk_c1d .AND. .NOT.lk_iomput )   CALL ctl_stop( 'nemo_ctl: The 1D configuration must be used ',   &
404         &                                               'with the IOM Input/Output manager. '        ,   &
405         &                                               'Compile with key_iomput enabled' )
406      !
407      IF( 1_wp /= SIGN(1._wp,-0._wp)  )   CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows ',  &
408         &                                               'f2003 standard. '                              ,  &
409         &                                               'Compile with key_nosignedzero enabled' )
410      !
411   END SUBROUTINE nemo_ctl
412
413
414   SUBROUTINE nemo_closefile
415      !!----------------------------------------------------------------------
416      !!                     ***  ROUTINE nemo_closefile  ***
417      !!
418      !! ** Purpose :   Close the files
419      !!----------------------------------------------------------------------
420      !
421      IF ( lk_mpp ) CALL mppsync
422      !
423      CALL iom_close                                 ! close all input/output files managed by iom_*
424      !
425      IF( numstp     /= -1 )   CLOSE( numstp     )   ! time-step file
426      IF( numnam_ref /= -1 )   CLOSE( numnam_ref )   ! oce reference namelist
427      IF( numnam_cfg /= -1 )   CLOSE( numnam_cfg )   ! oce configuration namelist
428      IF( numout     /=  6 )   CLOSE( numout     )   ! standard model output file
429      numout = 6                                     ! redefine numout in case it is used after this point...
430      !
431   END SUBROUTINE nemo_closefile
432
433
434   SUBROUTINE nemo_alloc
435      !!----------------------------------------------------------------------
436      !!                     ***  ROUTINE nemo_alloc  ***
437      !!
438      !! ** Purpose :   Allocate all the dynamic arrays of the OPA modules
439      !!
440      !! ** Method  :
441      !!----------------------------------------------------------------------
442      USE diawri,       ONLY: dia_wri_alloc
443      USE dom_oce,      ONLY: dom_oce_alloc
444      USE zdf_oce,      ONLY: zdf_oce_alloc
445      USE ldftra_oce,   ONLY: ldftra_oce_alloc
446      USE trc_oce,      ONLY: trc_oce_alloc
447      !
448      INTEGER :: ierr
449      !!----------------------------------------------------------------------
450      !
451      ierr =        oce_alloc       ()          ! ocean
452      ierr = ierr + dia_wri_alloc   ()
453      ierr = ierr + dom_oce_alloc   ()          ! ocean domain
454      ierr = ierr + ldftra_oce_alloc()          ! ocean lateral  physics : tracers
455      ierr = ierr + zdf_oce_alloc   ()          ! ocean vertical physics
456      !
457      ierr = ierr + trc_oce_alloc   ()          ! shared TRC / TRA arrays
458      !
459      IF( lk_mpp    )   CALL mpp_sum( ierr )
460      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'nemo_alloc: unable to allocate standard ocean arrays' )
461      !
462   END SUBROUTINE nemo_alloc
463
464
465   SUBROUTINE nemo_partition( num_pes )
466      !!----------------------------------------------------------------------
467      !!                 ***  ROUTINE nemo_partition  ***
468      !!
469      !! ** Purpose :   
470      !!
471      !! ** Method  :
472      !!----------------------------------------------------------------------
473      INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
474      !
475      INTEGER, PARAMETER :: nfactmax = 20
476      INTEGER :: nfact ! The no. of factors returned
477      INTEGER :: ierr  ! Error flag
478      INTEGER :: ji
479      INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
480      INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
481      !!----------------------------------------------------------------------
482
483      ierr = 0
484
485      CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
486
487      IF( nfact <= 1 ) THEN
488         WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
489         WRITE (numout, *) '       : using grid of ',num_pes,' x 1'
490         jpnj = 1
491         jpni = num_pes
492      ELSE
493         ! Search through factors for the pair that are closest in value
494         mindiff = 1000000
495         imin    = 1
496         DO ji = 1, nfact-1, 2
497            idiff = ABS( ifact(ji) - ifact(ji+1) )
498            IF( idiff < mindiff ) THEN
499               mindiff = idiff
500               imin = ji
501            ENDIF
502         END DO
503         jpnj = ifact(imin)
504         jpni = ifact(imin + 1)
505      ENDIF
506      !
507      jpnij = jpni*jpnj
508      !
509   END SUBROUTINE nemo_partition
510
511
512   SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
513      !!----------------------------------------------------------------------
514      !!                     ***  ROUTINE factorise  ***
515      !!
516      !! ** Purpose :   return the prime factors of n.
517      !!                knfax factors are returned in array kfax which is of
518      !!                maximum dimension kmaxfax.
519      !! ** Method  :
520      !!----------------------------------------------------------------------
521      INTEGER                    , INTENT(in   ) ::   kn, kmaxfax
522      INTEGER                    , INTENT(  out) ::   kerr, knfax
523      INTEGER, DIMENSION(kmaxfax), INTENT(  out) ::   kfax
524      !
525      INTEGER :: ifac, jl, inu
526      INTEGER, PARAMETER :: ntest = 14
527      INTEGER :: ilfax(ntest)
528      !
529      ! lfax contains the set of allowed factors.
530      data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256,  &
531         &                            128,   64,   32,   16,    8,   4,   2  /
532      !!----------------------------------------------------------------------
533
534      ! Clear the error flag and initialise output vars
535      kerr = 0
536      kfax = 1
537      knfax = 0
538
539      ! Find the factors of n.
540      IF( kn == 1 )   GOTO 20
541
542      ! nu holds the unfactorised part of the number.
543      ! knfax holds the number of factors found.
544      ! l points to the allowed factor list.
545      ! ifac holds the current factor.
546
547      inu   = kn
548      knfax = 0
549
550      DO jl = ntest, 1, -1
551         !
552         ifac = ilfax(jl)
553         IF( ifac > inu )   CYCLE
554
555         ! Test whether the factor will divide.
556
557         IF( MOD(inu,ifac) == 0 ) THEN
558            !
559            knfax = knfax + 1            ! Add the factor to the list
560            IF( knfax > kmaxfax ) THEN
561               kerr = 6
562               write (*,*) 'FACTOR: insufficient space in factor array ', knfax
563               return
564            ENDIF
565            kfax(knfax) = ifac
566            ! Store the other factor that goes with this one
567            knfax = knfax + 1
568            kfax(knfax) = inu / ifac
569            !WRITE (*,*) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
570         ENDIF
571         !
572      END DO
573
574   20 CONTINUE      ! Label 20 is the exit point from the factor search loop.
575      !
576   END SUBROUTINE factorise
577
578#if defined key_mpp_mpi
579   SUBROUTINE nemo_northcomms
580      !!======================================================================
581      !!                     ***  ROUTINE  nemo_northcomms  ***
582      !! nemo_northcomms    :  Setup for north fold exchanges with explicit
583      !!                       point-to-point messaging
584      !!=====================================================================
585      !!----------------------------------------------------------------------
586      !!
587      !! ** Purpose :   Initialization of the northern neighbours lists.
588      !!----------------------------------------------------------------------
589      !!    1.0  ! 2011-10  (A. C. Coward, NOCS & J. Donners, PRACE)
590      !!    2.0  ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC)
591      !!----------------------------------------------------------------------
592
593      INTEGER  ::   sxM, dxM, sxT, dxT, jn
594      INTEGER  ::   njmppmax
595
596      njmppmax = MAXVAL( njmppt )
597
598      !initializes the north-fold communication variables
599      isendto(:) = 0
600      nsndto = 0
601
602      !if I am a process in the north
603      IF ( njmpp == njmppmax ) THEN
604          !sxM is the first point (in the global domain) needed to compute the
605          !north-fold for the current process
606          sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1
607          !dxM is the last point (in the global domain) needed to compute the
608          !north-fold for the current process
609          dxM = jpiglo - nimppt(narea) + 2
610
611          !loop over the other north-fold processes to find the processes
612          !managing the points belonging to the sxT-dxT range
613          DO jn = jpnij - jpni +1, jpnij
614             IF ( njmppt(jn) == njmppmax ) THEN
615                !sxT is the first point (in the global domain) of the jn
616                !process
617                sxT = nimppt(jn)
618                !dxT is the last point (in the global domain) of the jn
619                !process
620                dxT = nimppt(jn) + nlcit(jn) - 1
621                IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN
622                   nsndto = nsndto + 1
623                   isendto(nsndto) = jn
624                ELSEIF ((sxM .le. sxT) .AND. (dxM .gt. dxT)) THEN
625                   nsndto = nsndto + 1
626                   isendto(nsndto) = jn
627                ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN
628                   nsndto = nsndto + 1
629                   isendto(nsndto) = jn
630                END IF
631             END IF
632          END DO
633      ENDIF
634      l_north_nogather = .TRUE.
635
636   END SUBROUTINE nemo_northcomms
637#else
638   SUBROUTINE nemo_northcomms      ! Dummy routine
639      WRITE(*,*) 'nemo_northcomms: You should not have seen this print! error?'
640   END SUBROUTINE nemo_northcomms
641#endif
642   !!======================================================================
643END MODULE nemogcm
Note: See TracBrowser for help on using the repository browser.