!
subroutine cct_integrate(rname,hcct,dcct,error)
  use gkernel_interfaces
  use image_def
  use gbl_message
  use imager_interfaces, only : map_message
  !---------------------------------------------------------------------
  ! @ private
  !*
  ! IMAGER -- Support for commands SHOW and VIEW CCT 
  !
  !   Compute the cumulative flux in Clean Components, and give access
  !   to it through the CCT_NCOMP and CCT_FLUX arrays.
  !!
  !---------------------------------------------------------------------  
  character(len=*), intent(in) :: rname     !! Command name
  type(gildas), intent(in) :: hcct          !! Header
  real, intent(in) :: dcct(:,:,:)           !! CCT array
  logical, intent(inout) :: error           !! Logical Error flag
  !
  ! Local ---
  real, allocatable, save :: fcct(:,:)
  integer, allocatable, save :: mcomp(:)
  integer, allocatable, save :: ftyp(:,:)
  real :: csize(20) ! Ample storage for Component sizes
  integer :: ic,jc,ncomp,nchan,ier
  integer :: is,js,ns
  integer(kind=index_length) :: dim(2)
  logical :: do_size
  !
  ! Code ----
  call sic_delvariable('CCT_NCOMP',.false.,error)
  call sic_delvariable('CCT_TYPE',.false.,error)    
  call sic_delvariable('CCT_FLUX',.false.,error)    
  if (allocated(fcct)) then
    deallocate(fcct,mcomp)
    if (allocated(ftyp)) deallocate(ftyp)
  endif
  !
  ! The FCCT array has a dummy Clean component number 0
  ! to start from Null flux value
  ncomp = hcct%gil%dim(3)+1
  nchan = hcct%gil%dim(2)
  !
  do_size = hcct%gil%dim(1) .eq.4    ! Check size of Component if needed
  if (do_size) then
    allocate(fcct(ncomp,nchan),mcomp(nchan),ftyp(ncomp,nchan),stat=ier)
    ns = 1
    csize = 0.0
    ftyp = 0
  else
    allocate(fcct(ncomp,nchan),mcomp(nchan),stat=ier)
  endif
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Memory allocation error')
    error = .true.
    return
  endif
  !
  fcct = 0.0  ! Initialize
  do ic=1,nchan
    fcct(1,ic) = 0 
    mcomp(ic) = ncomp
    do jc=1,ncomp-1           ! Stop at the number of components !...
      if (dcct(3,ic,jc).eq.0) then
        mcomp(ic) = jc
        exit
      else
        fcct(jc+1,ic) = dcct(3,ic,jc) + fcct(jc,ic)
        if (do_size) then
          js = 0
          do is = 1,ns
            if (dcct(4,ic,jc).eq.csize(is)) then
              js = is
              exit
            endif
          enddo
          if (js.eq.0) then
            ns = ns+1
            csize(ns) = dcct(4,ic,jc)
            js = ns
          endif
          ftyp(jc+1,ic) = js 
        endif
      endif
    enddo
    if (do_size) fcct(1,ic) = fcct(2,ic)
  enddo
  !
  dim(1) = ncomp
  dim(2) = nchan
  call sic_def_real('CCT_FLUX',fcct,2,dim,.true.,error)
  if (do_size) then
    call sic_def_inte('CCT_TYPE',ftyp,2,dim,.true.,error)
  endif
  dim(1) = nchan
  call sic_def_inte('CCT_NCOMP',mcomp,1,dim,.true.,error)
