program extract
  use gildas_def
  use image_def
  use gbl_format
  use gkernel_interfaces
  !---------------------------------------------------------------------
  ! GILDAS	Stand alone program
  !	Extract a subset from an input n-Dim image, and place
  !	it into an output p-Dim image, which may be created
  !	at the same time.
  !
  ! "Stupid" version, which reads the whole dataset...
  !---------------------------------------------------------------------
  ! Local
  character(len=filename_length) :: namex,namey
  logical :: error,init, blankout
  integer :: i, ier, n
  integer(kind=index_length) :: iblc(4),itrc(4),iout(4),pin(4)
  integer(kind=index_length) :: oblc(4),otrc(4),pout(4),odim(4)
  real :: initval
  !
  type(gildas) :: x,y
  !
  call gildas_open
  call gildas_char('Y_NAME$',namey)
  call gildas_char('X_NAME$',namex)
  call gildas_inte('BLC$',iblc,4)
  call gildas_inte('TRC$',itrc,4)
  call gildas_inte('PIXEL_IN$',pin,4)
  call gildas_inte('PIXEL_OUT$',pout,4)
  call gildas_logi('INITIALIZE$',init,1)
  if (init) then
    call gildas_inte('X_DIM$',odim,4)
    call gildas_logi('BLANKOUT$',blankout,1)
    if (.not.blankout) then
      call gildas_real('INITVAL$',initval,1)
    endif
  endif
  call gildas_close
  !
  n = len_trim(namey)
  if (n.eq.0) call sysexi(1)
  call gildas_null(y)
  y%gil%form = fmt_r4
  call gdf_read_gildas(y,namey,'.gdf',error, rank=4)
  if (error) then
    call gagout('F-EXTRACT,  Cannot read input file')
    goto 100
  endif
  do i=1,4
    if (iblc(i).eq.0) then
      oblc(i) = 1
      iblc(i) = 1
    else
      oblc(i) = iblc(i)  ! No min-max
      iblc(i) = max(iblc(i),1)
    endif
    if (itrc(i).eq.0) then
      otrc(i) = y%gil%dim(i)
      itrc(i) = y%gil%dim(i)
    else
      otrc(i) = itrc(i)  ! No min-max
      itrc(i) = min(itrc(i),y%gil%dim(i))
    endif
    if (iblc(i).gt.itrc(i)) then
      call gagout('F-EXTRACT,  Invalid subset')
      goto 100
    endif
  enddo
  !
  call gildas_null(x)
  call gdf_copy_header(y,x,error)
  n = len_trim(namex)
  call sic_parsef(namex(1:n),x%file,' ','.gdf')
  !
  ! Init
  ! IOUT is the place of bottom left corner (IBLC) in output image
  ! Then if PIN=IBLC, IOUT = POUT
  do i=1,4
    iout(i) = pout(i)-pin(i)+iblc(i)
  enddo
  if (init) then
    x%gil%ndim = 4
    do i=1,4
      if (odim(i).eq.0) then
        x%gil%dim(i) = otrc(i)-oblc(i)+1
      else
        x%gil%dim(i) = odim(i)
      endif
    enddo
    i = 4
    do while (x%gil%dim(i).eq.1)
      x%gil%ndim = x%gil%ndim-1
      i = i-1
    enddo
    !
    ! Create output image
    x%gil%extr_words = 0
    !
    ! Put pixel IMIN,JMIN at IOUT of output image
    x%gil%ref = x%gil%ref + iout - iblc
    !
    allocate (x%r4d(x%gil%dim(1), x%gil%dim(2), x%gil%dim(3), x%gil%dim(4)), stat=ier)
    if (blankout) then
      initval = x%gil%bval
      x%gil%eval = max(x%gil%eval,0.0)
    endif
    call ext001 (   &
     &      y%r4d,y%gil%dim(1),y%gil%dim(2),y%gil%dim(3),y%gil%dim(4),   &
     &      x%r4d,x%gil%dim(1),x%gil%dim(2),x%gil%dim(3),x%gil%dim(4),   &
     &      iblc,itrc,iout,initval)
    !
  else
    !
    ! Place in
    x%gil%form = fmt_r4
    call gdf_read_gildas(x,namex,'.gdf',error, rank=4)
    if (error) then
      call gagout('F-EXTRACT,  Cannot open output file ')
      call gagout(x%file)
      goto 100
    endif
    call ext002 (   &
     &      y%r4d,y%gil%dim(1),y%gil%dim(2),y%gil%dim(3),y%gil%dim(4),   &
     &      x%r4d,x%gil%dim(1),x%gil%dim(2),x%gil%dim(3),x%gil%dim(4),   &
     &      iblc,itrc,iout,y%gil%bval,y%gil%eval)
     
  endif
  !
  call gdf_write_image(x,x%r4d,error)
  if (error) goto 100
  call gagout('S-EXTRACT,  Successful completion')
  call sysexi(1)
  !
