source: branches/UKMO/dev_r5518_GO6_package_text_diagnostics/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90 @ 10774

Last change on this file since 10774 was 10774, checked in by andmirek, 20 months ago

GMED 450 add flush after prints

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