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/UKMO/dev_r8864_restart_date/NEMOGCM/TOOLS/DOMAINcfg/src – NEMO

source: branches/UKMO/dev_r8864_restart_date/NEMOGCM/TOOLS/DOMAINcfg/src/prtctl.f90 @ 9235

Last change on this file since 9235 was 9235, checked in by davestorkey, 6 years ago

UKMO/dev_r8864_restart_date : clear SVN keywords.

File size: 23.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
11
12
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
443
444
445
446      ijpi = ( jpiglo-2*jpreci + (isplt-1) ) / isplt + 2*jpreci
447      ijpj = ( jpjglo-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj
448
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
458      DO jj = 1, jsplt
459         DO ji = 1, irestil
460            ilcitl(ji,jj) = ijpi
461         END DO
462         DO ji = irestil+1, isplt
463            ilcitl(ji,jj) = ijpi -1
464         END DO
465      END DO
466
467     
468      IF( irestjl == 0 )   irestjl = jsplt
469
470      DO ji = 1, isplt
471         DO jj = 1, irestjl
472            ilcjtl(ji,jj) = ijpj
473         END DO
474         DO jj = irestjl+1, jsplt
475            ilcjtl(ji,jj) = ijpj -1
476         END DO
477      END DO
478
479      zidom = nrecil
480      DO ji = 1, isplt
481         zidom = zidom + ilcitl(ji,1) - nrecil
482      END DO
483      IF(lwp) WRITE(numout,*)
484      IF(lwp) WRITE(numout,*)' sum ilcitl(i,1) = ', zidom, ' jpiglo = ', jpiglo
485     
486      zjdom = nrecjl
487      DO jj = 1, jsplt
488         zjdom = zjdom + ilcjtl(1,jj) - nrecjl
489      END DO
490      IF(lwp) WRITE(numout,*)' sum ilcitl(1,j) = ', zjdom, ' jpjglo = ', jpjglo
491      IF(lwp) WRITE(numout,*)
492     
493
494      !  2. Index arrays for subdomains
495      ! -------------------------------
496
497      iimpptl(:,:) = 1
498      ijmpptl(:,:) = 1
499     
500      IF( isplt > 1 ) THEN
501         DO jj = 1, jsplt
502            DO ji = 2, isplt
503               iimpptl(ji,jj) = iimpptl(ji-1,jj) + ilcitl(ji-1,jj) - nrecil
504            END DO
505         END DO
506      ENDIF
507
508      IF( jsplt > 1 ) THEN
509         DO jj = 2, jsplt
510            DO ji = 1, isplt
511               ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ilcjtl(ji,jj-1)-nrecjl
512            END DO
513         END DO
514      ENDIF
515     
516      ! 3. Subdomain description
517      ! ------------------------
518
519      DO jn = 1, ijsplt
520         ii = 1 + MOD( jn-1, isplt )
521         ij = 1 + (jn-1) / isplt
522         nimpptl(jn) = iimpptl(ii,ij)
523         njmpptl(jn) = ijmpptl(ii,ij)
524         nlcitl (jn) = ilcitl (ii,ij)     
525         nlcil       = nlcitl (jn)     
526         nlcjtl (jn) = ilcjtl (ii,ij)     
527         nlcjl       = nlcjtl (jn)
528         nbondjl = -1                                    ! general case
529         IF( jn   >  isplt          )   nbondjl = 0      ! first row of processor
530         IF( jn   >  (jsplt-1)*isplt )  nbondjl = 1     ! last  row of processor
531         IF( jsplt == 1             )   nbondjl = 2      ! one processor only in j-direction
532         ibonjtl(jn) = nbondjl
533         
534         nbondil = 0                                     !
535         IF( MOD( jn, isplt ) == 1 )   nbondil = -1      !
536         IF( MOD( jn, isplt ) == 0 )   nbondil =  1      !
537         IF( isplt            == 1 )   nbondil =  2      ! one processor only in i-direction
538         ibonitl(jn) = nbondil
539         
540         nldil =  1   + jpreci
541         nleil = nlcil - jpreci
542         IF( nbondil == -1 .OR. nbondil == 2 )   nldil = 1
543         IF( nbondil ==  1 .OR. nbondil == 2 )   nleil = nlcil
544         nldjl =  1   + jprecj
545         nlejl = nlcjl - jprecj
546         IF( nbondjl == -1 .OR. nbondjl == 2 )   nldjl = 1
547         IF( nbondjl ==  1 .OR. nbondjl == 2 )   nlejl = nlcjl
548         nlditl(jn) = nldil
549         nleitl(jn) = nleil
550         nldjtl(jn) = nldjl
551         nlejtl(jn) = nlejl
552      END DO
553      !
554      !
555      CALL wrk_dealloc( isplt, jsplt, ilcitl, ilcjtl, iimpptl, ijmpptl )
556      !
557      !
558   END SUBROUTINE sub_dom
559
560   !!======================================================================
561END MODULE prtctl
Note: See TracBrowser for help on using the repository browser.