end subroutine cct_integrate
!
subroutine cct_remove_start(head,iplane,resid,tfbeam,dcct,tcc, &
  & nfields,primary,weight,wtrun,next_iter,start_flux)
  use image_def
  use clean_def
  use imager_interfaces, only : map_message, mulgau
  use gbl_message
  use omp_lib
  !----------------------------------------------------------
  ! @ private-mandatory
  !*
  ! IMAGER -- Support for command CLEAN /RESTART
  !
  !   Subtract a Starting List of Clean Components.
  !!
  !----------------------------------------------------------
  type(gildas), intent(in) :: head          !! Imager Header
  integer, intent(in) :: iplane             !! Current plane number
  real, intent(inout) :: resid(:,:)         !! Current residual
  real, intent(in) :: dcct(:,:,:)           !! Clean Component List (from READ CCT)
  real, intent(in) :: tfbeam(:,:,:)         !! Dirty Beam FT (Gridded UV coverage)
  type(cct_par), intent(inout) :: tcc(:)    !! Clean Component Table
  integer, intent(in) :: nfields            !! Number of fields
  real, intent(in) :: primary(:,:,:)        !! Primary beams
  real, intent(in) :: weight(:,:)           !! Mosaic weights
  real, intent(in) :: wtrun                 !! Mosaic primary beam truncation
  integer, intent(out) :: next_iter         !! Next available CC
  real, intent(out) :: start_flux           !! Cumulative flux in Starting list
  !
  ! Local ---
  integer :: isc  ! Component number
  integer :: isx, isy ! Pixel of Clean Component
  integer :: ksp  ! Plane number of Clean Component
  integer :: nx, ny   ! Image size
  integer :: np   ! Number of channels in Clean Components
  integer :: nc   ! Number of Clean Components
  integer :: ier
  integer :: i,j,k,ip ! For mosaics
  integer :: nn(2), ndim
  complex, allocatable :: fcomp(:,:)
  real, allocatable :: clean(:,:)
  real, allocatable :: wfft(:)
  logical :: do_size
  real :: sizes(20)
  integer :: n_size, is, js
  real :: fact, xinc, yinc
  integer :: ithread
  character(len=80) :: chain
  !
  ! Code ----
  ithread = 0
  !$ ithread = omp_get_thread_num()+1
  write(chain,'(A,I0,A,I0)') 'Entering CCT_REMOVE_START plane ',iplane,' thread ',ithread
  call map_message(seve%t,'CLEAN /RESTART',chain)
  nx = head%gil%dim(1) 
  ny = head%gil%dim(2)
  do_size = ubound(dcct,1).eq.4   ! Variable size Components
  np = ubound(dcct,2)   ! Number of planes in CCT
  nc = ubound(dcct,3)   ! Maximum number of Clean Components in CCT
  if (nfields.le.1) then
    isx = 1
    isy = 1
  else
    isx = nx
    isy = ny
  endif
  allocate(fcomp(nx,ny),clean(isx,isy),wfft(2*max(nx,ny)),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,'CLEAN /RESTART','Memory allocation error in CCT_REMOVE_START')
    return
  endif
  !
  next_iter = nc+1 
  start_flux = 0
  n_size = 1 ! By default, only Point sources
  sizes = 0.0
  !
  do isc=1,nc
    ksp = min(np, iplane)  ! Plane number
    isx = nint( (dcct(1,ksp,isc)-head%gil%val(1)) / head%gil%inc(1) + head%gil%ref(1) )
    isy = nint( (dcct(2,ksp,isc)-head%gil%val(2)) / head%gil%inc(2) + head%gil%ref(2) )
    tcc(isc)%value = dcct(3,ksp,isc)
    tcc(isc)%size = 0
    if (tcc(isc)%value.eq.0) then
      next_iter = isc
      exit
    endif
    tcc(isc)%ix = isx
    tcc(isc)%iy = isy
    tcc(isc)%size = 0
    if (do_size) then
      js = 0
      do is=1,n_size
        if (sizes(is).eq.dcct(4,ksp,isc)) then
          js = is
          exit
        endif
      enddo
      if ((js.eq.0).and.(n_size.le.20)) then
        n_size = n_size+1
        sizes(n_size) = dcct(4,ksp,isc)
        js = n_size
      endif
      if (js.eq.0) js = n_size
      tcc(isc)%size = sizes(js)
    endif
    !
    start_flux = start_flux+tcc(isc)%value
  enddo
  tcc(next_iter)%ix = 0
  tcc(next_iter)%iy = 0
  tcc(next_iter)%value = 0
  tcc(next_iter)%size = 0
  !
  ndim = 2
  nn(1) = nx
  nn(2) = ny
  if (n_size.eq.1) then
    !
    if (nfields.le.1) then
      fcomp = 0.0   ! Initialize
      do isc=1,next_iter-1
        fcomp(tcc(isc)%ix,tcc(isc)%iy) = fcomp(tcc(isc)%ix,tcc(isc)%iy) + cmplx(tcc(isc)%value,0.0)
      enddo
      !
      ! Remove this by Convolution with Dirty Beam
      call fourt(fcomp,nn,ndim,-1,0,wfft)
      fcomp(:,:) = fcomp*tfbeam(:,:,1)
      call fourt(fcomp,nn,ndim,1,1,wfft)
      resid = resid-real(fcomp)
    else
      ! Optimized by using CLEAN to store sum of components before multiplying
      ! by the weights to subtract from the Residuals
      clean = 0.0
      do ip=1,nfields
        fcomp = 0.0
        do k=1,next_iter-1
          fcomp(tcc(k)%ix,tcc(k)%iy) = tcc(k)%value   &
       &          * primary(ip,tcc(k)%ix,tcc(k)%iy)
        enddo
        call fourt(fcomp,nn,ndim,-1,0,wfft)
        fcomp(:,:) = fcomp*tfbeam(:,:,ip)
        call fourt(fcomp,nn,ndim,1,1,wfft)
        do j=1,ny
          do i=1,nx
            if (primary(ip,i,j).gt.wtrun) then
              clean(i,j) = clean(i,j) + real(fcomp(i,j))   &
       &              *primary(ip,i,j)
            endif
          enddo
        enddo
      enddo
      resid = resid - clean*weight
    endif
  else
    if (nfields.gt.1) call map_message(seve%w,'CLEAN /RESTART', &
      & 'Restarting from GCLEAN component list under debug for Mosaics')
    !
    fact = 1.0 ! or 1.0/(nx*ny) ! or 1 ?
    xinc = head%gil%inc(1)
    yinc = head%gil%inc(2)
    !
    do is=1,n_size
      if (nfields.le.1) then
        fcomp = 0.0   ! Initialize
        do isc=1,next_iter-1
          if (tcc(isc)%size.eq.sizes(is)) fcomp(tcc(isc)%ix,tcc(isc)%iy) = &
            & fcomp(tcc(isc)%ix,tcc(isc)%iy) + cmplx(tcc(isc)%value,0.0)
        enddo
        !
        ! Remove this by Convolution with Dirty Beam
        call fourt(fcomp,nn,ndim,-1,0,wfft)
        fcomp(:,:) = fcomp*tfbeam(:,:,1)
        ! Smooth by the Gaussian
        if (sizes(is).ne.0) then
          call mulgau(fcomp,nx,ny,   &
             &    sizes(is),sizes(is),0.0,  &
             &    fact,xinc,yinc,-1)
        endif
        call fourt(fcomp,nn,ndim,1,1,wfft)
        resid = resid-real(fcomp)
      else
        ! Optimized by using CLEAN to store sum of components before multiplying
        ! by the weights to subtract from the Residuals
        clean = 0.0
        do ip=1,nfields
          fcomp = 0.0
          do k=1,next_iter-1
            if (tcc(k)%size.eq.sizes(is)) fcomp(tcc(k)%ix,tcc(k)%iy) = tcc(k)%value   &
         &          * primary(ip,tcc(k)%ix,tcc(k)%iy)
          enddo
          call fourt(fcomp,nn,ndim,-1,0,wfft)
          fcomp(:,:) = fcomp*tfbeam(:,:,ip)
          ! Smooth by the Gaussian - WARNING - The convolution should have been done before
          ! the Primary beam attenuation in strict theory...
          if (sizes(is).ne.0) then
            call mulgau(fcomp,nx,ny,   &
               &    sizes(is),sizes(is),0.0,  &
               &    fact,xinc,yinc,-1)
          endif
          call fourt(fcomp,nn,ndim,1,1,wfft)
          do j=1,ny
            do i=1,nx
              if (primary(ip,i,j).gt.wtrun) then
                clean(i,j) = clean(i,j) + real(fcomp(i,j))   &
         &              *primary(ip,i,j)
              endif
            enddo
          enddo
        enddo
        resid = resid - clean*weight
      endif
    enddo
    !
  endif
  deallocate(fcomp,clean,wfft,stat=ier)
  !
