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

source: branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90 @ 2633

Last change on this file since 2633 was 2633, checked in by trackstand2, 13 years ago

Renamed wrk_use => wrk_in_use and wrk_release => wrk_not_released
  • Property svn:keywords set to Id
File size: 23.7 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   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
34   !! $Id$
35   !! Software governed by the CeCILL licence (NEMOGCM/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      USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released
81      USE wrk_nemo, ONLY: ztab2d_1 => wrk_2d_1, ztab2d_2 => wrk_2d_2
82      USE wrk_nemo, ONLY:   zmask1 => wrk_3d_1,   zmask2 => wrk_3d_2, &
83                          ztab3d_1 => wrk_3d_3, ztab3d_2 => wrk_3d_4
84      !! * Arguments
85      REAL(wp), DIMENSION(:,:)  , INTENT(in), OPTIONAL :: tab2d_1
86      REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: tab3d_1
87      REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask1
88      CHARACTER (len=*)         , INTENT(in), OPTIONAL :: clinfo1
89      REAL(wp), DIMENSION(:,:)  , INTENT(in), OPTIONAL :: tab2d_2
90      REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: tab3d_2
91      REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask2
92      CHARACTER (len=*)         , INTENT(in), OPTIONAL :: clinfo2
93      INTEGER                   , INTENT(in), OPTIONAL :: ovlap
94      INTEGER                   , INTENT(in), OPTIONAL :: kdim
95      CHARACTER (len=*)         , INTENT(in), OPTIONAL :: clinfo3
96
97      !! * Local declarations
98      INTEGER :: overlap, jn, sind, eind, kdir,j_id
99      CHARACTER (len=15) :: cl2
100      REAL(wp) :: zsum1, zsum2, zvctl1, zvctl2
101      !!----------------------------------------------------------------------
102
103      IF( wrk_in_use(2, 1,2) .OR. wrk_in_use(3, 1,2,3,4) )THEN
104         CALL ctl_stop('prt_ctl : requested workspace arrays unavailable.')
105         RETURN
106      END IF
107
108      ! Arrays, scalars initialization
109      overlap   = 0
110      kdir      = jpkm1
111      cl2       = ''
112      zsum1     = 0.e0
113      zsum2     = 0.e0
114      zvctl1    = 0.e0
115      zvctl2    = 0.e0
116      ztab2d_1(:,:)   = 0.e0
117      ztab2d_2(:,:)   = 0.e0
118      ztab3d_1(:,:,:) = 0.e0
119      ztab3d_2(:,:,:) = 0.e0
120      zmask1  (:,:,:) = 1.e0
121      zmask2  (:,:,:) = 1.e0
122
123      ! Control of optional arguments
124      IF( PRESENT(clinfo2) )  cl2            = clinfo2
125      IF( PRESENT(ovlap)   )  overlap        = ovlap
126      IF( PRESENT(kdim)    )  kdir           = kdim
127      IF( PRESENT(tab2d_1) )  ztab2d_1(:,:)  = tab2d_1(:,:)
128      IF( PRESENT(tab2d_2) )  ztab2d_2(:,:)  = tab2d_2(:,:)
129      IF( PRESENT(tab3d_1) )  ztab3d_1(:,:,1:kdir)= tab3d_1(:,:,:)
130      IF( PRESENT(tab3d_2) )  ztab3d_2(:,:,1:kdir)= tab3d_2(:,:,:)
131      IF( PRESENT(mask1)   )  zmask1  (:,:,:)= mask1  (:,:,:)
132      IF( PRESENT(mask2)   )  zmask2  (:,:,:)= mask2  (:,:,:)
133
134      IF( lk_mpp )   THEN
135         ! processor number
136         sind = narea
137         eind = narea
138      ELSE
139         ! processors total number
140         sind = 1
141         eind = ijsplt
142      ENDIF
143
144      ! Loop over each sub-domain, i.e. the total number of processors ijsplt
145      DO jn = sind, eind
146         ! Set logical unit
147         j_id = numid(jn - narea + 1)
148         ! Set indices for the SUM control
149         IF( .NOT. lsp_area ) THEN
150            IF (lk_mpp )   THEN
151               nictls = MAX( 1, nlditl(jn) - overlap )
152               nictle = nleitl(jn) + overlap * MIN( 1, nlcitl(jn) - nleitl(jn)) 
153               njctls = MAX( 1, nldjtl(jn) - overlap )
154               njctle = nlejtl(jn) + overlap * MIN( 1, nlcjtl(jn) - nlejtl(jn))
155               ! Do not take into account the bound of the domain
156               IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls)
157               IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls)
158               IF( ibonitl(jn) ==  1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nleitl(jn) - 1)
159               IF( ibonjtl(jn) ==  1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, nlejtl(jn) - 1)
160            ELSE
161               nictls = MAX( 1, nimpptl(jn) + nlditl(jn) - 1 - overlap )
162               nictle = nimpptl(jn) + nleitl(jn) - 1 + overlap * MIN( 1, nlcitl(jn) - nleitl(jn) ) 
163               njctls = MAX( 1, njmpptl(jn) + nldjtl(jn) - 1 - overlap )
164               njctle = njmpptl(jn) + nlejtl(jn) - 1 + overlap * MIN( 1, nlcjtl(jn) - nlejtl(jn) ) 
165               ! Do not take into account the bound of the domain
166               IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls)
167               IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls)
168               IF( ibonitl(jn) ==  1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nimpptl(jn) + nleitl(jn) - 2)
169               IF( ibonjtl(jn) ==  1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, njmpptl(jn) + nlejtl(jn) - 2)
170            ENDIF
171         ENDIF
172
173         IF ( clinfo3 == 'tra' )  THEN
174             zvctl1 = t_ctll(jn)
175             zvctl2 = s_ctll(jn)
176         ELSEIF ( clinfo3 == 'dyn' )   THEN
177             zvctl1 = u_ctll(jn)
178             zvctl2 = v_ctll(jn)
179         ENDIF
180
181         ! Compute the sum control
182         ! 2D arrays
183         IF( PRESENT(tab2d_1) )   THEN
184            zsum1 = SUM( ztab2d_1(nictls:nictle,njctls:njctle)*zmask1(nictls:nictle,njctls:njctle,1) )
185            zsum2 = SUM( ztab2d_2(nictls:nictle,njctls:njctle)*zmask2(nictls:nictle,njctls:njctle,1) )
186         ENDIF
187
188         ! 3D arrays
189         IF( PRESENT(tab3d_1) )   THEN
190            zsum1 = SUM( ztab3d_1(nictls:nictle,njctls:njctle,1:kdir)*zmask1(nictls:nictle,njctls:njctle,1:kdir) )
191            zsum2 = SUM( ztab3d_2(nictls:nictle,njctls:njctle,1:kdir)*zmask2(nictls:nictle,njctls:njctle,1:kdir) )
192         ENDIF
193
194         ! Print the result
195         IF( PRESENT(clinfo3) )   THEN
196            WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1-zvctl1, cl2, zsum2-zvctl2
197            SELECT CASE( clinfo3 )
198            CASE ( 'tra-ta' ) 
199               t_ctll(jn) = zsum1
200            CASE ( 'tra' ) 
201                t_ctll(jn) = zsum1
202                s_ctll(jn) = zsum2
203            CASE ( 'dyn' ) 
204                u_ctll(jn) = zsum1
205                v_ctll(jn) = zsum2 
206            END SELECT
207         ELSEIF ( PRESENT(clinfo2) .OR. PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) )   THEN
208            WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1, cl2, zsum2
209         ELSE
210            WRITE(j_id,FMT='(a,D23.16)')clinfo1, zsum1
211         ENDIF
212
213      ENDDO
214
215      IF( wrk_not_released(2, 1,2) .OR. wrk_not_released(3, 1,2,3,4) )THEN
216         CALL ctl_stop('prt_ctl : failed to release workspace arrays.')
217      END IF
218
219   END SUBROUTINE prt_ctl
220
221
222   SUBROUTINE prt_ctl_info (clinfo1, ivar1, clinfo2, ivar2, itime)
223      !!----------------------------------------------------------------------
224      !!                     ***  ROUTINE prt_ctl_info  ***
225      !!
226      !! ** Purpose : - print information without any computation
227      !!
228      !! ** Action  : - input arguments
229      !!                    clinfo1 : information about the ivar1
230      !!                    ivar1   : value to print
231      !!                    clinfo2 : information about the ivar2
232      !!                    ivar2   : value to print
233      !!
234      !! History :
235      !!   9.0  !  05-07  (C. Talandier) original code
236      !!----------------------------------------------------------------------
237      !! * Arguments
238      CHARACTER (len=*), INTENT(in) ::   clinfo1
239      INTEGER          , INTENT(in), OPTIONAL ::   ivar1
240      CHARACTER (len=*), INTENT(in), OPTIONAL ::   clinfo2
241      INTEGER          , INTENT(in), OPTIONAL ::   ivar2
242      INTEGER          , INTENT(in), OPTIONAL ::   itime
243
244      !! * Local declarations
245      INTEGER :: jn, sind, eind, iltime, j_id
246      !!----------------------------------------------------------------------
247
248      IF( lk_mpp )   THEN
249         ! processor number
250         sind = narea
251         eind = narea
252      ELSE
253         ! total number of processors
254         sind = 1
255         eind = ijsplt
256      ENDIF
257
258      ! Set to zero arrays at each new time step
259      IF( PRESENT(itime) )   THEN
260         iltime = itime
261         IF( iltime > ktime )   THEN
262            t_ctll(:) = 0.e0   ;   s_ctll(:) = 0.e0
263            u_ctll(:) = 0.e0   ;   v_ctll(:) = 0.e0
264            ktime = iltime
265         ENDIF
266      ENDIF
267
268      ! Loop over each sub-domain, i.e. number of processors ijsplt
269      DO jn = sind, eind
270         
271         ! Set logical unit
272         j_id = numid(jn - narea + 1)
273
274         IF( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. PRESENT(ivar2) )   THEN
275            WRITE(j_id,*)clinfo1, ivar1, clinfo2, ivar2
276         ELSEIF ( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) )   THEN
277            WRITE(j_id,*)clinfo1, ivar1, clinfo2
278         ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. PRESENT(ivar2) )   THEN
279            WRITE(j_id,*)clinfo1, ivar1, ivar2
280         ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) )   THEN
281            WRITE(j_id,*)clinfo1, ivar1
282         ELSE
283            WRITE(j_id,*)clinfo1
284         ENDIF
285
286      ENDDO
287
288
289      END SUBROUTINE prt_ctl_info
290
291   SUBROUTINE prt_ctl_init
292      !!----------------------------------------------------------------------
293      !!                     ***  ROUTINE prt_ctl_init  ***
294      !!
295      !! ** Purpose :   open ASCII files & compute indices
296      !!
297      !! History :
298      !!   9.0  !  05-07  (C. Talandier) original code
299      !!----------------------------------------------------------------------
300      !! * Local declarations
301      INTEGER ::   jn, sind, eind, j_id
302      CHARACTER (len=28) :: clfile_out
303      CHARACTER (len=23) :: clb_name
304      CHARACTER (len=19) :: cl_run
305      !!----------------------------------------------------------------------
306
307      ! Allocate arrays
308      ALLOCATE(nlditl (ijsplt))
309      ALLOCATE(nldjtl (ijsplt))
310      ALLOCATE(nleitl (ijsplt))
311      ALLOCATE(nlejtl (ijsplt))
312      ALLOCATE(nimpptl(ijsplt))
313      ALLOCATE(njmpptl(ijsplt))
314      ALLOCATE(nlcitl (ijsplt))
315      ALLOCATE(nlcjtl (ijsplt))
316      ALLOCATE(t_ctll (ijsplt))
317      ALLOCATE(s_ctll (ijsplt))
318      ALLOCATE(u_ctll (ijsplt))
319      ALLOCATE(v_ctll (ijsplt))
320      ALLOCATE(ibonitl(ijsplt))
321      ALLOCATE(ibonjtl(ijsplt))
322
323      ! Initialization
324      t_ctll(:)=0.e0
325      s_ctll(:)=0.e0
326      u_ctll(:)=0.e0
327      v_ctll(:)=0.e0
328      ktime = 1
329
330      IF( lk_mpp ) THEN
331         sind = narea
332         eind = narea
333         clb_name = "('mpp.output_',I4.4)"
334         cl_run = 'MULTI processor run'
335         ! use indices for each area computed by mpp_init subroutine
336         nlditl(:) = nldit(:) 
337         nleitl(:) = nleit(:) 
338         nldjtl(:) = nldjt(:) 
339         nlejtl(:) = nlejt(:) 
340         !
341         nimpptl(:) = nimppt(:)
342         njmpptl(:) = njmppt(:)
343         !
344         nlcitl(:) = nlcit(:)
345         nlcjtl(:) = nlcjt(:)
346         !
347         ibonitl(:) = ibonit(:)
348         ibonjtl(:) = ibonjt(:)
349      ELSE
350         sind = 1
351         eind = ijsplt
352         clb_name = "('mono.output_',I4.4)"
353         cl_run = 'MONO processor run '
354         ! compute indices for each area as done in mpp_init subroutine
355         CALL sub_dom
356      ENDIF
357
358      ALLOCATE(numid(eind-sind+1))
359
360      DO jn = sind, eind
361         WRITE(clfile_out,FMT=clb_name) jn-1
362         CALL ctl_opn( numid(jn -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', 1, numout, .FALSE. )
363         j_id = numid(jn -narea + 1)
364         WRITE(j_id,*)
365         WRITE(j_id,*) '                 L O D Y C - I P S L'
366         WRITE(j_id,*) '                     O P A model'
367         WRITE(j_id,*) '            Ocean General Circulation Model'
368         WRITE(j_id,*) '               version OPA 9.0  (2005) '
369         WRITE(j_id,*)
370         WRITE(j_id,*) '                   PROC number: ', jn
371         WRITE(j_id,*)
372         WRITE(j_id,FMT="(19x,a20)")cl_run
373
374         ! Print the SUM control indices
375         IF( .NOT. lsp_area )   THEN
376            nictls = nimpptl(jn) + nlditl(jn) - 1
377            nictle = nimpptl(jn) + nleitl(jn) - 1
378            njctls = njmpptl(jn) + nldjtl(jn) - 1
379            njctle = njmpptl(jn) + nlejtl(jn) - 1
380         ENDIF
381         WRITE(j_id,*) 
382         WRITE(j_id,*) 'prt_ctl :  Sum control indices'
383         WRITE(j_id,*) '~~~~~~~'
384         WRITE(j_id,*)
385         WRITE(j_id,9000)'                                nlej   = ', nlejtl(jn), '              '
386         WRITE(j_id,9000)'                  ------------- njctle = ', njctle, ' -------------'
387         WRITE(j_id,9001)'                  |                                       |'
388         WRITE(j_id,9001)'                  |                                       |'
389         WRITE(j_id,9001)'                  |                                       |'
390         WRITE(j_id,9002)'           nictls = ', nictls,  '                           nictle = ', nictle
391         WRITE(j_id,9002)'           nldi   = ', nlditl(jn),  '                           nlei   = ', nleitl(jn)
392         WRITE(j_id,9001)'                  |                                       |'
393         WRITE(j_id,9001)'                  |                                       |'
394         WRITE(j_id,9001)'                  |                                       |'
395         WRITE(j_id,9004)'  njmpp  = ',njmpptl(jn),'   ------------- njctls = ', njctls, ' -------------'
396         WRITE(j_id,9003)'           nimpp  = ', nimpptl(jn), '        nldj   = ', nldjtl(jn), '              '
397         WRITE(j_id,*)
398         WRITE(j_id,*)
399
4009000     FORMAT(a41,i4.4,a14)
4019001     FORMAT(a59)
4029002     FORMAT(a20,i4.4,a36,i3.3)
4039003     FORMAT(a20,i4.4,a17,i4.4)
4049004     FORMAT(a11,i4.4,a26,i4.4,a14)
405      ENDDO
406
407   END SUBROUTINE prt_ctl_init
408
409
410   SUBROUTINE sub_dom
411      !!----------------------------------------------------------------------
412      !!                  ***  ROUTINE sub_dom  ***
413      !!                   
414      !! ** Purpose :   Lay out the global domain over processors.
415      !!                CAUTION:
416      !!                This part has been extracted from the mpp_init
417      !!                subroutine and names of variables/arrays have been
418      !!                slightly changed to avoid confusion but the computation
419      !!                is exactly the same. Any modification about indices of
420      !!                each sub-domain in the mppini.F90 module should be reported
421      !!                here.
422      !!
423      !! ** Method  :   Global domain is distributed in smaller local domains.
424      !!                Periodic condition is a function of the local domain position
425      !!                (global boundary or neighbouring domain) and of the global
426      !!                periodic
427      !!                Type :         jperio global periodic condition
428      !!                               nperio local  periodic condition
429      !!
430      !! ** Action  : - set domain parameters
431      !!                    nimpp     : longitudinal index
432      !!                    njmpp     : latitudinal  index
433      !!                    nperio    : lateral condition type
434      !!                    narea     : number for local area
435      !!                    nlcil      : first dimension
436      !!                    nlcjl      : second dimension
437      !!                    nbondil    : mark for "east-west local boundary"
438      !!                    nbondjl    : mark for "north-south local boundary"
439      !!
440      !! History :
441      !!        !  94-11  (M. Guyon)  Original code
442      !!        !  95-04  (J. Escobar, M. Imbard)
443      !!        !  98-02  (M. Guyon)  FETI method
444      !!        !  98-05  (M. Imbard, J. Escobar, L. Colombet )  SHMEM and MPI versions
445      !!   8.5  !  02-08  (G. Madec)  F90 : free form
446      !!----------------------------------------------------------------------
447      !! * Local variables
448      INTEGER ::   ji, jj, jn               ! dummy loop indices
449      INTEGER ::   &
450         ii, ij,                         &  ! temporary integers
451         irestil, irestjl,               &  !    "          "
452         ijpi  , ijpj, nlcil,            &  ! temporary logical unit
453         nlcjl , nbondil, nbondjl,       &
454         nrecil, nrecjl, nldil, nleil, nldjl, nlejl
455
456      INTEGER, DIMENSION(:,:), ALLOCATABLE ::   &
457         iimpptl, ijmpptl, ilcitl, ilcjtl       ! temporary workspace
458      REAL(wp) ::   zidom, zjdom            ! temporary scalars
459      !!----------------------------------------------------------------------
460
461      !  1. Dimension arrays for subdomains
462      ! -----------------------------------
463      !  Computation of local domain sizes ilcitl() ilcjtl()
464      !  These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo
465      !  The subdomains are squares leeser than or equal to the global
466      !  dimensions divided by the number of processors minus the overlap
467      !  array (cf. par_oce.F90).
468
469      ijpi = ( jpiglo-2*jpreci + (isplt-1) ) / isplt + 2*jpreci
470      ijpj = ( jpjglo-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj
471
472      ALLOCATE(ilcitl (isplt,jsplt))
473      ALLOCATE(ilcjtl (isplt,jsplt))
474
475      nrecil  = 2 * jpreci
476      nrecjl  = 2 * jprecj
477      irestil = MOD( jpiglo - nrecil , isplt )
478      irestjl = MOD( jpjglo - nrecjl , jsplt )
479
480      IF(  irestil == 0 )   irestil = isplt
481      DO jj = 1, jsplt
482         DO ji = 1, irestil
483            ilcitl(ji,jj) = ijpi
484         END DO
485         DO ji = irestil+1, isplt
486            ilcitl(ji,jj) = ijpi -1
487         END DO
488      END DO
489     
490      IF( irestjl == 0 )   irestjl = jsplt
491      DO ji = 1, isplt
492         DO jj = 1, irestjl
493            ilcjtl(ji,jj) = ijpj
494         END DO
495         DO jj = irestjl+1, jsplt
496            ilcjtl(ji,jj) = ijpj -1
497         END DO
498      END DO
499     
500      zidom = nrecil
501      DO ji = 1, isplt
502         zidom = zidom + ilcitl(ji,1) - nrecil
503      END DO
504      IF(lwp) WRITE(numout,*)
505      IF(lwp) WRITE(numout,*)' sum ilcitl(i,1) = ', zidom, ' jpiglo = ', jpiglo
506     
507      zjdom = nrecjl
508      DO jj = 1, jsplt
509         zjdom = zjdom + ilcjtl(1,jj) - nrecjl
510      END DO
511      IF(lwp) WRITE(numout,*)' sum ilcitl(1,j) = ', zjdom, ' jpjglo = ', jpjglo
512      IF(lwp) WRITE(numout,*)
513     
514
515      !  2. Index arrays for subdomains
516      ! -------------------------------
517
518      ALLOCATE(iimpptl(isplt,jsplt))
519      ALLOCATE(ijmpptl(isplt,jsplt))
520     
521      iimpptl(:,:) = 1
522      ijmpptl(:,:) = 1
523     
524      IF( isplt > 1 ) THEN
525         DO jj = 1, jsplt
526            DO ji = 2, isplt
527               iimpptl(ji,jj) = iimpptl(ji-1,jj) + ilcitl(ji-1,jj) - nrecil
528            END DO
529         END DO
530      ENDIF
531
532      IF( jsplt > 1 ) THEN
533         DO jj = 2, jsplt
534            DO ji = 1, isplt
535               ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ilcjtl(ji,jj-1)-nrecjl
536            END DO
537         END DO
538      ENDIF
539     
540      ! 3. Subdomain description
541      ! ------------------------
542
543      DO jn = 1, ijsplt
544         ii = 1 + MOD( jn-1, isplt )
545         ij = 1 + (jn-1) / isplt
546         nimpptl(jn) = iimpptl(ii,ij)
547         njmpptl(jn) = ijmpptl(ii,ij)
548         nlcitl (jn) = ilcitl (ii,ij)     
549         nlcil       = nlcitl (jn)     
550         nlcjtl (jn) = ilcjtl (ii,ij)     
551         nlcjl       = nlcjtl (jn)
552         nbondjl = -1                                    ! general case
553         IF( jn   >  isplt          )   nbondjl = 0      ! first row of processor
554         IF( jn   >  (jsplt-1)*isplt )  nbondjl = 1     ! last  row of processor
555         IF( jsplt == 1             )   nbondjl = 2      ! one processor only in j-direction
556         ibonjtl(jn) = nbondjl
557         
558         nbondil = 0                                     !
559         IF( MOD( jn, isplt ) == 1 )   nbondil = -1      !
560         IF( MOD( jn, isplt ) == 0 )   nbondil =  1      !
561         IF( isplt            == 1 )   nbondil =  2      ! one processor only in i-direction
562         ibonitl(jn) = nbondil
563         
564         nldil =  1   + jpreci
565         nleil = nlcil - jpreci
566         IF( nbondil == -1 .OR. nbondil == 2 )   nldil = 1
567         IF( nbondil ==  1 .OR. nbondil == 2 )   nleil = nlcil
568         nldjl =  1   + jprecj
569         nlejl = nlcjl - jprecj
570         IF( nbondjl == -1 .OR. nbondjl == 2 )   nldjl = 1
571         IF( nbondjl ==  1 .OR. nbondjl == 2 )   nlejl = nlcjl
572         nlditl(jn) = nldil
573         nleitl(jn) = nleil
574         nldjtl(jn) = nldjl
575         nlejtl(jn) = nlejl
576      END DO
577
578      DEALLOCATE(iimpptl)
579      DEALLOCATE(ijmpptl)
580      DEALLOCATE(ilcitl)
581      DEALLOCATE(ilcjtl)
582
583   END SUBROUTINE sub_dom
584
585END MODULE prtctl
Note: See TracBrowser for help on using the repository browser.