program correlate
  use gildas_def
  use image_def
  use gkernel_interfaces
  !---------------------------------------------------------------------
  ! GILDAS  Computes the cross correlation of two data cubes.
  !---------------------------------------------------------------------
  ! Local
  character(len=filename_length) :: in_name1,in_name2,out_name
  logical :: error,corr
  integer(kind=4) :: dim(2)
  integer(kind=4) :: i, j, n
  type(gildas) :: x,y,z
  integer(kind=4), allocatable :: work(:,:)
  integer(kind=4) :: ier
  !
  call gildas_open
  call gildas_char('IN_NAME1$',in_name1)
  call gildas_char('IN_NAME2$',in_name2)
  call gildas_char('OUT_NAME$',out_name)
  call gildas_inte('OUT_SIZE$',dim,2)
  call gildas_logi('MODE$',corr,1)
  call gildas_close
  !
  call gildas_null(z)
  z%gil%ndim = 3
  call gdf_read_gildas(z,in_name1,'.gdf',error,data=.false.)
  if (error) call sysexi(fatale)
  !
  call gildas_null(y)
  y%gil%ndim = 3
  call gdf_read_gildas(y,in_name2,'.gdf',error,data=.false.)
  if (error) call sysexi(fatale)
  !
  do i=3,4
    if (y%gil%dim(i).ne.z%gil%dim(i)) then
      call gagout('F-CORRELATE,  Input cubes have different'//   &
     &        ' channel numbers')
      goto 100
    endif
  enddo
  !
  error = .false.
  ! Check 3rd axis
  if (y%gil%dim(3).gt.1) then
    call do_check('Ref3',y%gil%ref(3),z%gil%ref(3),error)
    if (error)  goto 100
    call do_check('Val3',y%gil%val(3),z%gil%val(3),error)
    if (error)  goto 100
    call do_check('Inc3',y%gil%inc(3),z%gil%inc(3),error)
    if (error)  goto 100
  endif
  !
  ! Check 4th axis
  if (y%gil%dim(4).gt.1) then
    call do_check('Ref4',y%gil%ref(4),z%gil%ref(4),error)
    if (error)  goto 100
    call do_check('Val4',y%gil%val(4),z%gil%val(4),error)
    if (error)  goto 100
    call do_check('Inc4',y%gil%inc(4),z%gil%inc(4),error)
    if (error)  goto 100
  endif
  !
  error = .false.
  if (z%gil%inc(1).ne.y%gil%inc(1).or.z%gil%inc(2).ne.y%gil%inc(2)) then
    error = .true.
  elseif  (y%gil%dim(3).gt.1 .and. z%gil%inc(3).ne.y%gil%inc(3)) then
    error = .true.
  elseif  (y%gil%dim(4).gt.1 .and. z%gil%inc(4).ne.y%gil%inc(4)) then
    error = .true.
  endif
  if (error) then
    call gagout('F-CORRELATE,  Pixel sizes do not match')
    write(6,*) z%gil%inc(1), y%gil%inc(1)
    write(6,*) z%gil%inc(2), y%gil%inc(2)
    write(6,*) z%gil%inc(3), y%gil%inc(3)
    write(6,*) z%gil%inc(4), y%gil%inc(4)
    goto 100
  endif
  !
  call gildas_null(x)
  call gdf_copy_header (y,x,error)
  n = lenc(out_name)
  if (n.eq.0) goto 100
  call sic_parsef(out_name(1:n),x%file,' ','.gdf')
  !
  x%gil%extr_words = 0
  x%gil%blan_words = 2
  if (corr) then
    x%gil%bval = 0.0
    x%gil%eval = 0.0
  else
    x%gil%bval = 1.0
    x%gil%eval = 0.0
  endif

  ! Determine size of correlation cube
  x%gil%dim(1) = z%gil%dim(1) + y%gil%dim(1) - 1
  if (dim(1).gt.0) x%gil%dim(1) = min(dim(1),x%gil%dim(1))
  x%gil%dim(2) = z%gil%dim(2) + y%gil%dim(2) - 1
  if (dim(2).gt.0) x%gil%dim(2) = min(dim(2),x%gil%dim(2))
  x%gil%dim(3) = y%gil%dim(3)
  x%gil%dim(4) = y%gil%dim(4)
  x%gil%val(1) = z%gil%val(1)-y%gil%val(1)
  x%gil%val(2) = z%gil%val(2)-y%gil%val(2)
  x%gil%ref(1) = z%gil%ref(1)-y%gil%ref(1)+x%gil%dim(1)/2
  x%gil%ref(2) = z%gil%ref(2)-y%gil%ref(2)+x%gil%dim(2)/2
  x%loca%size = 1
  do i = 1, 4
    x%loca%size = x%loca%size*x%gil%dim(i)
  enddo
  !
  call gdf_create_image(x,error)
  if (error) then
    call gagout('F-CORRELATE,  Cannot create image') 
    goto 100
  endif
  !
  allocate (x%r2d(x%gil%dim(1),x%gil%dim(2)) , &
            work(x%gil%dim(1),x%gil%dim(2)),   &
            y%r2d(y%gil%dim(1),y%gil%dim(2)),  &
            z%r2d(z%gil%dim(1),z%gil%dim(2)), stat=ier)
  if (ier.ne.0) then
    call gagout('F-CORRELATE,  Cannot allocate work space')
    goto 100
  endif
  !
  do j = 1, x%gil%dim(4)
    x%blc(4) = j
    x%trc(4) = j
    do i = 1, x%gil%dim(3)
      x%blc(3) = i
      x%trc(3) = i
      if (error) goto 100
      y%blc = x%blc
      y%trc = x%trc
      call gdf_read_data(y,y%r2d,error)
      if (error) goto 100
      z%blc = x%blc
      z%trc = x%trc
      call gdf_read_data(z,z%r2d,error)
      if (error) goto 100
      !
      if (corr) then
        call do_correl(  &
          z%r2d,z%gil%dim(1),z%gil%dim(2),z%gil%bval,z%gil%eval,  &
          y%r2d,y%gil%dim(1),y%gil%dim(2),y%gil%bval,y%gil%eval,  &
          x%r2d,x%gil%dim(1),x%gil%dim(2),                        &
          work)
      else
        call do_square(  &
          z%r2d,z%gil%dim(1),z%gil%dim(2),z%gil%bval,z%gil%eval,  &
          y%r2d,y%gil%dim(1),y%gil%dim(2),y%gil%bval,y%gil%eval,  &
          x%r2d,x%gil%dim(1),x%gil%dim(2),                        &
          work)
      endif
      call gdf_write_data(x,x%r2d,error)
    enddo
  enddo
  !
  deallocate(x%r2d,work,y%r2d,z%r2d)
  !
  call gagout('S-CORRELATE,  Successful completion')
  goto 101
  !
