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/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

source: branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90 @ 5010

Last change on this file since 5010 was 5010, checked in by cbricaud, 9 years ago

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