New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
prtctl.F90 in branches/2012/dev_r3387_LOCEAN6_AGRIF_LIM/NEMOGCM/NEMO/OPA_SRC/IOM – NEMO

source: branches/2012/dev_r3387_LOCEAN6_AGRIF_LIM/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90 @ 3566

Last change on this file since 3566 was 3566, checked in by cetlod, 11 years ago

branch dev_r3387_LOCEAN6_AGRIF_LIM: add some corrections to make AGRIF compatible with TOP

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