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 trunk/NEMO/OPA_SRC – NEMO

source: trunk/NEMO/OPA_SRC/mppini.F90 @ 247

Last change on this file since 247 was 247, checked in by opalod, 19 years ago

CL : Add CVS Header and CeCILL licence information
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 18.4 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 sol_oce         ! ocean elliptic solver
17   USE lib_mpp         ! distribued memory computing library
18
19   IMPLICIT NONE
20   PRIVATE
21
22   !! * Routine accessibility
23   PUBLIC mpp_init       ! called by opa.F90
24   PUBLIC mpp_init2      ! called by opa.F90
25
26   !! * Substitutions
27#  include "domzgr_substitute.h90"
28   !!----------------------------------------------------------------------
29   !!   OPA 9.0 , LOCEAN-IPSL (2005)
30   !! $Header$
31   !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt
32   !!----------------------------------------------------------------------
33
34CONTAINS
35
36#if ! defined key_mpp_mpi   &&   ! defined key_mpp_shmem
37   !!----------------------------------------------------------------------
38   !!   Default option :                            shared memory computing
39   !!----------------------------------------------------------------------
40
41   SUBROUTINE mpp_init
42      !!----------------------------------------------------------------------
43      !!                  ***  ROUTINE mpp_init  ***
44      !!
45      !! ** Purpose :   Lay out the global domain over processors.
46      !!
47      !! ** Method  :   Shared memory computing, set the local processor
48      !!      variables to the value of the global domain
49      !!
50      !! History :
51      !!   9.0  !  04-01  (G. Madec, J.M. Molines)  F90 : free form, north fold jpni >1
52      !!----------------------------------------------------------------------
53      ! No mpp computation
54
55      nimpp  = 1
56      njmpp  = 1
57      nlci   = jpi
58      nlcj   = jpj
59      nldi   = 1
60      nldj   = 1
61      nlei   = jpi
62      nlej   = jpj
63      nperio = jperio
64      nbondi = 2
65      nbondj = 2
66      IF(lwp) THEN
67         WRITE(numout,*)
68         WRITE(numout,*) 'mpp_init(2) : NO massively parallel processing'
69         WRITE(numout,*) '~~~~~~~~~~~: '
70         WRITE(numout,*) '         nperio = ', nperio
71         WRITE(numout,*) '         npolj  = ', npolj
72         WRITE(numout,*) '         nimpp  = ', nimpp
73         WRITE(numout,*) '         njmpp  = ', njmpp
74      ENDIF
75
76      IF(  jpni /= 1 .OR. jpnj /= 1 .OR. jpnij /= 1 ) THEN
77          IF(lwp)WRITE(numout,cform_err)
78          IF(lwp)WRITE(numout,*) 'equality  jpni = jpnj = jpnij = 1 is not satisfied'
79          IF(lwp)WRITE(numout,*) 'the domain is lay out for distributed memory computing! '
80          nstop = nstop + 1
81      ENDIF
82
83   END SUBROUTINE mpp_init
84
85
86   SUBROUTINE mpp_init2 
87      CALL mpp_init                             ! same routine as mpp_init
88   END SUBROUTINE mpp_init2
89
90#else
91   !!----------------------------------------------------------------------
92   !!   'key_mpp_mpi'          OR         MPI massively parallel processing
93   !!   'key_mpp_shmem'                 SHMEM 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      !! * Local variables
132      INTEGER ::   ji, jj, jn               ! dummy loop indices
133      INTEGER ::   &
134         ii, ij, ifreq, il1, il2,        &  ! temporary integers
135         iresti, irestj, ijm1, imil,     &  !    "          "
136         inum                               ! temporary logical unit
137
138      INTEGER, DIMENSION(jpnij) ::       &
139         ibonit, ibonjt                     ! temporary workspace
140      INTEGER, DIMENSION(jpni,jpnj) ::   &
141         iimppt, ijmppt, ilcit, ilcjt       ! temporary workspace
142      REAL(wp) ::   zidom, zjdom            ! temporary scalars
143      !!----------------------------------------------------------------------
144
145#if defined key_mpp_shmem
146      IF(lwp) WRITE(numout,*)
147      IF(lwp) WRITE(numout,*) 'mpp_init : Message Passing PVM T3E + SHMEM'
148      IF(lwp) WRITE(numout,*) '~~~~~~~~'
149
150      CALL mppshmem                           ! Initialisation of shmem array
151
152#endif
153#if defined key_mpp_mpi
154      IF(lwp) WRITE(numout,*)
155      IF(lwp) WRITE(numout,*) 'mpp_init : Message Passing MPI'
156      IF(lwp) WRITE(numout,*) '~~~~~~~~'
157#endif
158
159
160      !  1. Dimension arrays for subdomains
161      ! -----------------------------------
162      !  Computation of local domain sizes ilcit() ilcjt()
163      !  These dimensions depend on global sizes jpni,jpnj and jpiglo,jpjglo
164      !  The subdomains are squares leeser than or equal to the global
165      !  dimensions divided by the number of processors minus the overlap
166      !  array (cf. par_oce.F90).
167     
168      nreci  = 2 * jpreci
169      nrecj  = 2 * jprecj
170      iresti = MOD( jpiglo - nreci , jpni )
171      irestj = MOD( jpjglo - nrecj , jpnj )
172
173      IF(  iresti == 0 )   iresti = jpni
174      DO jj = 1, jpnj
175         DO ji = 1, iresti
176            ilcit(ji,jj) = jpi
177         END DO
178         DO ji = iresti+1, jpni
179            ilcit(ji,jj) = jpi -1
180         END DO
181      END DO
182     
183      IF( irestj == 0 )   irestj = jpnj
184      DO ji = 1, jpni
185         DO jj = 1, irestj
186            ilcjt(ji,jj) = jpj
187         END DO
188         DO jj = irestj+1, jpnj
189            ilcjt(ji,jj) = jpj -1
190         END DO
191      END DO
192     
193      IF(lwp) THEN
194         WRITE(numout,*)
195         WRITE(numout,*) '           defines mpp subdomains'
196         WRITE(numout,*) '           ----------------------'
197         WRITE(numout,*) '              iresti=',iresti,' irestj=',irestj
198         WRITE(numout,*) '              jpni=',jpni,' jpnj=',jpnj
199         ifreq = 4
200         il1   = 1
201         DO jn = 1, (jpni-1)/ifreq+1
202            il2 = MIN( jpni, il1+ifreq-1 )
203            WRITE(numout,*)
204            WRITE(numout,9201) (ji,ji = il1,il2)
205            WRITE(numout,9200) ('***',ji = il1,il2-1)
206            DO jj = 1, jpnj
207               WRITE(numout,9203) ('   ',ji = il1,il2-1)
208               WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 )
209               WRITE(numout,9203) ('   ',ji = il1,il2-1)
210               WRITE(numout,9200) ('***',ji = il1,il2-1)
211            END DO
212            il1 = il1+ifreq
213         END DO
214 9200    FORMAT('     ***',20('*************',a3))
215 9203    FORMAT('     *     ',20('         *   ',a3))
216 9201    FORMAT('        ',20('   ',i3,'          '))
217 9202    FORMAT(' ',i3,' *  ',20(i3,'  x',i3,'   *   '))
218      ENDIF
219
220      zidom = nreci
221      DO ji = 1, jpni
222         zidom = zidom + ilcit(ji,1) - nreci
223      END DO
224      IF(lwp) WRITE(numout,*)
225      IF(lwp) WRITE(numout,*)' sum ilcit(i,1) = ', zidom, ' jpiglo = ', jpiglo
226     
227      zjdom = nrecj
228      DO jj = 1, jpnj
229         zjdom = zjdom + ilcjt(1,jj) - nrecj
230      END DO
231      IF(lwp) WRITE(numout,*)' sum ilcit(1,j) = ', zjdom, ' jpjglo = ', jpjglo
232      IF(lwp) WRITE(numout,*)
233     
234
235      !  2. Index arrays for subdomains
236      ! -------------------------------
237     
238      iimppt(:,:) = 1
239      ijmppt(:,:) = 1
240     
241      IF( jpni > 1 ) THEN
242         DO jj = 1, jpnj
243            DO ji = 2, jpni
244               iimppt(ji,jj) = iimppt(ji-1,jj) + ilcit(ji-1,jj) - nreci
245            END DO
246         END DO
247      ENDIF
248
249      IF( jpnj > 1 ) THEN
250         DO jj = 2, jpnj
251            DO ji = 1, jpni
252               ijmppt(ji,jj) = ijmppt(ji,jj-1)+ilcjt(ji,jj-1)-nrecj
253            END DO
254         END DO
255      ENDIF
256     
257      ! 3. Subdomain description
258      ! ------------------------
259
260      DO jn = 1, jpnij
261         ii = 1 + MOD( jn-1, jpni )
262         ij = 1 + (jn-1) / jpni
263         nimppt(jn) = iimppt(ii,ij)
264         njmppt(jn) = ijmppt(ii,ij)
265         nlcit (jn) = ilcit (ii,ij)     
266         nlci       = nlcit (jn)     
267         nlcjt (jn) = ilcjt (ii,ij)     
268         nlcj       = nlcjt (jn)
269         nbondj = -1                                   ! general case
270         IF( jn   >  jpni          )   nbondj = 0      ! first row of processor
271         IF( jn   >  (jpnj-1)*jpni )   nbondj = 1      ! last  row of processor
272         IF( jpnj == 1             )   nbondj = 2      ! one processor only in j-direction
273         ibonjt(jn) = nbondj
274         
275         nbondi = 0                                    !
276         IF( MOD( jn, jpni ) == 1 )   nbondi = -1      !
277         IF( MOD( jn, jpni ) == 0 )   nbondi =  1      !
278         IF( jpni            == 1 )   nbondi =  2      ! one processor only in i-direction
279         ibonit(jn) = nbondi
280         
281         nldi =  1   + jpreci
282         nlei = nlci - jpreci
283         IF( nbondi == -1 .OR. nbondi == 2 )   nldi = 1
284         IF( nbondi ==  1 .OR. nbondi == 2 )   nlei = nlci
285         nldj =  1   + jprecj
286         nlej = nlcj - jprecj
287         IF( nbondj == -1 .OR. nbondj == 2 )   nldj = 1
288         IF( nbondj ==  1 .OR. nbondj == 2 )   nlej = nlcj
289         nldit(jn) = nldi
290         nleit(jn) = nlei
291         nldjt(jn) = nldj
292         nlejt(jn) = nlej
293      END DO
294     
295
296      ! 4. From global to local
297      ! -----------------------
298
299      nperio = 0
300      IF( jperio == 2 .AND. nbondj == -1 )   nperio = 2
301
302
303      ! 5. Subdomain neighbours
304      ! ----------------------
305
306      nproc = narea - 1
307      noso  = nproc - jpni
308      nowe  = nproc - 1
309      noea  = nproc + 1
310      nono  = nproc + jpni
311      ! great neighbours
312      npnw = nono - 1
313      npne = nono + 1
314      npsw = noso - 1
315      npse = noso + 1
316      nbsw = 1
317      nbnw = 1
318      IF( MOD( nproc, jpni ) == 0 ) THEN
319         nbsw = 0
320         nbnw = 0
321      ENDIF
322      nbse = 1
323      nbne = 1
324      IF( MOD( nproc, jpni ) == jpni-1 ) THEN
325         nbse = 0
326         nbne = 0
327      ENDIF
328      IF(nproc < jpni) THEN
329         nbsw = 0
330         nbse = 0
331      ENDIF
332      IF( nproc >= (jpnj-1)*jpni ) THEN
333         nbnw = 0
334         nbne = 0
335      ENDIF
336      nlcj = nlcjt(narea) 
337      nlci = nlcit(narea) 
338      nldi = nldit(narea)
339      nlei = nleit(narea)
340      nldj = nldjt(narea)
341      nlej = nlejt(narea)
342      nbondi = ibonit(narea)
343      nbondj = ibonjt(narea)
344      nimpp  = nimppt(narea) 
345      njmpp  = njmppt(narea) 
346
347     ! Save processor layout in layout.dat file
348       IF (lwp) THEN
349        inum = 11   
350
351        OPEN(inum,FILE='layout.dat')
352        WRITE(inum,'(6i8)') jpnij,jpi,jpj,jpk,jpiglo,jpjglo
353        WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimpp njmpp'
354
355        DO  jn = 1, jpnij
356         WRITE(inum,'(9i5)') jn, nlcit(jn), nlcjt(jn), &
357                                      nldit(jn), nldjt(jn), &
358                                      nleit(jn), nlejt(jn), &
359                                      nimppt(jn), njmppt(jn)
360        END DO
361        CLOSE(inum)   
362      END IF
363
364
365      ! w a r n i n g  narea (zone) /= nproc (processors)!
366
367      IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 ) THEN
368         IF( jpni == 1 )THEN
369            nbondi = 2
370            nperio = 1
371         ELSE
372            nbondi = 0
373         ENDIF
374         IF( MOD( narea, jpni ) == 0 ) THEN
375            noea = nproc-(jpni-1)
376            npne = npne-jpni
377            npse = npse-jpni
378         ENDIF
379         IF( MOD( narea, jpni ) == 1 ) THEN
380            nowe = nproc+(jpni-1)
381            npnw = npnw+jpni
382            npsw = npsw+jpni
383         ENDIF
384         nbsw = 1
385         nbnw = 1
386         nbse = 1
387         nbne = 1
388         IF( nproc < jpni ) THEN
389            nbsw = 0
390            nbse = 0
391         ENDIF
392         IF( nproc >= (jpnj-1)*jpni ) THEN
393            nbnw = 0
394            nbne = 0
395         ENDIF
396      ENDIF
397      npolj = 0
398      IF( jperio == 3 .OR. jperio == 4 ) THEN
399         ijm1 = jpni*(jpnj-1)
400         imil = ijm1+(jpni+1)/2
401         IF( narea > ijm1 ) npolj = 3
402         IF( MOD(jpni,2) == 1 .AND. narea == imil ) npolj = 4
403         IF( npolj == 3 ) nono = jpni*jpnj-narea+ijm1
404      ENDIF
405      IF( jperio == 5 .OR. jperio == 6 ) THEN
406          ijm1 = jpni*(jpnj-1)
407          imil = ijm1+(jpni+1)/2
408          IF( narea > ijm1) npolj = 5
409          IF( MOD(jpni,2) == 1 .AND. narea == imil ) npolj = 6
410          IF( npolj == 5 ) nono = jpni*jpnj-narea+ijm1
411      ENDIF
412
413      ! FETI method
414
415      IF( nperio == 1 .AND. nsolv == 3 ) THEN 
416         
417         ! general case : Earth == infinite tube
418         
419         nbnw = 1
420         npnw = narea
421         nbne = 1
422         npne = narea
423         nbsw = 1
424         npsw = (narea-2)
425         nbse = 1
426         npse = (narea-2)
427         
428         ! REAL boundary condition
429         
430         IF( nbondj == -1 .OR. nbondj == 2 ) THEN
431            nbsw = 0
432            nbse = 0
433         ENDIF
434         
435         IF( nbondj == -1 .OR. nbondj == 2 ) THEN
436            nbsw = 0
437            nbse = 0
438         ENDIF
439         
440         IF( nbondj == 1  .OR. nbondj == 2 ) THEN
441            nbnw = 0
442            nbne = 0
443         ENDIF
444      ENDIF
445
446      ! Periodicity : no corner if nbondi = 2 and nperio != 1
447
448      IF(lwp) THEN
449         WRITE(numout,*) ' nproc  = ', nproc
450         WRITE(numout,*) ' nowe   = ', nowe  , ' noea   =  ', noea
451         WRITE(numout,*) ' nono   = ', nono  , ' noso   =  ', noso
452         WRITE(numout,*) ' nbondi = ', nbondi
453         WRITE(numout,*) ' nbondj = ', nbondj
454         WRITE(numout,*) ' npolj  = ', npolj
455         WRITE(numout,*) ' nperio = ', nperio
456         WRITE(numout,*) ' nlci   = ', nlci
457         WRITE(numout,*) ' nlcj   = ', nlcj
458         WRITE(numout,*) ' nimpp  = ', nimpp
459         WRITE(numout,*) ' njmpp  = ', njmpp
460         WRITE(numout,*) ' nbse   = ', nbse  , ' npse   = ', npse
461         WRITE(numout,*) ' nbsw   = ', nbsw  , ' npsw   = ', npsw
462         WRITE(numout,*) ' nbne   = ', nbne  , ' npne   = ', npne
463         WRITE(numout,*) ' nbnw   = ', nbnw  , ' npnw   = ', npnw
464      ENDIF
465
466      IF( nperio == 1 .AND. jpni /= 1 )THEN
467         IF(lwp) WRITE(numout,cform_err)
468         IF(lwp) WRITE(numout,*) ' mpp_init: error on cyclicity'
469         nstop = nstop + 1
470      ENDIF
471
472      ! Prepare mpp north fold
473
474      IF (jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN
475         CALL mpp_ini_north
476      END IF
477
478      ! Prepare NetCDF output file (if necessary)
479      CALL mpp_init_ioipsl
480
481   END SUBROUTINE mpp_init
482
483#  include "mppini_2.h90"
484
485# if defined key_dimgout
486   !!----------------------------------------------------------------------
487   !!   'key_dimgout'                  NO use of NetCDF files
488   !!----------------------------------------------------------------------
489   SUBROUTINE mpp_init_ioipsl       ! Dummy routine
490   END SUBROUTINE mpp_init_ioipsl 
491# else
492   SUBROUTINE mpp_init_ioipsl
493      !!----------------------------------------------------------------------
494      !!                  ***  ROUTINE mpp_init_ioipsl  ***
495      !!
496      !! ** Purpose :   
497      !!
498      !! ** Method  :   
499      !!
500      !! History :
501      !!   9.0  !  04-03  (G. Madec)  MPP-IOIPSL
502      !!----------------------------------------------------------------------
503      USE ioipsl
504      INTEGER, DIMENSION(4) ::   &
505         iglo, iloc, iabsf, iabsl, ihals, ihale   ! ???
506      !!----------------------------------------------------------------------
507      iglo(1) = jpiglo
508      iglo(2) = jpjglo
509      iglo(3) = jpk
510      iglo(4) = 1
511      iloc(1) = nlci
512      iloc(2) = nlcj
513      iloc(3) = jpk
514      iloc(4) = 1
515      iabsf(1) = nimppt(narea)
516      iabsf(2) = njmppt(narea)
517      iabsf(3) = 1
518      iabsf(4) = 1
519      iabsl(:) = iabsf(:) + iloc(:) - 1
520      ihals(1) = jpreci
521      ihals(2) = jprecj
522      ihals(3) = 0
523      ihals(4) = 0
524      ihale(1) = jpreci
525      ihale(2) = jprecj
526      ihale(3) = 0
527      ihale(4) = 0
528      IF( nbondi == -1 .OR. nbondi == 2 )   ihals(1) = 0
529      IF( nbondi ==  1 .OR. nbondi == 2 )   ihale(1) = 0
530      IF( nbondj == -1 .OR. nbondj == 2 )   ihals(2) = 0
531      IF( nbondj ==  1 .OR. nbondj == 2 )   ihale(2) = 0
532      IF(lwp) THEN
533          WRITE(numout,*) 'mpp_init_ioipsl :   iloc  = ', iloc (1), iloc (2), iloc (3), iloc (4)
534          WRITE(numout,*) '~~~~~~~~~~~~~~~     iabsf = ', iabsf(1), iabsf(2), iabsf(3), iabsf(4)
535          WRITE(numout,*) '                    ihals = ', ihals(1), ihals(2), ihals(3), ihals(4)
536          WRITE(numout,*) '                    ihale = ', ihale(1), ihale(2), ihale(3), ihale(4)
537      ENDIF
538
539      CALL ioipsl_inimpp( jpnij, nproc, iglo, iloc, iabsf, iabsl, ihals, ihale )
540
541   END SUBROUTINE mpp_init_ioipsl 
542
543# endif
544#endif
545
546   !!======================================================================
547END MODULE mppini
Note: See TracBrowser for help on using the repository browser.