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/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

source: branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90 @ 3211

Last change on this file since 3211 was 3211, checked in by spickles2, 12 years ago

Stephen Pickles, 11 Dec 2011

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