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

source: branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90 @ 8314

Last change on this file since 8314 was 8314, checked in by acc, 7 years ago

Branch 2017/dev_r8126_ROBUST08_no_ghost. Merge in changes from branches/2017/dev_r8126_ROBUST10_MPPINI to combine mppini and mppini_2 functionalities into a single routine. SETTE-like test performed with ORCA2LIMPISCES using an 8x8 partition with 60 processors to confirm consistency of results when using land suppression. The dev_r8126_ROBUST10_MPPINI branch will not be needed in the 2017 merge if dev_r8126_ROBUST08_no_ghost is included.

  • Property svn:keywords set to Id
File size: 25.7 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   !!                    with/without land processor elimination
10   !!   mpp_init_ioispl: IOIPSL initialization in mpp
11   !!----------------------------------------------------------------------
12   USE dom_oce         ! ocean space and time domain
13   USE in_out_manager  ! I/O Manager
14   USE lib_mpp         ! distribued memory computing library
15   USE ioipsl
16   USE iom
17
18   IMPLICIT NONE
19   PRIVATE
20
21   PUBLIC mpp_init       ! called by opa.F90
22
23   !!----------------------------------------------------------------------
24   !! NEMO/OPA 4.0 , NEMO Consortium (2017)
25   !! $Id$
26   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
27   !!----------------------------------------------------------------------
28CONTAINS
29
30#if ! defined key_mpp_mpi
31   !!----------------------------------------------------------------------
32   !!   Default option :                            shared memory computing
33   !!----------------------------------------------------------------------
34
35   SUBROUTINE mpp_init
36      !!----------------------------------------------------------------------
37      !!                  ***  ROUTINE mpp_init  ***
38      !!
39      !! ** Purpose :   Lay out the global domain over processors.
40      !!
41      !! ** Method  :   Shared memory computing, set the local processor
42      !!      variables to the value of the global domain
43      !!
44      !! History :
45      !!   9.0  !  04-01  (G. Madec, J.M. Molines)  F90 : free form, north fold jpni >1
46      !!----------------------------------------------------------------------
47
48      ! No mpp computation
49      nimpp  = 1
50      njmpp  = 1
51      nlci   = jpi
52      nlcj   = jpj
53      nldi   = 1
54      nldj   = 1
55      nlei   = jpi
56      nlej   = jpj
57      nperio = jperio
58      nbondi = 2
59      nbondj = 2
60      nidom  = FLIO_DOM_NONE
61      npolj = jperio
62
63      IF(lwp) THEN
64         WRITE(numout,*)
65         WRITE(numout,*) 'mpp_init(2) : NO massively parallel processing'
66         WRITE(numout,*) '~~~~~~~~~~~ '
67         WRITE(numout,*) '         nperio = ', nperio
68         WRITE(numout,*) '         npolj  = ', npolj
69         WRITE(numout,*) '         nimpp  = ', nimpp
70         WRITE(numout,*) '         njmpp  = ', njmpp
71      ENDIF
72
73      IF(  jpni /= 1 .OR. jpnj /= 1 .OR. jpnij /= 1 ) &
74          CALL ctl_stop( 'equality  jpni = jpnj = jpnij = 1 is not satisfied',   &
75          &              'the domain is lay out for distributed memory computing! ' )
76
77      IF( jperio == 7 ) CALL ctl_stop( ' jperio = 7 needs distributed memory computing ',   &
78          &              ' with 1 process. Add key_mpp_mpi in the list of active cpp keys ' )
79   END SUBROUTINE mpp_init
80
81#else
82   !!----------------------------------------------------------------------
83   !!   'key_mpp_mpi'          OR         MPI massively parallel processing
84   !!----------------------------------------------------------------------
85
86   SUBROUTINE mpp_init
87      !!----------------------------------------------------------------------
88      !!                  ***  ROUTINE mpp_init  ***
89      !!                   
90      !! ** Purpose :   Lay out the global domain over processors.
91      !!      If land processors are to be eliminated, this program requires the
92      !!      presence of the domain configuration file. Land processors elimination
93      !!      is performed if jpni x jpnj /= jpnij. In this case, using the MPP_PREP
94      !!      preprocessing tool, hekp for defining the best cutting out.
95      !!
96      !! ** Method  :   Global domain is distributed in smaller local domains.
97      !!      Periodic condition is a function of the local domain position
98      !!      (global boundary or neighbouring domain) and of the global
99      !!      periodic
100      !!      Type :         jperio global periodic condition
101      !!                     nperio local  periodic condition
102      !!
103      !! ** Action : - set domain parameters
104      !!                    nimpp     : longitudinal index
105      !!                    njmpp     : latitudinal  index
106      !!                    nperio    : lateral condition type
107      !!                    narea     : number for local area
108      !!                    nlci      : first dimension
109      !!                    nlcj      : second dimension
110      !!                    nbondi    : mark for "east-west local boundary"
111      !!                    nbondj    : mark for "north-south local boundary"
112      !!                    nproc     : number for local processor
113      !!                    noea      : number for local neighboring processor
114      !!                    nowe      : number for local neighboring processor
115      !!                    noso      : number for local neighboring processor
116      !!                    nono      : number for local neighboring processor
117      !!
118      !! History :       !  1994-11  (M. Guyon)  Original code
119      !!  OPA            !  1995-04  (J. Escobar, M. Imbard)
120      !!                 !  1998-02  (M. Guyon)  FETI method
121      !!                 !  1998-05  (M. Imbard, J. Escobar, L. Colombet )  SHMEM and MPI versions
122      !!  NEMO      1.0  !  2004-01  (G. Madec, J.M Molines)  F90 : free form , north fold jpni > 1
123      !!            4.0  !  2016-06  (G. Madec)  use domain configuration file instead of bathymetry file
124      !!            4.0  !  2017-06  (J.M. Molines, T. Lovato) merge of mppini and mppini_2
125      !!----------------------------------------------------------------------
126      !!
127      USE in_out_manager  ! I/O Manager
128      !!
129      INTEGER :: ji, jj, jn, jproc, jarea     ! dummy loop indices
130      INTEGER ::  inum                        ! temporary logical unit
131      INTEGER ::  idir                        ! temporary integers
132      INTEGER ::   &
133         ii, ij, ifreq, il1, il2,          &  ! temporary integers
134         icont, ili, ilj,                  &  !    "          "
135         isurf, ijm1, imil,                &  !    "          "
136         iino, ijno, iiso, ijso,           &  !    "          "
137         iiea, ijea, iiwe, ijwe,           &  !    "          "
138         iresti, irestj, iproc                !    "          "
139      INTEGER, DIMENSION(jpnij) ::   &
140         iin, ijn         
141      INTEGER, DIMENSION(jpni,jpnj) ::   &
142         iimppt, ijmppt, ilci  , ilcj  ,   &  ! temporary workspace
143         ipproc, ibondj, ibondi, ipolj ,   &  !    "           "
144         ilei  , ilej  , ildi  , ildj  ,   &  !    "           "
145         ioea  , iowe  , ioso  , iono         !    "           "
146      INTEGER,  DIMENSION(jpiglo,jpjglo) ::   imask               ! global workspace
147      REAL(wp) ::   zidom , zjdom          ! local scalars
148      INTEGER, DIMENSION(jpnij) :: ii_nono, ii_noso, ii_noea, ii_nowe  ! jmm used for printing
149      !!----------------------------------------------------------------------
150
151      IF(lwp)WRITE(numout,*)
152      IF(lwp)WRITE(numout,*) 'mpp_init: Message Passing MPI'
153      IF(lwp)WRITE(numout,*) '~~~~~~~~~~'
154      IF(lwp)WRITE(numout,*) ' '
155
156      IF ( jpni * jpnj == jpnij ) THEN
157         imask(:,:) = 1                     ! no land processor elimination
158      ELSEIF ( jpni*jpnj > jpnij )   THEN
159         CALL mpp_init_mask(imask)          ! land processor elimination requires imask=0 on land
160      ELSE
161         CALL ctl_stop( ' jpnij > jpni x jpnj. Check namelist setting!'  )
162      ENDIF
163
164      !  1. Dimension arrays for subdomains
165      ! -----------------------------------
166
167      !  Computation of local domain sizes ilci() ilcj()
168      !  These dimensions depend on global sizes jpni,jpnj and jpiglo,jpjglo
169      !  The subdomains are squares leeser than or equal to the global
170      !  dimensions divided by the number of processors minus the overlap
171      !  array.
172
173      nreci=2*jpreci
174      nrecj=2*jprecj
175      iresti = 1 + MOD( jpiglo - nreci -1 , jpni )
176      irestj = 1 + MOD( jpjglo - nrecj -1 , jpnj )
177
178#if defined key_nemocice_decomp
179      ! Change padding to be consistent with CICE
180      ilci(1:jpni-1      ,:) = jpi
181      ilci(jpni          ,:) = jpiglo - (jpni - 1) * (jpi - nreci)
182
183      ilcj(:,      1:jpnj-1) = jpj
184      ilcj(:,          jpnj) = jpjglo - (jpnj - 1) * (jpj - nrecj)
185#else
186      ilci(1:iresti      ,:) = jpi
187      ilci(iresti+1:jpni ,:) = jpi-1
188
189      ilcj(:,      1:irestj) = jpj
190      ilcj(:, irestj+1:jpnj) = jpj-1
191#endif
192
193      nfilcit(:,:) = ilci(:,:)
194
195      IF(lwp) WRITE(numout,*)
196      IF(lwp) WRITE(numout,*) ' mpp_init: defines mpp subdomains'
197      IF(lwp) WRITE(numout,*) ' ~~~~~~  ----------------------'
198      IF(lwp) WRITE(numout,*)
199      IF(lwp) WRITE(numout,*) 'iresti=',iresti,' irestj=',irestj
200      IF(lwp) WRITE(numout,*)
201      IF(lwp) WRITE(numout,*) 'jpni=',jpni,' jpnj=',jpnj
202
203      zidom = nreci + sum(ilci(:,1) - nreci ) 
204      IF(lwp) WRITE(numout,*)
205      IF(lwp) WRITE(numout,*)' sum ilci(i,1)=',zidom,' jpiglo=',jpiglo
206
207      zjdom = nrecj + sum(ilcj(1,:) - nrecj ) 
208      IF(lwp) WRITE(numout,*) ' sum ilcj(1,j)=',zjdom,' jpjglo=',jpjglo
209      IF(lwp) WRITE(numout,*)
210
211
212      !  2. Index arrays for subdomains
213      ! -------------------------------
214
215      iimppt(:,:) = 1
216      ijmppt(:,:) = 1
217      ipproc(:,:) = -1
218
219      IF( jpni > 1 )THEN
220         DO jj = 1, jpnj
221            DO ji = 2, jpni
222               iimppt(ji,jj) = iimppt(ji-1,jj) + ilci(ji-1,jj) - nreci
223            END DO
224         END DO
225      ENDIF
226      nfiimpp(:,:) = iimppt(:,:)
227
228      IF( jpnj > 1 )THEN
229         DO jj = 2, jpnj
230            DO ji = 1, jpni
231               ijmppt(ji,jj) = ijmppt(ji,jj-1) + ilcj(ji,jj-1) - nrecj
232            END DO
233         END DO
234      ENDIF
235
236
237      ! 3. Subdomain description in the Regular Case
238      ! --------------------------------------------
239
240      nperio = 0
241      icont = -1
242      DO jarea = 1, jpni*jpnj
243         ii = 1 + MOD(jarea-1,jpni)
244         ij = 1 +    (jarea-1)/jpni
245         ili = ilci(ii,ij)
246         ilj = ilcj(ii,ij)
247         ibondj(ii,ij) = -1
248         IF( jarea >  jpni          )   ibondj(ii,ij) = 0
249         IF( jarea >  (jpnj-1)*jpni )   ibondj(ii,ij) = 1
250         IF( jpnj  == 1             )   ibondj(ii,ij) = 2
251         ibondi(ii,ij) = 0
252         IF( MOD(jarea,jpni) == 1 )   ibondi(ii,ij) = -1
253         IF( MOD(jarea,jpni) == 0 )   ibondi(ii,ij) =  1
254         IF( jpni            == 1 )   ibondi(ii,ij) =  2
255
256         ! 2.4 Subdomain neighbors
257
258         iproc = jarea - 1
259         ioso(ii,ij) = iproc - jpni
260         iowe(ii,ij) = iproc - 1
261         ioea(ii,ij) = iproc + 1
262         iono(ii,ij) = iproc + jpni
263         ildi(ii,ij) = 1 + jpreci
264         ilei(ii,ij) = ili -jpreci
265
266         IF( ibondi(ii,ij) == -1 .OR. ibondi(ii,ij) == 2 ) ildi(ii,ij) = 1
267         IF( ibondi(ii,ij) ==  1 .OR. ibondi(ii,ij) == 2 ) ilei(ii,ij) = ili
268         ildj(ii,ij) =  1  + jprecj
269         ilej(ii,ij) = ilj - jprecj
270         IF( ibondj(ii,ij) == -1 .OR. ibondj(ii,ij) == 2 ) ildj(ii,ij) = 1
271         IF( ibondj(ii,ij) ==  1 .OR. ibondj(ii,ij) == 2 ) ilej(ii,ij) = ilj
272
273         ! warning ii*ij (zone) /= nproc (processors)!
274
275         IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 ) THEN
276            IF( jpni == 1 )THEN
277               ibondi(ii,ij) = 2
278               nperio = 1
279            ELSE
280               ibondi(ii,ij) = 0
281            ENDIF
282            IF( MOD(jarea,jpni) == 0 ) THEN
283               ioea(ii,ij) = iproc - (jpni-1)
284            ENDIF
285            IF( MOD(jarea,jpni) == 1 ) THEN
286               iowe(ii,ij) = iproc + jpni - 1
287            ENDIF
288         ENDIF
289         ipolj(ii,ij) = 0
290         IF( jperio == 3 .OR. jperio == 4 ) THEN
291            ijm1 = jpni*(jpnj-1)
292            imil = ijm1+(jpni+1)/2
293            IF( jarea > ijm1 ) ipolj(ii,ij) = 3
294            IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 4
295            IF( ipolj(ii,ij) == 3 ) iono(ii,ij) = jpni*jpnj-jarea+ijm1   ! MPI rank of northern neighbour
296         ENDIF
297         IF( jperio == 5 .OR. jperio == 6 ) THEN
298            ijm1 = jpni*(jpnj-1)
299            imil = ijm1+(jpni+1)/2
300            IF( jarea > ijm1) ipolj(ii,ij) = 5
301            IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 6
302            IF( ipolj(ii,ij) == 5) iono(ii,ij) = jpni*jpnj-jarea+ijm1    ! MPI rank of northern neighbour
303         ENDIF
304
305         ! Check wet points over the entire domain to preserve the MPI communication stencil
306         isurf = 0
307         DO jj = 1, ilj
308            DO  ji = 1, ili
309               IF( imask(ji+iimppt(ii,ij)-1, jj+ijmppt(ii,ij)-1) == 1)   isurf = isurf+1
310            END DO
311         END DO
312
313         IF(isurf /= 0) THEN
314            icont = icont + 1
315            ipproc(ii,ij) = icont
316            iin(icont+1) = ii
317            ijn(icont+1) = ij
318         ENDIF
319      END DO
320
321      nfipproc(:,:) = ipproc(:,:)
322
323      ! Control
324      IF(icont+1 /= jpnij) THEN
325         WRITE(ctmp1,*) ' jpni =',jpni,' jpnj =',jpnj
326         WRITE(ctmp2,*) ' jpnij =',jpnij, '< jpni x jpnj' 
327         WRITE(ctmp3,*) ' ***********, mpp_init2 finds jpnij=',icont+1
328         CALL ctl_stop( ' Eliminate land processors algorithm', '', ctmp1, ctmp2, '', ctmp3 )
329      ENDIF
330
331      ! 4. Subdomain print
332      ! ------------------
333
334      IF(lwp) THEN
335         ifreq = 4
336         il1 = 1
337         DO jn = 1,(jpni-1)/ifreq+1
338            il2 = MIN(jpni,il1+ifreq-1)
339            WRITE(numout,*)
340            WRITE(numout,9400) ('***',ji=il1,il2-1)
341            DO jj = jpnj, 1, -1
342               WRITE(numout,9403) ('   ',ji=il1,il2-1)
343               WRITE(numout,9402) jj, (ilci(ji,jj),ilcj(ji,jj),ji=il1,il2)
344               WRITE(numout,9404) (ipproc(ji,jj),ji=il1,il2)
345               WRITE(numout,9403) ('   ',ji=il1,il2-1)
346               WRITE(numout,9400) ('***',ji=il1,il2-1)
347            END DO
348            WRITE(numout,9401) (ji,ji=il1,il2)
349            il1 = il1+ifreq
350         END DO
351 9400     FORMAT('     ***',20('*************',a3))
352 9403     FORMAT('     *     ',20('         *   ',a3))
353 9401     FORMAT('        ',20('   ',i3,'          '))
354 9402     FORMAT(' ',i3,' *  ',20(i3,'  x',i3,'   *   '))
355 9404     FORMAT('     *  ',20('      ',i3,'   *   '))
356      ENDIF
357
358
359      ! 5. neighbour treatment
360      ! ----------------------
361
362      DO jarea = 1, jpni*jpnj
363         iproc = jarea-1
364         ii = 1 + MOD(jarea-1,jpni)
365         ij = 1 +    (jarea-1)/jpni
366         IF( ipproc(ii,ij) == -1 .AND. iono(ii,ij) >= 0   &
367            .AND. iono(ii,ij) <= jpni*jpnj-1 ) THEN
368            iino = 1 + MOD(iono(ii,ij),jpni)
369            ijno = 1 +    (iono(ii,ij))/jpni
370              ! Need to reverse the logical direction of communication
371              ! for northern neighbours of northern row processors (north-fold)
372              ! i.e. need to check that the northern neighbour only communicates
373              ! to the SOUTH (or not at all) if this area is land-only (#1057)
374            idir = 1
375            IF( ij .eq. jpnj .AND. ijno .eq. jpnj ) idir = -1   
376            IF( ibondj(iino,ijno) == idir ) ibondj(iino,ijno)=2
377            IF( ibondj(iino,ijno) == 0 ) ibondj(iino,ijno) = -idir
378         ENDIF
379         IF( ipproc(ii,ij) == -1 .AND. ioso(ii,ij) >= 0   &
380            .AND. ioso(ii,ij) <= jpni*jpnj-1 ) THEN
381            iiso = 1 + MOD(ioso(ii,ij),jpni)
382            ijso = 1 +    (ioso(ii,ij))/jpni
383            IF( ibondj(iiso,ijso) == -1 ) ibondj(iiso,ijso) = 2
384            IF( ibondj(iiso,ijso) ==  0 ) ibondj(iiso,ijso) = 1
385         ENDIF
386         IF( ipproc(ii,ij) == -1 .AND. ioea(ii,ij) >= 0   &
387            .AND. ioea(ii,ij) <= jpni*jpnj-1) THEN
388            iiea = 1 + MOD(ioea(ii,ij),jpni)
389            ijea = 1 +    (ioea(ii,ij))/jpni
390            IF( ibondi(iiea,ijea) == 1 ) ibondi(iiea,ijea) = 2
391            IF( ibondi(iiea,ijea) == 0 ) ibondi(iiea,ijea) = -1
392         ENDIF
393         IF( ipproc(ii,ij) == -1 .AND. iowe(ii,ij) >= 0   &
394            .AND. iowe(ii,ij) <= jpni*jpnj-1) THEN
395            iiwe = 1 + MOD(iowe(ii,ij),jpni)
396            ijwe = 1 +    (iowe(ii,ij))/jpni
397            IF( ibondi(iiwe,ijwe) == -1 ) ibondi(iiwe,ijwe) = 2
398            IF( ibondi(iiwe,ijwe) ==  0 ) ibondi(iiwe,ijwe) = 1
399         ENDIF
400      END DO
401
402
403    ! just to save nono etc for all proc
404    ii_noso(:) = -1
405    ii_nono(:) = -1
406    ii_noea(:) = -1
407    ii_nowe(:) = -1 
408    nproc = narea-1
409    DO jarea = 1, jpnij
410       ii = iin(jarea)
411       ij = ijn(jarea)
412       IF( ioso(ii,ij) >= 0 .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN
413          iiso = 1 + MOD(ioso(ii,ij),jpni)
414          ijso = 1 +    (ioso(ii,ij))/jpni
415          noso = ipproc(iiso,ijso)
416          ii_noso(jarea)= noso
417       ENDIF
418       IF( iowe(ii,ij) >= 0 .AND. iowe(ii,ij) <= (jpni*jpnj-1) ) THEN
419          iiwe = 1 + MOD(iowe(ii,ij),jpni)
420          ijwe = 1 +    (iowe(ii,ij))/jpni
421          nowe = ipproc(iiwe,ijwe)
422          ii_nowe(jarea)= nowe
423       ENDIF
424       IF( ioea(ii,ij) >= 0 .AND. ioea(ii,ij) <= (jpni*jpnj-1) ) THEN
425          iiea = 1 + MOD(ioea(ii,ij),jpni)
426          ijea = 1 +    (ioea(ii,ij))/jpni
427          noea = ipproc(iiea,ijea)
428          ii_noea(jarea)= noea
429       ENDIF
430       IF( iono(ii,ij) >= 0 .AND. iono(ii,ij) <= (jpni*jpnj-1) ) THEN
431          iino = 1 + MOD(iono(ii,ij),jpni)
432          ijno = 1 +    (iono(ii,ij))/jpni
433          nono = ipproc(iino,ijno)
434          ii_nono(jarea)= nono
435       ENDIF
436    END DO
437      ! 6. Change processor name
438      ! ------------------------
439
440      nproc = narea-1
441      ii = iin(narea)
442      ij = ijn(narea)
443
444      ! set default neighbours
445      noso = ii_noso(narea)
446      nowe = ii_nowe(narea)
447      noea = ii_noea(narea)
448      nono = ii_nono(narea)
449      nlcj = ilcj(ii,ij) 
450      nlci = ilci(ii,ij) 
451      nldi = ildi(ii,ij)
452      nlei = ilei(ii,ij)
453      nldj = ildj(ii,ij)
454      nlej = ilej(ii,ij)
455      nbondi = ibondi(ii,ij)
456      nbondj = ibondj(ii,ij)
457      nimpp = iimppt(ii,ij) 
458      njmpp = ijmppt(ii,ij) 
459      DO jproc = 1, jpnij
460         ii = iin(jproc)
461         ij = ijn(jproc)
462         nimppt(jproc) = iimppt(ii,ij) 
463         njmppt(jproc) = ijmppt(ii,ij) 
464         nlcjt(jproc) = ilcj(ii,ij)
465         nlcit(jproc) = ilci(ii,ij)
466         nldit(jproc) = ildi(ii,ij)
467         nleit(jproc) = ilei(ii,ij)
468         nldjt(jproc) = ildj(ii,ij)
469         nlejt(jproc) = ilej(ii,ij)
470      END DO
471
472      ! Save processor layout in ascii file
473      IF (lwp) THEN
474         CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea )
475         WRITE(inum,'(a)') '   jpnij     jpi     jpj     jpk  jpiglo  jpjglo'
476         WRITE(inum,'(6i8)') jpnij,jpi,jpj,jpk,jpiglo,jpjglo
477         WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimp njmp nono noso nowe noea nbondi nbondj '
478
479        DO  jproc = 1, jpnij
480           ii = iin(jproc)
481           ij = ijn(jproc)
482
483           WRITE(inum,'(15i5)') jproc-1, nlcit(jproc), nlcjt(jproc), &
484                 nldit(jproc), nldjt(jproc),     &
485                 nleit(jproc), nlejt(jproc),     &
486                 nimppt(jproc), njmppt(jproc),   & 
487                 ii_nono(jproc), ii_noso(jproc), &
488                 ii_nowe(jproc), ii_noea(jproc), &
489                 ibondi(ii,ij),  ibondj(ii,ij) 
490         END DO
491         CLOSE(inum)   
492      END IF
493
494      ! Defined npolj, either 0, 3 , 4 , 5 , 6
495      ! In this case the important thing is that npolj /= 0
496      ! Because if we go through these line it is because jpni >1 and thus
497      ! we must use lbcnorthmpp, which tests only npolj =0 or npolj /= 0
498
499      npolj = 0
500      ij = ijn(narea)
501
502      IF( jperio == 3 .OR. jperio == 4 ) THEN
503         IF( ij == jpnj ) npolj = 3
504      ENDIF
505
506      IF( jperio == 5 .OR. jperio == 6 ) THEN
507         IF( ij == jpnj ) npolj = 5
508      ENDIF
509
510      ! Periodicity : no corner if nbondi = 2 and nperio != 1
511
512      IF(lwp) THEN
513         WRITE(numout,*) ' nproc  = ', nproc
514         WRITE(numout,*) ' nowe   = ', nowe  , ' noea   =  ', noea
515         WRITE(numout,*) ' nono   = ', nono  , ' noso   =  ', noso
516         WRITE(numout,*) ' nbondi = ', nbondi
517         WRITE(numout,*) ' nbondj = ', nbondj
518         WRITE(numout,*) ' npolj  = ', npolj
519         WRITE(numout,*) ' nperio = ', nperio
520         WRITE(numout,*) ' nlci   = ', nlci
521         WRITE(numout,*) ' nlcj   = ', nlcj
522         WRITE(numout,*) ' nimpp  = ', nimpp
523         WRITE(numout,*) ' njmpp  = ', njmpp
524         WRITE(numout,*) ' nreci  = ', nreci 
525         WRITE(numout,*) ' nrecj  = ', nrecj 
526         WRITE(numout,*) ' jpreci = ', jpreci 
527         WRITE(numout,*) ' jprecj = ', jprecj 
528         WRITE(numout,*)
529      ENDIF
530
531      IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( ' mpp_init: error on cyclicity' )
532
533      ! Prepare mpp north fold
534
535      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN
536         CALL mpp_ini_north
537         IF(lwp) WRITE(numout,*) ' mpp_init : North fold boundary prepared for jpni >1'
538      ENDIF
539
540      ! Prepare NetCDF output file (if necessary)
541      CALL mpp_init_ioipsl
542
543
544    END SUBROUTINE mpp_init
545
546    SUBROUTINE mpp_init_mask(kmask)
547      !!----------------------------------------------------------------------
548      !!                  ***  ROUTINE mpp_init_mask  ***
549      !!
550      !! ** Purpose : Read relevant bathymetric information in a global array
551      !!              in order to provide a land/sea mask used for the elimination
552      !!              of land domains, in an mpp computation.
553      !!
554      !! ** Method  : Read the namelist ln_zco and ln_isfcav in namelist namzgr
555      !!              in order to choose the correct bathymetric information
556      !!              (file and variables) 
557      !!
558      !! History :
559      !!   4.0   !  17-06  (J.M. Molines) from mpp_init_2 to unified mppini
560      !!----------------------------------------------------------------------
561      USE bdy_oce
562      !!
563      INTEGER, DIMENSION(jpiglo,jpjglo), INTENT(out) :: kmask
564 
565      INTEGER :: inum   !: logical unit for configuration file
566      INTEGER :: ios    !: iostat error flag
567      INTEGER ::  ijstartrow                   ! temporary integers
568      REAL(wp), DIMENSION(jpiglo,jpjglo) ::   zbot, zbdy          ! global workspace
569      REAL(wp) ::   zidom , zjdom          ! local scalars
570      NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file,         &
571           &             ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta,     &
572           &             cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta,             & 
573           &             ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, &
574           &             cn_ice_lim, nn_ice_lim_dta,                           &
575           &             rn_ice_tem, rn_ice_sal, rn_ice_age,                 &
576           &             ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy
577      !!----------------------------------------------------------------------
578      ! 0. initialisation
579      ! -----------------
580      CALL iom_open( cn_domcfg, inum )
581      !
582      ! ocean bottom level
583      CALL iom_get( inum, jpdom_unknown, 'bottom_level' , zbot , lrowattr=ln_use_jattr )  ! nb of ocean T-points
584      !
585      CALL iom_close( inum )
586      !
587      ! 2D ocean mask (=1 if at least one level of the water column is ocean, =0 otherwise)
588      WHERE( zbot(:,:) > 0 )                   ;   kmask(:,:) = 1
589      ELSEWHERE                                ;   kmask(:,:) = 0
590      END WHERE
591 
592      ! Adjust kmask with bdy_msk if exists
593 
594      REWIND( numnam_ref )              ! Namelist nambdy in reference namelist : BDY
595      READ  ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903)
596903   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)', lwp )
597
598      REWIND( numnam_cfg )              ! Namelist nambdy in configuration namelist : BDY
599      READ  ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 )
600904   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)', lwp )
601
602      IF( ln_bdy .AND. ln_mask_file ) THEN
603         CALL iom_open( cn_mask_file, inum )
604         CALL iom_get ( inum, jpdom_unknown, 'bdy_msk', zbdy)
605         CALL iom_close( inum )
606         WHERE ( zbdy(:,:) <= 0. ) kmask = 0
607      ENDIF
608
609   END SUBROUTINE mpp_init_mask
610
611   SUBROUTINE mpp_init_ioipsl
612      !!----------------------------------------------------------------------
613      !!                  ***  ROUTINE mpp_init_ioipsl  ***
614      !!
615      !! ** Purpose :   
616      !!
617      !! ** Method  :   
618      !!
619      !! History :
620      !!   9.0  !  04-03  (G. Madec )  MPP-IOIPSL
621      !!   " "  !  08-12  (A. Coward)  addition in case of jpni*jpnj < jpnij
622      !!----------------------------------------------------------------------
623      INTEGER, DIMENSION(2) ::   iglo, iloc, iabsf, iabsl, ihals, ihale, idid
624      !!----------------------------------------------------------------------
625
626      ! The domain is split only horizontally along i- or/and j- direction
627      ! So we need at the most only 1D arrays with 2 elements.
628      ! Set idompar values equivalent to the jpdom_local_noextra definition
629      ! used in IOM. This works even if jpnij .ne. jpni*jpnj.
630      iglo(1) = jpiglo
631      iglo(2) = jpjglo
632      iloc(1) = nlci
633      iloc(2) = nlcj
634      iabsf(1) = nimppt(narea)
635      iabsf(2) = njmppt(narea)
636      iabsl(:) = iabsf(:) + iloc(:) - 1
637      ihals(1) = nldi - 1
638      ihals(2) = nldj - 1
639      ihale(1) = nlci - nlei
640      ihale(2) = nlcj - nlej
641      idid(1) = 1
642      idid(2) = 2
643
644      IF(lwp) THEN
645          WRITE(numout,*)
646          WRITE(numout,*) 'mpp_init_ioipsl :   iloc  = ', iloc (1), iloc (2)
647          WRITE(numout,*) '~~~~~~~~~~~~~~~     iabsf = ', iabsf(1), iabsf(2)
648          WRITE(numout,*) '                    ihals = ', ihals(1), ihals(2)
649          WRITE(numout,*) '                    ihale = ', ihale(1), ihale(2)
650      ENDIF
651      !
652      CALL flio_dom_set ( jpnij, nproc, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom)
653      !
654   END SUBROUTINE mpp_init_ioipsl 
655
656#endif
657
658   !!======================================================================
659END MODULE mppini
Note: See TracBrowser for help on using the repository browser.