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

source: branches/2011/dev_NEMO_MERGE_2011/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90 @ 3116

Last change on this file since 3116 was 3116, checked in by cetlod, 12 years ago

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