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.
mppini.F90 in branches/UKMO/dev_r5518_GO6_package_text_diagnostics/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

source: branches/UKMO/dev_r5518_GO6_package_text_diagnostics/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90 @ 10774

Last change on this file since 10774 was 10774, checked in by andmirek, 5 years ago

GMED 450 add flush after prints

File size: 18.4 KB
RevLine 
[3]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
[88]11   !!   mpp_init_ioispl: IOIPSL initialization in mpp
[3]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
[352]17   USE ioipsl
[3]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   !!----------------------------------------------------------------------
[2287]28   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
[6486]29   !! $Id$
[2715]30   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
[3]31   !!----------------------------------------------------------------------
32CONTAINS
33
[1556]34#if ! defined key_mpp_mpi
[3]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      !!----------------------------------------------------------------------
[352]51
[3]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
[352]64      nidom  = FLIO_DOM_NONE
[1344]65      npolj = jperio
[352]66
[3]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
[88]72         WRITE(numout,*) '         npolj  = ', npolj
[3]73         WRITE(numout,*) '         nimpp  = ', nimpp
74         WRITE(numout,*) '         njmpp  = ', njmpp
[10774]75         IF(lflush) CALL flush(numout)
[3]76      ENDIF
77
[474]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! ' )
[3]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   !!----------------------------------------------------------------------
[15]91   !!   'key_mpp_mpi'          OR         MPI massively parallel processing
[3]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
[3294]128      !!   3.4  !  11-11  (C. Harris) decomposition changes for running with CICE
[3]129      !!----------------------------------------------------------------------
[2715]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
[3]135      !!----------------------------------------------------------------------
136
[88]137      IF(lwp) WRITE(numout,*)
138      IF(lwp) WRITE(numout,*) 'mpp_init : Message Passing MPI'
139      IF(lwp) WRITE(numout,*) '~~~~~~~~'
[10774]140      IF(lflush) CALL flush(numout)
[3]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
[3294]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
[3]162      DO jj = 1, jpnj
[3294]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
[3]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     
[3294]180#endif
[4671]181      nfilcit(:,:) = ilcit(:,:)
[3]182      IF( irestj == 0 )   irestj = jpnj
[3294]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
[3]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     
[3294]204#endif
[3]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
[4671]219      nfiimpp(:,:)=iimppt(:,:)
[3]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
[4679]235         nfipproc(ii,ij) = jn - 1
[3]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
[6498]267
268      ! 4. Subdomain print
269      ! ------------------
[3]270     
[6498]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
[3]284
[6498]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,*)
[10774]291      IF(lwp .AND. lflush) CALL flush(numout)
[6498]292
[10766]293      IF(lwp .AND. nprint>1) THEN
[6498]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
[10774]310         IF(lflush) CALL flush(numout)
311      ENDIF
[6498]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
[3]319      ! -----------------------
320
321      nperio = 0
322      IF( jperio == 2 .AND. nbondj == -1 )   nperio = 2
323
324
[6498]325      ! 6. Subdomain neighbours
[3]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
[10766]370       IF (lwp .AND. nprint > 1) THEN
[1581]371        CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea )
[434]372        WRITE(inum,'(a)') '   jpnij     jpi     jpj     jpk  jpiglo  jpjglo'
[3]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
[10766]436      IF(lwp .and. nprint > 0) THEN
[3]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
[6498]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,*)
[10774]453         IF(lflush) CALL flush(numout)
[3]454      ENDIF
455
[474]456      IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( ' mpp_init: error on cyclicity' )
[3]457
458      ! Prepare mpp north fold
459
[6498]460      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN
[3]461         CALL mpp_ini_north
[6498]462         IF(lwp) WRITE(numout,*) ' mpp_init : North fold boundary prepared for jpni >1'
[10774]463         IF(lwp .AND. lflush) CALL flush(numout)
[6498]464      ENDIF
[3]465
[88]466      ! Prepare NetCDF output file (if necessary)
467      CALL mpp_init_ioipsl
[3]468
469   END SUBROUTINE mpp_init
470
471#  include "mppini_2.h90"
472
[239]473# if defined key_dimgout
[88]474   !!----------------------------------------------------------------------
[239]475   !!   'key_dimgout'                  NO use of NetCDF files
[88]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 :
[1238]489      !!   9.0  !  04-03  (G. Madec )  MPP-IOIPSL
490      !!   " "  !  08-12  (A. Coward)  addition in case of jpni*jpnj < jpnij
[88]491      !!----------------------------------------------------------------------
[2715]492      INTEGER, DIMENSION(2) ::   iglo, iloc, iabsf, iabsl, ihals, ihale, idid
[88]493      !!----------------------------------------------------------------------
[352]494
[1238]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.
[88]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
[1238]506      ihals(1) = nldi - 1
507      ihals(2) = nldj - 1
508      ihale(1) = nlci - nlei
509      ihale(2) = nlcj - nlej
[352]510      idid(1) = 1
511      idid(2) = 2
512
[10770]513      IF(lwp .AND. nprint > 0) THEN
[516]514          WRITE(numout,*)
[352]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)
[10774]519          IF(lflush) CALL flush(numout)
[88]520      ENDIF
[2715]521      !
[352]522      CALL flio_dom_set ( jpnij, nproc, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom)
[2715]523      !
[88]524   END SUBROUTINE mpp_init_ioipsl 
525
526# endif
[3]527#endif
[88]528
[3]529   !!======================================================================
530END MODULE mppini
Note: See TracBrowser for help on using the repository browser.