end subroutine cct_remove_start
!
subroutine uv_compact_clean(hcct,ccin,occt,ccou, mic)
  use image_def
  !-----------------------------------------------------------------
  ! @ private
  !
  ! IMAGER -- Support for command UV_RESTORE
  !
  !   Compact the component list by summing up all values at the
  !   same position
  !!
  !-----------------------------------------------------------------
  type(gildas), intent(in) :: hcct    !! header of Input CCT data set
  type(gildas), intent(in) :: occt    !! header of output CCT data set
  real, intent(in) :: ccin(hcct%gil%dim(1),hcct%gil%dim(2),hcct%gil%dim(3))
  !! Input CCT data set
  real, intent(out) :: ccou(occt%gil%dim(1),occt%gil%dim(2),occt%gil%dim(3))
  !! Output CCT data set
  integer, intent(inout) :: mic       !! Last valid component
  !
  ! Local ---
  integer nc
  integer ni
  integer :: ii,jj,ic
  integer :: ki, mi     ! Number of different components per channel
  logical :: doit, do_size
  integer :: scc
  !
  ! Code ----
  nc = hcct%gil%dim(2)
  ni = mic              ! no longer equal to hcct%gil%dim(3)
  scc = hcct%gil%dim(1) ! Size of a Clean Component (3 or 4)
  do_size = scc.eq.4    ! Check size if needed
  !
  mi = 0
  ccou = 0
  !
  do ic=1,nc
    ki = 0
    do ii=1,ni
      if (ccin(3,ic,ii).eq.0) then
        exit
      else
        doit = .true.
        do jj=1,ki
          if (ccou(1,ic,jj).eq.ccin(1,ic,ii)) then
            if (ccou(2,ic,jj).eq.ccin(2,ic,ii)) then
              if (do_size) then
                if (ccou(4,ic,jj).eq.ccin(4,ic,ii)) then
                  doit = .false.
                  ccou(3,ic,jj) = ccou(3,ic,jj) + ccin(3,ic,ii)
                  exit
                endif
              else
                doit = .false.
                !TEST! Print *,'Component ',ii,' relocated at ',jj
                ccou(3,ic,jj) = ccou(3,ic,jj) + ccin(3,ic,ii)
                exit
              endif
            endif
          endif
        enddo
        if (doit) then
          ki = ki+1
          !TEST! Print *,'Component ',ii,' new at ',ki
          ccou(1:scc,ic,ki) = ccin(1:scc,ic,ii)
        endif
      endif
    enddo
    if (ki.ne.0) mi = max(mi,ki)
  enddo
  !
  mic = mi
