123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586 |
- MODULE prtctl
- !!======================================================================
- !! *** MODULE prtctl ***
- !! Ocean system : print all SUM trends for each processor domain
- !!======================================================================
- !! History : 9.0 ! 05-07 (C. Talandier) original code
- !! 3.4 ! 11-11 (C. Harris) decomposition changes for running with CICE
- !!----------------------------------------------------------------------
- USE dom_oce ! ocean space and time domain variables
- #if defined key_nemocice_decomp
- USE ice_domain_size, only: nx_global, ny_global
- #endif
- USE in_out_manager ! I/O manager
- USE lib_mpp ! distributed memory computing
- USE wrk_nemo ! work arrays
- IMPLICIT NONE
- PRIVATE
- INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: numid
- INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nlditl , nldjtl ! first, last indoor index for each i-domain
- INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nleitl , nlejtl ! first, last indoor index for each j-domain
- INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nimpptl, njmpptl ! i-, j-indexes for each processor
- INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nlcitl , nlcjtl ! dimensions of every subdomain
- INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: ibonitl, ibonjtl !
- REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: t_ctll , s_ctll ! previous tracer trend values
- REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: u_ctll , v_ctll ! previous velocity trend values
- INTEGER :: ktime ! time step
- PUBLIC prt_ctl ! called by all subroutines
- PUBLIC prt_ctl_info ! called by all subroutines
- PUBLIC prt_ctl_init ! called by opa.F90
- PUBLIC sub_dom ! called by opa.F90
- !!----------------------------------------------------------------------
- !! NEMO/OPA 3.3 , NEMO Consortium (2010)
- !! $Id: prtctl.F90 4520 2014-02-28 11:44:02Z acc $
- !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
- !!----------------------------------------------------------------------
- CONTAINS
- SUBROUTINE prt_ctl (tab2d_1, tab3d_1, mask1, clinfo1, tab2d_2, tab3d_2, &
- & mask2, clinfo2, ovlap, kdim, clinfo3 )
- !!----------------------------------------------------------------------
- !! *** ROUTINE prt_ctl ***
- !!
- !! ** Purpose : - print sum control of 2D or 3D arrays over the same area
- !! in mono and mpp case. This way can be usefull when
- !! debugging a new parametrization in mono or mpp.
- !!
- !! ** Method : 2 possibilities exist when setting the ln_ctl parameter to
- !! .true. in the ocean namelist:
- !! - to debug a MPI run .vs. a mono-processor one;
- !! the control print will be done over each sub-domain.
- !! The nictl[se] and njctl[se] parameters in the namelist must
- !! be set to zero and [ij]splt to the corresponding splitted
- !! domain in MPI along respectively i-, j- directions.
- !! - to debug a mono-processor run over the whole domain/a specific area;
- !! in the first case the nictl[se] and njctl[se] parameters must be set
- !! to zero else to the indices of the area to be controled. In both cases
- !! isplt and jsplt must be set to 1.
- !! - All arguments of the above calling sequence are optional so their
- !! name must be explicitly typed if used. For instance if the 3D
- !! array tn(:,:,:) must be passed through the prt_ctl subroutine,
- !! it must looks like: CALL prt_ctl(tab3d_1=tn).
- !!
- !! tab2d_1 : first 2D array
- !! tab3d_1 : first 3D array
- !! mask1 : mask (3D) to apply to the tab[23]d_1 array
- !! clinfo1 : information about the tab[23]d_1 array
- !! tab2d_2 : second 2D array
- !! tab3d_2 : second 3D array
- !! mask2 : mask (3D) to apply to the tab[23]d_2 array
- !! clinfo2 : information about the tab[23]d_2 array
- !! ovlap : overlap value
- !! kdim : k- direction for 3D arrays
- !! clinfo3 : additional information
- !!----------------------------------------------------------------------
- REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1
- REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: tab3d_1
- REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask1
- CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo1
- REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2
- REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: tab3d_2
- REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask2
- CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo2
- INTEGER , INTENT(in), OPTIONAL :: ovlap
- INTEGER , INTENT(in), OPTIONAL :: kdim
- CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo3
- !
- CHARACTER (len=15) :: cl2
- INTEGER :: overlap, jn, sind, eind, kdir,j_id
- REAL(wp) :: zsum1, zsum2, zvctl1, zvctl2
- REAL(wp), POINTER, DIMENSION(:,:) :: ztab2d_1, ztab2d_2
- REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask1, zmask2, ztab3d_1, ztab3d_2
- !!----------------------------------------------------------------------
- CALL wrk_alloc( jpi,jpj, ztab2d_1, ztab2d_2 )
- CALL wrk_alloc( jpi,jpj,jpk, zmask1, zmask2, ztab3d_1, ztab3d_2 )
- ! Arrays, scalars initialization
- overlap = 0
- kdir = jpkm1
- cl2 = ''
- zsum1 = 0.e0
- zsum2 = 0.e0
- zvctl1 = 0.e0
- zvctl2 = 0.e0
- ztab2d_1(:,:) = 0.e0
- ztab2d_2(:,:) = 0.e0
- ztab3d_1(:,:,:) = 0.e0
- ztab3d_2(:,:,:) = 0.e0
- zmask1 (:,:,:) = 1.e0
- zmask2 (:,:,:) = 1.e0
- ! Control of optional arguments
- IF( PRESENT(clinfo2) ) cl2 = clinfo2
- IF( PRESENT(ovlap) ) overlap = ovlap
- IF( PRESENT(kdim) ) kdir = kdim
- IF( PRESENT(tab2d_1) ) ztab2d_1(:,:) = tab2d_1(:,:)
- IF( PRESENT(tab2d_2) ) ztab2d_2(:,:) = tab2d_2(:,:)
- IF( PRESENT(tab3d_1) ) ztab3d_1(:,:,1:kdir) = tab3d_1(:,:,1:kdir)
- IF( PRESENT(tab3d_2) ) ztab3d_2(:,:,1:kdir) = tab3d_2(:,:,1:kdir)
- IF( PRESENT(mask1) ) zmask1 (:,:,:) = mask1 (:,:,:)
- IF( PRESENT(mask2) ) zmask2 (:,:,:) = mask2 (:,:,:)
- IF( lk_mpp .AND. jpnij > 1 ) THEN ! processor number
- sind = narea
- eind = narea
- ELSE ! processors total number
- sind = 1
- eind = ijsplt
- ENDIF
- ! Loop over each sub-domain, i.e. the total number of processors ijsplt
- DO jn = sind, eind
- ! Set logical unit
- j_id = numid(jn - narea + 1)
- ! Set indices for the SUM control
- IF( .NOT. lsp_area ) THEN
- IF (lk_mpp .AND. jpnij > 1) THEN
- nictls = MAX( 1, nlditl(jn) - overlap )
- nictle = nleitl(jn) + overlap * MIN( 1, nlcitl(jn) - nleitl(jn))
- njctls = MAX( 1, nldjtl(jn) - overlap )
- njctle = nlejtl(jn) + overlap * MIN( 1, nlcjtl(jn) - nlejtl(jn))
- ! Do not take into account the bound of the domain
- IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls)
- IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls)
- IF( ibonitl(jn) == 1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nleitl(jn) - 1)
- IF( ibonjtl(jn) == 1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, nlejtl(jn) - 1)
- ELSE
- nictls = MAX( 1, nimpptl(jn) + nlditl(jn) - 1 - overlap )
- nictle = nimpptl(jn) + nleitl(jn) - 1 + overlap * MIN( 1, nlcitl(jn) - nleitl(jn) )
- njctls = MAX( 1, njmpptl(jn) + nldjtl(jn) - 1 - overlap )
- njctle = njmpptl(jn) + nlejtl(jn) - 1 + overlap * MIN( 1, nlcjtl(jn) - nlejtl(jn) )
- ! Do not take into account the bound of the domain
- IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls)
- IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls)
- IF( ibonitl(jn) == 1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nimpptl(jn) + nleitl(jn) - 2)
- IF( ibonjtl(jn) == 1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, njmpptl(jn) + nlejtl(jn) - 2)
- ENDIF
- ENDIF
- IF( PRESENT(clinfo3)) THEN
- IF ( clinfo3 == 'tra' ) THEN
- zvctl1 = t_ctll(jn)
- zvctl2 = s_ctll(jn)
- ELSEIF ( clinfo3 == 'dyn' ) THEN
- zvctl1 = u_ctll(jn)
- zvctl2 = v_ctll(jn)
- ENDIF
- ENDIF
- ! Compute the sum control
- ! 2D arrays
- IF( PRESENT(tab2d_1) ) THEN
- zsum1 = SUM( ztab2d_1(nictls:nictle,njctls:njctle)*zmask1(nictls:nictle,njctls:njctle,1) )
- zsum2 = SUM( ztab2d_2(nictls:nictle,njctls:njctle)*zmask2(nictls:nictle,njctls:njctle,1) )
- ENDIF
- ! 3D arrays
- IF( PRESENT(tab3d_1) ) THEN
- zsum1 = SUM( ztab3d_1(nictls:nictle,njctls:njctle,1:kdir)*zmask1(nictls:nictle,njctls:njctle,1:kdir) )
- zsum2 = SUM( ztab3d_2(nictls:nictle,njctls:njctle,1:kdir)*zmask2(nictls:nictle,njctls:njctle,1:kdir) )
- ENDIF
- ! Print the result
- IF( PRESENT(clinfo3) ) THEN
- WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1-zvctl1, cl2, zsum2-zvctl2
- SELECT CASE( clinfo3 )
- CASE ( 'tra-ta' )
- t_ctll(jn) = zsum1
- CASE ( 'tra' )
- t_ctll(jn) = zsum1
- s_ctll(jn) = zsum2
- CASE ( 'dyn' )
- u_ctll(jn) = zsum1
- v_ctll(jn) = zsum2
- END SELECT
- ELSEIF ( PRESENT(clinfo2) .OR. PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN
- WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1, cl2, zsum2
- ELSE
- WRITE(j_id,FMT='(a,D23.16)')clinfo1, zsum1
- ENDIF
- ENDDO
- CALL wrk_dealloc( jpi,jpj, ztab2d_1, ztab2d_2 )
- CALL wrk_dealloc( jpi,jpj,jpk, zmask1, zmask2, ztab3d_1, ztab3d_2 )
- !
- END SUBROUTINE prt_ctl
- SUBROUTINE prt_ctl_info (clinfo1, ivar1, clinfo2, ivar2, itime)
- !!----------------------------------------------------------------------
- !! *** ROUTINE prt_ctl_info ***
- !!
- !! ** Purpose : - print information without any computation
- !!
- !! ** Action : - input arguments
- !! clinfo1 : information about the ivar1
- !! ivar1 : value to print
- !! clinfo2 : information about the ivar2
- !! ivar2 : value to print
- !!----------------------------------------------------------------------
- CHARACTER (len=*), INTENT(in) :: clinfo1
- INTEGER , INTENT(in), OPTIONAL :: ivar1
- CHARACTER (len=*), INTENT(in), OPTIONAL :: clinfo2
- INTEGER , INTENT(in), OPTIONAL :: ivar2
- INTEGER , INTENT(in), OPTIONAL :: itime
- !
- INTEGER :: jn, sind, eind, iltime, j_id
- !!----------------------------------------------------------------------
- IF( lk_mpp .AND. jpnij > 1 ) THEN ! processor number
- sind = narea
- eind = narea
- ELSE ! total number of processors
- sind = 1
- eind = ijsplt
- ENDIF
- ! Set to zero arrays at each new time step
- IF( PRESENT(itime) ) THEN
- iltime = itime
- IF( iltime > ktime ) THEN
- t_ctll(:) = 0.e0 ; s_ctll(:) = 0.e0
- u_ctll(:) = 0.e0 ; v_ctll(:) = 0.e0
- ktime = iltime
- ENDIF
- ENDIF
- ! Loop over each sub-domain, i.e. number of processors ijsplt
- DO jn = sind, eind
- !
- j_id = numid(jn - narea + 1) ! Set logical unit
- !
- IF( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. PRESENT(ivar2) ) THEN
- WRITE(j_id,*)clinfo1, ivar1, clinfo2, ivar2
- ELSEIF ( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) ) THEN
- WRITE(j_id,*)clinfo1, ivar1, clinfo2
- ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. PRESENT(ivar2) ) THEN
- WRITE(j_id,*)clinfo1, ivar1, ivar2
- ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) ) THEN
- WRITE(j_id,*)clinfo1, ivar1
- ELSE
- WRITE(j_id,*)clinfo1
- ENDIF
- !
- END DO
- !
- END SUBROUTINE prt_ctl_info
- SUBROUTINE prt_ctl_init
- !!----------------------------------------------------------------------
- !! *** ROUTINE prt_ctl_init ***
- !!
- !! ** Purpose : open ASCII files & compute indices
- !!----------------------------------------------------------------------
- INTEGER :: jn, sind, eind, j_id
- CHARACTER (len=28) :: clfile_out
- CHARACTER (len=23) :: clb_name
- CHARACTER (len=19) :: cl_run
- !!----------------------------------------------------------------------
- ! Allocate arrays
- ALLOCATE( nlditl(ijsplt) , nleitl(ijsplt) , nimpptl(ijsplt) , ibonitl(ijsplt) , &
- & nldjtl(ijsplt) , nlejtl(ijsplt) , njmpptl(ijsplt) , ibonjtl(ijsplt) , &
- & nlcitl(ijsplt) , t_ctll(ijsplt) , u_ctll (ijsplt) , &
- & nlcjtl(ijsplt) , s_ctll(ijsplt) , v_ctll (ijsplt) )
- ! Initialization
- t_ctll(:) = 0.e0
- s_ctll(:) = 0.e0
- u_ctll(:) = 0.e0
- v_ctll(:) = 0.e0
- ktime = 1
- IF( lk_mpp .AND. jpnij > 1 ) THEN
- sind = narea
- eind = narea
- clb_name = "('mpp.output_',I4.4)"
- cl_run = 'MULTI processor run'
- ! use indices for each area computed by mpp_init subroutine
- nlditl(1:jpnij) = nldit(:)
- nleitl(1:jpnij) = nleit(:)
- nldjtl(1:jpnij) = nldjt(:)
- nlejtl(1:jpnij) = nlejt(:)
- !
- nimpptl(1:jpnij) = nimppt(:)
- njmpptl(1:jpnij) = njmppt(:)
- !
- nlcitl(1:jpnij) = nlcit(:)
- nlcjtl(1:jpnij) = nlcjt(:)
- !
- ibonitl(1:jpnij) = ibonit(:)
- ibonjtl(1:jpnij) = ibonjt(:)
- ELSE
- sind = 1
- eind = ijsplt
- clb_name = "('mono.output_',I4.4)"
- cl_run = 'MONO processor run '
- ! compute indices for each area as done in mpp_init subroutine
- CALL sub_dom
- ENDIF
- ALLOCATE( numid(eind-sind+1) )
- DO jn = sind, eind
- WRITE(clfile_out,FMT=clb_name) jn-1
- CALL ctl_opn( numid(jn -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', 1, numout, .FALSE. )
- j_id = numid(jn -narea + 1)
- WRITE(j_id,*)
- WRITE(j_id,*) ' L O D Y C - I P S L'
- WRITE(j_id,*) ' O P A model'
- WRITE(j_id,*) ' Ocean General Circulation Model'
- WRITE(j_id,*) ' version OPA 9.0 (2005) '
- WRITE(j_id,*)
- WRITE(j_id,*) ' PROC number: ', jn
- WRITE(j_id,*)
- WRITE(j_id,FMT="(19x,a20)")cl_run
- ! Print the SUM control indices
- IF( .NOT. lsp_area ) THEN
- nictls = nimpptl(jn) + nlditl(jn) - 1
- nictle = nimpptl(jn) + nleitl(jn) - 1
- njctls = njmpptl(jn) + nldjtl(jn) - 1
- njctle = njmpptl(jn) + nlejtl(jn) - 1
- ENDIF
- WRITE(j_id,*)
- WRITE(j_id,*) 'prt_ctl : Sum control indices'
- WRITE(j_id,*) '~~~~~~~'
- WRITE(j_id,*)
- WRITE(j_id,9000)' nlej = ', nlejtl(jn), ' '
- WRITE(j_id,9000)' ------------- njctle = ', njctle, ' -------------'
- WRITE(j_id,9001)' | |'
- WRITE(j_id,9001)' | |'
- WRITE(j_id,9001)' | |'
- WRITE(j_id,9002)' nictls = ', nictls, ' nictle = ', nictle
- WRITE(j_id,9002)' nldi = ', nlditl(jn), ' nlei = ', nleitl(jn)
- WRITE(j_id,9001)' | |'
- WRITE(j_id,9001)' | |'
- WRITE(j_id,9001)' | |'
- WRITE(j_id,9004)' njmpp = ',njmpptl(jn),' ------------- njctls = ', njctls, ' -------------'
- WRITE(j_id,9003)' nimpp = ', nimpptl(jn), ' nldj = ', nldjtl(jn), ' '
- WRITE(j_id,*)
- WRITE(j_id,*)
- 9000 FORMAT(a41,i4.4,a14)
- 9001 FORMAT(a59)
- 9002 FORMAT(a20,i4.4,a36,i3.3)
- 9003 FORMAT(a20,i4.4,a17,i4.4)
- 9004 FORMAT(a11,i4.4,a26,i4.4,a14)
- END DO
- !
- END SUBROUTINE prt_ctl_init
- SUBROUTINE sub_dom
- !!----------------------------------------------------------------------
- !! *** ROUTINE sub_dom ***
- !!
- !! ** Purpose : Lay out the global domain over processors.
- !! CAUTION:
- !! This part has been extracted from the mpp_init
- !! subroutine and names of variables/arrays have been
- !! slightly changed to avoid confusion but the computation
- !! is exactly the same. Any modification about indices of
- !! each sub-domain in the mppini.F90 module should be reported
- !! here.
- !!
- !! ** Method : Global domain is distributed in smaller local domains.
- !! Periodic condition is a function of the local domain position
- !! (global boundary or neighbouring domain) and of the global
- !! periodic
- !! Type : jperio global periodic condition
- !! nperio local periodic condition
- !!
- !! ** Action : - set domain parameters
- !! nimpp : longitudinal index
- !! njmpp : latitudinal index
- !! nperio : lateral condition type
- !! narea : number for local area
- !! nlcil : first dimension
- !! nlcjl : second dimension
- !! nbondil : mark for "east-west local boundary"
- !! nbondjl : mark for "north-south local boundary"
- !!
- !! History :
- !! ! 94-11 (M. Guyon) Original code
- !! ! 95-04 (J. Escobar, M. Imbard)
- !! ! 98-02 (M. Guyon) FETI method
- !! ! 98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI versions
- !! 8.5 ! 02-08 (G. Madec) F90 : free form
- !!----------------------------------------------------------------------
- INTEGER :: ji, jj, jn ! dummy loop indices
- INTEGER :: &
- ii, ij, & ! temporary integers
- irestil, irestjl, & ! " "
- ijpi , ijpj, nlcil, & ! temporary logical unit
- nlcjl , nbondil, nbondjl, &
- nrecil, nrecjl, nldil, nleil, nldjl, nlejl
- INTEGER, POINTER, DIMENSION(:,:) :: iimpptl, ijmpptl, ilcitl, ilcjtl ! workspace
- REAL(wp) :: zidom, zjdom ! temporary scalars
- !!----------------------------------------------------------------------
- !
- CALL wrk_alloc( isplt, jsplt, ilcitl, ilcjtl, iimpptl, ijmpptl )
- !
- ! 1. Dimension arrays for subdomains
- ! -----------------------------------
- ! Computation of local domain sizes ilcitl() ilcjtl()
- ! These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo
- ! The subdomains are squares leeser than or equal to the global
- ! dimensions divided by the number of processors minus the overlap
- ! array (cf. par_oce.F90).
- #if defined key_nemocice_decomp
- ijpi = ( nx_global+2-2*jpreci + (isplt-1) ) / isplt + 2*jpreci
- ijpj = ( ny_global+2-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj
- #else
- ijpi = ( jpiglo-2*jpreci + (isplt-1) ) / isplt + 2*jpreci
- ijpj = ( jpjglo-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj
- #endif
- nrecil = 2 * jpreci
- nrecjl = 2 * jprecj
- irestil = MOD( jpiglo - nrecil , isplt )
- irestjl = MOD( jpjglo - nrecjl , jsplt )
- IF( irestil == 0 ) irestil = isplt
- #if defined key_nemocice_decomp
- ! In order to match CICE the size of domains in NEMO has to be changed
- ! The last line of blocks (west) will have fewer points
- DO jj = 1, jsplt
- DO ji=1, isplt-1
- ilcitl(ji,jj) = ijpi
- END DO
- ilcitl(isplt,jj) = jpiglo - (isplt - 1) * (ijpi - nrecil)
- END DO
- #else
- DO jj = 1, jsplt
- DO ji = 1, irestil
- ilcitl(ji,jj) = ijpi
- END DO
- DO ji = irestil+1, isplt
- ilcitl(ji,jj) = ijpi -1
- END DO
- END DO
- #endif
-
- IF( irestjl == 0 ) irestjl = jsplt
- #if defined key_nemocice_decomp
- ! Same change to domains in North-South direction as in East-West.
- DO ji = 1, isplt
- DO jj=1, jsplt-1
- ilcjtl(ji,jj) = ijpj
- END DO
- ilcjtl(ji,jsplt) = jpjglo - (jsplt - 1) * (ijpj - nrecjl)
- END DO
- #else
- DO ji = 1, isplt
- DO jj = 1, irestjl
- ilcjtl(ji,jj) = ijpj
- END DO
- DO jj = irestjl+1, jsplt
- ilcjtl(ji,jj) = ijpj -1
- END DO
- END DO
- #endif
- zidom = nrecil
- DO ji = 1, isplt
- zidom = zidom + ilcitl(ji,1) - nrecil
- END DO
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*)' sum ilcitl(i,1) = ', zidom, ' jpiglo = ', jpiglo
-
- zjdom = nrecjl
- DO jj = 1, jsplt
- zjdom = zjdom + ilcjtl(1,jj) - nrecjl
- END DO
- IF(lwp) WRITE(numout,*)' sum ilcitl(1,j) = ', zjdom, ' jpjglo = ', jpjglo
- IF(lwp) WRITE(numout,*)
-
- ! 2. Index arrays for subdomains
- ! -------------------------------
- iimpptl(:,:) = 1
- ijmpptl(:,:) = 1
-
- IF( isplt > 1 ) THEN
- DO jj = 1, jsplt
- DO ji = 2, isplt
- iimpptl(ji,jj) = iimpptl(ji-1,jj) + ilcitl(ji-1,jj) - nrecil
- END DO
- END DO
- ENDIF
- IF( jsplt > 1 ) THEN
- DO jj = 2, jsplt
- DO ji = 1, isplt
- ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ilcjtl(ji,jj-1)-nrecjl
- END DO
- END DO
- ENDIF
-
- ! 3. Subdomain description
- ! ------------------------
- DO jn = 1, ijsplt
- ii = 1 + MOD( jn-1, isplt )
- ij = 1 + (jn-1) / isplt
- nimpptl(jn) = iimpptl(ii,ij)
- njmpptl(jn) = ijmpptl(ii,ij)
- nlcitl (jn) = ilcitl (ii,ij)
- nlcil = nlcitl (jn)
- nlcjtl (jn) = ilcjtl (ii,ij)
- nlcjl = nlcjtl (jn)
- nbondjl = -1 ! general case
- IF( jn > isplt ) nbondjl = 0 ! first row of processor
- IF( jn > (jsplt-1)*isplt ) nbondjl = 1 ! last row of processor
- IF( jsplt == 1 ) nbondjl = 2 ! one processor only in j-direction
- ibonjtl(jn) = nbondjl
-
- nbondil = 0 !
- IF( MOD( jn, isplt ) == 1 ) nbondil = -1 !
- IF( MOD( jn, isplt ) == 0 ) nbondil = 1 !
- IF( isplt == 1 ) nbondil = 2 ! one processor only in i-direction
- ibonitl(jn) = nbondil
-
- nldil = 1 + jpreci
- nleil = nlcil - jpreci
- IF( nbondil == -1 .OR. nbondil == 2 ) nldil = 1
- IF( nbondil == 1 .OR. nbondil == 2 ) nleil = nlcil
- nldjl = 1 + jprecj
- nlejl = nlcjl - jprecj
- IF( nbondjl == -1 .OR. nbondjl == 2 ) nldjl = 1
- IF( nbondjl == 1 .OR. nbondjl == 2 ) nlejl = nlcjl
- nlditl(jn) = nldil
- nleitl(jn) = nleil
- nldjtl(jn) = nldjl
- nlejtl(jn) = nlejl
- END DO
- !
- !
- CALL wrk_dealloc( isplt, jsplt, ilcitl, ilcjtl, iimpptl, ijmpptl )
- !
- !
- END SUBROUTINE sub_dom
- !!======================================================================
- END MODULE prtctl
|