# 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
!
! Thu Jan 9 08:44:20 PST 2003
!
!Purpose:
!
module basic_util_mod
  use sep3d_struct_mod
  use sep
  implicit none
  integer, private, save :: mem
  logical, private, save :: verb_mem
  interface write_out_field
    module procedure write_out_field_3d_r
  end interface
  interface get_tag_field
    module procedure get_tag_field_3d_r
  end interface
  interface write_ireg
    module procedure write_ireg_1dr
  end interface
  interface sreed_field
    module procedure read1_pt_r
    module procedure read2_pt_r
    module procedure read3_pt_r
    module procedure read1_pt_i
    module procedure read2_pt_i
    module procedure read3_pt_i
  end interface
  contains
  subroutine set_n_o_d_3d(struct,n,o,d)
    type(sep3d) :: struct
    integer :: n(3)
    real :: o(3),d(3)
    if (sep3d_ndims(struct).eq.2) then
      n=(/struct%n(1),struct%n(2),1/)
      o=(/struct%o(1),struct%o(2),0./)
      d=(/struct%d(1),struct%d(2),1./)
    else
      n=struct%n
      o=struct%o
      d=struct%d
    end if
  end subroutine
  logical function get_tag_field_3d_r(tag,field)
    type(sep3d) :: space
    character(len=*) :: tag
    real,pointer :: field(:,:,:)
    integer, external :: sreed
    integer :: n(3),ierr
    real :: o(3),d(3)
    get_tag_field_3d_r=.false.
    call init_sep3d(tag,space,"INPUT")
    call set_n_o_d_3d(space,n,o,d)
    allocate(field(n(1),n(2),n(3)),stat=ierr)
    if (ierr.ne.0) then
      write(0,*) "          ERROR: allocating field of size",product(n&
        &)
      return
    end if
    if (.not. sreed_field(tag,field)) then
      write(0,*) "          ERROR: reading in field of size",size(field&
        &)," tag ",trim(tag)
      return
    end if
    call sep3df_delete(space,tag)
    get_tag_field_3d_r=.true.
  end function
  logical function write_out_field_3d_r(tag,space,field)
    type(sep3d) :: space
    character(len=*) :: tag
    real :: field(:,:,:)
    integer, external :: srite
    write_out_field_3d_r=.false.
    call sep3d_write_description(tag,space)
    if (4*size(field) .ne. srite(tag,field,product(space%n)*4)) then
      write(0,*) "            ERROR: writing out field of size ",size&
        &(field)," to tag=",trim(tag)
      return
    end if
    write_out_field_3d_r=.true.
  end function
  logical function write_ireg_1dr(tag,field,headers)
    character(len=*) :: tag
    real :: field(:)
    real :: headers(:,:)
    integer,external :: srite,sep_put_val_headers
    write_ireg_1dr=.false.
    if (size(headers,2).ne.size(field)) then
      write(0,*) "          ERROR: and data size not the same for write&
        & for tag",trim(tag)
      write(0,*) "           SIZE CHECK",size(headers,2),size(field)
      return
    end if
    if (0.ne. sep_put_val_headers(tag,1,size(headers,2),headers)) then
      write(0,*) "          ERROR: writing out headers for tag",trim&
        &(tag)
      return
    end if
    if (4*size(field).ne.srite(tag,field,size(field)*4)) then
      write(0,*) "          ERROR: writing out data of size=",size(field&
        &)," to tag ",trim(tag)
      return
    end if
    write_ireg_1dr=.true.
  end function
  subroutine get_current_mem(nsize)
    integer :: nsize
    nsize=mem
  end subroutine
  subroutine add_mem(nsize)
    integer :: nsize
    mem=mem+nsize
  end subroutine
  subroutine del_mem(iadd)
    integer :: iadd
    mem=mem-iadd
  end subroutine
  subroutine show_mem(str)
    character(len=*) :: str
    if (verb_mem) then
      write(0,*) "memory used (mb) ",trim(str),":",real(mem)*4.&
        &/1000000.
    end if
  end subroutine
  logical function init_mem()
    mem=0
    call from_param("mem_monitor",verb_mem,.false.)
    init_mem=.true.
  end function
  logical function check_write(tag)
    character(len=*) :: tag
    character(len=128) :: none
    call from_param(tag,none,"none")
    if (none(1:4).eq."none") then
      check_write=.false.
    else
      check_write=.true.
    end if
  end function
  subroutine setup_ireg_file(tag,n)
    character(len=*) :: tag
    integer :: n