end subroutine uv_compact_clean
!
subroutine cct_prepare(line,nsizes,a_method,task,error)
  use gkernel_interfaces
  use imager_interfaces, only : get_i4list_fromsic, get_r4list_fromsic, & 
    & map_message, sub_read_image, reallocate_cct
  use clean_def
  use clean_arrays
  use clean_types
  use clean_default
  use gbl_message
  !---------------------------------------------------
  ! @ private
  !*
  ! IMAGER -- Support for command CLEAN 
  !
  !   Prepare the Clean Component Table for further use
  !!
  !---------------------------------------------------
  character(len=*), intent(in) :: line      !! Command line
  integer, intent(in) :: nsizes(3)          !! Cube Size
  type(clean_par), intent(in) :: a_method   !! Input method
  character(len=*), intent(in) :: task      !! Caller name
  logical, intent(out) :: error  !! Logical error flag
  !
  ! Constants
  integer, parameter :: opt_ares=5   ! /ARES 
  integer, parameter :: opt_range=10 ! No /RANGE option there
  integer, parameter :: cct_type=10
  integer, parameter :: opt_iter=4
  !
  ! Local ---
  integer :: nc                 ! Number of channels
  character(len=filename_length) :: name
  character(len=120) :: mess
  integer(kind=4) :: ier,x_iter,ns,i,n
  real, allocatable :: tcct(:,:,:)
  logical :: restart
  real(8) :: drange(2)          ! Range to be read (0,0)
  character(len=12) :: crange  ! Type of range
  logical :: compact
  integer :: cctsize
  integer :: opt_start
  !
  ! Code ----
  nc = nsizes(3)
  error = .false.
  x_iter = a_method%m_iter
  !
  ! Use up to nc = hdirty%gil%dim(3)
  if (sic_present(opt_iter,0)) then
    niter_listsize = hdirty%gil%dim(3)
    if (allocated(niter_list)) deallocate(niter_list)
    allocate(niter_list(niter_listsize),stat=ier)
    call get_i4list_fromsic(task,line,opt_iter,niter_listsize, &
      & niter_list,error)
    if (error) return
    ! 
    x_iter = maxval(niter_list)
  endif
  !
  if (sic_present(opt_ares,0)) then
    ares_listsize = hdirty%gil%dim(3)
    if (allocated(ares_list)) deallocate(ares_list)
    allocate(ares_list(ares_listsize),stat=ier)
    call get_r4list_fromsic(task,line,opt_ares,ares_listsize, &
      & ares_list,error)
    if (error) return
  endif
  !
  ! /RESTART [FileName]  option
  if (a_method%restart.ne.0) then 
    opt_start = a_method%restart
    !
    if (sic_present(opt_start,1)) then 
      !
      ! Load new CCT table if specified
      call sic_ch(line,opt_start,1,name,n,.true.,error)
      if (error) return
      !
      ! Read specified data file as Clean Component Table
      drange = 0.d0
      crange = 'CHANNEL'
      compact = .false.
      call sub_read_image (name,cct_type,drange,crange,compact,opt_range,error)
      if (error) return  
    else
      ! 
      ! Use Current CCT as Start Model
      if (.not.allocated(dcct)) then
        call map_message(seve%e,task,'No starting Clean Component table')
        error = .true.
        return
      endif
    endif
    x_iter = hcct%gil%dim(3)    ! Required in all cases: number of clean components.
    ns = ubound(dcct,2)         ! and number of channels.
    !
    ! Must match the number of channels, or be one...
    ! This may be incompatible with the FIRST and LAST stuff...
    if ((ns.ne.nc).and.(ns.ne.1)) then
      call map_message(seve%e,task,'Number of channels do not match ')
      error = .true.
      return
    endif
    !
    ! Here, save the available CCT as Start Model.
    restart = .true.
    write(mess,'(A,I0,A)') 'Re-using ',ns,' channels from previous Clean Component Table'
    call map_message(seve%i,task,mess,3)
  else 
    restart = .false.
  endif
  !
  if (a_method%method.eq.'MULTI') then
    x_iter = a_method%ninflate*x_iter
    x_iter = min(x_iter,nsizes(1)*nsizes(2))
    !!print *,'CCT-Prepare, Method MULTI ',a_method%m_iter,x_iter
  endif
  !print *,'CCT-Prepare, FIRST ',a_method%first,' LAST ',a_method%last
  call sic_delvariable('CCT',.false.,error)
  error = .false.  ! Not an error if no such variable
  !
  cctsize = 3
  x_iter = max(1,x_iter)
  if (.not.restart) then
    if (a_method%method.eq.'GAUSS') cctsize = 4
    call reallocate_cct(cctsize,nc,x_iter,dcct,error)
    if (error)  return
    ! Nullify the channels to be used: a 0 flux component indicates 
    ! the last valid one.
    dcct(:,a_method%first:a_method%last,1) = 0.  
  else
    cctsize = size(dcct,1)
    if (a_method%n_iter.ne.0) then
      if (x_iter.lt.hcct%gil%dim(3)) then
        write(mess,'(A,I0,A,I0,A)') 'More components in start model (',hcct%gil%dim(3), &
          & ' than allowed total (',x_iter,')'
        call map_message(seve%w,task,mess)
        x_iter = 2*hcct%gil%dim(3)    ! TEST
      endif
    endif
    !
    if (ns.ne.nc) then
      ! Continuum + Line case: restart from continuum
      allocate(tcct(cctsize,1,hcct%gil%dim(3)),stat=ier)
      tcct(:,:,:) = dcct
      call reallocate_cct(cctsize,nc,x_iter,dcct,error)
      do i=1,nc
        dcct(:,i,1:hcct%gil%dim(3)) = tcct(:,1,:)
      enddo
      !
      ! Nullify the next Clean Component
      if (x_iter.gt.hcct%gil%dim(3)) then
        dcct(:,:,hcct%gil%dim(3)+1:x_iter) = 0
      endif
    else
      ! Reallocate_cct does the job properly
      call reallocate_cct(cctsize,nc,x_iter,dcct,error)
      if (error)  return
    endif
  endif
  !
  ! Define the image header
  call gildas_null(hcct)
  call gdf_copy_header (hdirty,hcct,error)
  hcct%gil%ndim = 3
  hcct%char%unit = 'Jy'
  !
  hcct%gil%dim(1) = cctsize
  ! Keep the same axis description
  hcct%gil%xaxi = 1
  !
  hcct%gil%convert(:,2) = hdirty%gil%convert(:,3)
  hcct%gil%convert(:,3) = hdirty%gil%convert(:,2)
  hcct%gil%dim(2) = hdirty%gil%dim(3)
  hcct%char%code(2) = hdirty%char%code(3)
  hcct%gil%faxi = 2
  hcct%gil%dim(3) = x_iter
  hcct%char%code(3) = 'COMPONENT'
  hcct%gil%yaxi = 3
  hcct%loca%size = hcct%gil%dim(1)*hcct%gil%dim(2)*hcct%gil%dim(3)
  !
  ! Initialize BLCs...
  hcct%blc = 0
  hcct%trc = 0
  !
