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

source: branches/2012/dev_NOC_2012_rev3555/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90 @ 3625

Last change on this file since 3625 was 3625, checked in by acc, 11 years ago

Branch dev_NOC_2012_r3555. #1006. Step 7. Check in code now merged with dev_r3385_NOCS04_HAMF
  • Property svn:keywords set to Id
File size: 24.7 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
36   !!----------------------------------------------------------------------
37   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
38   !! $Id$
39   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
40   !!----------------------------------------------------------------------
41CONTAINS
42
43   SUBROUTINE prt_ctl (tab2d_1, tab3d_1, mask1, clinfo1, tab2d_2, tab3d_2,   &
44      &                                  mask2, clinfo2, ovlap, kdim, clinfo3 )
45      !!----------------------------------------------------------------------
46      !!                     ***  ROUTINE prt_ctl  ***
47      !!
48      !! ** Purpose : - print sum control of 2D or 3D arrays over the same area
49      !!                in mono and mpp case. This way can be usefull when
50      !!                debugging a new parametrization in mono or mpp.
51      !!
52      !! ** Method  : 2 possibilities exist when setting the ln_ctl parameter to
53      !!                .true. in the ocean namelist:
54      !!              - to debug a MPI run .vs. a mono-processor one;
55      !!                the control print will be done over each sub-domain.
56      !!                The nictl[se] and njctl[se] parameters in the namelist must
57      !!                be set to zero and [ij]splt to the corresponding splitted
58      !!                domain in MPI along respectively i-, j- directions.
59      !!              - to debug a mono-processor run over the whole domain/a specific area;
60      !!                in the first case the nictl[se] and njctl[se] parameters must be set
61      !!                to zero else to the indices of the area to be controled. In both cases
62      !!                isplt and jsplt must be set to 1.
63      !!              - All arguments of the above calling sequence are optional so their
64      !!                name must be explicitly typed if used. For instance if the 3D
65      !!                array tn(:,:,:) must be passed through the prt_ctl subroutine,
66      !!                it must looks like: CALL prt_ctl(tab3d_1=tn).
67      !!
68      !!                    tab2d_1 : first 2D array
69      !!                    tab3d_1 : first 3D array
70      !!                    mask1   : mask (3D) to apply to the tab[23]d_1 array
71      !!                    clinfo1 : information about the tab[23]d_1 array
72      !!                    tab2d_2 : second 2D array
73      !!                    tab3d_2 : second 3D array
74      !!                    mask2   : mask (3D) to apply to the tab[23]d_2 array
75      !!                    clinfo2 : information about the tab[23]d_2 array
76      !!                    ovlap   : overlap value
77      !!                    kdim    : k- direction for 3D arrays
78      !!                    clinfo3 : additional information
79      !!----------------------------------------------------------------------
80      REAL(wp), DIMENSION(:,:)  , INTENT(in), OPTIONAL ::   tab2d_1
81      REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL ::   tab3d_1
82      REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL ::   mask1
83      CHARACTER (len=*)         , INTENT(in), OPTIONAL ::   clinfo1
84      REAL(wp), DIMENSION(:,:)  , INTENT(in), OPTIONAL ::   tab2d_2
85      REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL ::   tab3d_2
86      REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL ::   mask2
87      CHARACTER (len=*)         , INTENT(in), OPTIONAL ::   clinfo2
88      INTEGER                   , INTENT(in), OPTIONAL ::   ovlap
89      INTEGER                   , INTENT(in), OPTIONAL ::   kdim
90      CHARACTER (len=*)         , INTENT(in), OPTIONAL ::   clinfo3
91      !
92      CHARACTER (len=15) :: cl2
93      INTEGER ::   overlap, jn, sind, eind, kdir,j_id
94      REAL(wp) :: zsum1, zsum2, zvctl1, zvctl2
95      REAL(wp), POINTER, DIMENSION(:,:)   :: ztab2d_1, ztab2d_2
96      REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask1, zmask2, ztab3d_1, ztab3d_2
97      !!----------------------------------------------------------------------
98
99      CALL wrk_alloc( jpi,jpj, ztab2d_1, ztab2d_2 )
100      CALL wrk_alloc( jpi,jpj,jpk, zmask1, zmask2, ztab3d_1, ztab3d_2 )
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(:,:,1:kdir)
124      IF( PRESENT(tab3d_2) )   ztab3d_2(:,:,1:kdir) = tab3d_2(:,:,1:kdir)
125      IF( PRESENT(mask1)   )   zmask1  (:,:,:)      = mask1  (:,:,:)
126      IF( PRESENT(mask2)   )   zmask2  (:,:,:)      = mask2  (:,:,:)
127
128      IF( lk_mpp .AND. jpnij > 1 ) 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 .AND. jpnij > 1)   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      CALL wrk_dealloc( jpi,jpj, ztab2d_1, ztab2d_2 )
208      CALL wrk_dealloc( jpi,jpj,jpk, zmask1, zmask2, ztab3d_1, ztab3d_2 )
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 .AND. jpnij > 1 ) 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 .AND. jpnij > 1 ) 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#if defined key_nemocice_decomp
437      ijpi = ( nx_global+2-2*jpreci + (isplt-1) ) / isplt + 2*jpreci
438      ijpj = ( ny_global+2-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj 
439#else
440      ijpi = ( jpiglo-2*jpreci + (isplt-1) ) / isplt + 2*jpreci
441      ijpj = ( jpjglo-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj
442#endif
443
444      ALLOCATE(ilcitl (isplt,jsplt))
445      ALLOCATE(ilcjtl (isplt,jsplt))
446
447      nrecil  = 2 * jpreci
448      nrecjl  = 2 * jprecj
449      irestil = MOD( jpiglo - nrecil , isplt )
450      irestjl = MOD( jpjglo - nrecjl , jsplt )
451
452      IF(  irestil == 0 )   irestil = isplt
453#if defined key_nemocice_decomp
454
455      ! In order to match CICE the size of domains in NEMO has to be changed
456      ! The last line of blocks (west) will have fewer points
457      DO jj = 1, jsplt 
458         DO ji=1, isplt-1 
459            ilcitl(ji,jj) = ijpi 
460         END DO
461         ilcitl(isplt,jj) = jpiglo - (isplt - 1) * (ijpi - nrecil)
462      END DO 
463
464#else
465
466      DO jj = 1, jsplt
467         DO ji = 1, irestil
468            ilcitl(ji,jj) = ijpi
469         END DO
470         DO ji = irestil+1, isplt
471            ilcitl(ji,jj) = ijpi -1
472         END DO
473      END DO
474
475#endif
476     
477      IF( irestjl == 0 )   irestjl = jsplt
478#if defined key_nemocice_decomp 
479
480      ! Same change to domains in North-South direction as in East-West.
481      DO ji = 1, isplt 
482         DO jj=1, jsplt-1 
483            ilcjtl(ji,jj) = ijpj 
484         END DO
485         ilcjtl(ji,jsplt) = jpjglo - (jsplt - 1) * (ijpj - nrecjl)
486      END DO 
487
488#else
489
490      DO ji = 1, isplt
491         DO jj = 1, irestjl
492            ilcjtl(ji,jj) = ijpj
493         END DO
494         DO jj = irestjl+1, jsplt
495            ilcjtl(ji,jj) = ijpj -1
496         END DO
497      END DO
498
499#endif
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, ijmpptl, ilcitl, ilcjtl )
579      !
580   END SUBROUTINE sub_dom
581
582   !!======================================================================
583END MODULE prtctl
Note: See TracBrowser for help on using the repository browser.