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

Last change on this file since 3294 was 3294, checked in by rblod, 12 years ago

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