100 call sysexi (fatale)
101 continue
end program correlate
!
subroutine do_check(axis,yval,zval,error)
  use gkernel_interfaces
  character(len=*), intent(in)    :: axis   ! Axis name
  real(kind=8),     intent(inout) :: yval   !
  real(kind=8),     intent(in)    :: zval   !
  logical,          intent(inout) :: error  ! Logical error flag
  !
  if ((yval-zval).gt.1d-37) then
    if (yval.eq.0.d0) yval = 1d-38
    if (abs((yval-zval)/yval).gt.1d-15) then
      call gagout('F-CORRELATE,  Input cubes have '//  &
        'incompatible conversion formula on 3rd or 4th axis:')
      write(6,*) axis, yval, zval
      error = .true.
      return
    endif
  endif
  !
end subroutine do_check
!
subroutine do_correl(in1,nxin1,nyin1,bval1,eval1,  &
                     in2,nxin2,nyin2,bval2,eval2,  &
                     out,nxout,nyout,work)
  use gildas_def
  integer(kind=index_length), intent(in)  :: nxin1              !
  integer(kind=index_length), intent(in)  :: nyin1              !
  real(kind=4),               intent(in)  :: in1(nxin1,nyin1)   !
  real(kind=4),               intent(in)  :: bval1              !
  real(kind=4),               intent(in)  :: eval1              !
  integer(kind=index_length), intent(in)  :: nxin2              !
  integer(kind=index_length), intent(in)  :: nyin2              !
  real(kind=4),               intent(in)  :: in2(nxin2,nyin2)   !
  real(kind=4),               intent(in)  :: bval2              !
  real(kind=4),               intent(in)  :: eval2              !
  integer(kind=index_length), intent(in)  :: nxout              !
  integer(kind=index_length), intent(in)  :: nyout              !
  real(kind=4),               intent(out) :: out(nxout,nyout)   !
  integer(kind=4),            intent(out) :: work(nxout,nyout)  !
  ! Local
  integer(kind=index_length) :: i1,j1,i2,j2,i,j,in,jn
  !
  ! Reset cross correlation to zero
  do j=1,nyout
    do i=1,nxout
      out(i,j) = 0.
    enddo
  enddo
  do j=1,nyout
    do i=1,nxout
      work(i,j) = 0
    enddo
  enddo
  !
  ! Compute
  in = nxout/2
  jn = nyout/2
  do j1 = 1, nyin1
    do i1 = 1, nxin1
      if (abs(in1(i1,j1)-bval1).gt.eval1) then
        do j2 = 1, nyin2
          j = j1-j2+jn
          if (j.ge.1 .and. j.le.nyout) then
            do i2 = 1, nxin2
              i = i1-i2+in
              if (i.ge.1 .and. i.le.nxout) then
                if (abs(in2(i2,j2)-bval2).gt.eval2) then
                  out(i,j) = out(i,j) +   &
                             in1(i1,j1)*in2(i2,j2)
                  work(i,j) = work(i,j)+1
                endif
              endif
            enddo
          endif
        enddo
      endif
    enddo
  enddo
  !
  ! Normalise
  do j=1,nyout
    do i=1,nxout
      if (work(i,j).ne.0) out(i,j) = out(i,j)/work(i,j)
    enddo
  enddo
