program moments
  use gildas_def
  use image_def
  use gkernel_interfaces
  use gbl_format
  !---------------------------------------------------------------------
  ! GILDAS
  !	A dedicated routine to compute the moment of an input data cube.
  !	Input: a LMV cube
  !	Output: 3 images
  !           1) the integrated intensity map
  !           2) The mean velocity
  !           3) The line width
  !	Method:
  !       For each spectrum, make a gate in velocity and clip based on
  !       intensity. Sum up weighted velocity and mean intensity.
  !---------------------------------------------------------------------
  ! Local
  character(len=filename_length) :: namex,namey,namez
  character(len=80) :: chain
  logical :: error,smooth
  real(kind=4) :: velo(2),seuil,dv,vfirst,vlast
  integer(kind=4) :: ier,n
  integer(kind=index_length) :: nv,ifirst,ilast,itmp
  integer(kind=size_length) :: nxy
  real(kind=4), allocatable :: ipb(:)
  type(gildas) :: x,y,z,w
  !
  call gildas_open
  call gildas_char('IN$',namey)
  call gildas_char('OUT$',namez)
  call gildas_real('VELOCITY$',velo,2)
  call gildas_real('THRESHOLD$',seuil,1)
  call gildas_logi('SMOOTH$',smooth,1)
  call gildas_close
  !
  n = len_trim(namey)
  if (n.eq.0) goto 100
  n = len_trim(namez)
  if (n.eq.0) goto 100
  !
  ! Open first input map, the one to be placed in Y place
  call gildas_null(y)
  ! Force reading in y%r3d (an error will be raised if in can not
  ! accomodate in a 3D cube)
  call gdf_read_gildas(y,namey,'.lmv',error,rank=+3)
  if (error)  goto 100
  !
  ! Compute the channel range
  if (velo(1).eq.0.0 .and. velo(2).eq.0.0) then
    ifirst = 1
    ilast = y%gil%dim(3)
  else
    ifirst = nint((velo(1) - y%gil%val(3)) / y%gil%inc(3) + y%gil%ref(3), kind=index_length)
    ilast = nint((velo(2) - y%gil%val(3)) / y%gil%inc(3) + y%gil%ref(3), kind=index_length)
    if (y%gil%inc(3).lt.0) then
      itmp = ifirst
      ifirst = ilast
      ilast = itmp
    endif
    ifirst = min(max(1,ifirst),y%gil%dim(3))
    ilast = min(max(1,ilast),y%gil%dim(3))
  endif
  !
  ! Same as above for X image
  namex = namez
  call gildas_null(x)
  call gdf_copy_header(y,x,error)
  call sic_parsef(namex,x%file,' ','.mean')
  !
  ! Modify the requested part of the X Header
  x%gil%dim(3) = 1
  x%char%code(3) = 'UNKNOWN'
  x%gil%convert(:,3) = 1.d0
  x%gil%extr_words = 0
  x%gil%blan_words = 2
  if (y%char%code(3).eq.'VELOCITY') then
    x%char%unit = trim(y%char%unit)//'.km/s'
  elseif (y%char%code(3).eq.'FREQUENCY') then
    x%char%unit = trim(y%char%unit)//'.MHz'
  else
    x%char%unit = 'UNKNOWN'
  endif
  x%gil%faxi = 0
  x%gil%bval = 0
  x%gil%eval = 0
  !
  ! Create the image (with write access of course)
  call gdf_create_image(x,error)
  if (error) then
    write(6,*) 'F-MOMENTS,  Cannot create output image'
    goto 100
  endif
  !
  ! As above for Z image
  call gildas_null(z)
  call gdf_copy_header(y,z,error)
  z%gil%extr_words = 0
  z%gil%ndim = 2
  z%char%code(3) = 'UNKNOWN'
  z%gil%dim(3) = 1
  if (y%char%code(3).eq.'VELOCITY') then
    z%char%unit = 'km/s'
  elseif (y%char%code(3).eq.'FREQUENCY') then
    z%char%unit = 'MHz'
  else
    z%char%unit = 'UNKNOWN'
  endif
  z%gil%faxi = 0
  z%gil%bval = 0
  z%gil%eval = 0
  namex = namez
  call sic_parsef(namex,z%file,' ','.velo')
  call gdf_create_image(z,error)
  if (error) then
    write(6,*) 'F-MOMENTS,  Cannot create output image'
    goto 100
  endif
  !
  ! And line width
  call gildas_null(w)
  call gdf_copy_header(z,w,error)
  w%gil%extr_words = 0
  namex = namez
  call sic_parsef(namex,w%file,' ','.width')
  call gdf_create_image(w,error)
  !
  ! Do some useful job
  nxy = z%gil%dim(1)*z%gil%dim(2)
  allocate (x%r2d(x%gil%dim(1), x%gil%dim(2)), z%r2d(z%gil%dim(1), z%gil%dim(2)),  &
            w%r2d(x%gil%dim(1), x%gil%dim(2)), ipb(y%gil%dim(3)), stat=ier)
  if (ier.ne.0) goto 100
  x%r2d = 0.0
  z%r2d = 0.0
  w%r2d = 0.0
  !
  nv = y%gil%dim(3)
  call set_velo(nv,ipb,y%gil%ref(3),y%gil%val(3),y%gil%inc(3))
  dv = abs(y%gil%inc(3))
  !
  ! Loop in valid range
  write(chain,*) 'I-MOMENT,  Channel range ',ifirst,ilast
  call gagout(chain)
  if (y%gil%inc(3).gt.0) then
    vfirst = (ifirst-0.5-y%gil%ref(3))*y%gil%inc(3)+y%gil%val(3)
    vlast  = (ilast+0.5-y%gil%ref(3))*y%gil%inc(3)+y%gil%val(3)
  else
    vlast = (ifirst-0.5-y%gil%ref(3))*y%gil%inc(3)+y%gil%val(3)
    vfirst  = (ilast+0.5-y%gil%ref(3))*y%gil%inc(3)+y%gil%val(3)
  endif
  write(chain,*) 'I-MOMENTS,  Velocity range ',vfirst,vlast
  call gagout(chain)
  !
  call compute_moments(y%r3d,nxy,nv,x%r2d,z%r2d,w%r2d,ipb,ifirst,ilast,  &
    seuil,y%gil%bval,y%gil%eval)
  ! Scale intensity map
  x%r2d = x%r2d * dv
  ! Scale line width to equivalent Gaussian profile
  dv = sqrt(8.0*alog(2.0))
  w%r2d = w%r2d * dv
  !
  call gdf_write_data (x,x%r2d,error)
  call gdf_write_data (z,z%r2d,error)
  call gdf_write_data (w,w%r2d,error)
  !
  deallocate(x%r2d,z%r2d,w%r2d,ipb)
  !
  ! STOP with some acknowledgement message
  call gagout('S-MOMENTS,  Successful completion')
  call sysexi (1)
  !
  ! Error processing
