program field_list
  use gildas_def
  use image_def
  use gkernel_interfaces
  use gbl_format
  !---------------------------------------------------------------------
  ! GDF	Extract parameters from fields
  ! Subroutines
  !	FIELD001
  !---------------------------------------------------------------------
  ! Local
  character(len=filename_length) :: namex,namey,names
  logical :: error
  integer :: nf, nfi, ier
  real, allocatable :: work(:)
  type(gildas) :: x,y,z
  !
  call gildas_open
  call gildas_char('Y_NAME$',namey)
  call gildas_char('X_NAME$',namex)
  call gildas_inte('FIELD$',nf,1)
  call gildas_char('T_NAME$',names)
  !
  call gildas_null(y)
  y%gil%form = fmt_r4
  call gdf_read_gildas(y,namey,'.gdf',error)
  if (error) then
    call gagout('F-FIELD,  Cannot read input file')
    goto 100
  endif
  !
  ! Read label image
  call gildas_null(x)
  x%gil%form = fmt_r4
  call gdf_read_gildas(x,namex,'.gdf',error)
  if (error) then
    call gagout('F-FIELD,  Cannot read label image')
    goto 100
  endif
  !
  ! Open output table
  call gildas_null (z, type='TABLE' )
  call sic_parsef(names,z%file,' ','.gdf')
  z%gil%dim(1) = nf
  z%gil%dim(2) = 7
  !
  call gdf_create_image(z,error)
  if (error) then
    call gagout('E-FIELD_LIST,  Cannot create output table')
    goto 100
  endif
  !
  allocate (work(5*nf), z%r2d (z%gil%dim(1), z%gil%dim(2)), stat=ier)
  if (ier.ne.0) goto 99
  !
  call field001(y%r2d,   &  !
     &    y%gil%dim(1),y%gil%dim(2),   &   !Size (BUT should equal x%gil%dim[i] !!!)
     &    x%r2d,   &     !Label
     &    y%gil%bval,y%gil%eval,   &   !
     &    y%gil%ref(1),y%gil%val(1), y%gil%inc(1),   &
     &    y%gil%ref(2),y%gil%val(2), y%gil%inc(2),   &  
     &    nf, nfi,   &         !
     &    z%r2d,   &
     &    work,    &
     &    ier)
  call gdf_write_data (z,z%r2d,error)
  if (nfi.eq.0) then
    call gagout('W-FIELD,  No field found')
  elseif (nfi.eq.1) then
    call gagout('I-FIELD,  Found 1 field in image')
  else
    write(namex,'(A,I12,A)') 'I-FIELD,  Found ',nfi,   &
     &      ' fields in image'
    call gagout(namex)
  endif
  if (ier.ne.0) call gagout('W-FIELD,  Too many fields')
  call sysexi(1)
  !
