# 1 "<stdin>"
# 1 "<built-in>"
# 1 "<command line>"
# 1 "<stdin>"
!<;
!dip_field
!
!Usage:
!dip_field.x <in.H >out.H
!
!Input Parameters:
!
!
!Output Parameters:
!
!
!
!Description:
!
!
!
!>
!-------------------------------------------------
!
!Author: Robert Clapp, ESMB 463, 7230253
!
!Wed Jan 8 14:52:30 PST 2003
!
!
!Purpose:
!
! Functions to reshape an array by simple compression account for
! 0 cells
module reshape_mod
  use basic_util_mod
  use put_3d_mod
  implicit none
  contains
  logical function shrink_image_tag(tag,n,o,d,ns,os,ds,image,wt_mask)
    character(len=*) :: tag
    integer :: n(3),ns(3)
    real :: os(3),ds(3),o(3),d(3)
    real :: image(:,:,:),wt_mask(:,:,:)
    optional :: wt_mask
    real,allocatable :: image_big(:,:),count(:,:,:)
    integer :: iloc(3),i1,i2,i3,ibeg(3),iend(3)
    real :: fract(3)
    shrink_image_tag=.false.
    allocate(count(ns(1),ns(2),ns(3)))
    allocate(image_big(n(1),n(2)))
    if (present(wt_mask)) then
      wt_mask=0
    end if
    do i1=1,3
      ibeg(i1)=max(1,nint((o(i1)-os(i1))/ds(i1)+1.))
      iend(i1)=min(ns(i1),nint((o(i1)+d(i1)*(n(i1)-1)-os(i1))/ds(i1)+1.&
        &))
    end do
    if (present(wt_mask)) then
      wt_mask(ibeg(1):iend(1),ibeg(2):iend(2),ibeg(3):iend(3))=1.
    end if
    call init_coord(ns,os,ds)
    count=0
    image_big=0
!SHRINK IMAGE
    do i3=1,n(3)
      fract(3)=o(3)+d(3)*(i3-1)
      fract(3)=(fract(3)-os(3))/ds(3)+1.
      iloc(3)=fract(3)
      fract(3)=fract(3)-iloc(3)
      if (.not. sreed_field(tag,image_big)) then
        write(0,*) "trouble reading image file slice",i3
        return
      end if
      if (iloc(3)>=1 .and. iloc(3) <= ns(3)) then
        do i2=1,n(2)
          fract(2)=o(2)+d(2)*(i2-1)
          fract(2)=(fract(2)-os(2))/ds(2)+1.
          iloc(2)=fract(2)
          fract(2)=fract(2)-iloc(2)
          if (iloc(2)>=1 .and. iloc(2) < ns(2)) then
            do i1=1,n(1)
              fract(1)=o(1)+d(1)*(i1-1)
              fract(1)=(fract(1)-os(1))/ds(1)+1.
              iloc(1)=fract(1)
              fract(1)=fract(1)-iloc(1)
              if (iloc(1)>=1 .and. iloc(1) < ns(1)) then
! count(iloc(1),iloc(2),iloc(3))+=1
! image(iloc(1),iloc(2),iloc(3))+=image_big(i1,i2)
                call put_interp_val(1.,count,1.,iloc(1),iloc(2),iloc(3&
                  &),fract(1),fract(2),fract(3))
                call put_interp_val(image_big(i1,i2),image,1.,iloc(1)&
                  &,iloc(2),iloc(3),fract(1), fract(2),fract(3))
              end if
            end do
          end if
        end do
      end if
    end do
    where(count>0.)
      image=image/count
end where
    deallocate(count,image_big)
    shrink_image_tag=.true.
  end function
end module
