program field_find
  use gildas_def
  use image_def
  use gkernel_interfaces
  use gbl_format
  ! Local
  character(len=filename_length) :: namex,namey
  logical :: error
  integer(kind=4) :: n, ier,nfields
  real(kind=4) :: the
  type(gildas) :: x,y
  !
  call gildas_open
  call gildas_char('Y_NAME$',namey)
  call gildas_char('X_NAME$',namex)
  call gildas_real('THRESHOLD$',the,1)
  call gildas_close
  !
  n = len_trim(namey)
  call gildas_null(y)
  y%gil%ndim = 2
  call gdf_read_gildas(y,namey,'.gdf',error, rank=2)
  if (error) then
    call gagout('F-FIELD_FIND,  Cannot read input file')
    goto 100
  endif
  !
  ! Create output image
  call gildas_null(x)
  call gdf_copy_header(y,x,error)
  n = len_trim(namex)
  call sic_parsef(namex(1:n),x%file,' ','.gdf')
  call gdf_create_image(x,error)
  if (error) then
    call gagout('F-FIELD_FIND,  Cannot create output image')
    goto 100
  endif
  !
  allocate (x%r2d(x%gil%dim(1),x%gil%dim(2)),stat=ier)
  if (ier.ne.0) goto 100
  !
  call label001(y%r2d,                      &  ! Input image
                x%gil%dim(1),x%gil%dim(2),  &  ! Size
                x%r2d,                      &  ! Output image
                nfields,                    &  !
                the,                        &  ! Threshold
                y%gil%bval,y%gil%eval,      &  ! Blanking values
                error)
  if (error)  goto 100
  !
  call gdf_write_data(x,x%r2d,error)
  if (error)  continue
  !
  ! Add/update the extrema
  call gdf_get_extrema(x,error)
  if (error)  continue
  call gdf_update_header(x,error)
  if (error)  continue
  !
  call gdf_close_image(x,error)
  if (error)  continue
  deallocate(x%r2d)
  !
  if (nfields.eq.0) then
    call gagout('W-FIELD_FIND,  No field found')
  elseif (nfields.eq.1) then
    call gagout('I-FIELD_FIND,  Found 1 field in image')
  else
    write(namex,'(A,I0,A)') 'I-FIELD_FIND,  Found ',nfields,' fields in image'
    call gagout(namex)
  endif
  call sysexi(1)
  !