! call sep_put_data_axis_par(tag,1,1,1.,1,"")
    call sep_put_data_axis_par(tag,1,n,1.,1.,"")
  end subroutine
  subroutine setup_reg_file(tag,nm,om,dm,n)
    character(len=*) :: tag
    integer :: n,nm(3)
    real :: om(3),dm(3)
    call sep_put_data_axis_par(tag,1,nm(1),om(1),dm(1),"z")
    call sep_put_data_axis_par(tag,2,nm(2),om(2),dm(2),"x")
    call sep_put_data_axis_par(tag,3,nm(3),om(3),dm(3),"y")
    call sep_put_data_axis_par(tag,4,n,1.,1.,"")
  end subroutine
  logical function read1_pt_i(tag,field,nsz)
    character(len=*) :: tag
    integer :: field(:)
    integer, allocatable :: temp(:)
    integer, optional :: nsz
    integer :: n,ierr
    integer,external :: sreed
    read1_pt_i=.false.
    if (present(nsz)) then
      n=nsz
    else
      n=size(field)
    end if
    allocate(temp(n))
    ierr= sreed(tag,temp,n*4)
    if (4*n .ne. ierr) then
      write(0,*) "          ERROR: reading from tag=",trim(tag)," size="&
        &,n,ierr,"=read"
      return
    end if
    field(1:n)=temp(1:n)
    deallocate(temp)
    read1_pt_i=.true.
  end function
  logical function read2_pt_i(tag,field,nsz)
    character(len=*) :: tag
    integer :: field(:,:)
    integer,allocatable :: temp(:,:)
    integer, optional :: nsz
    integer :: n,ierr
    integer,external :: sreed
    read2_pt_i=.false.
    if (present(nsz)) then
      n=nsz
    else
      n=size(field)
    end if
    allocate(temp(size(field,1),n/size(field,1)))
    ierr= sreed(tag,temp,n*4)
    if (4*n .ne.ierr) then
      write(0,*) "          ERROR: reading from tag=",trim(tag)," size="&
        &,n,ierr,"=read"
      return
    end if
    field(:,:size(temp,2))=temp
    deallocate(temp)
    read2_pt_i=.true.
  end function
  logical function read3_pt_i(tag,field,nsz)
    character(len=*) :: tag
    integer :: field(:,:,:)
    integer, optional :: nsz
    integer :: n,ierr
    integer :: temp(size(field,1),size(field,2),size(field,3))
    integer,external :: sreed
    read3_pt_i=.false.
    if (present(nsz)) then
      n=nsz
    else
      n=size(field)
    end if
    ierr= sreed(tag,temp,n*4)
    if (4*n .ne. ierr) then
      write(0,*) "          ERROR: reading from tag=",trim(tag)," size="&
        &,n,ierr,"=read"
      return
    end if
    field=temp
    read3_pt_i=.true.
  end function
  logical function read1_pt_r(tag,field,nsz)
    character(len=*) :: tag
    real :: field(:)
    real :: temp(size(field,1))
    integer, optional :: nsz
    integer :: n,ierr
    integer,external :: sreed
    read1_pt_r=.false.
    if (present(nsz)) then
      n=nsz
    else
      n=size(field)
    end if
    ierr= sreed(tag,temp,n*4)
    if (4*n .ne. ierr) then
      write(0,*) "          ERROR: reading from tag=",trim(tag)," size="&
        &,n,ierr,"=read"
      return
    end if
    field=temp
    read1_pt_r=.true.
  end function
  logical function read2_pt_r(tag,field,nsz)
    character(len=*) :: tag
    real :: field(:,:)
    real,allocatable :: temp(:,:)
    integer, optional :: nsz
    integer :: n,ierr
    integer,external :: sreed
    read2_pt_r=.false.
    if (present(nsz)) then
      n=nsz
    else
      n=size(field)
    end if
    allocate(temp(size(field,1),n/size(field,1)))
    ierr= sreed(tag,temp,n*4)
    if (4*n .ne. ierr) then
      write(0,*) "          ERROR: reading from tag=",trim(tag)," size="&
        &,n,ierr,'=read'
      return
    end if
    field(:,:size(temp,2))=temp
    deallocate(temp)
    read2_pt_r=.true.
  end function
  logical function read3_pt_r(tag,field,nsz)
    character(len=*) :: tag
    real :: field(:,:,:)
    integer, optional :: nsz
    integer :: n,ierr
    real :: temp(size(field,1),size(field,2),size(field,3))
    integer,external :: sreed
    read3_pt_r=.false.
    if (present(nsz)) then
      n=nsz
    else
      n=size(field)
    end if
    ierr= sreed(tag,temp,n*4)
    if (4*n .ne. ierr) then
      write(0,*) "          ERROR: reading from tag=",trim(tag)," size="&
        &,n,ierr,'=read'
      return
    end if
    field=temp
    read3_pt_r=.true.
  end function
end module