end subroutine cct_prepare
!
subroutine reallocate_cct(n1,n2,n3,array,error)
  use gbl_message
  use gkernel_interfaces, only : failed_allocate
  use imager_interfaces, only : map_message
  !-------------------------------------------------------------------
  ! @ private-mandatory
  !*
  ! IMAGER -- Basic utility 
  ! 
  ! (re)allocate the CCT allocatable array.
  ! If only the last dimension is enlarged, the previous contents are
  ! kept. Otherwise, the data is initialized to 0.
  !!
  !-------------------------------------------------------------------
  integer(kind=4),           intent(in)    :: n1,n2,n3        !! New dimensions
  real(kind=4), allocatable, intent(inout) :: array(:,:,:)    !! Array to be re-allocated
  logical,                   intent(inout) :: error           !! Logical error flag
  !
  ! Constants
  character(len=*), parameter :: task='CCT'
  ! Local ---
  character(len=message_length) :: mess
  logical :: keep, quiet, old
  integer(kind=4) :: ier,oldn1,oldn2,oldn3
  real(kind=4), allocatable :: tmp(:,:,:)
  !
  ! Code ----
  if (n1.le.0 .or. n2.le.0 .or. n3.le.0) then
    write(mess,'(A,3(I0,A))')  &
      'CCT size can not be zero nor negative (got n1 x n2 x n3 = ',  &
      n1,'x',n2,'x',n3,')'
    call map_message(seve%e,task,mess)
    error = .true.
    return
  endif
  !
  keep = .false.
  quiet = error
  error = .false.
  old = allocated(array)
  !
  if (old) then
    oldn1 = ubound(array,1)
    oldn2 = ubound(array,2)
    oldn3 = ubound(array,3)
    if (oldn1.eq.n1 .and.  &  ! Strict equality
        oldn2.eq.n2 .and.  &  ! Strict equality
        oldn3.ge.n3) then     ! Greater or equal
      if (quiet) return
      write(mess,'(a,i0,a,i0,a,i0,a)')  &
        'Re-using CCT table of size [',oldn1,',',oldn2,',',oldn3,']'
      call map_message(seve%i,task,mess)
      return
    endif
    !
    if (oldn1.eq.n1 .and.  &  ! Strict equality
        oldn2.eq.n2) then     ! Strict equality
      ! The 2 first dimensions are not modified, only the third is enlarged.
      ! Data will be kept.
      keep = .true.
      call move_alloc(from=array,to=tmp)    ! 'array' is now deallocated
    else
      deallocate(array)
    endif
  endif
  !
  ! Allocation
  allocate(array(n1,n2,n3),stat=ier)
  if (failed_allocate(task,'ARRAY',ier,error))  return
  !
  if (.not.quiet) then
    if (old) then
      write(mess,'(a,i0,a,i0,a,i0,a,i0,a,i0,a,i0,a)')  &
        'Extended CCT table size from [',oldn1,',',oldn2,',',oldn3,'], to [' &
        & ,n1,',',n2,',',n3,']'
      if (keep) mess = trim(mess)//' with copy'
    else
      write(mess,'(a,i0,a,i0,a,i0,a)')  &
      'Allocated new CCT table of size [',n1,',',n2,',',n3,']'
    endif
    call map_message(seve%i,task,mess)
  endif
  !
  ! Back copy
  if (keep) then
    array(:,:,1:oldn3) = tmp(:,:,1:oldn3)
    array(:,:,oldn3+1:n3) = 0.
    deallocate(tmp)
  else
    array(:,:,1) = 0.
  endif
  !
end subroutine reallocate_cct
