source: trunk/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90 @ 7646

Last change on this file since 7646 was 7646, checked in by timgraham, 4 years ago

Merge of dev_merge_2016 into trunk. UPDATE TO ARCHFILES NEEDED for XIOS2.
LIM_SRC_s/limrhg.F90 to follow in next commit due to change of kind (I'm unable to do it in this commit).
Merged using the following steps:

1) svn merge —reintegrate svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/trunk .
2) Resolve minor conflicts in sette.sh and namelist_cfg for ORCA2LIM3 (due to a change in trunk after branch was created)
3) svn commit
4) svn switch svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/trunk
5) svn merge svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/branches/2016/dev_merge_2016 .
6) At this stage I checked out a clean copy of the branch to compare against what is about to be committed to the trunk.
6) svn commit #Commit code to the trunk

In this commit I have also reverted a change to Fcheck_archfile.sh which was causing problems on the Paris machine.

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