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

source: branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90 @ 5214

Last change on this file since 5214 was 5214, checked in by davestorkey, 9 years ago

Merge in changes from the trunk up to rev 5107.

  • Property svn:keywords set to Id
File size: 24.8 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
3729000     FORMAT(a41,i4.4,a14)
3739001     FORMAT(a59)
3749002     FORMAT(a20,i4.4,a36,i3.3)
3759003     FORMAT(a20,i4.4,a17,i4.4)
3769004     FORMAT(a11,i4.4,a26,i4.4,a14)
377      END DO
378      !
379   END SUBROUTINE prt_ctl_init
380
381
382   SUBROUTINE sub_dom
383      !!----------------------------------------------------------------------
384      !!                  ***  ROUTINE sub_dom  ***
385      !!                   
386      !! ** Purpose :   Lay out the global domain over processors.
387      !!                CAUTION:
388      !!                This part has been extracted from the mpp_init
389      !!                subroutine and names of variables/arrays have been
390      !!                slightly changed to avoid confusion but the computation
391      !!                is exactly the same. Any modification about indices of
392      !!                each sub-domain in the mppini.F90 module should be reported
393      !!                here.
394      !!
395      !! ** Method  :   Global domain is distributed in smaller local domains.
396      !!                Periodic condition is a function of the local domain position
397      !!                (global boundary or neighbouring domain) and of the global
398      !!                periodic
399      !!                Type :         jperio global periodic condition
400      !!                               nperio local  periodic condition
401      !!
402      !! ** Action  : - set domain parameters
403      !!                    nimpp     : longitudinal index
404      !!                    njmpp     : latitudinal  index
405      !!                    nperio    : lateral condition type
406      !!                    narea     : number for local area
407      !!                    nlcil      : first dimension
408      !!                    nlcjl      : second dimension
409      !!                    nbondil    : mark for "east-west local boundary"
410      !!                    nbondjl    : mark for "north-south local boundary"
411      !!
412      !! History :
413      !!        !  94-11  (M. Guyon)  Original code
414      !!        !  95-04  (J. Escobar, M. Imbard)
415      !!        !  98-02  (M. Guyon)  FETI method
416      !!        !  98-05  (M. Imbard, J. Escobar, L. Colombet )  SHMEM and MPI versions
417      !!   8.5  !  02-08  (G. Madec)  F90 : free form
418      !!----------------------------------------------------------------------
419      INTEGER ::   ji, jj, jn               ! dummy loop indices
420      INTEGER ::   &
421         ii, ij,                         &  ! temporary integers
422         irestil, irestjl,               &  !    "          "
423         ijpi  , ijpj, nlcil,            &  ! temporary logical unit
424         nlcjl , nbondil, nbondjl,       &
425         nrecil, nrecjl, nldil, nleil, nldjl, nlejl
426
427      INTEGER, POINTER, DIMENSION(:,:) ::   iimpptl, ijmpptl, ilcitl, ilcjtl   ! workspace
428      REAL(wp) ::   zidom, zjdom            ! temporary scalars
429      !!----------------------------------------------------------------------
430
431      !
432      CALL wrk_alloc( isplt, jsplt, ilcitl, ilcjtl, iimpptl, ijmpptl )
433      !
434      !  1. Dimension arrays for subdomains
435      ! -----------------------------------
436      !  Computation of local domain sizes ilcitl() ilcjtl()
437      !  These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo
438      !  The subdomains are squares leeser than or equal to the global
439      !  dimensions divided by the number of processors minus the overlap
440      !  array (cf. par_oce.F90).
441
442#if defined key_nemocice_decomp
443      ijpi = ( nx_global+2-2*jpreci + (isplt-1) ) / isplt + 2*jpreci
444      ijpj = ( ny_global+2-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj 
445#else
446      ijpi = ( jpiglo-2*jpreci + (isplt-1) ) / isplt + 2*jpreci
447      ijpj = ( jpjglo-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj
448#endif
449
450
451      nrecil  = 2 * jpreci
452      nrecjl  = 2 * jprecj
453      irestil = MOD( jpiglo - nrecil , isplt )
454      irestjl = MOD( jpjglo - nrecjl , jsplt )
455
456      IF(  irestil == 0 )   irestil = isplt
457#if defined key_nemocice_decomp
458
459      ! In order to match CICE the size of domains in NEMO has to be changed
460      ! The last line of blocks (west) will have fewer points
461      DO jj = 1, jsplt 
462         DO ji=1, isplt-1 
463            ilcitl(ji,jj) = ijpi 
464         END DO
465         ilcitl(isplt,jj) = jpiglo - (isplt - 1) * (ijpi - nrecil)
466      END DO 
467
468#else
469
470      DO jj = 1, jsplt
471         DO ji = 1, irestil
472            ilcitl(ji,jj) = ijpi
473         END DO
474         DO ji = irestil+1, isplt
475            ilcitl(ji,jj) = ijpi -1
476         END DO
477      END DO
478
479#endif
480     
481      IF( irestjl == 0 )   irestjl = jsplt
482#if defined key_nemocice_decomp 
483
484      ! Same change to domains in North-South direction as in East-West.
485      DO ji = 1, isplt 
486         DO jj=1, jsplt-1 
487            ilcjtl(ji,jj) = ijpj 
488         END DO
489         ilcjtl(ji,jsplt) = jpjglo - (jsplt - 1) * (ijpj - nrecjl)
490      END DO 
491
492#else
493
494      DO ji = 1, isplt
495         DO jj = 1, irestjl
496            ilcjtl(ji,jj) = ijpj
497         END DO
498         DO jj = irestjl+1, jsplt
499            ilcjtl(ji,jj) = ijpj -1
500         END DO
501      END DO
502
503#endif
504      zidom = nrecil
505      DO ji = 1, isplt
506         zidom = zidom + ilcitl(ji,1) - nrecil
507      END DO
508      IF(lwp) WRITE(numout,*)
509      IF(lwp) WRITE(numout,*)' sum ilcitl(i,1) = ', zidom, ' jpiglo = ', jpiglo
510     
511      zjdom = nrecjl
512      DO jj = 1, jsplt
513         zjdom = zjdom + ilcjtl(1,jj) - nrecjl
514      END DO
515      IF(lwp) WRITE(numout,*)' sum ilcitl(1,j) = ', zjdom, ' jpjglo = ', jpjglo
516      IF(lwp) WRITE(numout,*)
517     
518
519      !  2. Index arrays for subdomains
520      ! -------------------------------
521
522      iimpptl(:,:) = 1
523      ijmpptl(:,:) = 1
524     
525      IF( isplt > 1 ) THEN
526         DO jj = 1, jsplt
527            DO ji = 2, isplt
528               iimpptl(ji,jj) = iimpptl(ji-1,jj) + ilcitl(ji-1,jj) - nrecil
529            END DO
530         END DO
531      ENDIF
532
533      IF( jsplt > 1 ) THEN
534         DO jj = 2, jsplt
535            DO ji = 1, isplt
536               ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ilcjtl(ji,jj-1)-nrecjl
537            END DO
538         END DO
539      ENDIF
540     
541      ! 3. Subdomain description
542      ! ------------------------
543
544      DO jn = 1, ijsplt
545         ii = 1 + MOD( jn-1, isplt )
546         ij = 1 + (jn-1) / isplt
547         nimpptl(jn) = iimpptl(ii,ij)
548         njmpptl(jn) = ijmpptl(ii,ij)
549         nlcitl (jn) = ilcitl (ii,ij)     
550         nlcil       = nlcitl (jn)     
551         nlcjtl (jn) = ilcjtl (ii,ij)     
552         nlcjl       = nlcjtl (jn)
553         nbondjl = -1                                    ! general case
554         IF( jn   >  isplt          )   nbondjl = 0      ! first row of processor
555         IF( jn   >  (jsplt-1)*isplt )  nbondjl = 1     ! last  row of processor
556         IF( jsplt == 1             )   nbondjl = 2      ! one processor only in j-direction
557         ibonjtl(jn) = nbondjl
558         
559         nbondil = 0                                     !
560         IF( MOD( jn, isplt ) == 1 )   nbondil = -1      !
561         IF( MOD( jn, isplt ) == 0 )   nbondil =  1      !
562         IF( isplt            == 1 )   nbondil =  2      ! one processor only in i-direction
563         ibonitl(jn) = nbondil
564         
565         nldil =  1   + jpreci
566         nleil = nlcil - jpreci
567         IF( nbondil == -1 .OR. nbondil == 2 )   nldil = 1
568         IF( nbondil ==  1 .OR. nbondil == 2 )   nleil = nlcil
569         nldjl =  1   + jprecj
570         nlejl = nlcjl - jprecj
571         IF( nbondjl == -1 .OR. nbondjl == 2 )   nldjl = 1
572         IF( nbondjl ==  1 .OR. nbondjl == 2 )   nlejl = nlcjl
573         nlditl(jn) = nldil
574         nleitl(jn) = nleil
575         nldjtl(jn) = nldjl
576         nlejtl(jn) = nlejl
577      END DO
578      !
579      !
580      CALL wrk_dealloc( isplt, jsplt, ilcitl, ilcjtl, iimpptl, ijmpptl )
581      !
582      !
583   END SUBROUTINE sub_dom
584
585   !!======================================================================
586END MODULE prtctl
Note: See TracBrowser for help on using the repository browser.