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/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/IOM – NEMO

source: branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90 @ 4405

Last change on this file since 4405 was 3211, checked in by spickles2, 12 years ago

Stephen Pickles, 11 Dec 2011

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