100 call sysexi(fatale)
end program field_find
!
subroutine label001(imagein,ncolumns,nlines,labelout,nfields,threshold,  &
  blank,eblank,error)
  use gildas_def
  use gkernel_interfaces
  !---------------------------------------------------------------------
  ! Modifie S.Guilloteau LAB 20 Janv 2013
  !    Order the field numbers by number of pixels
  ! Modifie S.Guilloteau
  ! Groupe d'Astrophysique de Grenoble 22 Octobre 1985
  ! Valeurs non definies et declaration LabelOut en reel
  !
  ! Origine : A.Bijaoui 25 octobre 1984 Observatoire de Nice
  ! Saidi1 Permet l'etiquettage des domaines a partir d'une
  ! segmentation avec seuil de flux
  !---------------------------------------------------------------------
  integer(kind=index_length), intent(in)    :: ncolumns                   ! Number of "Columns"
  integer(kind=index_length), intent(in)    :: nlines                     ! Number of "lines"
  real(kind=4),               intent(in)    :: imagein(ncolumns,nlines)   ! Input image
  real(kind=4),               intent(out)   :: labelout(ncolumns,nlines)  ! Labels of fields
  integer(kind=4),            intent(out)   :: nfields                    ! Number of fields
  real(kind=4),               intent(in)    :: threshold                  ! Threshold
  real(kind=4),               intent(in)    :: blank                      ! Blanking
  real(kind=4),               intent(in)    :: eblank                     ! and tolerance
  logical,                    intent(inout) :: error                      ! Logical error flag
  ! Local
  integer(kind=index_length) :: iline,icolumn
  integer(kind=4) :: l1,l2,la1,la2,la,ier
  integer(kind=4), allocatable :: buf1(:),buf2(:)
  integer(kind=4) :: mfields,nfieldsi,ifield,jfield
  !
  ! Allocate working buffers
  mfields = nlines*ncolumns  ! Maximum number of fields in image
  allocate(buf1(mfields),buf2(mfields),stat=ier)
  if (failed_allocate('FIELD_FIND','buffers',ier,error))  return
  !
  nfieldsi=0
  do iline=1,nlines
    do icolumn=1,ncolumns
      if (imagein(icolumn,iline).lt.threshold) then
        labelout(icolumn,iline)=0.0
      elseif (abs(imagein(icolumn,iline)-blank).le.eblank) then    !SG
        labelout(icolumn,iline)=0.0    !SG
      else
        labelout (icolumn,iline) = 0.0
        if (icolumn.ne.1) then
          l1=labelout(icolumn-1,iline)
          if (l1.ne.0) labelout(icolumn,iline)=l1
        endif
        if (iline.ne.1) then
          l2=labelout(icolumn,iline-1)
          if (l1.eq.0) then
            if (l2.eq.0) then
              nfieldsi=nfieldsi+1
              buf1(nfieldsi)=nfieldsi
              labelout(icolumn,iline)=nfieldsi
            else
              labelout(icolumn,iline)=l2
            endif
          else
            if (l2.ne.0) then
              if (l2.ne.l1) then
                call descen(buf1,l1,la1)
                call descen(buf1,l2,la2)
                la=min(la1,la2)
                buf1(la1)=la
                buf1(la2)=la
                labelout(icolumn,iline)=la
              endif
            endif
          endif
        endif
      endif
    enddo
  enddo
  !
  nfields=0
  do ifield=1,nfieldsi
    call descen(buf1,ifield,jfield)
    if (ifield.eq.jfield) then
      nfields=nfields+1
      buf2(ifield)=nfields
    endif
  enddo
  do iline=1,nlines
    do icolumn=1,ncolumns
      l1 = labelout(icolumn,iline)
      if (l1.ne.0) then
        call descen(buf1,l1,la1)
        labelout(icolumn,iline)=buf2(la1)
      endif
    enddo
  enddo
  !
  ! Sort the final labels by ascending number of pixels...
  buf1(:) = 0  ! buf1 is now used as the number of pixels per field
  do iline=1,nlines
    do icolumn=1,ncolumns
      if (labelout(icolumn,iline).ne.0) then
        ifield = labelout(icolumn,iline)
        buf1(ifield) = buf1(ifield)+1
      endif
    enddo
  enddo
  !
  ! Compute the sorting array
  do iline=1,nfields
    buf2(iline) = iline  ! buf2 is now used as the sorting array
  enddo
  call gi4_trie(buf1,buf2,nfields,error)
  ! Compute back sorting array
  do iline=1,nfields
    buf1(buf2(iline)) = iline  ! buf1 is now used as the back sorting srray
  enddo
  !
  do iline=1,nlines
    do icolumn=1,ncolumns
      if (labelout(icolumn,iline).ne.0) then
        ifield = labelout(icolumn,iline)
        labelout(icolumn,iline) = buf1(ifield)
      endif
    enddo
  enddo
  !
  deallocate(buf1,buf2)
  !
contains
  !
  subroutine descen(label,labin,labout)
    integer(kind=4), intent(inout) :: label(*)
    integer(kind=4), intent(in)    :: labin
    integer(kind=4), intent(out)   :: labout
    ! Local
    integer(kind=4) :: lab
    !
    labout = labin
    do
      lab = label(labout)
      if (lab.eq.labout) return
      labout = lab
    enddo
  end subroutine descen
  !
end subroutine label001
