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.
prtctl.F90 in branches/nemo_v3_3_beta/NEMOGCM/NEMO/OPA_SRC/IOM – NEMO

source: branches/nemo_v3_3_beta/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90 @ 2281

Last change on this file since 2281 was 2281, checked in by smasson, 14 years ago

set proper svn properties to all files...
  • Property svn:keywords set to Id
File size: 23.3 KB
Line 
1MODULE prtctl
2   !!==============================================================================
3   !!                       ***  MODULE prtctl   ***
4   !! Ocean system   : print all SUM trends for each processor domain
5   !!==============================================================================
6   USE dom_oce          ! ocean space and time domain variables
7   USE in_out_manager   ! I/O manager
8   USE lib_mpp          ! distributed memory computing
9
10   IMPLICIT NONE
11   PRIVATE
12
13   !! * Module declaration
14   INTEGER, DIMENSION(:), ALLOCATABLE :: numid
15   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   &  !:
16      nlditl , nldjtl ,   &  !: first, last indoor index for each i-domain
17      nleitl , nlejtl ,   &  !: first, last indoor index for each j-domain
18      nimpptl, njmpptl,   &  !: i-, j-indexes for each processor
19      nlcitl , nlcjtl ,   &  !: dimensions of every subdomain
20      ibonitl, ibonjtl
21
22   REAL(wp), DIMENSION(:), ALLOCATABLE ::   &  !:
23      t_ctll , s_ctll ,   &  !: previous trend values
24      u_ctll , v_ctll
25
26   INTEGER ::   ktime        !: time step
27
28   !! * Routine accessibility
29   PUBLIC prt_ctl         ! called by all subroutines
30   PUBLIC prt_ctl_info    ! called by all subroutines
31   PUBLIC prt_ctl_init    ! called by opa.F90
32   !!----------------------------------------------------------------------
33   !!   OPA 9.0 , LOCEAN-IPSL (2005)
34   !! $Id$
35   !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt
36   !!----------------------------------------------------------------------
37
38
39CONTAINS
40
41   SUBROUTINE prt_ctl (tab2d_1, tab3d_1, mask1, clinfo1, tab2d_2, tab3d_2, mask2, clinfo2, ovlap, kdim, clinfo3)
42      !!----------------------------------------------------------------------
43      !!                     ***  ROUTINE prt_ctl  ***
44      !!
45      !! ** Purpose : - print sum control of 2D or 3D arrays over the same area
46      !!                in mono and mpp case. This way can be usefull when
47      !!                debugging a new parametrization in mono or mpp.
48      !!
49      !! ** Method  : 2 possibilities exist when setting the ln_ctl parameter to
50      !!                .true. in the ocean namelist:
51      !!              - to debug a MPI run .vs. a mono-processor one;
52      !!                the control print will be done over each sub-domain.
53      !!                The nictl[se] and njctl[se] parameters in the namelist must
54      !!                be set to zero and [ij]splt to the corresponding splitted
55      !!                domain in MPI along respectively i-, j- directions.
56      !!              - to debug a mono-processor run over the whole domain/a specific area;
57      !!                in the first case the nictl[se] and njctl[se] parameters must be set
58      !!                to zero else to the indices of the area to be controled. In both cases
59      !!                isplt and jsplt must be set to 1.
60      !!              - All arguments of the above calling sequence are optional so their
61      !!                name must be explicitly typed if used. For instance if the 3D
62      !!                array tn(:,:,:) must be passed through the prt_ctl subroutine,
63      !!                it must looks like: CALL prt_ctl(tab3d_1=tn).
64      !!
65      !!                    tab2d_1 : first 2D array
66      !!                    tab3d_1 : first 3D array
67      !!                    mask1   : mask (3D) to apply to the tab[23]d_1 array
68      !!                    clinfo1 : information about the tab[23]d_1 array
69      !!                    tab2d_2 : second 2D array
70      !!                    tab3d_2 : second 3D array
71      !!                    mask2   : mask (3D) to apply to the tab[23]d_2 array
72      !!                    clinfo2 : information about the tab[23]d_2 array
73      !!                    ovlap   : overlap value
74      !!                    kdim    : k- direction for 3D arrays
75      !!                    clinfo3 : additional information
76      !!
77      !! History :
78      !!   9.0  !  05-07  (C. Talandier) original code
79      !!----------------------------------------------------------------------
80      !! * Arguments
81      REAL(wp), DIMENSION(:,:)  , INTENT(in), OPTIONAL :: tab2d_1
82      REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: tab3d_1
83      REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask1
84      CHARACTER (len=*)         , INTENT(in), OPTIONAL :: clinfo1
85      REAL(wp), DIMENSION(:,:)  , INTENT(in), OPTIONAL :: tab2d_2
86      REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: tab3d_2
87      REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask2
88      CHARACTER (len=*)         , INTENT(in), OPTIONAL :: clinfo2
89      INTEGER                   , INTENT(in), OPTIONAL :: ovlap
90      INTEGER                   , INTENT(in), OPTIONAL :: kdim
91      CHARACTER (len=*)         , INTENT(in), OPTIONAL :: clinfo3
92
93      !! * Local declarations
94      INTEGER :: overlap, jn, sind, eind, kdir,j_id
95      CHARACTER (len=15) :: cl2
96      REAL(wp) :: zsum1, zsum2, zvctl1, zvctl2
97      REAL(wp), DIMENSION(jpi,jpj) :: ztab2d_1, ztab2d_2
98      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask1, zmask2, ztab3d_1, ztab3d_2
99      !!----------------------------------------------------------------------
100
101      ! Arrays, scalars initialization
102      overlap   = 0
103      kdir      = jpkm1
104      cl2       = ''
105      zsum1     = 0.e0
106      zsum2     = 0.e0
107      zvctl1    = 0.e0
108      zvctl2    = 0.e0
109      ztab2d_1(:,:)   = 0.e0
110      ztab2d_2(:,:)   = 0.e0
111      ztab3d_1(:,:,:) = 0.e0
112      ztab3d_2(:,:,:) = 0.e0
113      zmask1  (:,:,:) = 1.e0
114      zmask2  (:,:,:) = 1.e0
115
116      ! Control of optional arguments
117      IF( PRESENT(clinfo2) )  cl2            = clinfo2
118      IF( PRESENT(ovlap)   )  overlap        = ovlap
119      IF( PRESENT(kdim)    )  kdir           = kdim
120      IF( PRESENT(tab2d_1) )  ztab2d_1(:,:)  = tab2d_1(:,:)
121      IF( PRESENT(tab2d_2) )  ztab2d_2(:,:)  = tab2d_2(:,:)
122      IF( PRESENT(tab3d_1) )  ztab3d_1(:,:,1:kdir)= tab3d_1(:,:,:)
123      IF( PRESENT(tab3d_2) )  ztab3d_2(:,:,1:kdir)= tab3d_2(:,:,:)
124      IF( PRESENT(mask1)   )  zmask1  (:,:,:)= mask1  (:,:,:)
125      IF( PRESENT(mask2)   )  zmask2  (:,:,:)= mask2  (:,:,:)
126
127      IF( lk_mpp )   THEN
128         ! processor number
129         sind = narea
130         eind = narea
131      ELSE
132         ! processors total number
133         sind = 1
134         eind = ijsplt
135      ENDIF
136
137      ! Loop over each sub-domain, i.e. the total number of processors ijsplt
138      DO jn = sind, eind
139         ! Set logical unit
140         j_id = numid(jn - narea + 1)
141         ! Set indices for the SUM control
142         IF( .NOT. lsp_area ) THEN
143            IF (lk_mpp )   THEN
144               nictls = MAX( 1, nlditl(jn) - overlap )
145               nictle = nleitl(jn) + overlap * MIN( 1, nlcitl(jn) - nleitl(jn)) 
146               njctls = MAX( 1, nldjtl(jn) - overlap )
147               njctle = nlejtl(jn) + overlap * MIN( 1, nlcjtl(jn) - nlejtl(jn))
148               ! Do not take into account the bound of the domain
149               IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls)
150               IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls)
151               IF( ibonitl(jn) ==  1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nleitl(jn) - 1)
152               IF( ibonjtl(jn) ==  1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, nlejtl(jn) - 1)
153            ELSE
154               nictls = MAX( 1, nimpptl(jn) + nlditl(jn) - 1 - overlap )
155               nictle = nimpptl(jn) + nleitl(jn) - 1 + overlap * MIN( 1, nlcitl(jn) - nleitl(jn) ) 
156               njctls = MAX( 1, njmpptl(jn) + nldjtl(jn) - 1 - overlap )
157               njctle = njmpptl(jn) + nlejtl(jn) - 1 + overlap * MIN( 1, nlcjtl(jn) - nlejtl(jn) ) 
158               ! Do not take into account the bound of the domain
159               IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls)
160               IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls)
161               IF( ibonitl(jn) ==  1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nimpptl(jn) + nleitl(jn) - 2)
162               IF( ibonjtl(jn) ==  1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, njmpptl(jn) + nlejtl(jn) - 2)
163            ENDIF
164         ENDIF
165
166         IF ( clinfo3 == 'tra' )  THEN
167             zvctl1 = t_ctll(jn)
168             zvctl2 = s_ctll(jn)
169         ELSEIF ( clinfo3 == 'dyn' )   THEN
170             zvctl1 = u_ctll(jn)
171             zvctl2 = v_ctll(jn)
172         ENDIF
173
174         ! Compute the sum control
175         ! 2D arrays
176         IF( PRESENT(tab2d_1) )   THEN
177            zsum1 = SUM( ztab2d_1(nictls:nictle,njctls:njctle)*zmask1(nictls:nictle,njctls:njctle,1) )
178            zsum2 = SUM( ztab2d_2(nictls:nictle,njctls:njctle)*zmask2(nictls:nictle,njctls:njctle,1) )
179         ENDIF
180
181         ! 3D arrays
182         IF( PRESENT(tab3d_1) )   THEN
183            zsum1 = SUM( ztab3d_1(nictls:nictle,njctls:njctle,1:kdir)*zmask1(nictls:nictle,njctls:njctle,1:kdir) )
184            zsum2 = SUM( ztab3d_2(nictls:nictle,njctls:njctle,1:kdir)*zmask2(nictls:nictle,njctls:njctle,1:kdir) )
185         ENDIF
186
187         ! Print the result
188         IF( PRESENT(clinfo3) )   THEN
189            WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1-zvctl1, cl2, zsum2-zvctl2
190            SELECT CASE( clinfo3 )
191            CASE ( 'tra-ta' ) 
192               t_ctll(jn) = zsum1
193            CASE ( 'tra' ) 
194                t_ctll(jn) = zsum1
195                s_ctll(jn) = zsum2
196            CASE ( 'dyn' ) 
197                u_ctll(jn) = zsum1
198                v_ctll(jn) = zsum2 
199            END SELECT
200         ELSEIF ( PRESENT(clinfo2) .OR. PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) )   THEN
201            WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1, cl2, zsum2
202         ELSE
203            WRITE(j_id,FMT='(a,D23.16)')clinfo1, zsum1
204         ENDIF
205
206      ENDDO
207
208   END SUBROUTINE prt_ctl
209
210
211   SUBROUTINE prt_ctl_info (clinfo1, ivar1, clinfo2, ivar2, itime)
212      !!----------------------------------------------------------------------
213      !!                     ***  ROUTINE prt_ctl_info  ***
214      !!
215      !! ** Purpose : - print information without any computation
216      !!
217      !! ** Action  : - input arguments
218      !!                    clinfo1 : information about the ivar1
219      !!                    ivar1   : value to print
220      !!                    clinfo2 : information about the ivar2
221      !!                    ivar2   : value to print
222      !!
223      !! History :
224      !!   9.0  !  05-07  (C. Talandier) original code
225      !!----------------------------------------------------------------------
226      !! * Arguments
227      CHARACTER (len=*), INTENT(in) ::   clinfo1
228      INTEGER          , INTENT(in), OPTIONAL ::   ivar1
229      CHARACTER (len=*), INTENT(in), OPTIONAL ::   clinfo2
230      INTEGER          , INTENT(in), OPTIONAL ::   ivar2
231      INTEGER          , INTENT(in), OPTIONAL ::   itime
232
233      !! * Local declarations
234      INTEGER :: jn, sind, eind, iltime, j_id
235      !!----------------------------------------------------------------------
236
237      IF( lk_mpp )   THEN
238         ! processor number
239         sind = narea
240         eind = narea
241      ELSE
242         ! total number of processors
243         sind = 1
244         eind = ijsplt
245      ENDIF
246
247      ! Set to zero arrays at each new time step
248      IF( PRESENT(itime) )   THEN
249         iltime = itime
250         IF( iltime > ktime )   THEN
251            t_ctll(:) = 0.e0   ;   s_ctll(:) = 0.e0
252            u_ctll(:) = 0.e0   ;   v_ctll(:) = 0.e0
253            ktime = iltime
254         ENDIF
255      ENDIF
256
257      ! Loop over each sub-domain, i.e. number of processors ijsplt
258      DO jn = sind, eind
259         
260         ! Set logical unit
261         j_id = numid(jn - narea + 1)
262
263         IF( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. PRESENT(ivar2) )   THEN
264            WRITE(j_id,*)clinfo1, ivar1, clinfo2, ivar2
265         ELSEIF ( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) )   THEN
266            WRITE(j_id,*)clinfo1, ivar1, clinfo2
267         ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. PRESENT(ivar2) )   THEN
268            WRITE(j_id,*)clinfo1, ivar1, ivar2
269         ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) )   THEN
270            WRITE(j_id,*)clinfo1, ivar1
271         ELSE
272            WRITE(j_id,*)clinfo1
273         ENDIF
274
275      ENDDO
276
277
278      END SUBROUTINE prt_ctl_info
279
280   SUBROUTINE prt_ctl_init
281      !!----------------------------------------------------------------------
282      !!                     ***  ROUTINE prt_ctl_init  ***
283      !!
284      !! ** Purpose :   open ASCII files & compute indices
285      !!
286      !! History :
287      !!   9.0  !  05-07  (C. Talandier) original code
288      !!----------------------------------------------------------------------
289      !! * Local declarations
290      INTEGER ::   jn, sind, eind, j_id
291      CHARACTER (len=28) :: clfile_out
292      CHARACTER (len=23) :: clb_name
293      CHARACTER (len=19) :: cl_run
294      !!----------------------------------------------------------------------
295
296      ! Allocate arrays
297      ALLOCATE(nlditl (ijsplt))
298      ALLOCATE(nldjtl (ijsplt))
299      ALLOCATE(nleitl (ijsplt))
300      ALLOCATE(nlejtl (ijsplt))
301      ALLOCATE(nimpptl(ijsplt))
302      ALLOCATE(njmpptl(ijsplt))
303      ALLOCATE(nlcitl (ijsplt))
304      ALLOCATE(nlcjtl (ijsplt))
305      ALLOCATE(t_ctll (ijsplt))
306      ALLOCATE(s_ctll (ijsplt))
307      ALLOCATE(u_ctll (ijsplt))
308      ALLOCATE(v_ctll (ijsplt))
309      ALLOCATE(ibonitl(ijsplt))
310      ALLOCATE(ibonjtl(ijsplt))
311
312      ! Initialization
313      t_ctll(:)=0.e0
314      s_ctll(:)=0.e0
315      u_ctll(:)=0.e0
316      v_ctll(:)=0.e0
317      ktime = 1
318
319      IF( lk_mpp ) THEN
320         sind = narea
321         eind = narea
322         clb_name = "('mpp.output_',I4.4)"
323         cl_run = 'MULTI processor run'
324         ! use indices for each area computed by mpp_init subroutine
325         nlditl(:) = nldit(:) 
326         nleitl(:) = nleit(:) 
327         nldjtl(:) = nldjt(:) 
328         nlejtl(:) = nlejt(:) 
329         !
330         nimpptl(:) = nimppt(:)
331         njmpptl(:) = njmppt(:)
332         !
333         nlcitl(:) = nlcit(:)
334         nlcjtl(:) = nlcjt(:)
335         !
336         ibonitl(:) = ibonit(:)
337         ibonjtl(:) = ibonjt(:)
338      ELSE
339         sind = 1
340         eind = ijsplt
341         clb_name = "('mono.output_',I4.4)"
342         cl_run = 'MONO processor run '
343         ! compute indices for each area as done in mpp_init subroutine
344         CALL sub_dom
345      ENDIF
346
347      ALLOCATE(numid(eind-sind+1))
348
349      DO jn = sind, eind
350         WRITE(clfile_out,FMT=clb_name) jn-1
351         CALL ctl_opn( numid(jn -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', 1, numout, .FALSE. )
352         j_id = numid(jn -narea + 1)
353         WRITE(j_id,*)
354         WRITE(j_id,*) '                 L O D Y C - I P S L'
355         WRITE(j_id,*) '                     O P A model'
356         WRITE(j_id,*) '            Ocean General Circulation Model'
357         WRITE(j_id,*) '               version OPA 9.0  (2005) '
358         WRITE(j_id,*)
359         WRITE(j_id,*) '                   PROC number: ', jn
360         WRITE(j_id,*)
361         WRITE(j_id,FMT="(19x,a20)")cl_run
362
363         ! Print the SUM control indices
364         IF( .NOT. lsp_area )   THEN
365            nictls = nimpptl(jn) + nlditl(jn) - 1
366            nictle = nimpptl(jn) + nleitl(jn) - 1
367            njctls = njmpptl(jn) + nldjtl(jn) - 1
368            njctle = njmpptl(jn) + nlejtl(jn) - 1
369         ENDIF
370         WRITE(j_id,*) 
371         WRITE(j_id,*) 'prt_ctl :  Sum control indices'
372         WRITE(j_id,*) '~~~~~~~'
373         WRITE(j_id,*)
374         WRITE(j_id,9000)'                                nlej   = ', nlejtl(jn), '              '
375         WRITE(j_id,9000)'                  ------------- njctle = ', njctle, ' -------------'
376         WRITE(j_id,9001)'                  |                                       |'
377         WRITE(j_id,9001)'                  |                                       |'
378         WRITE(j_id,9001)'                  |                                       |'
379         WRITE(j_id,9002)'           nictls = ', nictls,  '                           nictle = ', nictle
380         WRITE(j_id,9002)'           nldi   = ', nlditl(jn),  '                           nlei   = ', nleitl(jn)
381         WRITE(j_id,9001)'                  |                                       |'
382         WRITE(j_id,9001)'                  |                                       |'
383         WRITE(j_id,9001)'                  |                                       |'
384         WRITE(j_id,9004)'  njmpp  = ',njmpptl(jn),'   ------------- njctls = ', njctls, ' -------------'
385         WRITE(j_id,9003)'           nimpp  = ', nimpptl(jn), '        nldj   = ', nldjtl(jn), '              '
386         WRITE(j_id,*)
387         WRITE(j_id,*)
388
3899000     FORMAT(a41,i4.4,a14)
3909001     FORMAT(a59)
3919002     FORMAT(a20,i4.4,a36,i3.3)
3929003     FORMAT(a20,i4.4,a17,i4.4)
3939004     FORMAT(a11,i4.4,a26,i4.4,a14)
394      ENDDO
395
396   END SUBROUTINE prt_ctl_init
397
398
399   SUBROUTINE sub_dom
400      !!----------------------------------------------------------------------
401      !!                  ***  ROUTINE sub_dom  ***
402      !!                   
403      !! ** Purpose :   Lay out the global domain over processors.
404      !!                CAUTION:
405      !!                This part has been extracted from the mpp_init
406      !!                subroutine and names of variables/arrays have been
407      !!                slightly changed to avoid confusion but the computation
408      !!                is exactly the same. Any modification about indices of
409      !!                each sub-domain in the mppini.F90 module should be reported
410      !!                here.
411      !!
412      !! ** Method  :   Global domain is distributed in smaller local domains.
413      !!                Periodic condition is a function of the local domain position
414      !!                (global boundary or neighbouring domain) and of the global
415      !!                periodic
416      !!                Type :         jperio global periodic condition
417      !!                               nperio local  periodic condition
418      !!
419      !! ** Action  : - set domain parameters
420      !!                    nimpp     : longitudinal index
421      !!                    njmpp     : latitudinal  index
422      !!                    nperio    : lateral condition type
423      !!                    narea     : number for local area
424      !!                    nlcil      : first dimension
425      !!                    nlcjl      : second dimension
426      !!                    nbondil    : mark for "east-west local boundary"
427      !!                    nbondjl    : mark for "north-south local boundary"
428      !!
429      !! History :
430      !!        !  94-11  (M. Guyon)  Original code
431      !!        !  95-04  (J. Escobar, M. Imbard)
432      !!        !  98-02  (M. Guyon)  FETI method
433      !!        !  98-05  (M. Imbard, J. Escobar, L. Colombet )  SHMEM and MPI versions
434      !!   8.5  !  02-08  (G. Madec)  F90 : free form
435      !!----------------------------------------------------------------------
436      !! * Local variables
437      INTEGER ::   ji, jj, jn               ! dummy loop indices
438      INTEGER ::   &
439         ii, ij,                         &  ! temporary integers
440         irestil, irestjl,               &  !    "          "
441         ijpi  , ijpj, nlcil,            &  ! temporary logical unit
442         nlcjl , nbondil, nbondjl,       &
443         nrecil, nrecjl, nldil, nleil, nldjl, nlejl
444
445      INTEGER, DIMENSION(:,:), ALLOCATABLE ::   &
446         iimpptl, ijmpptl, ilcitl, ilcjtl       ! temporary workspace
447      REAL(wp) ::   zidom, zjdom            ! temporary scalars
448      !!----------------------------------------------------------------------
449
450      !  1. Dimension arrays for subdomains
451      ! -----------------------------------
452      !  Computation of local domain sizes ilcitl() ilcjtl()
453      !  These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo
454      !  The subdomains are squares leeser than or equal to the global
455      !  dimensions divided by the number of processors minus the overlap
456      !  array (cf. par_oce.F90).
457
458      ijpi = ( jpiglo-2*jpreci + (isplt-1) ) / isplt + 2*jpreci
459      ijpj = ( jpjglo-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj
460
461      ALLOCATE(ilcitl (isplt,jsplt))
462      ALLOCATE(ilcjtl (isplt,jsplt))
463
464      nrecil  = 2 * jpreci
465      nrecjl  = 2 * jprecj
466      irestil = MOD( jpiglo - nrecil , isplt )
467      irestjl = MOD( jpjglo - nrecjl , jsplt )
468
469      IF(  irestil == 0 )   irestil = isplt
470      DO jj = 1, jsplt
471         DO ji = 1, irestil
472            ilcitl(ji,jj) = ijpi
473         END DO
474         DO ji = irestil+1, isplt
475            ilcitl(ji,jj) = ijpi -1
476         END DO
477      END DO
478     
479      IF( irestjl == 0 )   irestjl = jsplt
480      DO ji = 1, isplt
481         DO jj = 1, irestjl
482            ilcjtl(ji,jj) = ijpj
483         END DO
484         DO jj = irestjl+1, jsplt
485            ilcjtl(ji,jj) = ijpj -1
486         END DO
487      END DO
488     
489      zidom = nrecil
490      DO ji = 1, isplt
491         zidom = zidom + ilcitl(ji,1) - nrecil
492      END DO
493      IF(lwp) WRITE(numout,*)
494      IF(lwp) WRITE(numout,*)' sum ilcitl(i,1) = ', zidom, ' jpiglo = ', jpiglo
495     
496      zjdom = nrecjl
497      DO jj = 1, jsplt
498         zjdom = zjdom + ilcjtl(1,jj) - nrecjl
499      END DO
500      IF(lwp) WRITE(numout,*)' sum ilcitl(1,j) = ', zjdom, ' jpjglo = ', jpjglo
501      IF(lwp) WRITE(numout,*)
502     
503
504      !  2. Index arrays for subdomains
505      ! -------------------------------
506
507      ALLOCATE(iimpptl(isplt,jsplt))
508      ALLOCATE(ijmpptl(isplt,jsplt))
509     
510      iimpptl(:,:) = 1
511      ijmpptl(:,:) = 1
512     
513      IF( isplt > 1 ) THEN
514         DO jj = 1, jsplt
515            DO ji = 2, isplt
516               iimpptl(ji,jj) = iimpptl(ji-1,jj) + ilcitl(ji-1,jj) - nrecil
517            END DO
518         END DO
519      ENDIF
520
521      IF( jsplt > 1 ) THEN
522         DO jj = 2, jsplt
523            DO ji = 1, isplt
524               ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ilcjtl(ji,jj-1)-nrecjl
525            END DO
526         END DO
527      ENDIF
528     
529      ! 3. Subdomain description
530      ! ------------------------
531
532      DO jn = 1, ijsplt
533         ii = 1 + MOD( jn-1, isplt )
534         ij = 1 + (jn-1) / isplt
535         nimpptl(jn) = iimpptl(ii,ij)
536         njmpptl(jn) = ijmpptl(ii,ij)
537         nlcitl (jn) = ilcitl (ii,ij)     
538         nlcil       = nlcitl (jn)     
539         nlcjtl (jn) = ilcjtl (ii,ij)     
540         nlcjl       = nlcjtl (jn)
541         nbondjl = -1                                    ! general case
542         IF( jn   >  isplt          )   nbondjl = 0      ! first row of processor
543         IF( jn   >  (jsplt-1)*isplt )  nbondjl = 1     ! last  row of processor
544         IF( jsplt == 1             )   nbondjl = 2      ! one processor only in j-direction
545         ibonjtl(jn) = nbondjl
546         
547         nbondil = 0                                     !
548         IF( MOD( jn, isplt ) == 1 )   nbondil = -1      !
549         IF( MOD( jn, isplt ) == 0 )   nbondil =  1      !
550         IF( isplt            == 1 )   nbondil =  2      ! one processor only in i-direction
551         ibonitl(jn) = nbondil
552         
553         nldil =  1   + jpreci
554         nleil = nlcil - jpreci
555         IF( nbondil == -1 .OR. nbondil == 2 )   nldil = 1
556         IF( nbondil ==  1 .OR. nbondil == 2 )   nleil = nlcil
557         nldjl =  1   + jprecj
558         nlejl = nlcjl - jprecj
559         IF( nbondjl == -1 .OR. nbondjl == 2 )   nldjl = 1
560         IF( nbondjl ==  1 .OR. nbondjl == 2 )   nlejl = nlcjl
561         nlditl(jn) = nldil
562         nleitl(jn) = nleil
563         nldjtl(jn) = nldjl
564         nlejtl(jn) = nlejl
565      END DO
566
567      DEALLOCATE(iimpptl)
568      DEALLOCATE(ijmpptl)
569      DEALLOCATE(ilcitl)
570      DEALLOCATE(ilcjtl)
571
572   END SUBROUTINE sub_dom
573
574END MODULE prtctl
Note: See TracBrowser for help on using the repository browser.