source: branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90 @ 11101

Last change on this file since 11101 was 11101, checked in by frrh, 18 months ago

Merge changes from Met Office GMED ticket 450 to reduce unnecessary
text output from NEMO.
This output, which is typically not switchable, is rarely of interest
in normal (non-debugging) runs and simply redunantley consumes extra
file space.
Further, the presence of this text output has been shown to
significantly degrade performance of models which are run during
Met Office HPC RAID (disk) checks.
The new code introduces switches which are configurable via the
changes made in the associated Met Office MOCI ticket 399.

File size: 18.4 KB
Line 
1MODULE mppini
2   !!==============================================================================
3   !!                       ***  MODULE mppini   ***
4   !! Ocean initialization : distributed memory computing initialization
5   !!==============================================================================
6
7   !!----------------------------------------------------------------------
8   !!   mpp_init       : Lay out the global domain over processors
9   !!   mpp_init2      : Lay out the global domain over processors
10   !!                    with land processor elimination
11   !!   mpp_init_ioispl: IOIPSL initialization in mpp
12   !!----------------------------------------------------------------------
13   !! * Modules used
14   USE dom_oce         ! ocean space and time domain
15   USE in_out_manager  ! I/O Manager
16   USE lib_mpp         ! distribued memory computing library
17   USE ioipsl
18
19   IMPLICIT NONE
20   PRIVATE
21
22   PUBLIC mpp_init       ! called by opa.F90
23   PUBLIC mpp_init2      ! called by opa.F90
24
25   !! * Substitutions
26#  include "domzgr_substitute.h90"
27   !!----------------------------------------------------------------------
28   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
29   !! $Id$
30   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
31   !!----------------------------------------------------------------------
32CONTAINS
33
34#if ! defined key_mpp_mpi
35   !!----------------------------------------------------------------------
36   !!   Default option :                            shared memory computing
37   !!----------------------------------------------------------------------
38
39   SUBROUTINE mpp_init
40      !!----------------------------------------------------------------------
41      !!                  ***  ROUTINE mpp_init  ***
42      !!
43      !! ** Purpose :   Lay out the global domain over processors.
44      !!
45      !! ** Method  :   Shared memory computing, set the local processor
46      !!      variables to the value of the global domain
47      !!
48      !! History :
49      !!   9.0  !  04-01  (G. Madec, J.M. Molines)  F90 : free form, north fold jpni >1
50      !!----------------------------------------------------------------------
51
52      ! No mpp computation
53      nimpp  = 1
54      njmpp  = 1
55      nlci   = jpi
56      nlcj   = jpj
57      nldi   = 1
58      nldj   = 1
59      nlei   = jpi
60      nlej   = jpj
61      nperio = jperio
62      nbondi = 2
63      nbondj = 2
64      nidom  = FLIO_DOM_NONE
65      npolj = jperio
66
67      IF(lwp) THEN
68         WRITE(numout,*)
69         WRITE(numout,*) 'mpp_init(2) : NO massively parallel processing'
70         WRITE(numout,*) '~~~~~~~~~~~: '
71         WRITE(numout,*) '         nperio = ', nperio
72         WRITE(numout,*) '         npolj  = ', npolj
73         WRITE(numout,*) '         nimpp  = ', nimpp
74         WRITE(numout,*) '         njmpp  = ', njmpp
75         IF(lflush) CALL flush(numout)
76      ENDIF
77
78      IF(  jpni /= 1 .OR. jpnj /= 1 .OR. jpnij /= 1 ) &
79          CALL ctl_stop( 'equality  jpni = jpnj = jpnij = 1 is not satisfied',   &
80          &              'the domain is lay out for distributed memory computing! ' )
81
82   END SUBROUTINE mpp_init
83
84
85   SUBROUTINE mpp_init2 
86      CALL mpp_init                             ! same routine as mpp_init
87   END SUBROUTINE mpp_init2
88
89#else
90   !!----------------------------------------------------------------------
91   !!   'key_mpp_mpi'          OR         MPI massively parallel processing
92   !!----------------------------------------------------------------------
93
94   SUBROUTINE mpp_init
95      !!----------------------------------------------------------------------
96      !!                  ***  ROUTINE mpp_init  ***
97      !!                   
98      !! ** Purpose :   Lay out the global domain over processors.
99      !!
100      !! ** Method  :   Global domain is distributed in smaller local domains.
101      !!      Periodic condition is a function of the local domain position
102      !!      (global boundary or neighbouring domain) and of the global
103      !!      periodic
104      !!      Type :         jperio global periodic condition
105      !!                     nperio local  periodic condition
106      !!
107      !! ** Action  : - set domain parameters
108      !!                    nimpp     : longitudinal index
109      !!                    njmpp     : latitudinal  index
110      !!                    nperio    : lateral condition type
111      !!                    narea     : number for local area
112      !!                    nlci      : first dimension
113      !!                    nlcj      : second dimension
114      !!                    nbondi    : mark for "east-west local boundary"
115      !!                    nbondj    : mark for "north-south local boundary"
116      !!                    nproc     : number for local processor
117      !!                    noea      : number for local neighboring processor
118      !!                    nowe      : number for local neighboring processor
119      !!                    noso      : number for local neighboring processor
120      !!                    nono      : number for local neighboring processor
121      !!
122      !! History :
123      !!        !  94-11  (M. Guyon)  Original code
124      !!        !  95-04  (J. Escobar, M. Imbard)
125      !!        !  98-02  (M. Guyon)  FETI method
126      !!        !  98-05  (M. Imbard, J. Escobar, L. Colombet )  SHMEM and MPI versions
127      !!   8.5  !  02-08  (G. Madec)  F90 : free form
128      !!   3.4  !  11-11  (C. Harris) decomposition changes for running with CICE
129      !!----------------------------------------------------------------------
130      INTEGER  ::   ji, jj, jn   ! dummy loop indices
131      INTEGER  ::   ii, ij, ifreq, il1, il2            ! local integers
132      INTEGER  ::   iresti, irestj, ijm1, imil, inum   !   -      -
133      REAL(wp) ::   zidom, zjdom                       ! local scalars
134      INTEGER, DIMENSION(jpni,jpnj) ::   iimppt, ijmppt, ilcit, ilcjt   ! local workspace
135      !!----------------------------------------------------------------------
136
137      IF(lwp) WRITE(numout,*)
138      IF(lwp) WRITE(numout,*) 'mpp_init : Message Passing MPI'
139      IF(lwp) WRITE(numout,*) '~~~~~~~~'
140      IF(lflush) CALL flush(numout)
141
142
143      !  1. Dimension arrays for subdomains
144      ! -----------------------------------
145      !  Computation of local domain sizes ilcit() ilcjt()
146      !  These dimensions depend on global sizes jpni,jpnj and jpiglo,jpjglo
147      !  The subdomains are squares leeser than or equal to the global
148      !  dimensions divided by the number of processors minus the overlap
149      !  array (cf. par_oce.F90).
150     
151      nreci  = 2 * jpreci
152      nrecj  = 2 * jprecj
153      iresti = MOD( jpiglo - nreci , jpni )
154      irestj = MOD( jpjglo - nrecj , jpnj )
155
156      IF(  iresti == 0 )   iresti = jpni
157
158#if defined key_nemocice_decomp
159      ! In order to match CICE the size of domains in NEMO has to be changed
160      ! The last line of blocks (west) will have fewer points
161
162      DO jj = 1, jpnj
163         DO ji=1, jpni-1
164            ilcit(ji,jj) = jpi
165         END DO
166         ilcit(jpni,jj) = jpiglo - (jpni - 1) * (jpi - nreci)
167      END DO
168
169#else
170
171      DO jj = 1, jpnj
172         DO ji = 1, iresti
173            ilcit(ji,jj) = jpi
174         END DO
175         DO ji = iresti+1, jpni
176            ilcit(ji,jj) = jpi -1
177         END DO
178      END DO
179     
180#endif
181      nfilcit(:,:) = ilcit(:,:)
182      IF( irestj == 0 )   irestj = jpnj
183
184#if defined key_nemocice_decomp
185      ! Same change to domains in North-South direction as in East-West.
186      DO ji=1,jpni
187         DO jj=1,jpnj-1
188            ilcjt(ji,jj) = jpj
189         END DO
190         ilcjt(ji,jpnj) = jpjglo - (jpnj - 1) * (jpj - nrecj)
191      END DO
192
193#else
194
195      DO ji = 1, jpni
196         DO jj = 1, irestj
197            ilcjt(ji,jj) = jpj
198         END DO
199         DO jj = irestj+1, jpnj
200            ilcjt(ji,jj) = jpj -1
201         END DO
202      END DO
203     
204#endif
205
206      !  2. Index arrays for subdomains
207      ! -------------------------------
208     
209      iimppt(:,:) = 1
210      ijmppt(:,:) = 1
211     
212      IF( jpni > 1 ) THEN
213         DO jj = 1, jpnj
214            DO ji = 2, jpni
215               iimppt(ji,jj) = iimppt(ji-1,jj) + ilcit(ji-1,jj) - nreci
216            END DO
217         END DO
218      ENDIF
219      nfiimpp(:,:)=iimppt(:,:)
220
221      IF( jpnj > 1 ) THEN
222         DO jj = 2, jpnj
223            DO ji = 1, jpni
224               ijmppt(ji,jj) = ijmppt(ji,jj-1)+ilcjt(ji,jj-1)-nrecj
225            END DO
226         END DO
227      ENDIF
228     
229      ! 3. Subdomain description
230      ! ------------------------
231
232      DO jn = 1, jpnij
233         ii = 1 + MOD( jn-1, jpni )
234         ij = 1 + (jn-1) / jpni
235         nfipproc(ii,ij) = jn - 1
236         nimppt(jn) = iimppt(ii,ij)
237         njmppt(jn) = ijmppt(ii,ij)
238         nlcit (jn) = ilcit (ii,ij)     
239         nlci       = nlcit (jn)     
240         nlcjt (jn) = ilcjt (ii,ij)     
241         nlcj       = nlcjt (jn)
242         nbondj = -1                                   ! general case
243         IF( jn   >  jpni          )   nbondj = 0      ! first row of processor
244         IF( jn   >  (jpnj-1)*jpni )   nbondj = 1      ! last  row of processor
245         IF( jpnj == 1             )   nbondj = 2      ! one processor only in j-direction
246         ibonjt(jn) = nbondj
247         
248         nbondi = 0                                    !
249         IF( MOD( jn, jpni ) == 1 )   nbondi = -1      !
250         IF( MOD( jn, jpni ) == 0 )   nbondi =  1      !
251         IF( jpni            == 1 )   nbondi =  2      ! one processor only in i-direction
252         ibonit(jn) = nbondi
253         
254         nldi =  1   + jpreci
255         nlei = nlci - jpreci
256         IF( nbondi == -1 .OR. nbondi == 2 )   nldi = 1
257         IF( nbondi ==  1 .OR. nbondi == 2 )   nlei = nlci
258         nldj =  1   + jprecj
259         nlej = nlcj - jprecj
260         IF( nbondj == -1 .OR. nbondj == 2 )   nldj = 1
261         IF( nbondj ==  1 .OR. nbondj == 2 )   nlej = nlcj
262         nldit(jn) = nldi
263         nleit(jn) = nlei
264         nldjt(jn) = nldj
265         nlejt(jn) = nlej
266      END DO
267
268      ! 4. Subdomain print
269      ! ------------------
270     
271      IF(lwp) WRITE(numout,*)
272      IF(lwp) WRITE(numout,*) ' mpp_init: defines mpp subdomains'
273      IF(lwp) WRITE(numout,*) ' ~~~~~~  ----------------------'
274      IF(lwp) WRITE(numout,*)
275      IF(lwp) WRITE(numout,*) 'iresti=',iresti,' irestj=',irestj
276      IF(lwp) WRITE(numout,*)
277      IF(lwp) WRITE(numout,*) 'jpni=',jpni,' jpnj=',jpnj
278      zidom = nreci
279      DO ji = 1, jpni
280         zidom = zidom + ilcit(ji,1) - nreci
281      END DO
282      IF(lwp) WRITE(numout,*)
283      IF(lwp) WRITE(numout,*)' sum ilcit(i,1)=', zidom, ' jpiglo=', jpiglo
284
285      zjdom = nrecj
286      DO jj = 1, jpnj
287         zjdom = zjdom + ilcjt(1,jj) - nrecj
288      END DO
289      IF(lwp) WRITE(numout,*)' sum ilcit(1,j)=', zjdom, ' jpjglo=', jpjglo
290      IF(lwp) WRITE(numout,*)
291      IF(lwp .AND. lflush) CALL flush(numout)
292
293      IF(lwp .AND. nprint>1) THEN
294         ifreq = 4
295         il1   = 1
296         DO jn = 1, (jpni-1)/ifreq+1
297            il2 = MIN( jpni, il1+ifreq-1 )
298            WRITE(numout,*)
299            WRITE(numout,9200) ('***',ji = il1,il2-1)
300            DO jj = jpnj, 1, -1
301               WRITE(numout,9203) ('   ',ji = il1,il2-1)
302               WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 )
303               WRITE(numout,9204) (nfipproc(ji,jj),ji=il1,il2)
304               WRITE(numout,9203) ('   ',ji = il1,il2-1)
305               WRITE(numout,9200) ('***',ji = il1,il2-1)
306            END DO
307            WRITE(numout,9201) (ji,ji = il1,il2)
308            il1 = il1+ifreq
309         END DO
310         IF(lflush) CALL flush(numout)
311      ENDIF
312 9200     FORMAT('     ***',20('*************',a3))
313 9203     FORMAT('     *     ',20('         *   ',a3))
314 9201     FORMAT('        ',20('   ',i3,'          '))
315 9202     FORMAT(' ',i3,' *  ',20(i3,'  x',i3,'   *   '))
316 9204     FORMAT('     *  ',20('      ',i3,'   *   '))
317
318      ! 5. From global to local
319      ! -----------------------
320
321      nperio = 0
322      IF( jperio == 2 .AND. nbondj == -1 )   nperio = 2
323
324
325      ! 6. Subdomain neighbours
326      ! ----------------------
327
328      nproc = narea - 1
329      noso  = nproc - jpni
330      nowe  = nproc - 1
331      noea  = nproc + 1
332      nono  = nproc + jpni
333      ! great neighbours
334      npnw = nono - 1
335      npne = nono + 1
336      npsw = noso - 1
337      npse = noso + 1
338      nbsw = 1
339      nbnw = 1
340      IF( MOD( nproc, jpni ) == 0 ) THEN
341         nbsw = 0
342         nbnw = 0
343      ENDIF
344      nbse = 1
345      nbne = 1
346      IF( MOD( nproc, jpni ) == jpni-1 ) THEN
347         nbse = 0
348         nbne = 0
349      ENDIF
350      IF(nproc < jpni) THEN
351         nbsw = 0
352         nbse = 0
353      ENDIF
354      IF( nproc >= (jpnj-1)*jpni ) THEN
355         nbnw = 0
356         nbne = 0
357      ENDIF
358      nlcj = nlcjt(narea) 
359      nlci = nlcit(narea) 
360      nldi = nldit(narea)
361      nlei = nleit(narea)
362      nldj = nldjt(narea)
363      nlej = nlejt(narea)
364      nbondi = ibonit(narea)
365      nbondj = ibonjt(narea)
366      nimpp  = nimppt(narea) 
367      njmpp  = njmppt(narea) 
368
369     ! Save processor layout in layout.dat file
370       IF (lwp .AND. nprint > 1) THEN
371        CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea )
372        WRITE(inum,'(a)') '   jpnij     jpi     jpj     jpk  jpiglo  jpjglo'
373        WRITE(inum,'(6i8)') jpnij,jpi,jpj,jpk,jpiglo,jpjglo
374        WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimpp njmpp'
375
376        DO  jn = 1, jpnij
377         WRITE(inum,'(9i5)') jn, nlcit(jn), nlcjt(jn), &
378                                      nldit(jn), nldjt(jn), &
379                                      nleit(jn), nlejt(jn), &
380                                      nimppt(jn), njmppt(jn)
381        END DO
382        CLOSE(inum)   
383      END IF
384
385
386      ! w a r n i n g  narea (zone) /= nproc (processors)!
387
388      IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 ) THEN
389         IF( jpni == 1 )THEN
390            nbondi = 2
391            nperio = 1
392         ELSE
393            nbondi = 0
394         ENDIF
395         IF( MOD( narea, jpni ) == 0 ) THEN
396            noea = nproc-(jpni-1)
397            npne = npne-jpni
398            npse = npse-jpni
399         ENDIF
400         IF( MOD( narea, jpni ) == 1 ) THEN
401            nowe = nproc+(jpni-1)
402            npnw = npnw+jpni
403            npsw = npsw+jpni
404         ENDIF
405         nbsw = 1
406         nbnw = 1
407         nbse = 1
408         nbne = 1
409         IF( nproc < jpni ) THEN
410            nbsw = 0
411            nbse = 0
412         ENDIF
413         IF( nproc >= (jpnj-1)*jpni ) THEN
414            nbnw = 0
415            nbne = 0
416         ENDIF
417      ENDIF
418      npolj = 0
419      IF( jperio == 3 .OR. jperio == 4 ) THEN
420         ijm1 = jpni*(jpnj-1)
421         imil = ijm1+(jpni+1)/2
422         IF( narea > ijm1 ) npolj = 3
423         IF( MOD(jpni,2) == 1 .AND. narea == imil ) npolj = 4
424         IF( npolj == 3 ) nono = jpni*jpnj-narea+ijm1
425      ENDIF
426      IF( jperio == 5 .OR. jperio == 6 ) THEN
427          ijm1 = jpni*(jpnj-1)
428          imil = ijm1+(jpni+1)/2
429          IF( narea > ijm1) npolj = 5
430          IF( MOD(jpni,2) == 1 .AND. narea == imil ) npolj = 6
431          IF( npolj == 5 ) nono = jpni*jpnj-narea+ijm1
432      ENDIF
433
434      ! Periodicity : no corner if nbondi = 2 and nperio != 1
435
436      IF(lwp .and. nprint > 0) THEN
437         WRITE(numout,*) ' nproc  = ', nproc
438         WRITE(numout,*) ' nowe   = ', nowe  , ' noea   =  ', noea
439         WRITE(numout,*) ' nono   = ', nono  , ' noso   =  ', noso
440         WRITE(numout,*) ' nbondi = ', nbondi
441         WRITE(numout,*) ' nbondj = ', nbondj
442         WRITE(numout,*) ' npolj  = ', npolj
443         WRITE(numout,*) ' nperio = ', nperio
444         WRITE(numout,*) ' nlci   = ', nlci
445         WRITE(numout,*) ' nlcj   = ', nlcj
446         WRITE(numout,*) ' nimpp  = ', nimpp
447         WRITE(numout,*) ' njmpp  = ', njmpp
448         WRITE(numout,*) ' nreci  = ', nreci  , ' npse   = ', npse
449         WRITE(numout,*) ' nrecj  = ', nrecj  , ' npsw   = ', npsw
450         WRITE(numout,*) ' jpreci = ', jpreci , ' npne   = ', npne
451         WRITE(numout,*) ' jprecj = ', jprecj , ' npnw   = ', npnw
452         WRITE(numout,*)
453         IF(lflush) CALL flush(numout)
454      ENDIF
455
456      IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( ' mpp_init: error on cyclicity' )
457
458      ! Prepare mpp north fold
459
460      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN
461         CALL mpp_ini_north
462         IF(lwp) WRITE(numout,*) ' mpp_init : North fold boundary prepared for jpni >1'
463         IF(lwp .AND. lflush) CALL flush(numout)
464      ENDIF
465
466      ! Prepare NetCDF output file (if necessary)
467      CALL mpp_init_ioipsl
468
469   END SUBROUTINE mpp_init
470
471#  include "mppini_2.h90"
472
473# if defined key_dimgout
474   !!----------------------------------------------------------------------
475   !!   'key_dimgout'                  NO use of NetCDF files
476   !!----------------------------------------------------------------------
477   SUBROUTINE mpp_init_ioipsl       ! Dummy routine
478   END SUBROUTINE mpp_init_ioipsl 
479# else
480   SUBROUTINE mpp_init_ioipsl
481      !!----------------------------------------------------------------------
482      !!                  ***  ROUTINE mpp_init_ioipsl  ***
483      !!
484      !! ** Purpose :   
485      !!
486      !! ** Method  :   
487      !!
488      !! History :
489      !!   9.0  !  04-03  (G. Madec )  MPP-IOIPSL
490      !!   " "  !  08-12  (A. Coward)  addition in case of jpni*jpnj < jpnij
491      !!----------------------------------------------------------------------
492      INTEGER, DIMENSION(2) ::   iglo, iloc, iabsf, iabsl, ihals, ihale, idid
493      !!----------------------------------------------------------------------
494
495      ! The domain is split only horizontally along i- or/and j- direction
496      ! So we need at the most only 1D arrays with 2 elements.
497      ! Set idompar values equivalent to the jpdom_local_noextra definition
498      ! used in IOM. This works even if jpnij .ne. jpni*jpnj.
499      iglo(1) = jpiglo
500      iglo(2) = jpjglo
501      iloc(1) = nlci
502      iloc(2) = nlcj
503      iabsf(1) = nimppt(narea)
504      iabsf(2) = njmppt(narea)
505      iabsl(:) = iabsf(:) + iloc(:) - 1
506      ihals(1) = nldi - 1
507      ihals(2) = nldj - 1
508      ihale(1) = nlci - nlei
509      ihale(2) = nlcj - nlej
510      idid(1) = 1
511      idid(2) = 2
512
513      IF(lwp .AND. nprint > 0) THEN
514          WRITE(numout,*)
515          WRITE(numout,*) 'mpp_init_ioipsl :   iloc  = ', iloc (1), iloc (2)
516          WRITE(numout,*) '~~~~~~~~~~~~~~~     iabsf = ', iabsf(1), iabsf(2)
517          WRITE(numout,*) '                    ihals = ', ihals(1), ihals(2)
518          WRITE(numout,*) '                    ihale = ', ihale(1), ihale(2)
519          IF(lflush) CALL flush(numout)
520      ENDIF
521      !
522      CALL flio_dom_set ( jpnij, nproc, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom)
523      !
524   END SUBROUTINE mpp_init_ioipsl 
525
526# endif
527#endif
528
529   !!======================================================================
530END MODULE mppini
Note: See TracBrowser for help on using the repository browser.