source: trunk/NEMOGCM/NEMO/SAS_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: 28.9 KB
Line 
1MODULE nemogcm
2   !!======================================================================
3   !!                       ***  MODULE nemogcm   ***
4   !! Ocean system   : NEMO GCM (ocean dynamics, on-line tracers, biochemistry and sea-ice)
5   !!======================================================================
6   !! History :  OPA  ! 1990-10  (C. Levy, G. Madec)  Original code
7   !!            7.0  ! 1991-11  (M. Imbard, C. Levy, G. Madec)
8   !!            7.1  ! 1993-03  (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,
9   !!                             P. Delecluse, C. Perigaud, G. Caniaux, B. Colot, C. Maes) release 7.1
10   !!             -   ! 1992-06  (L.Terray)  coupling implementation
11   !!             -   ! 1993-11  (M.A. Filiberti) IGLOO sea-ice
12   !!            8.0  ! 1996-03  (M. Imbard, C. Levy, G. Madec, O. Marti, M. Guyon, A. Lazar,
13   !!                             P. Delecluse, L.Terray, M.A. Filiberti, J. Vialar, A.M. Treguier, M. Levy) release 8.0
14   !!            8.1  ! 1997-06  (M. Imbard, G. Madec)
15   !!            8.2  ! 1999-11  (M. Imbard, H. Goosse)  LIM sea-ice model
16   !!                 ! 1999-12  (V. Thierry, A-M. Treguier, M. Imbard, M-A. Foujols)  OPEN-MP
17   !!                 ! 2000-07  (J-M Molines, M. Imbard)  Open Boundary Conditions  (CLIPPER)
18   !!   NEMO     1.0  ! 2002-08  (G. Madec)  F90: Free form and modules
19   !!             -   ! 2004-06  (R. Redler, NEC CCRLE, Germany) add OASIS[3/4] coupled interfaces
20   !!             -   ! 2004-08  (C. Talandier) New trends organization
21   !!             -   ! 2005-06  (C. Ethe) Add the 1D configuration possibility
22   !!             -   ! 2005-11  (V. Garnier) Surface pressure gradient organization
23   !!             -   ! 2006-03  (L. Debreu, C. Mazauric)  Agrif implementation
24   !!             -   ! 2006-04  (G. Madec, R. Benshila)  Step reorganization
25   !!             -   ! 2007-07  (J. Chanut, A. Sellar) Unstructured open boundaries (BDY)
26   !!            3.2  ! 2009-08  (S. Masson)  open/write in the listing file in mpp
27   !!            3.3  ! 2010-05  (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface
28   !!             -   ! 2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase
29   !!            3.3.1! 2011-01  (A. R. Porter, STFC Daresbury) dynamical allocation
30   !!            3.4  ! 2011-11  (C. Harris) decomposition changes for running with CICE
31   !!----------------------------------------------------------------------
32
33   !!----------------------------------------------------------------------
34   !!   nemo_gcm       : solve ocean dynamics, tracer, biogeochemistry and/or sea-ice
35   !!   nemo_init      : initialization of the NEMO system
36   !!   nemo_ctl       : initialisation of the contol print
37   !!   nemo_closefile : close remaining open files
38   !!   nemo_alloc     : dynamical allocation
39   !!   nemo_partition : calculate MPP domain decomposition
40   !!   factorise      : calculate the factors of the no. of MPI processes
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 daymod          ! calendar
47   USE mppini          ! shared/distributed memory setting (mpp_init routine)
48   USE domain          ! domain initialization             (dom_init routine)
49   USE phycst          ! physical constant                  (par_cst routine)
50   USE step            ! NEMO time-stepping                 (stp     routine)
51   USE lib_mpp         ! distributed memory computing
52#if defined key_iomput
53   USE xios
54#endif
55   USE sbcssm
56   USE lbcnfd, ONLY: isendto, nsndto ! Setup of north fold exchanges
57
58   IMPLICIT NONE
59   PRIVATE
60
61   PUBLIC   nemo_gcm    ! called by model.F90
62   PUBLIC   nemo_init   ! needed by AGRIF
63
64   CHARACTER(lc) ::   cform_aaa="( /, 'AAAAAAAA', / ) "     ! flag for output listing
65
66   !!----------------------------------------------------------------------
67   !! NEMO/OPA 4.0 , NEMO Consortium (2011)
68   !! $Id: nemogcm.F90 3294 2012-01-28 16:44:18Z rblod $
69   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
70   !!----------------------------------------------------------------------
71CONTAINS
72
73   SUBROUTINE nemo_gcm
74      !!----------------------------------------------------------------------
75      !!                     ***  ROUTINE nemo_gcm  ***
76      !!
77      !! ** Purpose :   NEMO solves the primitive equations on an orthogonal
78      !!              curvilinear mesh on the sphere.
79      !!
80      !! ** Method  : - model general initialization
81      !!              - launch the time-stepping (stp routine)
82      !!              - finalize the run by closing files and communications
83      !!
84      !! References : Madec, Delecluse, Imbard, and Levy, 1997:  internal report, IPSL.
85      !!              Madec, 2008, internal report, IPSL.
86      !!----------------------------------------------------------------------
87      INTEGER ::   istp       ! time step index
88      !!----------------------------------------------------------------------
89      !
90#if defined key_agrif
91      CALL Agrif_Init_Grids()      ! AGRIF: set the meshes
92#endif
93
94      !                            !-----------------------!
95      CALL nemo_init               !==  Initialisations  ==!
96      !                            !-----------------------!
97#if defined key_agrif
98      CALL Agrif_Declare_Var       ! AGRIF: set the meshes
99#endif
100      ! check that all process are still there... If some process have an error,
101      ! they will never enter in step and other processes will wait until the end of the cpu time!
102      IF( lk_mpp )   CALL mpp_max( nstop )
103
104      IF(lwp) WRITE(numout,cform_aaa)   ! Flag AAAAAAA
105
106      !                            !-----------------------!
107      !                            !==   time stepping   ==!
108      !                            !-----------------------!
109      istp = nit000
110       
111      DO WHILE ( istp <= nitend .AND. nstop == 0 )
112#if defined key_agrif
113         CALL Agrif_Step( stp )           ! AGRIF: time stepping
114#else
115         CALL stp( istp )                 ! standard time stepping
116#endif
117         istp = istp + 1
118         IF( lk_mpp )   CALL mpp_max( nstop )
119      END DO
120      !                            !------------------------!
121      !                            !==  finalize the run  ==!
122      !                            !------------------------!
123      IF(lwp) WRITE(numout,cform_aaa)   ! Flag AAAAAAA
124      !
125      IF( nstop /= 0 .AND. lwp ) THEN   ! error print
126         WRITE(numout,cform_err)
127         WRITE(numout,*) nstop, ' error have been found' 
128      ENDIF
129      !
130#if defined key_agrif
131      CALL Agrif_ParentGrid_To_ChildGrid()
132      IF( nn_timing == 1 )   CALL timing_finalize
133      CALL Agrif_ChildGrid_To_ParentGrid()
134#endif
135      IF( nn_timing == 1 )   CALL timing_finalize
136      !
137      CALL nemo_closefile
138#if defined key_iomput
139      CALL xios_finalize                ! end mpp communications with xios
140#else
141      IF( lk_mpp )   CALL mppstop       ! end mpp communications
142#endif
143      !
144   END SUBROUTINE nemo_gcm
145
146
147   SUBROUTINE nemo_init
148      !!----------------------------------------------------------------------
149      !!                     ***  ROUTINE nemo_init  ***
150      !!
151      !! ** Purpose :   initialization of the NEMO GCM
152      !!----------------------------------------------------------------------
153      INTEGER ::   ji            ! dummy loop indices
154      INTEGER ::   ilocal_comm   ! local integer     
155      INTEGER ::   ios
156
157      CHARACTER(len=80), DIMENSION(16) ::   cltxt
158      !!
159      NAMELIST/namctl/ ln_ctl  , nn_print, nn_ictls, nn_ictle,   &
160         &             nn_isplt, nn_jsplt, nn_jctls, nn_jctle,   &
161         &             nn_bench, nn_timing
162      NAMELIST/namcfg/ cp_cfg, cp_cfz, jp_cfg, jpidta, jpjdta, jpkdta, jpiglo, jpjglo, &
163         &             jpizoom, jpjzoom, jperio
164      !!----------------------------------------------------------------------
165      cltxt = ''
166      !
167      !                             ! Open reference namelist and configuration namelist files
168      CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
169      CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
170      !
171      REWIND( numnam_ref )              ! Namelist namctl in reference namelist : Control prints & Benchmark
172      READ  ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 )
173901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. )
174
175      REWIND( numnam_cfg )              ! Namelist namctl in confguration namelist : Control prints & Benchmark
176      READ  ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 )
177902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. )
178
179      !
180      REWIND( numnam_ref )              ! Namelist namcfg in reference namelist : Control prints & Benchmark
181      READ  ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 )
182903   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. )
183
184      REWIND( numnam_cfg )              ! Namelist namcfg in confguration namelist : Control prints & Benchmark
185      READ  ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 )
186904   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. )   
187
188      !                             !--------------------------------------------!
189      !                             !  set communicator & select the local node  !
190      !                             !  NB: mynode also opens output.namelist.dyn !
191      !                             !      on unit number numond on first proc   !
192      !                             !--------------------------------------------!
193#if defined key_iomput
194      IF( Agrif_Root() ) THEN
195         CALL  xios_initialize( "nemo",return_comm=ilocal_comm )
196      ENDIF
197      narea = mynode ( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )  ! Nodes selection
198#else
199      ilocal_comm = 0
200      narea = mynode( cltxt, numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )        ! Nodes selection (control print return in cltxt)
201#endif
202      narea = narea + 1                                     ! mynode return the rank of proc (0 --> jpnij -1 )
203
204      lwm = (narea == 1)                                    ! control of output namelists
205      lwp = (narea == 1) .OR. ln_ctl                        ! control of all listing output print
206
207      IF(lwm) THEN
208         ! write merged namelists from earlier to output namelist now that the
209         ! file has been opened in call to mynode. nammpp has already been
210         ! written in mynode (if lk_mpp_mpi)
211         WRITE( numond, namctl )
212         WRITE( numond, namcfg )
213      ENDIF
214
215      ! If dimensions of processor grid weren't specified in the namelist file
216      ! then we calculate them here now that we have our communicator size
217      IF( (jpni < 1) .OR. (jpnj < 1) )THEN
218#if   defined key_mpp_mpi
219         IF( Agrif_Root() ) CALL nemo_partition(mppsize)
220#else
221         jpni  = 1
222         jpnj  = 1
223         jpnij = jpni*jpnj
224#endif
225      END IF
226
227      ! Calculate domain dimensions given calculated jpni and jpnj
228      ! This used to be done in par_oce.F90 when they were parameters rather
229      ! than variables
230      IF( Agrif_Root() ) THEN
231         jpi = ( jpiglo-2*jpreci + (jpni-1) ) / jpni + 2*jpreci   ! first  dim.
232#if defined key_nemocice_decomp
233         jpj = ( jpjglo+1-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj ! second dim.
234#else
235         jpj = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj   ! second dim.
236#endif
237         jpk = jpkdta                                             ! third dim
238         jpim1 = jpi-1                                            ! inner domain indices
239         jpjm1 = jpj-1                                            !   "           "
240         jpkm1 = jpk-1                                            !   "           "
241         jpij  = jpi*jpj                                          !  jpi x j
242      ENDIF
243
244      IF(lwp) THEN                            ! open listing units
245         !
246         CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
247         !
248         WRITE(numout,*)
249         WRITE(numout,*) '   CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC'
250         WRITE(numout,*) '                       NEMO team'
251         WRITE(numout,*) '            Ocean General Circulation Model'
252         WRITE(numout,*) '                  version 3.4  (2011) '
253         WRITE(numout,*) '             StandAlone Surface version (SAS) '
254         WRITE(numout,*)
255         WRITE(numout,*)
256         DO ji = 1, SIZE(cltxt) 
257            IF( TRIM(cltxt(ji)) /= '' )   WRITE(numout,*) cltxt(ji)      ! control print of mynode
258         END DO
259         WRITE(numout,cform_aaa)                                         ! Flag AAAAAAA
260         !
261      ENDIF
262
263      ! Now we know the dimensions of the grid and numout has been set we can
264      ! allocate arrays
265      CALL nemo_alloc()
266
267      !                             !-------------------------------!
268      !                             !  NEMO general initialization  !
269      !                             !-------------------------------!
270
271      CALL nemo_ctl                          ! Control prints & Benchmark
272
273      !                                      ! Domain decomposition
274      IF( jpni*jpnj == jpnij ) THEN   ;   CALL mpp_init      ! standard cutting out
275      ELSE                            ;   CALL mpp_init2     ! eliminate land processors
276      ENDIF
277      !
278      IF( nn_timing == 1 )  CALL timing_init
279      !
280      !                                     ! General initialization
281                            CALL phy_cst    ! Physical constants
282                            CALL eos_init   ! Equation of state
283                            CALL dom_cfg    ! Domain configuration
284                            CALL dom_init   ! Domain
285
286      IF( ln_nnogather )    CALL nemo_northcomms   ! Initialise the northfold neighbour lists (must be done after the masks are defined)
287
288      IF( ln_ctl        )   CALL prt_ctl_init   ! Print control
289                            CALL flush(numout)
290
291                            CALL day_init   ! model calendar (using both namelist and restart infos)
292
293                            CALL sbc_init   ! Forcings : surface module
294     
295      IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler
296      !
297   END SUBROUTINE nemo_init
298
299
300   SUBROUTINE nemo_ctl
301      !!----------------------------------------------------------------------
302      !!                     ***  ROUTINE nemo_ctl  ***
303      !!
304      !! ** Purpose :   control print setting
305      !!
306      !! ** Method  : - print namctl information and check some consistencies
307      !!----------------------------------------------------------------------
308      !
309      IF(lwp) THEN                  ! control print
310         WRITE(numout,*)
311         WRITE(numout,*) 'nemo_ctl: Control prints & Benchmark'
312         WRITE(numout,*) '~~~~~~~ '
313         WRITE(numout,*) '   Namelist namctl'
314         WRITE(numout,*) '      run control (for debugging)     ln_ctl     = ', ln_ctl
315         WRITE(numout,*) '      level of print                  nn_print   = ', nn_print
316         WRITE(numout,*) '      Start i indice for SUM control  nn_ictls   = ', nn_ictls
317         WRITE(numout,*) '      End i indice for SUM control    nn_ictle   = ', nn_ictle
318         WRITE(numout,*) '      Start j indice for SUM control  nn_jctls   = ', nn_jctls
319         WRITE(numout,*) '      End j indice for SUM control    nn_jctle   = ', nn_jctle
320         WRITE(numout,*) '      number of proc. following i     nn_isplt   = ', nn_isplt
321         WRITE(numout,*) '      number of proc. following j     nn_jsplt   = ', nn_jsplt
322         WRITE(numout,*) '      benchmark parameter (0/1)       nn_bench   = ', nn_bench
323      ENDIF
324      !
325      nprint    = nn_print          ! convert DOCTOR namelist names into OLD names
326      nictls    = nn_ictls
327      nictle    = nn_ictle
328      njctls    = nn_jctls
329      njctle    = nn_jctle
330      isplt     = nn_isplt
331      jsplt     = nn_jsplt
332      nbench    = nn_bench
333
334      IF(lwp) THEN                  ! control print
335         WRITE(numout,*)
336         WRITE(numout,*) 'namcfg  : configuration initialization through namelist read'
337         WRITE(numout,*) '~~~~~~~ '
338         WRITE(numout,*) '   Namelist namcfg'
339         WRITE(numout,*) '      configuration name              cp_cfg      = ', TRIM(cp_cfg)
340         WRITE(numout,*) '      configuration zoom name         cp_cfz      = ', TRIM(cp_cfz)
341         WRITE(numout,*) '      configuration resolution        jp_cfg      = ', jp_cfg
342         WRITE(numout,*) '      1st lateral dimension ( >= jpi ) jpidta     = ', jpidta
343         WRITE(numout,*) '      2nd    "         "    ( >= jpj ) jpjdta     = ', jpjdta
344         WRITE(numout,*) '      3nd    "         "               jpkdta     = ', jpkdta
345         WRITE(numout,*) '      1st dimension of global domain in i jpiglo  = ', jpiglo
346         WRITE(numout,*) '      2nd    -                  -    in j jpjglo  = ', jpjglo
347         WRITE(numout,*) '      left bottom i index of the zoom (in data domain) jpizoom = ', jpizoom
348         WRITE(numout,*) '      left bottom j index of the zoom (in data domain) jpizoom = ', jpjzoom
349         WRITE(numout,*) '      lateral cond. type (between 0 and 6) jperio = ', jperio   
350      ENDIF
351      !                             ! Parameter control
352      !
353      IF( ln_ctl ) THEN                 ! sub-domain area indices for the control prints
354         IF( lk_mpp .AND. jpnij > 1 ) THEN
355            isplt = jpni   ;   jsplt = jpnj   ;   ijsplt = jpni*jpnj   ! the domain is forced to the real split domain
356         ELSE
357            IF( isplt == 1 .AND. jsplt == 1  ) THEN
358               CALL ctl_warn( ' - isplt & jsplt are equal to 1',   &
359                  &           ' - the print control will be done over the whole domain' )
360            ENDIF
361            ijsplt = isplt * jsplt            ! total number of processors ijsplt
362         ENDIF
363         IF(lwp) WRITE(numout,*)'          - The total number of processors over which the'
364         IF(lwp) WRITE(numout,*)'            print control will be done is ijsplt : ', ijsplt
365         !
366         !                              ! indices used for the SUM control
367         IF( nictls+nictle+njctls+njctle == 0 )   THEN    ! print control done over the default area
368            lsp_area = .FALSE.                       
369         ELSE                                             ! print control done over a specific  area
370            lsp_area = .TRUE.
371            IF( nictls < 1 .OR. nictls > jpiglo )   THEN
372               CALL ctl_warn( '          - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
373               nictls = 1
374            ENDIF
375            IF( nictle < 1 .OR. nictle > jpiglo )   THEN
376               CALL ctl_warn( '          - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
377               nictle = jpiglo
378            ENDIF
379            IF( njctls < 1 .OR. njctls > jpjglo )   THEN
380               CALL ctl_warn( '          - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
381               njctls = 1
382            ENDIF
383            IF( njctle < 1 .OR. njctle > jpjglo )   THEN
384               CALL ctl_warn( '          - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
385               njctle = jpjglo
386            ENDIF
387         ENDIF
388      ENDIF
389      !
390      IF( nbench == 1 ) THEN              ! Benchmark
391         SELECT CASE ( cp_cfg )
392         CASE ( 'gyre' )   ;   CALL ctl_warn( ' The Benchmark is activated ' )
393         CASE DEFAULT      ;   CALL ctl_stop( ' The Benchmark is based on the GYRE configuration:',   &
394            &                                 ' cp_cfg="gyre" in namelist &namcfg or set nbench = 0' )
395         END SELECT
396      ENDIF
397      !
398   END SUBROUTINE nemo_ctl
399
400
401   SUBROUTINE nemo_closefile
402      !!----------------------------------------------------------------------
403      !!                     ***  ROUTINE nemo_closefile  ***
404      !!
405      !! ** Purpose :   Close the files
406      !!----------------------------------------------------------------------
407      !
408      IF( lk_mpp )   CALL mppsync
409      !
410      CALL iom_close                                 ! close all input/output files managed by iom_*
411      !
412      IF( numstp          /= -1 )   CLOSE( numstp      )   ! time-step file     
413      IF( numnam_ref      /= -1 )   CLOSE( numnam_ref      )   ! oce reference namelist
414      IF( numnam_cfg      /= -1 )   CLOSE( numnam_cfg      )   ! oce configuration namelist
415      IF( lwm.AND.numond  /= -1 )   CLOSE( numond          )   ! oce output namelist
416      IF( numnam_ice_ref  /= -1 )   CLOSE( numnam_ice_ref  )   ! ice reference namelist
417      IF( numnam_ice_cfg  /= -1 )   CLOSE( numnam_ice_cfg  )   ! ice configuration namelist
418      IF( lwm.AND.numoni  /= -1 )   CLOSE( numoni          )   ! ice output namelist
419      IF( numevo_ice      /= -1 )   CLOSE( numevo_ice  )   ! ice variables (temp. evolution)
420      IF( numout          /=  6 )   CLOSE( numout      )   ! standard model output file
421      !
422      numout = 6                                     ! redefine numout in case it is used after this point...
423      !
424   END SUBROUTINE nemo_closefile
425
426
427   SUBROUTINE nemo_alloc
428      !!----------------------------------------------------------------------
429      !!                     ***  ROUTINE nemo_alloc  ***
430      !!
431      !! ** Purpose :   Allocate all the dynamic arrays of the OPA modules
432      !!
433      !! ** Method  :
434      !!----------------------------------------------------------------------
435      USE diawri    , ONLY: dia_wri_alloc
436      USE dom_oce   , ONLY: dom_oce_alloc
437      USE oce       , ONLY : sshn, sshb, snwice_mass, snwice_mass_b, snwice_fmass 
438      !
439      INTEGER :: ierr,ierr4
440      !!----------------------------------------------------------------------
441      !
442      ierr =        dia_wri_alloc   ()
443      ierr = ierr + dom_oce_alloc   ()          ! ocean domain
444      ALLOCATE( snwice_mass(jpi,jpj)  , snwice_mass_b(jpi,jpj),             &
445         &      snwice_fmass(jpi,jpj), STAT= ierr4 )
446      ierr = ierr + ierr4
447      !
448      IF( lk_mpp    )   CALL mpp_sum( ierr )
449      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'nemo_alloc : unable to allocate standard ocean arrays' )
450      !
451   END SUBROUTINE nemo_alloc
452
453
454   SUBROUTINE nemo_partition( num_pes )
455      !!----------------------------------------------------------------------
456      !!                 ***  ROUTINE nemo_partition  ***
457      !!
458      !! ** Purpose :   
459      !!
460      !! ** Method  :
461      !!----------------------------------------------------------------------
462      INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
463      !
464      INTEGER, PARAMETER :: nfactmax = 20
465      INTEGER :: nfact ! The no. of factors returned
466      INTEGER :: ierr  ! Error flag
467      INTEGER :: ji
468      INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
469      INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
470      !!----------------------------------------------------------------------
471
472      ierr = 0
473
474      CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
475
476      IF( nfact <= 1 ) THEN
477         WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
478         WRITE (numout, *) '       : using grid of ',num_pes,' x 1'
479         jpnj = 1
480         jpni = num_pes
481      ELSE
482         ! Search through factors for the pair that are closest in value
483         mindiff = 1000000
484         imin    = 1
485         DO ji = 1, nfact-1, 2
486            idiff = ABS( ifact(ji) - ifact(ji+1) )
487            IF( idiff < mindiff ) THEN
488               mindiff = idiff
489               imin = ji
490            ENDIF
491         END DO
492         jpnj = ifact(imin)
493         jpni = ifact(imin + 1)
494      ENDIF
495      !
496      jpnij = jpni*jpnj
497      !
498   END SUBROUTINE nemo_partition
499
500
501   SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
502      !!----------------------------------------------------------------------
503      !!                     ***  ROUTINE factorise  ***
504      !!
505      !! ** Purpose :   return the prime factors of n.
506      !!                knfax factors are returned in array kfax which is of
507      !!                maximum dimension kmaxfax.
508      !! ** Method  :
509      !!----------------------------------------------------------------------
510      INTEGER                    , INTENT(in   ) ::   kn, kmaxfax
511      INTEGER                    , INTENT(  out) ::   kerr, knfax
512      INTEGER, DIMENSION(kmaxfax), INTENT(  out) ::   kfax
513      !
514      INTEGER :: ifac, jl, inu
515      INTEGER, PARAMETER :: ntest = 14
516      INTEGER :: ilfax(ntest)
517
518      ! lfax contains the set of allowed factors.
519      data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256,  &
520         &                            128,   64,   32,   16,    8,   4,   2  /
521      !!----------------------------------------------------------------------
522
523      ! Clear the error flag and initialise output vars
524      kerr = 0
525      kfax = 1
526      knfax = 0
527
528      ! Find the factors of n.
529      IF( kn == 1 )   GOTO 20
530
531      ! nu holds the unfactorised part of the number.
532      ! knfax holds the number of factors found.
533      ! l points to the allowed factor list.
534      ! ifac holds the current factor.
535
536      inu   = kn
537      knfax = 0
538
539      DO jl = ntest, 1, -1
540         !
541         ifac = ilfax(jl)
542         IF( ifac > inu )   CYCLE
543
544         ! Test whether the factor will divide.
545
546         IF( MOD(inu,ifac) == 0 ) THEN
547            !
548            knfax = knfax + 1            ! Add the factor to the list
549            IF( knfax > kmaxfax ) THEN
550               kerr = 6
551               write (*,*) 'FACTOR: insufficient space in factor array ', knfax
552               return
553            ENDIF
554            kfax(knfax) = ifac
555            ! Store the other factor that goes with this one
556            knfax = knfax + 1
557            kfax(knfax) = inu / ifac
558            !WRITE (*,*) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
559         ENDIF
560         !
561      END DO
562
563   20 CONTINUE      ! Label 20 is the exit point from the factor search loop.
564      !
565   END SUBROUTINE factorise
566
567#if defined key_mpp_mpi
568   SUBROUTINE nemo_northcomms
569      !!======================================================================
570      !!                     ***  ROUTINE  nemo_northcomms  ***
571      !! nemo_northcomms    :  Setup for north fold exchanges with explicit
572      !!                       point-to-point messaging
573      !!=====================================================================
574      !!----------------------------------------------------------------------
575      !!
576      !! ** Purpose :   Initialization of the northern neighbours lists.
577      !!----------------------------------------------------------------------
578      !!    1.0  ! 2011-10  (A. C. Coward, NOCS & J. Donners, PRACE)
579      !!    2.0  ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC)
580      !!----------------------------------------------------------------------
581
582      INTEGER  ::   sxM, dxM, sxT, dxT, jn
583      INTEGER  ::   njmppmax
584
585      njmppmax = MAXVAL( njmppt )
586   
587      !initializes the north-fold communication variables
588      isendto(:) = 0
589      nsndto = 0
590
591      !if I am a process in the north
592      IF ( njmpp == njmppmax ) THEN
593          !sxM is the first point (in the global domain) needed to compute the
594          !north-fold for the current process
595          sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1
596          !dxM is the last point (in the global domain) needed to compute the
597          !north-fold for the current process
598          dxM = jpiglo - nimppt(narea) + 2
599
600          !loop over the other north-fold processes to find the processes
601          !managing the points belonging to the sxT-dxT range
602          DO jn = jpnij - jpni +1, jpnij
603             IF ( njmppt(jn) == njmppmax ) THEN
604                !sxT is the first point (in the global domain) of the jn
605                !process
606                sxT = nimppt(jn)
607                !dxT is the last point (in the global domain) of the jn
608                !process
609                dxT = nimppt(jn) + nlcit(jn) - 1
610                IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN
611                   nsndto = nsndto + 1
612                   isendto(nsndto) = jn
613                ELSEIF ((sxM .le. sxT) .AND. (dxM .gt. dxT)) THEN
614                   nsndto = nsndto + 1
615                   isendto(nsndto) = jn
616                ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN
617                   nsndto = nsndto + 1
618                   isendto(nsndto) = jn
619                END IF
620             END IF
621          END DO
622      ENDIF
623      l_north_nogather = .TRUE.
624   END SUBROUTINE nemo_northcomms
625
626#else
627   SUBROUTINE nemo_northcomms      ! Dummy routine
628      WRITE(*,*) 'nemo_northcomms: You should not have seen this print! error?'
629   END SUBROUTINE nemo_northcomms
630#endif
631   !!======================================================================
632END MODULE nemogcm
Note: See TracBrowser for help on using the repository browser.