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 NEMO/trunk/src/OCE/IOM – NEMO

source: NEMO/trunk/src/OCE/IOM/prtctl.F90 @ 12377

Last change on this file since 12377 was 12377, checked in by acc, 5 years ago

The big one. Merging all 2019 developments from the option 1 branch back onto the trunk.

This changeset reproduces 2019/dev_r11943_MERGE_2019 on the trunk using a 2-URL merge
onto a working copy of the trunk. I.e.:

svn merge --ignore-ancestry \

svn+ssh://acc@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/NEMO/trunk \
svn+ssh://acc@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/NEMO/branches/2019/dev_r11943_MERGE_2019 ./

The --ignore-ancestry flag avoids problems that may otherwise arise from the fact that
the merge history been trunk and branch may have been applied in a different order but
care has been taken before this step to ensure that all applicable fixes and updates
are present in the merge branch.

The trunk state just before this step has been branched to releases/release-4.0-HEAD
and that branch has been immediately tagged as releases/release-4.0.2. Any fixes
or additions in response to tickets on 4.0, 4.0.1 or 4.0.2 should be done on
releases/release-4.0-HEAD. From now on future 'point' releases (e.g. 4.0.2) will
remain unchanged with periodic releases as needs demand. Note release-4.0-HEAD is a
transitional naming convention. Future full releases, say 4.2, will have a release-4.2
branch which fulfills this role and the first point release (e.g. 4.2.0) will be made
immediately following the release branch creation.

2020 developments can be started from any trunk revision later than this one.

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