100 call sysexi (fatale)
end program extract
!
subroutine ext001(a,na1,na2,na3,na4,   &
     &    b,nb1,nb2,nb3,nb4,ni,nu,np,blank)
  use gildas_def
  integer(kind=index_length) :: na1                    !
  integer(kind=index_length) :: na2                    !
  integer(kind=index_length) :: na3                    !
  integer(kind=index_length) :: na4                    !
  real :: a(na1,na2,na3,na4)        !
  integer(kind=index_length) :: nb1                    !
  integer(kind=index_length) :: nb2                    !
  integer(kind=index_length) :: nb3                    !
  integer(kind=index_length) :: nb4                    !
  real :: b(nb1,nb2,nb3,nb4)        !
  integer(kind=index_length) :: ni(4)                  !
  integer(kind=index_length) :: nu(4)                  !
  integer(kind=index_length) :: np(4)                  !
  real :: blank                     !
  ! Local
  integer :: ia,ja,ka,la, ib,jb,kb,lb
  !
  do lb=1,nb4
    la = lb+ni(4)-np(4)
    if (la.ge.ni(4) .and. la.le.nu(4)) then
      do kb=1,nb3
        ka = kb+ni(3)-np(3)
        if (ka.ge.ni(3) .and. ka.le.nu(3)) then
          do jb=1,nb2
            ja = jb+ni(2)-np(2)
            if (ja.ge.ni(2) .and. ja.le.nu(2)) then
              do ib=1,nb1
                ia = ib+ni(1)-np(1)
                if (ia.ge.ni(1) .and. ia.le.nu(1)) then
                  b(ib,jb,kb,lb) = a(ia,ja,ka,la)
                else
                  b(ib,jb,kb,lb) = blank
                endif
              enddo
            else
              do ib=1,nb1
                b(ib,jb,kb,lb) = blank
              enddo
            endif
          enddo
        else
          do jb=1,nb2
            do ib=1,nb1
              b(ib,jb,kb,lb) = blank
            enddo
          enddo
        endif
      enddo
    else
      do kb=1,nb3
        do jb=1,nb2
          do ib=1,nb1
            b(ib,jb,kb,lb) = blank
          enddo
        enddo
      enddo
    endif
  enddo
end subroutine ext001
!
subroutine ext002(a,na1,na2,na3,na4,   &
     &    b,nb1,nb2,nb3,nb4,ni,nu,np,ybl,tbl)
  use gildas_def
  integer(kind=index_length) :: na1                    !
  integer(kind=index_length) :: na2                    !
  integer(kind=index_length) :: na3                    !
  integer(kind=index_length) :: na4                    !
  real :: a(na1,na2,na3,na4)        !
  integer(kind=index_length) :: nb1                    !
  integer(kind=index_length) :: nb2                    !
  integer(kind=index_length) :: nb3                    !
  integer(kind=index_length) :: nb4                    !
  real :: b(nb1,nb2,nb3,nb4)        !
  integer(kind=index_length) :: ni(4)                  !
  integer(kind=index_length) :: nu(4)                  !
  integer(kind=index_length) :: np(4)                  !
  real :: ybl                       !
  real :: tbl                       !
  ! Local
  integer :: ia,ja,ka,la, ib,jb,kb,lb
  real :: v
  !
  do la = ni(4),nu(4)
    lb = la - ni(4) + np(4)
    if (lb.ge.1 .and. lb.le.nb4) then
      do ka = ni(3),nu(3)
        kb = ka - ni(3) + np(3)
        if (kb.ge.1 .and. kb.le.nb3) then
          do ja = ni(2),nu(2)
            jb = ja - ni(2) + np(2)
            if (jb.ge.1 .and. jb.le.nb2) then
              do ia = ni(1),nu(1)
                ib = ia - ni(1) + np(1)
                if (ib.ge.1 .and. ib.le.nb1) then
                  v = a (ia,ja,ka,la)
                  if (abs(v-ybl).gt.tbl) then
                    b(ib,jb,kb,lb) = v
                  endif
                endif
              enddo
            endif
          enddo
        endif
      enddo
    endif
  enddo
end subroutine ext002
