!*$*OPTIMIZE(5)
!*$*ROUNDOFF(3)
!*$*SCALAROPTIMIZE(3)

module gendown3d_mod
  use gendown3d_types
  use data_types
  use image_types
  use slow_types
  use down_process_types

  use down_gen_par_mod
  use data_mod
  use image_mod
  use slow_mod
  use filter_data_mod

  implicit none

  type(gendown3d_param_type), private :: gen_par
  type (gendown3d_info_type), private::  info_down
  type (data_param_type), private:: data_par
  type (image_param_type), private:: image_par
  type (down_process_param_type), private:: down_par
  type (slow_param_type), private:: slow_par

contains
  function gendown3d(adj,add,tag_mod,tag_data, &
  down_oper,scatter_oper, &
  oper3,oper4,oper5) result(stat)

    integer stat
    logical adj,add
    integer, save :: previous_adj=0
    character(len=128) :: tag_data,tag_mod
    integer down_oper,scatter_oper
    integer oper3,oper4,oper5
    optional down_oper,scatter_oper
    optional oper3,oper4,oper5
    external down_oper,scatter_oper
    external oper3,oper4,oper5

    integer ierr
    integer n_block_w,n_block_z,i_block_w,i_block_z,i_w_block_par
    real z_down_0,nint_w_min_0

    real,    allocatable, dimension (:,:,:,:,:,:)   :: slow_data_block
    complex, allocatable, dimension (:,:,:,:,:,:,:) :: dslow_data_block
    complex, allocatable, dimension (:,:,:,:,:,:)   :: data_block
    complex, allocatable, dimension (:,:,:,:,:,:)   :: ddata_block
    complex, allocatable, dimension (:,:,:,:,:,:)   :: image_block
    complex, allocatable, dimension (:,:,:,:,:,:)   :: dimage_block

    down_par%adj=adj
    down_par%add=add

    if(gen_par%debug1) write(0,*)'down_par%adj=',down_par%adj
    if(gen_par%debug1) write(0,*)'down_par%add=',down_par%add

    ! deals with changes in tags
    select case (gen_par%domain_range(1:9))
    case ('data_imag')
       if(trim(tag_mod) /= trim(data_par%tag_data) ) then
          write(0,*)'Change of tag_data from ',trim(data_par%tag_data), &
          ' to ',trim(tag_mod)
          data_par%tag_data=trim(tag_mod)
       end if
       if(trim(tag_data) /= trim(image_par%tag_image) ) then
          write(0,*)'Change of tag_image from ',trim(image_par%tag_image), &
          ' to ',trim(tag_data)
          image_par%tag_image=trim(tag_data)
       end if
    case ('data_wave')
       if(trim(tag_data) /= trim(data_par%tag_down_data) ) then
          write(0,*)'Change of tag_down_data from ',trim(data_par%tag_down_data), &
          ' to ',trim(tag_data)
          data_par%tag_down_data=trim(tag_data)
       end if
       if(trim(tag_mod) /= trim(data_par%tag_data) ) then
          write(0,*)'Change of tag_data from ',trim(data_par%tag_data), &
          ' to ',trim(tag_mod)
          data_par%tag_data=trim(tag_mod)
       end if
    case ('dslow_dim')
       if(trim(tag_data) /= trim(image_par%tag_dimage) ) then
          write(0,*)'Change of tag_dimage from ',trim(image_par%tag_dimage), &
          ' to ',trim(tag_data)
          image_par%tag_dimage=trim(tag_data)
       end if
       if(trim(tag_mod) /= trim(slow_par%tag_dslow) ) then
          write(0,*)'Change of tag_dslow from ',trim(slow_par%tag_dslow), &
          ' to ',trim(tag_mod)
          slow_par%tag_dslow=trim(tag_mod)
       end if
    case default
       write(0,*)'gen_par-domain_range=',trim(gen_par%domain_range)
       call seperr('Not supported domain_range')
    end select

    if(((previous_adj ==  1) .and. &
    (.not. down_par%adj)) .or. &
    ((previous_adj == -1) .and. (down_par%adj))) then
       !{
       select case (gen_par%domain_range(1:9))
       case ('data_imag')
          if(down_par%adj) then
             !{
             if(data_par%data_file == DATA_SYNTH) call seperr('I need a Data file')
             data_par%data_file = DATA_OUTPUT
             if(data_par%down_data_file /= DATA_NO_FILE) &
             data_par%down_data_file = DATA_INPUT
             if(data_par%down_ddata_file /= DATA_NO_FILE) &
             data_par%down_ddata_file = DATA_INPUT
             image_par%image_file = DATA_INPUT

             down_par%z_down_0= &
             gen_par%z_image_0 + (gen_par%n_z_image-1)*gen_par%d_z_image
             down_par%d_z_down=-gen_par%d_z_image
             !}
          else
             !{
             data_par%data_file = DATA_INPUT
             if(data_par%down_data_file /= DATA_NO_FILE) &
             data_par%down_data_file = DATA_OUTPUT
             if(data_par%down_ddata_file /= DATA_NO_FILE) &
             data_par%down_ddata_file = DATA_OUTPUT
             image_par%image_file = DATA_OUTPUT

             down_par%z_down_0= gen_par%z_image_0
             down_par%d_z_down=gen_par%d_z_image
             !}
          end if
       case ('data_wave')
          if(down_par%adj) then
             !{
             if(data_par%data_file == DATA_SYNTH) call seperr('I need a Data file')
             data_par%data_file = DATA_OUTPUT
             data_par%down_data_file = DATA_INPUT
             if(data_par%down_ddata_file /= DATA_NO_FILE) &
             data_par%down_ddata_file = DATA_INPUT
             down_par%z_down_0= &
             data_par%z_data_0 + (gen_par%n_z_image)*gen_par%d_z_image
             down_par%d_z_down=-gen_par%d_z_image
             !}
          else
             !{
             data_par%data_file = DATA_INPUT
             data_par%down_data_file = DATA_OUTPUT
             if(data_par%down_ddata_file /= DATA_NO_FILE) &
             data_par%down_ddata_file = DATA_OUTPUT

             down_par%z_down_0= data_par%z_data_0
             down_par%d_z_down=gen_par%d_z_image
             !}
          end if
       case ('dslow_dim')
          if(down_par%adj) then
             !{
             data_par%data_file = DATA_NO_FILE
             slow_par%dslow_file = SLOW_OUTPUT
             if(image_par%image_file /= IMAGE_NO_FILE) then
                if(data_par%wavefield_file == DATA_NO_FILE) then
                   image_par%image_file = IMAGE_INPUT
                else
                   image_par%image_file = IMAGE_NO_FILE
                end if
             end if
             image_par%dimage_file = IMAGE_INPUT
             down_par%z_down_0= &
             gen_par%z_image_0 + (gen_par%n_z_image-1)*gen_par%d_z_image
             down_par%d_z_down=-gen_par%d_z_image
             !}
          else
             !{
             data_par%data_file = DATA_INPUT
             slow_par%dslow_file = SLOW_INPUT
             if(image_par%image_file /= IMAGE_NO_FILE) &
             image_par%image_file = IMAGE_OUTPUT
             image_par%dimage_file = IMAGE_OUTPUT
             down_par%z_down_0= gen_par%z_image_0
             down_par%d_z_down=gen_par%d_z_image
             !}
          end if
       case default
          write(0,*)'gen_par-domain_range=',trim(gen_par%domain_range)
          call seperr('Not supported domain_range')
       end select
       !}
    end if
    if(down_par%adj) then
       previous_adj=1
    else
       previous_adj=-1
    end if

    if(gen_par%debug2) write(0,*)'data_file=',data_par%data_file
    if(gen_par%debug2) write(0,*)'ddata_file=',data_par%ddata_file
    if(gen_par%debug2) write(0,*)'down_data_file=',data_par%down_data_file
    if(gen_par%debug2) write(0,*)'down_ddata_file=',data_par%down_ddata_file
    if(gen_par%debug2) write(0,*)'image_file=',image_par%image_file
    if(gen_par%debug2) write(0,*)'dimage_file=',image_par%dimage_file
    if(gen_par%debug2) write(0,*)'slow_file=',slow_par%slow_file
    if(gen_par%debug2) write(0,*)'dslow_file=',slow_par%dslow_file
    if(gen_par%debug2) write(0,*)'file_wavefield',data_par%wavefield_file

    n_block_w=down_par%n_w_extrap/gen_par%n_w_block
    n_block_z=down_par%n_z_down/down_par%n_z_block

    if(gen_par%debug2) write(0,*)'down_par%filter_data=',down_par%filter_data
    if(down_par%filter_data) then
       call design_time_filter(gen_par,data_par,down_par)
    end if
    if((data_par%data_file /= DATA_NO_FILE) .or. &
    (data_par%ddata_file /= DATA_NO_FILE)) then
       call init_io_data(gen_par,data_par,down_par)
    end if
    if((image_par%image_file /= IMAGE_NO_FILE) .or. &
    (image_par%dimage_file /= IMAGE_NO_FILE)) then
       call init_io_image(gen_par,data_par,image_par,down_par)
    end if
    if((slow_par%slow_file /= SLOW_NO_FILE) .or. &
    (slow_par%dslow_file /= SLOW_NO_FILE)) then
       call init_io_slow(gen_par,down_par,data_par,slow_par,image_par)
    end if

    if(gen_par%debug2) write(0,*)'gen_par%verb=',gen_par%verb
    if(gen_par%debug2) write(0,*)'down_par%n_w_block_ser=',down_par%n_w_block_ser
    if(gen_par%debug2) write(0,*)'down_par%n_w_block_par=',down_par%n_w_block_par
    if(gen_par%debug2) write(0,*)'n_block_w=',n_block_w
    if(gen_par%debug2) write(0,*)'down_par%n_z_block=',down_par%n_z_block
    if(gen_par%debug2) write(0,*)'n_block_z=',n_block_z

    if(slow_par%slow_file /= SLOW_NO_FILE) then
       allocate (slow_data_block(data_par%n_mx_pad,data_par%n_my_pad, &
       data_par%n_hx_pad,data_par%n_hy_pad, &
       slow_par%n_comp_slow, &
       down_par%n_z_block),stat=ierr)  
       if(ierr .ne. 0) call seperr("Problems with allocation of slow_data_block")
       if(gen_par%debug2) write(0,*)'Allocate slow_data_block with shape=',shape(slow_data_block)
    else
       allocate (slow_data_block(1,1,1,1,1,1),stat=ierr)  
       if(ierr .ne. 0) call seperr("Problems with allocation of slow_data_block")
       if(gen_par%debug2) write(0,*)'Allocate slow_data_block with shape=',shape(slow_data_block)
    end if

    if(slow_par%dslow_file /= SLOW_NO_FILE) then
       allocate (dslow_data_block(data_par%n_mx_pad,data_par%n_my_pad, &
       data_par%n_hx_pad,data_par%n_hy_pad, &
       slow_par%n_comp_slow, &
       down_par%n_z_block, &
       down_par%n_w_block_par),stat=ierr)  
       if(ierr .ne. 0) call seperr("Problems with allocation of dslow_data_block")
       if(gen_par%debug2) write(0,*)'Allocate dslow_data_block with shape=',shape(dslow_data_block)
    else 
       allocate (dslow_data_block(1,1,1,1,1,1,1),stat=ierr)  
       if(ierr .ne. 0) call seperr("Problems with allocation of dslow_data_block")
       if(gen_par%debug2) write(0,*)'Allocate dslow_data_block with shape=',shape(dslow_data_block)
    end if

    allocate (data_block(data_par%n_mx_pad,data_par%n_my_pad, &
    data_par%n_hx_pad,data_par%n_hy_pad, &
    down_par%n_w_block_ser,down_par%n_w_block_par),stat=ierr)  
    if(ierr .ne. 0) call seperr("Problems with allocation of data_block")
    if(gen_par%debug2) write(0,*)'Allocate data_block with shape=',shape(data_block)

    if (gen_par%oper_type(1:1) == 'd') then
       allocate (ddata_block(data_par%n_mx_pad,data_par%n_my_pad, &
       data_par%n_hx_pad,data_par%n_hy_pad, &
       down_par%n_w_block_ser,down_par%n_w_block_par),stat=ierr)  
       if(ierr .ne. 0) call seperr("Problems with allocation of ddata_block")
       if(gen_par%debug2) write(0,*)'Allocate ddata_block with shape=',shape(ddata_block)
    else 
       allocate (ddata_block(1,1,1,1,1,1),stat=ierr)  
       if(ierr .ne. 0) call seperr("Problems with allocation of ddata_block")
       if(gen_par%debug2) write(0,*)'Allocate ddata_block with shape=',shape(ddata_block)
    end if

    if(image_par%image_file /= IMAGE_NO_FILE) then
       allocate (image_block(image_par%n_mx_image,image_par%n_my_image, &
       image_par%n_hx_image,image_par%n_hy_image, &
       down_par%n_z_block,down_par%n_w_block_par),stat=ierr)  
       if(gen_par%debug2) write(0,*)'Allocate image_block with shape=',shape(image_block)
       if(ierr .ne. 0) call seperr("Problems with allocation of image_block")
    else
       allocate (image_block(1,1,1,1,1,1),stat=ierr)  
       if(gen_par%debug2) write(0,*)'Allocate image_block with shape=',shape(image_block)
       if(ierr .ne. 0) call seperr("Problems with allocation of image_block")
    end if

    if(image_par%dimage_file /= IMAGE_NO_FILE) then
       allocate (dimage_block(image_par%n_mx_image,image_par%n_my_image, &
       image_par%n_hx_image,image_par%n_hy_image, &
       down_par%n_z_block,down_par%n_w_block_par),stat=ierr)  
       if(ierr .ne. 0) call seperr("Problems with allocation of dimage_block")
       if(gen_par%debug2) write(0,*)'Allocate dimage_block with shape=',shape(dimage_block)
    else
       allocate (dimage_block(1,1,1,1,1,1),stat=ierr)  
       if(ierr .ne. 0) call seperr("Problems with allocation of dimage_block")
       if(gen_par%debug2) write(0,*)'Allocate dimage_block with shape=',shape(dimage_block)
    end if

    stat= down_gen_par( &
    n_block_w,n_block_z,z_down_0, &
    gen_par,data_par,image_par,down_par,slow_par, &
    down_oper,scatter_oper, &
    slow_data_block,dslow_data_block,&
    data_block,ddata_block,&
    image_block,dimage_block) 

    if(ierr .ne. 0) call seperr("gendown3d_mod: Problems with down_gen_par")

    if(allocated(image_block)) deallocate (image_block,stat=ierr)  
    if(allocated(dimage_block)) deallocate (dimage_block,stat=ierr)  
    if(allocated(data_block)) deallocate (data_block,stat=ierr)  
    if(allocated(ddata_block)) deallocate (ddata_block,stat=ierr)  
    if(allocated(slow_data_block)) deallocate (slow_data_block,stat=ierr)  
    if(allocated(dslow_data_block)) deallocate (dslow_data_block,stat=ierr)  

    if(ierr .ne. 0) call seperr("Problems with deallocation")

    if(down_par%filter_data) then
       call clean_time_filter()
    end if

    if((slow_par%slow_file /= SLOW_NO_FILE) .or. &
    (slow_par%dslow_file /= SLOW_NO_FILE)) then
       call clean_io_slow()
    end if

    if((image_par%image_file /= IMAGE_NO_FILE) .or. &
    (image_par%dimage_file /= IMAGE_NO_FILE)) then
       call clean_io_image()
    end if
    return
  end function gendown3d

  subroutine gendown3d_init(verb,init_down_oper)
    interface 
       subroutine param_gen(gen_par)
         use gendown3d_types, only: gendown3d_param_type
         type (gendown3d_param_type) gen_par
       end subroutine param_gen
    end interface
    interface 
       subroutine param_data(gen_par,data_par)
         use gendown3d_types, only: gendown3d_param_type
         use data_types, only: data_param_type
         type (gendown3d_param_type) gen_par
         type (data_param_type) data_par
       end subroutine param_data
    end interface
    interface 
       subroutine param_down( &
       gen_par,data_par,image_par,down_par,slow_par)
         use gendown3d_types, only: gendown3d_param_type
         use data_types, only: data_param_type
         use image_types, only: image_param_type
         use down_process_types, only: down_process_param_type
         use slow_types, only: slow_param_type
         type (gendown3d_param_type) gen_par
         type (data_param_type) data_par
         type (image_param_type) image_par
         type (down_process_param_type) down_par
         type (slow_param_type) slow_par
       end subroutine param_down
    end interface

    interface
       function init_down_oper(gen_par,data_par,slow_par) result(info)
         use gendown3d_types, only: gendown3d_param_type,gendown3d_info_type
         use data_types, only: data_param_type
         use slow_types, only: slow_param_type
         type (gendown3d_info_type) info
         type (gendown3d_param_type) gen_par
         type (data_param_type) data_par
         type (slow_param_type) slow_par
       end  function init_down_oper
    end interface

    logical :: verb
    ! initialize the default parameters
    gen_par = &
    gendown3d_param_type ( &
    verb_init, &
    debug1_init, &
    debug2_init, &
    timers_on_init, &
    rho_filt_init, &
    image_zero_offset_init, &
    image_cra_init, &
    k_domain_init, &
    first_adj_init, &
    first_add_init, &
    check_stability_init, &
    complex_image_init, &
    synth_data_init, &
    no_data_init, &
    single_hx_dip_init, &
    time_mig_init, &
    trim(oper_type_init), &
    trim(domain_range_init), &
    n_threads_init, &
    max_memory_init, &
    non_data_memory_init, &
    n_data_dim_init, &
    n_mx_pad_init, &
    n_my_pad_init, &
    n_hx_pad_init, &
    n_hy_pad_init, &
    n_z_image_init, &
    n_w_block_init, &
    n_z_block_init, &
    i_block_z_restart_init, &
    slow_const_init, &
    slow_scale_init, &
    max_propag_angle_init, &
    z_image_0_init, &
    d_z_image_init, &
    t_spike_0_init, &
    mx_spike_0_init, &
    my_spike_0_init, &
    hx_spike_0_init, &
    hy_spike_0_init, &
    t_spike_1_init, &
    mx_spike_1_init, &
    my_spike_1_init, &
    hx_spike_1_init, &
    hy_spike_1_init, &
    px_plane_0_init, &
    py_plane_0_init, &
    px_plane_1_init, &
    py_plane_1_init, &
    freq_min_0_init, &
    freq_min_1_init, &
    freq_max_0_init, &
    freq_max_1_init)

    if(verb) then
       write(0,*)'*******************************'
       write(0,*)'*******************************'
       write(0,*)'Default parameters for Gendown3d'
       write(0,*)'verb=',gen_par%verb
       write(0,*)'debug1=',gen_par%debug1
       write(0,*)'debug2=',gen_par%debug2
       write(0,*)'timers_on=',gen_par%timers_on
       write(0,*)'rho_filt=',gen_par%rho_filt
       write(0,*)'image_zero_offset=',gen_par%image_zero_offset
       write(0,*)'image_cra',gen_par%image_cra
       write(0,*)'k_domain=',gen_par%k_domain
       write(0,*)'first_adj=',gen_par%first_adj
       write(0,*)'first_add=',gen_par%first_add
       write(0,*)'check_stability=',gen_par%check_stability
       write(0,*)'complex_image_init=',gen_par%complex_image
       write(0,*)'synth_data_init=',gen_par%synth_data
       write(0,*)'no_data_init=',gen_par%no_data
       write(0,*)'single_hx_dip_init=',gen_par%single_hx_dip
       write(0,*)'time_mig_init=',gen_par%time_mig
       write(0,*)'oper_type=',trim(gen_par%oper_type)
       write(0,*)'domain_range=',trim(gen_par%domain_range)
       write(0,*)'n_threads=',gen_par%n_threads
       write(0,*)'max_memory=',gen_par%max_memory
       write(0,*)'non_data_memory=',gen_par%non_data_memory
       write(0,*)'n_data_dim=',gen_par%n_data_dim
       write(0,*)'n_mx_pad=',gen_par%n_mx_pad
       write(0,*)'n_my_pad=',gen_par%n_my_pad
       write(0,*)'n_hx_pad=',gen_par%n_hx_pad
       write(0,*)'n_hy_pad=',gen_par%n_hy_pad
       write(0,*)'n_z_image=',gen_par%n_z_image
       write(0,*)'n_w_block=',gen_par%n_w_block
       write(0,*)'n_z_block=',gen_par%n_z_block
       write(0,*)'i_block_z_restart_init=',gen_par%i_block_z_restart

       write(0,*)'slow_const=',gen_par%slow_const
       write(0,*)'slow_scale=',gen_par%slow_scale
       write(0,*)'max_propag_angle=',gen_par%max_propag_angle
       write(0,*)'z_image_0=',gen_par%z_image_0
       write(0,*)'d_z_image=',gen_par%d_z_image
       write(0,*)'t_spike_0=',gen_par%t_spike_0
       write(0,*)'mx_spike_0=',gen_par%mx_spike_0
       write(0,*)'my_spike_0=',gen_par%my_spike_0
       write(0,*)'hx_spike_0=',gen_par%hx_spike_0
       write(0,*)'hy_spike_0=',gen_par%hy_spike_0
       write(0,*)'t_spike_1=',gen_par%t_spike_1
       write(0,*)'mx_spike_1=',gen_par%mx_spike_1
       write(0,*)'my_spike_1=',gen_par%my_spike_1
       write(0,*)'hx_spike_1=',gen_par%hx_spike_1
       write(0,*)'hy_spike_1=',gen_par%hy_spike_1
       write(0,*)'px_plane_0=',gen_par%px_plane_0
       write(0,*)'py_plane_0=',gen_par%py_plane_0
       write(0,*)'px_plane_1=',gen_par%px_plane_1
       write(0,*)'py_plane_1=',gen_par%py_plane_1
       write(0,*)'freq_min_0=',gen_par%freq_min_0
       write(0,*)'freq_min_1=',gen_par%freq_min_1
       write(0,*)'freq_max_0=',gen_par%freq_max_0
       write(0,*)'freq_max_1=',gen_par%freq_max_1
       write(0,*)'*******************************'
    end if

    call param_gen(gen_par)
    call param_data(gen_par,data_par)
    call param_down(gen_par,data_par,image_par,down_par,slow_par)

    info_down=init_down_oper(gen_par,data_par,slow_par)
    return
  end subroutine gendown3d_init

  subroutine gendown3d_clean(verb,clean_down_oper)
    interface
       function clean_down_oper() result(stat)
         integer stat
       end  function clean_down_oper
    end interface

    logical :: verb
    integer stat

    stat=clean_down_oper()
    if(verb .and. (stat /= 0)) write(0,*)'Problems in clean_down_oper'
    return
  end subroutine gendown3d_clean
end module gendown3d_mod