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 @ 239

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

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