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

source: trunk/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90 @ 2715

Last change on this file since 2715 was 2715, checked in by rblod, 13 years ago

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