end subroutine do_correl
!
subroutine do_square(in1,nxin1,nyin1,bval1,eval1,  &
                     in2,nxin2,nyin2,bval2,eval2,  &
                     out,nxout,nyout,work)
  use gildas_def
  integer(kind=index_length), intent(in)  :: nxin1              !
  integer(kind=index_length), intent(in)  :: nyin1              !
  real(kind=4),               intent(in)  :: in1(nxin1,nyin1)   !
  real(kind=4),               intent(in)  :: bval1              !
  real(kind=4),               intent(in)  :: eval1              !
  integer(kind=index_length), intent(in)  :: nxin2              !
  integer(kind=index_length), intent(in)  :: nyin2              !
  real(kind=4),               intent(in)  :: in2(nxin2,nyin2)   !
  real(kind=4),               intent(in)  :: bval2              !
  real(kind=4),               intent(in)  :: eval2              !
  integer(kind=index_length), intent(in)  :: nxout              !
  integer(kind=index_length), intent(in)  :: nyout              !
  real(kind=4),               intent(out) :: out(nxout,nyout)   !
  integer(kind=4),            intent(out) :: work(nxout,nyout)  !
  ! Local
  integer(kind=index_length) :: i1,j1,i2,j2,i,j,in,jn
  !
  ! Reset cross correlation to zero
  do j=1,nyout
    do i=1,nxout
      out(i,j) = 0.
    enddo
  enddo
  do j=1,nyout
    do i=1,nxout
      work(i,j) = 0
    enddo
  enddo
  !
  in = nxout/2
  jn = nyout/2
  do j1 = 1, nyin1
    do i1 = 1, nxin1
      if (abs(in1(i1,j1)-bval1).gt.eval1) then
        do j2 = 1, nyin2
          j = j1-j2+jn
          if (j.ge.1 .and. j.le.nyout) then
            do i2 = 1, nxin2
              i = i1-i2+in
              if (i.ge.1 .and. i.le.nxout) then
                if (abs(in2(i2,j2)-bval2).gt.eval2) then
                  out(i,j) = out(i,j) -   &
                            (in1(i1,j1)-in2(i2,j2))**2
                  work(i,j) = work(i,j)+1
                endif
              endif
            enddo
          endif
        enddo
      endif
    enddo
  enddo
  !
  ! Normalise
  do j=1,nyout
    do i=1,nxout
      if (work(i,j).ne.0) then
        out(i,j) = out(i,j)/work(i,j)
      else
        out(i,j) = 1.0
      endif
    enddo
  enddo
end subroutine do_square