99 call gagout('F-FIELD,  Memory allocation failure')
100 call sysexi(fatale)
end program field_list
!
subroutine field001( imagein, ncolumns, nlines, labelin,   &
     &    blank, eblank, xref,xval,incx,yref,yval,incy, nf, nfi,   &
     &    table, work, ierr)
  use gildas_def
  !---------------------------------------------------------------------
  !	S.Guilloteau	Blanking Value			(Oct-1985)
  !			All fields at a time
  !	A.Bijaoui M.Khouchane E.Slezak 14 janvier 1985
  !	Saidi5 permet de determiner les parametres structuraux elementaires
  !	d'un domaine image
  !---------------------------------------------------------------------
  integer(kind=index_length) :: ncolumns                  !
  integer(kind=index_length) :: nlines                    !
  real(4) ::  imagein(ncolumns,nlines)  !
  real(4) ::  labelin(ncolumns,nlines)  !
  real(4) ::  blank                     !
  real(4) ::  eblank                    !
  real(8) ::  xref                      !
  real(8) ::  xval                      !
  real(8) ::  incx                      !
  real(8) ::  yref                      !
  real(8) ::  yval                      !
  real(8) ::  incy                      !
  integer :: nf                        !
  integer :: nfi                       !
  real(4) ::  table(nf,7)               !
  real(4) ::  work(5,nf)                !
  integer :: ierr                      !
  ! Local
  real(4) ::  npi
  !
  !	ImageIn		= Original Image
  !	Ncolumns	= Image Number of columns
  !	Nlines		= Image Number of lines
  !	LabelIn		= Labels table of the image
  !	Blank		= Blanking value
  !	Eblank		= Tolerance on blanking
  !	IncX		= User increment per column
  !	IncY		= ------------------ line
  !	Nf		= Maximum number of fields
  !	Nfi		= Number of fields found
  !	Table(*,1) 	= Number of pixels of the field
  !	Table(*,2)	= Integrate intensity of the field
  !	Table(*,3)	= Field X position (weighted by intensity) in pixels
  !	Table(*,4)	= Field Y position (---------------------) in pixels
  !	Table(*,5)	= Equivalent Major axis of the contour
  !	Table(*,6)	= Equivalent Minor Axis of the contour
  !	Table(*,7)	= Orientation of the ellipsis fitted to the contour
  !	Work		= Work space
  !	Ierr		= Output error parameter
  !	0 no error
  !	1 Too many fields
  !
  integer i,j,iline,icolumn,label,if
  real y,x,value,s3,s4,s5,bx,ax,orientation,s,c,w3,w4,b
  !
  table = 0.0
  work = 0.0
  ierr = 0
  nfi  = 0
  !
  do iline=1,nlines
    y = (iline-yref)*incy+yval
    do icolumn=1,ncolumns
      x = (icolumn-xref)*incx+xval
      label = labelin(icolumn,iline)
      if (label.gt.nf) then
        nfi = nf
        ierr = 1
      elseif (label.gt.0) then
        value = imagein(icolumn,iline)
        if (abs(value-blank).gt.eblank) then
          table(label,1)=table(label,1)+1
          table(label,2)=table(label,2)+value
          table(label,3)=table(label,3)+value*x
          table(label,4)=table(label,4)+value*y
          work(1,label)=work(1,label)+x
          work(2,label)=work(2,label)+y
          work(3,label)=work(3,label)+x*x
          work(4,label)=work(4,label)+y*y
          work(5,label)=work(5,label)+x*y
        endif
        nfi = max(nfi,label)
      endif
    enddo
  enddo
  !
  do if=1,nfi
    npi = table(if,1)
    ! check against possible null integrated intensity
    if (table(if,2).ne.0) then
      table(if,3)=table(if,3)/table(if,2)
      table(if,4)=table(if,4)/table(if,2)
    else
      ! we should provide an option to compute non-weighted centroids
      ! in that case...
      write(6,'(A,I12,A)') 'W-FIELD_FIND, object #',if,   &
     &        ' has a null intensity'
    endif
    if (npi.gt.1.1) then
      work(1,if)=work(1,if)/npi
      work(2,if)=work(2,if)/npi
      s3=work(3,if)/npi-work(1,if)*work(1,if)
      s4=work(4,if)/npi-work(2,if)*work(2,if)
      s5=work(5,if)/npi-work(1,if)*work(2,if)
      if (s3.eq.0.0.and.s4.eq.0.0) then
        ax = abs(0.5*incx)
        bx = abs(0.5*incy)
        orientation = 0.
      elseif (s3.eq.0.0) then
        bx = abs(0.5*incx)
        ax = sqrt(abs(s4))
        orientation = -90.
      elseif (s4.eq.0.0) then
        bx = abs(0.5*incy)
        ax = sqrt(abs(s3))
        orientation = 0.
      else
        if (s3.ne.s4) then
          orientation=atan(2.*s5/(s4-s3))/2.
        else
          orientation=0.7854
        endif
        s=sin(orientation)
        c=cos(orientation)
        w3= sqrt( abs(c*c*s3-2.*s*c*s5+s*s*s4) )
        w4= sqrt( abs(s*s*s3+2.*s*c*s5+c*c*s4) )
        bx = (2.*w4/w3)*sqrt(w3*w4/3.14159)
        ax = bx*w3/w4
        if (s3.gt.s4) then
          b=ax
          ax=bx
          bx=b
          orientation=orientation+1.57079
        endif
        orientation=180.*orientation/3.14159
      endif
      table(if,5)=ax
      table(if,6)=bx
      table(if,7)=-orientation
    else
      table(if,5)=abs(incx*0.5)
      table(if,6)=abs(incy*0.5)
      table(if,7)=0.0
    endif
  enddo
end subroutine field001