100 call sysexi (fatale)
end program moments
!
subroutine compute_moments(a,nxy,nv,a0,a1,a2,v,ivmin,ivmax,s,bval,eval)
  use gildas_def
  integer(kind=size_length),  intent(in)  :: nxy
  integer(kind=index_length), intent(in)  :: nv
  real(kind=4),               intent(in)  :: a(nxy,nv)
  real(kind=4),               intent(out) :: a0(nxy)
  real(kind=4),               intent(out) :: a1(nxy)
  real(kind=4),               intent(out) :: a2(nxy)
  real(kind=4),               intent(in)  :: v(nv)
  integer(kind=index_length), intent(in)  :: ivmin
  integer(kind=index_length), intent(in)  :: ivmax
  real(kind=4),               intent(in)  :: s
  real(kind=4),               intent(in)  :: bval,eval
  ! Local
  integer(kind=size_length) :: i
  integer(kind=index_length) :: k
  real(kind=4) :: a12
  !
  if (eval.lt.0.) then
    do k=ivmin,ivmax
      do i=1,nxy
        if (a(i,k).ge.s) then
          a0(i) = a0(i) + a(i,k)
          a1(i) = a1(i) + v(k)*a(i,k)
          a2(i) = a2(i) + v(k)*v(k)*a(i,k)
        endif
      enddo
    enddo
  else
    do k=ivmin,ivmax
      do i=1,nxy
        if (a(i,k).ge.s .and. abs(a(i,k)-bval).gt.eval) then
          a0(i) = a0(i) + a(i,k)
          a1(i) = a1(i) + v(k)*a(i,k)
          a2(i) = a2(i) + v(k)*v(k)*a(i,k)
        endif
      enddo
    enddo
  endif
  !
  do i=1,nxy
    if (a0(i).ne.0.0) then
      a1(i) = a1(i)/a0(i)
      a2(i) = a2(i)/a0(i)
      a12 = a1(i)*a1(i)
      if (a12.gt.a2(i)) then
        a2(i) = 0.0
      else
        a2(i) = sqrt(a2(i) - a12)
      endif
    else
      a1(i) = 0.0
      a2(i) = 0.0
    endif
  enddo
end subroutine compute_moments
!
subroutine set_velo(nv,av,ref,val,inc)
  use gildas_def
  integer(kind=index_length), intent(in)  :: nv
  real(kind=4),               intent(out) :: av(nv)
  real(kind=8),               intent(in)  :: ref,val,inc
  ! Local
  integer(kind=index_length) :: iv
  do iv=1,nv
    av(iv) = (iv-ref)*inc+val
  enddo
end subroutine set_velo
