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/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/SAO_SRC – NEMO

source: branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/SAO_SRC/nemogcm.F90 @ 8758

Last change on this file since 8758 was 8758, checked in by acc, 6 years ago

Branch 2017/dev_r8126_ROBUST08_no_ghost. Changes to eliminate ghost rows and columns. Currently the halo width is still fixed as 1 but a single variable (nn_hls) has been introduced for the halo-size in preparation for allowing this to vary. nn_hls replaces jpreci and jprecj. These changes have passed full SETTE tests but iceberg exchanges across the north-fold remain untested (SETTE tests only release bergs in the SO) and will require further attention. Note layout.dat now reports the jpi and jpj values for the reporting processor only.

  • Property svn:keywords set to Id
File size: 28.4 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 :  3.6  ! 2015-12  (A. Ryan) Original code   (from OPA_SRC/)
7   !!            4.0  ! 2016-11  (G. Madec, S. Flavoni)  domain configuration / user defined interface
8   !!----------------------------------------------------------------------
9
10   !!----------------------------------------------------------------------
11   !!   nemo_gcm      : solve ocean dynamics, tracer, biogeochemistry and/or sea-ice
12   !!   nemo_init     : initialization of the NEMO system
13   !!   nemo_ctl      : initialisation of the contol print
14   !!   nemo_closefile: close remaining open files
15   !!   nemo_alloc    : dynamical allocation
16   !!   nemo_partition: calculate MPP domain decomposition
17   !!   factorise     : calculate the factors of the no. of MPI processes
18   !!----------------------------------------------------------------------
19   USE step_oce       ! module used in the ocean time stepping module (step.F90)
20   USE domain         ! domain initialization   (dom_init & dom_cfg routines)
21   USE istate         ! initial state setting          (istate_init routine)
22   USE phycst         ! physical constant                  (par_cst routine)
23   USE step           ! NEMO time-stepping                 (stp     routine)
24   USE cpl_oasis3     ! OASIS3 coupling
25   USE diaobs         ! Observation diagnostics       (dia_obs_init routine)
26#if defined key_nemocice_decomp
27   USE ice_domain_size, only: nx_global, ny_global
28#endif
29   !           ! Stand Alone Observation operator modules
30   USE sao_data
31   USE sao_intp
32   !
33   USE lib_mpp        ! distributed memory computing
34   USE mppini         ! shared/distributed memory setting (mpp_init routine)
35   USE lbcnfd  , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges
36   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
37#if defined key_iomput
38   USE xios           ! xIOserver
39#endif
40
41   IMPLICIT NONE
42   PRIVATE
43
44   PUBLIC   nemo_gcm    ! called by model.F90
45   PUBLIC   nemo_init   ! needed by AGRIF
46   PUBLIC   nemo_alloc  ! needed by TAM
47
48   CHARACTER(lc) ::   cform_aaa="( /, 'AAAAAAAA', / ) "     ! flag for output listing
49
50   !!----------------------------------------------------------------------
51   !! NEMO/OPA 4.0 , NEMO Consortium (2016)
52   !! $Id$
53   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
54   !!----------------------------------------------------------------------
55CONTAINS
56
57   SUBROUTINE nemo_gcm
58         !!----------------------------------------------------------------------
59         !!                    ***  SUBROUTINE offline_obs_oper ***
60         !!
61         !! ** Purpose : To use NEMO components to interpolate model fields
62         !!              to observation space.
63         !!
64         !! ** Method : 1. Initialise NEMO
65         !!             2. Initialise offline obs_oper
66         !!             3. Cycle through match ups
67         !!             4. Write results to file
68         !!----------------------------------------------------------------------
69         !
70         CALL nemo_init       ! Initialise NEMO
71         !
72         CALL sao_data_init   ! Initialise Stand Alone Observation operator data
73         !
74         CALL dia_obs_init    ! Initialise obs_operator
75         !
76         CALL sao_interp      ! Interpolate to observation space
77         !
78         CALL dia_obs_wri     ! Pipe to output files
79         !
80         CALL dia_obs_dealloc ! Reset the obs_oper between
81         !
82         IF(lk_mpp)   CALL mppstop  ! Safely stop MPI (end mpp communications)
83         !
84   END SUBROUTINE nemo_gcm
85
86
87   SUBROUTINE nemo_init
88      !!----------------------------------------------------------------------
89      !!                     ***  ROUTINE nemo_init  ***
90      !!
91      !! ** Purpose :   initialization of the NEMO GCM
92      !!----------------------------------------------------------------------
93      INTEGER ::   ji                 ! dummy loop indices
94      INTEGER ::   ios, ilocal_comm   ! local integer
95      INTEGER  ::   iiarea, ijarea     ! local integers
96      INTEGER  ::   iirest, ijrest     ! local integers
97      CHARACTER(len=120), DIMENSION(30) ::   cltxt, cltxt2, clnam
98      !
99      NAMELIST/namctl/ ln_ctl   , nn_print, nn_ictls, nn_ictle,   &
100         &             nn_isplt , nn_jsplt, nn_jctls, nn_jctle,   &
101         &             nn_timing, nn_diacfl
102      NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_write_cfg, cn_domcfg_out, ln_use_jattr
103      !!----------------------------------------------------------------------
104      !
105      cltxt  = ''
106      cltxt2 = ''
107      clnam  = '' 
108      cxios_context = 'nemo'
109      !
110      !                             ! Open reference namelist and configuration namelist files
111      CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
112      CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
113      !
114      REWIND( numnam_ref )              ! Namelist namctl in reference namelist : Control prints
115      READ  ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 )
116901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. )
117      !
118      REWIND( numnam_cfg )              ! Namelist namctl in confguration namelist
119      READ  ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 )
120902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. )
121      !
122      REWIND( numnam_ref )              ! Namelist namcfg in reference namelist : Control prints
123      READ  ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 )
124903   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. )
125
126      REWIND( numnam_cfg )              ! Namelist namcfg in confguration namelist : Control prints & Benchmark
127      READ  ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 )
128904   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. )   
129
130      !                             !--------------------------!
131      !                             !  Set global domain size  !   (control print return in cltxt2)
132      !                             !--------------------------!
133      IF( ln_read_cfg ) THEN              ! Read sizes in domain configuration file
134         CALL domain_cfg ( cltxt2,        cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
135         !
136      ELSE                                ! user-defined namelist
137         CALL usr_def_nam( cltxt2, clnam, cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio )
138      ENDIF
139      !
140      jpk = jpkglo
141      !
142#if defined key_agrif
143      IF( .NOT. Agrif_Root() ) THEN       ! AGRIF children: specific setting (cf. agrif_user.F90)
144         jpiglo  = nbcellsx + 2 + 2*nbghostcells
145         jpjglo  = nbcellsy + 2 + 2*nbghostcells
146         jpi     = ( jpiglo-2*jpreci + (jpni-1+0) ) / jpni + 2*jpreci
147         jpj     = ( jpjglo-2*jprecj + (jpnj-1+0) ) / jpnj + 2*jprecj
148         nperio  = 0
149         jperio  = 0
150         ln_use_jattr = .false.
151      ENDIF
152#endif
153      !
154      !                             !--------------------------------------------!
155      !                             !  set communicator & select the local node  !
156      !                             !  NB: mynode also opens output.namelist.dyn !
157      !                             !      on unit number numond on first proc   !
158      !                             !--------------------------------------------!
159#if defined key_iomput
160      IF( Agrif_Root() ) THEN
161         IF( lk_oasis ) THEN
162            CALL cpl_init( "oceanx", ilocal_comm )                     ! nemo local communicator given by oasis
163            CALL xios_initialize( "not used",local_comm=ilocal_comm )    ! send nemo communicator to xios
164         ELSE
165            CALL  xios_initialize( "for_xios_mpi_id",return_comm=ilocal_comm )    ! nemo local communicator given by xios
166         ENDIF
167      ENDIF
168      ! Nodes selection (control print return in cltxt)
169      narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )
170#else
171      IF( lk_oasis ) THEN
172         IF( Agrif_Root() ) THEN
173            CALL cpl_init( "oceanx", ilocal_comm )                      ! nemo local communicator given by oasis
174         ENDIF
175         ! Nodes selection (control print return in cltxt)
176         narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm )
177      ELSE
178         ilocal_comm = 0
179         ! Nodes selection (control print return in cltxt)
180         narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop )
181      ENDIF
182#endif
183
184      narea = narea + 1                                     ! mynode return the rank of proc (0 --> jpnij -1 )
185
186      lwm = (narea == 1)                                    ! control of output namelists
187      lwp = (narea == 1) .OR. ln_ctl                        ! control of all listing output print
188
189      IF(lwm) THEN
190         ! write merged namelists from earlier to output namelist now that the
191         ! file has been opened in call to mynode. nammpp has already been
192         ! written in mynode (if lk_mpp_mpi)
193         WRITE( numond, namctl )
194         WRITE( numond, namcfg )
195         IF( .NOT.ln_read_cfg ) THEN
196            DO ji = 1, SIZE(clnam)
197               IF( TRIM(clnam(ji)) /= '' )   WRITE(numond, * ) clnam(ji)     ! namusr_def print
198            END DO
199         ENDIF
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         IF( Agrif_Root() )   CALL nemo_partition( mppsize )
207#else
208         jpni  = 1
209         jpnj  = 1
210         jpnij = jpni*jpnj
211#endif
212      ENDIF
213      !
214#if defined key_agrif
215      IF( .NOT. Agrif_Root() ) THEN       ! AGRIF children: specific setting (cf. agrif_user.F90)
216         jpiglo  = nbcellsx + 2 + 2*nbghostcells
217         jpjglo  = nbcellsy + 2 + 2*nbghostcells
218         jpi     = ( jpiglo-2*nn_hls + (jpni-1+0) ) / jpni + 2*nn_hls
219         jpj     = ( jpjglo-2*nn_hls + (jpnj-1+0) ) / jpnj + 2*nn_hls
220         jpimax  = jpi
221         jpjmax  = jpj
222         nperio  = 0
223         jperio  = 0
224         ln_use_jattr = .false.
225      ENDIF
226#endif
227
228      IF( Agrif_Root() ) THEN       ! AGRIF mother: specific setting from jpni and jpnj
229         iiarea = 1 + MOD( narea - 1 , jpni )
230         ijarea = 1 + ( narea - 1 ) / jpni
231         iirest = 1 + MOD( jpiglo - 2*nn_hls - 1 , jpni )
232         ijrest = 1 + MOD( jpjglo - 2*nn_hls - 1 , jpnj )
233#if defined key_nemocice_decomp
234         jpi = ( nx_global+2-2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls    ! first  dim.
235         jpj = ( ny_global+2-2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls    ! second dim.
236         jpimax  = jpi
237         jpjmax  = jpj
238         IF( iiarea == jpni ) jpi = jpiglo - (jpni - 1) * (jpi - 2*nn_hls)
239         IF( ijarea == jpnj ) jpj = jpjglo - (jpnj - 1) * (jpj - 2*nn_hls)
240#else
241         jpi = ( jpiglo     -2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls    ! first  dim.
242         jpj = ( jpjglo     -2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls    ! second dim.
243         jpimax  = jpi
244         jpjmax  = jpj
245         IF( iiarea > iirest ) jpi = jpi - 1
246         IF( ijarea > ijrest ) jpj = jpj - 1
247#endif
248      ENDIF
249
250      jpk = jpkglo                                             ! third dim
251
252#if defined key_agrif
253      ! simple trick to use same vertical grid as parent but different number of levels:
254      ! Save maximum number of levels in jpkglo, then define all vertical grids with this number.
255      ! Suppress once vertical online interpolation is ok
256      IF(.NOT.Agrif_Root())   jpkglo = Agrif_Parent( jpkglo )
257#endif
258      jpim1 = jpi-1                                            ! inner domain indices
259      jpjm1 = jpj-1                                            !   "           "
260      jpkm1 = MAX( 1, jpk-1 )                                  !   "           "
261      jpij  = jpi*jpj                                          !  jpi x j
262
263      IF(lwp) THEN                            ! open listing units
264         !
265         CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea )
266         !
267         WRITE(numout,*)
268         WRITE(numout,*) '   CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC'
269         WRITE(numout,*) '                       NEMO team'
270         WRITE(numout,*) '            Stand Alone Observation operator'
271         WRITE(numout,*) '                NEMO version 3.7  (2015) '
272         WRITE(numout,*)
273         WRITE(numout,*)
274         DO ji = 1, SIZE(cltxt)
275            IF( TRIM(cltxt (ji)) /= '' )   WRITE(numout,*) cltxt(ji)    ! control print of mynode
276         END DO
277         WRITE(numout,*)
278         WRITE(numout,*)
279         DO ji = 1, SIZE(cltxt2)
280            IF( TRIM(cltxt2(ji)) /= '' )   WRITE(numout,*) cltxt2(ji)   ! control print of domain size
281         END DO
282         !
283         WRITE(numout,cform_aaa)                                        ! Flag AAAAAAA
284         !
285      ENDIF
286
287      ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays
288      CALL nemo_alloc()
289
290      !                             !-------------------------------!
291      !                             !  NEMO general initialization  !
292      !                             !-------------------------------!
293
294      CALL nemo_ctl                          ! Control prints & Benchmark
295
296      !                                      ! Domain decomposition
297      CALL mpp_init
298      !
299      IF( nn_timing == 1 )  CALL timing_init
300      !
301      !                                      ! General initialization
302                            CALL     phy_cst    ! Physical constants
303                            CALL     eos_init   ! Equation of state
304                            CALL     dom_init   ! Domain
305
306      IF( ln_nnogather )    CALL nemo_northcomms   ! Initialise the northfold neighbour lists (must be done after the masks are defined)
307
308      IF( ln_ctl        )   CALL prt_ctl_init   ! Print control
309
310                            CALL  istate_init   ! ocean initial state (Dynamics and tracers)
311   END SUBROUTINE nemo_init
312
313
314   SUBROUTINE nemo_ctl
315      !!----------------------------------------------------------------------
316      !!                     ***  ROUTINE nemo_ctl  ***
317      !!
318      !! ** Purpose :   control print setting
319      !!
320      !! ** Method  : - print namctl information and check some consistencies
321      !!----------------------------------------------------------------------
322      !
323      IF(lwp) THEN                  ! control print
324         WRITE(numout,*)
325         WRITE(numout,*) 'nemo_ctl: Control prints'
326         WRITE(numout,*) '~~~~~~~ '
327         WRITE(numout,*) '   Namelist namctl'
328         WRITE(numout,*) '      run control (for debugging)     ln_ctl     = ', ln_ctl
329         WRITE(numout,*) '      level of print                  nn_print   = ', nn_print
330         WRITE(numout,*) '      Start i indice for SUM control  nn_ictls   = ', nn_ictls
331         WRITE(numout,*) '      End i indice for SUM control    nn_ictle   = ', nn_ictle
332         WRITE(numout,*) '      Start j indice for SUM control  nn_jctls   = ', nn_jctls
333         WRITE(numout,*) '      End j indice for SUM control    nn_jctle   = ', nn_jctle
334         WRITE(numout,*) '      number of proc. following i     nn_isplt   = ', nn_isplt
335         WRITE(numout,*) '      number of proc. following j     nn_jsplt   = ', nn_jsplt
336         WRITE(numout,*) '      timing activated    (0/1)       nn_timing  = ', nn_timing
337      ENDIF
338      !
339      nprint    = nn_print          ! convert DOCTOR namelist names into OLD names
340      nictls    = nn_ictls
341      nictle    = nn_ictle
342      njctls    = nn_jctls
343      njctle    = nn_jctle
344      isplt     = nn_isplt
345      jsplt     = nn_jsplt
346
347      IF(lwp) THEN                  ! control print
348         WRITE(numout,*)
349         WRITE(numout,*) 'namcfg  : configuration initialization through namelist read'
350         WRITE(numout,*) '~~~~~~~ '
351         WRITE(numout,*) '   Namelist namcfg'
352         WRITE(numout,*) '      read domain configuration file                ln_read_cfg      = ', ln_read_cfg
353         WRITE(numout,*) '         filename to be read                           cn_domcfg     = ', TRIM(cn_domcfg)
354         WRITE(numout,*) '      write configuration definition file           ln_write_cfg     = ', ln_write_cfg
355         WRITE(numout,*) '         filename to be written                        cn_domcfg_out = ', TRIM(cn_domcfg_out)
356         WRITE(numout,*) '      use file attribute if exists as i/p j-start   ln_use_jattr     = ', ln_use_jattr
357      ENDIF
358      !                             ! Parameter control
359      !
360      IF( ln_ctl ) THEN                 ! sub-domain area indices for the control prints
361         IF( lk_mpp .AND. jpnij > 1 ) THEN
362            isplt = jpni   ;   jsplt = jpnj   ;   ijsplt = jpni*jpnj   ! the domain is forced to the real split domain
363         ELSE
364            IF( isplt == 1 .AND. jsplt == 1  ) THEN
365               CALL ctl_warn( ' - isplt & jsplt are equal to 1',   &
366                  &           ' - the print control will be done over the whole domain' )
367            ENDIF
368            ijsplt = isplt * jsplt            ! total number of processors ijsplt
369         ENDIF
370         IF(lwp) WRITE(numout,*)'          - The total number of processors over which the'
371         IF(lwp) WRITE(numout,*)'            print control will be done is ijsplt : ', ijsplt
372         !
373         !                              ! indices used for the SUM control
374         IF( nictls+nictle+njctls+njctle == 0 )   THEN    ! print control done over the default area
375            lsp_area = .FALSE.
376         ELSE                                             ! print control done over a specific  area
377            lsp_area = .TRUE.
378            IF( nictls < 1 .OR. nictls > jpiglo )   THEN
379               CALL ctl_warn( '          - nictls must be 1<=nictls>=jpiglo, it is forced to 1' )
380               nictls = 1
381            ENDIF
382            IF( nictle < 1 .OR. nictle > jpiglo )   THEN
383               CALL ctl_warn( '          - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' )
384               nictle = jpiglo
385            ENDIF
386            IF( njctls < 1 .OR. njctls > jpjglo )   THEN
387               CALL ctl_warn( '          - njctls must be 1<=njctls>=jpjglo, it is forced to 1' )
388               njctls = 1
389            ENDIF
390            IF( njctle < 1 .OR. njctle > jpjglo )   THEN
391               CALL ctl_warn( '          - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' )
392               njctle = jpjglo
393            ENDIF
394         ENDIF
395      ENDIF
396      !
397      IF( 1_wp /= SIGN(1._wp,-0._wp)  )   CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows ',  &
398         &                                               'f2003 standard. '                              ,  &
399         &                                               'Compile with key_nosignedzero enabled' )
400      !
401   END SUBROUTINE nemo_ctl
402
403
404   SUBROUTINE nemo_closefile
405      !!----------------------------------------------------------------------
406      !!                     ***  ROUTINE nemo_closefile  ***
407      !!
408      !! ** Purpose :   Close the files
409      !!----------------------------------------------------------------------
410      !
411      IF( lk_mpp )   CALL mppsync
412      !
413      CALL iom_close                                 ! close all input/output files managed by iom_*
414      !
415      IF( numstp          /= -1 )   CLOSE( numstp          )   ! time-step file
416      IF( numrun          /= -1 )   CLOSE( numrun          )   ! run statistics file
417      IF( numnam_ref      /= -1 )   CLOSE( numnam_ref      )   ! oce reference namelist
418      IF( numnam_cfg      /= -1 )   CLOSE( numnam_cfg      )   ! oce configuration namelist
419      IF( lwm.AND.numond  /= -1 )   CLOSE( numond          )   ! oce output namelist
420      IF( numnam_ice_ref  /= -1 )   CLOSE( numnam_ice_ref  )   ! ice reference namelist
421      IF( numnam_ice_cfg  /= -1 )   CLOSE( numnam_ice_cfg  )   ! ice configuration namelist
422      IF( lwm.AND.numoni  /= -1 )   CLOSE( numoni          )   ! ice output namelist
423      IF( numevo_ice      /= -1 )   CLOSE( numevo_ice      )   ! ice variables (temp. evolution)
424      IF( numout          /=  6 )   CLOSE( numout          )   ! standard model output file
425      IF( numdct_vol      /= -1 )   CLOSE( numdct_vol      )   ! volume transports
426      IF( numdct_heat     /= -1 )   CLOSE( numdct_heat     )   ! heat transports
427      IF( numdct_salt     /= -1 )   CLOSE( numdct_salt     )   ! salt transports
428      !
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      !
445      INTEGER :: ierr
446      !!----------------------------------------------------------------------
447      !
448      ierr =        oce_alloc       ()          ! ocean
449      ierr = ierr + dia_wri_alloc   ()
450      ierr = ierr + dom_oce_alloc   ()          ! ocean domain
451      !
452      IF( lk_mpp    )   CALL mpp_sum( ierr )
453      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'nemo_alloc : unable to allocate standard ocean arrays' )
454      !
455   END SUBROUTINE nemo_alloc
456
457
458   SUBROUTINE nemo_partition( num_pes )
459      !!----------------------------------------------------------------------
460      !!                 ***  ROUTINE nemo_partition  ***
461      !!
462      !! ** Purpose :
463      !!
464      !! ** Method  :
465      !!----------------------------------------------------------------------
466      INTEGER, INTENT(in) ::   num_pes   ! The number of MPI processes we have
467      !
468      INTEGER, PARAMETER :: nfactmax = 20
469      INTEGER :: nfact ! The no. of factors returned
470      INTEGER :: ierr  ! Error flag
471      INTEGER :: ji
472      INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
473      INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
474      !!----------------------------------------------------------------------
475      !
476      ierr = 0
477      !
478      CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
479      !
480      IF( nfact <= 1 ) THEN
481         WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
482         WRITE (numout, *) '       : using grid of ',num_pes,' x 1'
483         jpnj = 1
484         jpni = num_pes
485      ELSE
486         ! Search through factors for the pair that are closest in value
487         mindiff = 1000000
488         imin    = 1
489         DO ji = 1, nfact-1, 2
490            idiff = ABS( ifact(ji) - ifact(ji+1) )
491            IF( idiff < mindiff ) THEN
492               mindiff = idiff
493               imin = ji
494            ENDIF
495         END DO
496         jpnj = ifact(imin)
497         jpni = ifact(imin + 1)
498      ENDIF
499      !
500      jpnij = jpni*jpnj
501      !
502   END SUBROUTINE nemo_partition
503
504
505   SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
506      !!----------------------------------------------------------------------
507      !!                     ***  ROUTINE factorise  ***
508      !!
509      !! ** Purpose :   return the prime factors of n.
510      !!                knfax factors are returned in array kfax which is of
511      !!                maximum dimension kmaxfax.
512      !! ** Method  :
513      !!----------------------------------------------------------------------
514      INTEGER                    , INTENT(in   ) ::   kn, kmaxfax
515      INTEGER                    , INTENT(  out) ::   kerr, knfax
516      INTEGER, DIMENSION(kmaxfax), INTENT(  out) ::   kfax
517      !
518      INTEGER :: ifac, jl, inu
519      INTEGER, PARAMETER :: ntest = 14
520      INTEGER, DIMENSION(ntest) ::   ilfax
521      !!----------------------------------------------------------------------
522      !
523      ! lfax contains the set of allowed factors.
524      ilfax(:) = (/(2**jl,jl=ntest,1,-1)/)
525      !
526      ! Clear the error flag and initialise output vars
527      kerr  = 0
528      kfax  = 1
529      knfax = 0
530      !
531      ! Find the factors of n.
532      IF( kn == 1 )   GOTO 20
533
534      ! nu holds the unfactorised part of the number.
535      ! knfax holds the number of factors found.
536      ! l points to the allowed factor list.
537      ! ifac holds the current factor.
538      !
539      inu   = kn
540      knfax = 0
541      !
542      DO jl = ntest, 1, -1
543         !
544         ifac = ilfax(jl)
545         IF( ifac > inu )   CYCLE
546
547         ! Test whether the factor will divide.
548
549         IF( MOD(inu,ifac) == 0 ) THEN
550            !
551            knfax = knfax + 1            ! Add the factor to the list
552            IF( knfax > kmaxfax ) THEN
553               kerr = 6
554               write (*,*) 'FACTOR: insufficient space in factor array ', knfax
555               return
556            ENDIF
557            kfax(knfax) = ifac
558            ! Store the other factor that goes with this one
559            knfax = knfax + 1
560            kfax(knfax) = inu / ifac
561            !WRITE (*,*) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
562         ENDIF
563         !
564      END DO
565      !
566   20 CONTINUE      ! Label 20 is the exit point from the factor search loop.
567      !
568   END SUBROUTINE factorise
569
570#if defined key_mpp_mpi
571
572   SUBROUTINE nemo_northcomms
573      !!----------------------------------------------------------------------
574      !!                     ***  ROUTINE  nemo_northcomms  ***
575      !! ** Purpose :   Setup for north fold exchanges with explicit
576      !!                point-to-point messaging
577      !!
578      !! ** Method :   Initialization of the northern neighbours lists.
579      !!----------------------------------------------------------------------
580      !!    1.0  ! 2011-10  (A. C. Coward, NOCS & J. Donners, PRACE)
581      !!    2.0  ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC)
582      !!----------------------------------------------------------------------
583      INTEGER  ::   sxM, dxM, sxT, dxT, jn
584      INTEGER  ::   njmppmax
585      !!----------------------------------------------------------------------
586      !
587      njmppmax = MAXVAL( njmppt )
588      !
589      !initializes the north-fold communication variables
590      isendto(:) = 0
591      nsndto     = 0
592      !
593      !if I am a process in the north
594      IF ( njmpp == njmppmax ) THEN
595          !sxM is the first point (in the global domain) needed to compute the
596          !north-fold for the current process
597          sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1
598          !dxM is the last point (in the global domain) needed to compute the
599          !north-fold for the current process
600          dxM = jpiglo - nimppt(narea) + 2
601
602          !loop over the other north-fold processes to find the processes
603          !managing the points belonging to the sxT-dxT range
604 
605          DO jn = 1, jpni
606                !sxT is the first point (in the global domain) of the jn
607                !process
608                sxT = nfiimpp(jn, jpnj)
609                !dxT is the last point (in the global domain) of the jn
610                !process
611                dxT = nfiimpp(jn, jpnj) + nfilcit(jn, jpnj) - 1
612                IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN
613                   nsndto = nsndto + 1
614                   isendto(nsndto) = jn
615                ELSEIF ((sxM .le. sxT) .AND. (dxM .ge. dxT)) THEN
616                   nsndto = nsndto + 1
617                   isendto(nsndto) = jn
618                ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN
619                   nsndto = nsndto + 1
620                   isendto(nsndto) = jn
621                ENDIF
622          END DO
623          nfsloop = 1
624          nfeloop = nlci
625          DO jn = 2,jpni-1
626           IF(nfipproc(jn,jpnj) .eq. (narea - 1)) THEN
627              IF (nfipproc(jn - 1 ,jpnj) .eq. -1) THEN
628                 nfsloop = nldi
629              ENDIF
630              IF (nfipproc(jn + 1,jpnj) .eq. -1) THEN
631                 nfeloop = nlei
632              ENDIF
633           ENDIF
634        END DO
635
636      ENDIF
637      l_north_nogather = .TRUE.
638   END SUBROUTINE nemo_northcomms
639
640#else
641   SUBROUTINE nemo_northcomms      ! Dummy routine
642      WRITE(*,*) 'nemo_northcomms: You should not have seen this print! error?'
643   END SUBROUTINE nemo_northcomms
644#endif
645
646   !!======================================================================
647END MODULE nemogcm
648
Note: See TracBrowser for help on using the repository browser.