submodule(convection_exchangeable_interface) &
    convection_exchangeable_implementation
  use assertions_interface, only : assert, assertions
  ! use exchangeable_interface, only : exchangeable_t
  use domain_interface, only : pressure_at_elevation, exner_function, sat_mr

  ! use grid_interface, only : grid_t
  implicit none

  ! ----- PARAMETERS TO TUNE CONVECTION MODEL -----
  logical, parameter :: debug = .false.
  logical, parameter :: wrap_neighbors = .true.
  logical, parameter :: convection = .true.
  logical, parameter :: wind = .true.
  logical, parameter :: fake_wind_correction = .false.
  logical, parameter :: use_input_wind = .true.
  logical, parameter :: caf_comm_message = .false.
  logical, parameter :: particle_create_message = .false.
  logical, parameter :: brunt_vaisala_data = .false.
  logical, parameter :: replacement = .true.
  logical, parameter :: replacement_message = .false.
  logical, parameter :: init_theta = .false.
  logical, parameter :: init_velocity = .true.
  logical, parameter :: count_p_comm = .false.
  integer, save      :: particles_communicated[*]
  integer, save      :: particles_per_image
  integer, save      :: local_buf_size
  real,    save      :: input_wind
  logical, save      :: dry_air_particles
  ! integer, parameter :: particles_per_image=1
  ! integer, parameter :: local_buf_size=4*particles_per_image
  ! logical, parameter :: dry_air_particles=.true.
  ! -----------------------------------------------

  integer, parameter :: default_buf_size=1
  integer, parameter :: default_halo_size=1
  integer, save, allocatable :: neighbors(:)
  integer, save :: north_con_neighbor, south_con_neighbor, buf_size, halo_size
  integer, save :: east_con_neighbor, west_con_neighbor
  integer, save :: northeast_con_neighbor, northwest_con_neighbor
  integer, save :: southeast_con_neighbor, southwest_con_neighbor

contains
  module subroutine convect_const(this, potential_temp, u_in, v_in, w_in, grid,&
      z_m, z_interface, ims, ime, kms, kme, jms, jme, dz_val, &
      its, ite, kts, kte, jts, jte, pressure, input_buf_size, halo_width)
    class(convection_exchangeable_t), intent(inout) :: this
    class(exchangeable_t), intent(in)    :: potential_temp
    class(exchangeable_t), intent(in)    :: u_in, v_in, w_in
    type(grid_t), intent(in)      :: grid
    real, intent(in)              :: z_m(ims:ime,kms:kme,jms:jme)
    real, intent(in)              :: pressure(ims:ime,kms:kme,jms:jme)
    real, intent(in)              :: z_interface(ims:ime,jms:jme)
    integer, intent(in)           :: ims, ime, kms, kme, jms, jme
    integer, intent(in)           :: its, ite, kts, kte, jts, jte
    real, intent(in)              :: dz_val
    integer, intent(in), optional :: input_buf_size
    integer, intent(in), optional :: halo_width

    integer :: me, create, seed(34)
    real :: random_start(3), x, z, y
    real :: z_meters, z_interface_val, theta_val
    real :: pressure_val, exner_val, temp_val, water_vapor_val
    real :: u_val, v_val, w_val
    integer :: x0, x1, z0, z1, y0, y1
    logical :: calc

    me = this_image()
    call initialize_from_file()
    particles_communicated = 0
    if (particles_per_image .eq. 0) then
       if (me .eq. 1) print *, "No air parcels used"
       return
    end if

    me = this_image()
    ! if (present(input_buf_size)) then
    !   buf_size = input_buf_size
    !   print *, 'using input_buf_size'
    ! else
    !   buf_size = default_buf_size
    !   print *, 'using default_buf_size'
    ! end if
    buf_size = particles_per_image

    if (present(halo_width)) then
      halo_size = halo_width
    else
      halo_size = default_halo_size
    end if

    ! if (me .eq. 1) print *, "Buf size is", buf_size

    if (allocated(this%local)) deallocate(this%local)
    this%north_boundary = (grid%yimg == grid%yimages)
    this%south_boundary = (grid%yimg == 1)
    this%east_boundary  = (grid%ximg == grid%ximages)
    this%west_boundary  = (grid%ximg == 1)

    allocate(this%local(particles_per_image * 4))
    if (particle_create_message .eqv. .true.) then
      if (me == 1) then
        print*, "Creating", particles_per_image, "parcels per image"
      end if
    end if

    seed = -1
    call random_seed(PUT=seed)
    call random_init(.true.,.true.)

    do create=1,particles_per_image
      call this%create_particle_id()
      this%local(create) = create_particle(this%particle_id_count, &
          its, ite, kts, kte, jts, jte, ims, ime, kms, kme, jms, jme, &
          z_m, potential_temp, z_interface, pressure, u_in, v_in, w_in)

      ! this%local(create) = convection_particle(this%particle_id_count, .true., &
      !     .false., x, y, z, u_val, v_val, w_val, z_meters, z_interface_val, &
      !     pressure_val, temp_val, theta_val, 0, water_vapor_val, 0)
    end do

    if (particle_create_message .eqv. .true.) then
      print *, "ALLOCATING BUFFERS OF SIZE", buf_size
    end if
    allocate( this%buf_north_in(buf_size)[*])
    allocate( this%buf_south_in(buf_size)[*])
    allocate( this%buf_east_in(buf_size)[*])
    allocate( this%buf_west_in(buf_size)[*])
    allocate( this%buf_northeast_in(buf_size)[*])
    allocate( this%buf_northwest_in(buf_size)[*])
    allocate( this%buf_southeast_in(buf_size)[*])
    allocate( this%buf_southwest_in(buf_size)[*])

    call this%setup_neighbors(grid)
  end subroutine convect_const

  module function create_particle(particle_id, its, ite, kts, kte, jts, jte, &
      ims, ime, kms, kme, jms, jme, z_m, potential_temp, z_interface, &
      pressure, u_in, v_in, w_in, times_moved) result(particle)
    integer :: particle_id
    type(convection_particle) :: particle
    integer, intent(in)           :: ims, ime, kms, kme, jms, jme
    integer, intent(in)           :: its, ite, kts, kte, jts, jte
    real, intent(in)              :: z_m(ims:ime,kms:kme,jms:jme)
    real, intent(in)              :: pressure(ims:ime,kms:kme,jms:jme)
    class(exchangeable_t), intent(in)    :: potential_temp
    real, intent(in)              :: z_interface(ims:ime,jms:jme)
    class(exchangeable_t), intent(in)    :: u_in, v_in, w_in
    integer, intent(in), optional :: times_moved
    real :: relative_humidity_in
    real :: z_meters, z_interface_val, theta_val
    real :: random_start(3), x, z, y
    integer :: x0, x1, z0, z1, y0, y1, times_moved_val
    real :: pressure_val, exner_val, temp_val, water_vapor_val
    real :: u_val, v_val, w_val, velocity, cloud_water
    call random_number(random_start)

    x = its + (random_start(1) * (ite-its))
    z = kts + (random_start(3) * (kte-kts))
    y = jts + (random_start(2) * (jte-jts))

    if (x .lt. its .or. &
        x .gt. ite .or. &
        z .lt. kts .or. &
        z .gt. kte .or. &
        y .lt. jts .or. &
        y .gt. jte) then
      print *, "x:", its, "<", x, "<", ite
      print *, "z:", kts, "<", z, "<", kte
      print *, "y:", jts, "<", y, "<", jte
      stop "x,y,z is out of bounds"
    end if

    x0 = floor(x); z0 = floor(z); y0 = floor(y);
    x1 = ceiling(x); z1 = ceiling(z); y1 = ceiling(y);

    associate (A => z_m)
      z_meters = trilinear_interpolation(x, x0, x1, z, z0, z1, y, y0, y1, &
          A(x0,z0,y0), A(x0,z0,y1), A(x0,z1,y0), A(x1,z0,y0), &
          A(x0,z1,y1), A(x1,z0,y1), A(x1,z1,y0), A(x1,z1,y1))
    end associate

    associate (A => potential_temp%local)
      theta_val = trilinear_interpolation(x, x0, x1, z, z0, z1, y, y0, y1, &
          A(x0,z0,y0), A(x0,z0,y1), A(x0,z1,y0), A(x1,z0,y0), &
          A(x0,z1,y1), A(x1,z0,y1), A(x1,z1,y0), A(x1,z1,y1))
    end associate

    associate (A => pressure)
      pressure_val = trilinear_interpolation(x, x0, x1, z, z0, z1, y, y0, y1, &
          A(x0,z0,y0), A(x0,z0,y1), A(x0,z1,y0), A(x1,z0,y0), &
          A(x0,z1,y1), A(x1,z0,y1), A(x1,z1,y0), A(x1,z1,y1))
    end associate

    ! print *, "val and func", pressure_val, pressure_at_elevation(100000.0, z_meters)
    ! call exit

    associate (A => z_interface)
      z_interface_val = bilinear_interpolation(x, x0, x1, y, y0, y1, &
          A(x0,y0), A(x0,y1), A(x1,y0), A(x1,y1))
    end associate

    ! print *, "z meters =" , z_meters, "z =", z, "zm =", z_m(x0,z0,y0)
    ! print *, "z_interface_val =", z_interface_val, "try =", z*dz_val + z_interface_val -250
    ! print *, "----"

    ! call flush()
    ! sync all
    ! call exit

    ! sealevel_pressure => 100000.0
    ! pressure_val = pressure_at_elevation(100000.0, z_meters)
    exner_val = exner_function(pressure_val)

    ! call random_number(rand)
    if (init_theta .eqv. .true.) then
      theta_val = theta_val * (1 + 1.0 / 100) ! random 0-1% change
    else
      theta_val = theta_val ! * (1 + 0.01) ! increase by 1%
   end if

   if (init_velocity .eqv. .true.) then
      velocity = 5
   else
      velocity = 0
   end if

    temp_val = exner_val * theta_val

    if (dry_air_particles .eqv. .true.) then
       water_vapor_val = 0
    else
       water_vapor_val = sat_mr(temp_val, pressure_val) *  1.0 !0.99
    end if
    relative_humidity_in = water_vapor_val

    ! When testing, set to 0
    ! relative_humidity_in = 0

    ! wind is constant in this system, ignoring w wind (aka z-direction)
    u_val = u_in%local(x0, z0, y0)
    v_val = v_in%local(x0, z0, y0)
    w_val = 0

    cloud_water = 0
    if (present(times_moved) .eqv. .true.) then
       times_moved_val = times_moved
    else
       times_moved_val = 0
    end if

    particle = convection_particle(particle_id, .true., times_moved_val, &
        x, y, z, u_val, v_val, w_val, z_meters, z_interface_val, &
        pressure_val, temp_val, theta_val, velocity, water_vapor_val, &
        cloud_water, relative_humidity_in)

  end function

  module subroutine process(this, nx_global, ny_global, &
      ims, ime, kms, kme, jms, jme, dt, dz, temperature, z_interface, &
      its, ite, kts, kte, jts, jte, z_m, potential_temp, pressure, u_in, v_in, &
      w_in, timestep)
    implicit none
    class(convection_exchangeable_t), intent(inout) :: this
    integer, intent(in) :: nx_global, ny_global
    real, intent(in)    :: dt, dz
    real, intent(in)    :: temperature(ims:ime,kms:kme,jms:jme)
    real, intent(in)    :: pressure(ims:ime,kms:kme,jms:jme)
    real, intent(in)    :: z_interface(ims:ime,jms:jme)
    integer, intent(in) :: ims, ime, kms, kme, jms, jme
    integer, intent(in) :: its, ite, kts, kte, jts, jte
    real, intent(in) :: z_m(ims:ime,kms:kme,jms:jme)
    class(exchangeable_t), intent(in) :: potential_temp
    class(exchangeable_t), intent(in), optional :: u_in, v_in, w_in
    integer, intent(in), optional :: timestep

    real, parameter :: gravity = 9.80665
    type(convection_particle) :: new_particle
    real :: Gamma
    real :: a_prime, z_displacement, t, t_prime, buoyancy
    real :: ws, wind_correction, delta_z, z_interface_val, z_wind_change
    integer :: i,j,k, l_bound(1), dif(1), new_ijk(3), me, iter
    real :: new_pressure, R_s, p0, exponent, alt_pressure, alt_pressure2
    real :: alt_pressure3, alt_pressure4, mixing_ratio, sat_mr_val
    real :: vapor_p, sat_p, T_C, T_K, mr, T_squared, T_original, tmp
    real :: xx, yy, z_0, z_1
    real :: rate_of_temp_change, bv(local_buf_size)
    integer :: x0, x1, z0, z1, y0, y1, bv_i, image, particle_id(local_buf_size)
    integer :: u_bound(3)
    logical :: calc, calc_x, calc_y, exist
    character(len=32) :: filename

    if (debug .eqv. .true.) print*, "start particle processing"

    me = this_image()
    bv_i = 1
    bv = 0
    particle_id = 0

    do i=1,ubound(this%local,1)
      associate (particle=>this%local(i))
        if (particle%exists .eqv. .true.) then
          if (particle%x .lt. its-1 .or. &
              particle%z .lt. kts-1 .or. &
              particle%y .lt. jts-1 .or. &
              particle%x .gt. ite+1 .or. &
              particle%z .gt. kte+1 .or. &
              particle%y .gt. jte+1) then
            print *, "particle", particle%particle_id, "on image", me
            print *, "x:", its, "<", particle%x, "<", ite, "with halo 2"
            print *, "z:", kts, "<", particle%z, "<", kte, "with halo 2"
            print *, "y:", jts, "<", particle%y, "<", jte, "with halo 2"
            stop "x,y,z is out of bounds"
          end if

          !-----------------------------------------------------------------
          ! Handle Buoyancy
          !-----------------------------------------------------------------
          ! Buoyancy (B), Temperature (T), Surrounding Tmperature (T')
          ! B = (T - T') / T'                                         (4.12)
          ! acceleration'_z = B * g                                    (11)
          !-----------------------------------------------------------------
          ! acceleration in terms of potential temperature             (13)
          ! theta = T(p_0 / p') ^ (R_d / c_p)
          ! acceleration'_z = B * g = (theta' - theta) / theta * gravity
          !-----------------------------------------------------------------
          ! displacement (s), initial velocity (u), final velocity (v)
          ! v = u + a * t
          ! s = u*t + 1/2 a*t^2
          !-----------------------------------------------------------------
          ! new: properites of environment are prime
          T = particle%temperature

          associate (A => temperature, x => particle%x, z => particle%z , &
              y => particle%y)
            x0 = floor(x); z0 = floor(z); y0 = floor(y);
            x1 = ceiling(x); z1 = ceiling(z); y1 = ceiling(y);

            T_prime = trilinear_interpolation(x, x0, x1, z, z0, z1, y, y0,y1,&
                A(x0,z0,y0), A(x0,z0,y1), A(x0,z1,y0), A(x1,z0,y0), &
                A(x0,z1,y1), A(x1,z0,y1), A(x1,z1,y0), A(x1,z1,y1))
          end associate

          if (convection .eqv. .true.) then
            buoyancy = (T - T_prime) / T_prime
            a_prime = buoyancy * gravity
            ! d = v_0 * t + 1/2 * a * t^2
            z_displacement = particle%velocity * dt + 0.5 * a_prime * dt * dt
            ! z_displacement = particle%velocity + 0.5 * a_prime

            ! number from dz_interface, currently always 500
            delta_z = z_displacement / dz
            if (z_displacement /= z_displacement) then
              print *, me, ":: ---------NAN ERROR---------", &
                  particle%particle_id, T, T_prime
              particle%z = -1
              print *, p0, z_displacement, gravity, particle%temperature
              call exit
            else
              particle%z = particle%z + delta_z
              particle%velocity = z_displacement
            end if
          else
            z_displacement = 0.0
          end if

          !-----------------------------------------------------------------
          ! Orographic lift
          ! Find dz change from change in environment
          !-----------------------------------------------------------------
          if (wind .eqv. .true.) then
            wind_correction = (1.0 / dz) ! real correction
            ! print *, "wind", wind_correction
            ! wind_correction = (1.0 / 10) ! real correction
            if (fake_wind_correction .eqv. .true.) then
                wind_correction = wind_correction * 0.0
            end if

            ! u: zonal velocity, wind towards the east
            ! v: meridional velocity, wind towards north
            if (use_input_wind .eqv. .true.) then
               particle%x = particle%x + (input_wind * wind_correction)
               particle%y = particle%y + (input_wind * wind_correction)
            else
               particle%x = particle%x + (particle%u * wind_correction)
               particle%y = particle%y + (particle%v * wind_correction)
            end if

            associate (A => z_interface, x=> particle%x, y=>particle%y)
              x0 = floor(x); x1 = ceiling(x)
              y0 = floor(y); y1 = ceiling(y)

              z_interface_val = bilinear_interpolation(x, x0, x1, y, y0, y1, &
                  A(x0,y0), A(x0,y1), A(x1,y0), A(x1,y1))
            end associate
            z_wind_change = z_interface_val - particle%z_interface
            particle%z_interface = z_interface_val
            z_displacement = z_displacement + z_wind_change
          end if

          !-----------------------------------------------------------------
          ! Move particle, remove particle if beyond the z axis
          !-----------------------------------------------------------------
          z_0 = particle%z_meters
          z_1 = particle%z_meters + z_displacement
          particle%z_meters = z_1
          if (particle%z .lt. kts) then
            ! ---- hits the ground and stops  ----
            ! z_displacement = z_displacement + dz * (1-particle%z)
            ! particle%z = 1
            ! particle%z_meters = z_interface_val + dz/2
            ! particle%velocity = 0

            ! ---- replacement code ----
            particle%exists = .false.
            ! print *, "-replacing??!!-", particle%particle_id
            if (replacement .eqv. .true.) then
               particle = create_particle(particle%particle_id, &
                  its, ite, kts, kte, jts, jte, ims, ime, kms, kme, jms, jme, &
                  z_m, potential_temp, z_interface, pressure, u_in, v_in, w_in,&
                  particle%moved)
              if (replacement_message .eqv. .true.) then
                print *, me,":",particle%particle_id, "hit the ground"
              end if
            end if

          else if (particle%z .gt. kte) then
            particle%exists = .false.
            if (replacement .eqv. .true.) then
               particle = create_particle(particle%particle_id, &
                  its, ite, kts, kte, jts, jte, ims, ime, kms, kme, jms, jme, &
                  z_m, potential_temp, z_interface, pressure, u_in, v_in, w_in,&
                  particle%moved)
              if (replacement_message .eqv. .true.) then
                print *, me,":",particle%particle_id, "went off the top"
              end if
            end if
            ! call exit
            ! cycle
          end if

          if (brunt_vaisala_data .eqv. .true.) then
             associate (A => potential_temp%local, x => particle%x, &
                  z => particle%z , y => particle%y)
               x0 = floor(x); z0 = floor(z); y0 = floor(y);
               x1 = ceiling(x); z1 = ceiling(z); y1 = ceiling(y);

               bv(bv_i) = trilinear_interpolation( &
                    x, x0, x1, z, z0, z1, y, y0,y1, &
                    A(x0,z0,y0), A(x0,z0,y1), A(x0,z1,y0), A(x1,z0,y0), &
                    A(x0,z1,y1), A(x1,z0,y1), A(x1,z1,y0), A(x1,z1,y1))
               particle_id(bv_i) = particle%particle_id
               bv_i = bv_i + 1
             end associate
          end if

          !-----------------------------------------------------------------
          ! Dry Lapse Rate
          !-----------------------------------------------------------------
          ! p = p_0 * e^( ((9.81/287.058)*dz) / t_mean )
          !-----------------------------------------------------------------
          ! Method one: physics
          !        a) change pressure         b) update temperature
          !-----------------------------------------------------------------
          if (dry_air_particles .eqv. .true.) then
             if (debug .eqv. .true.) print *, "-- only dry air parcels --"
             call dry_lapse_rate(particle%pressure, particle%temperature, &
                  particle%potential_temp, z_displacement)
          else
          !-----------------------------------------------------------------
          ! Relative Humidity and physics of Moist Adiabatic Lapse Rate
          !-----------------------------------------------------------------
          ! | Mixing Ratio |
          ! saturate = sat_mr(t,p)
          ! if (water_vapor > saturated)
          !   condensate = water_vapor - satured
          !   water_vapor -= condensate
          !   clouds += condensate
          !   Q_heat  = specific_latent_heat * condensate
          !   delta_T = Q_heat / c_p   ! c_p is specific heat capacity
          !   temperature += delta_T
          !-----------------------------------------------------------------
            block
              real :: saturate, condensate, vapor, vapor_needed, RH
              ! specific latent heat values, calculating using formula
              real, parameter :: condensation_lh = 2600!000 ! 2.5 x 10^6 J/kg
              real, parameter :: vaporization_lh = -condensation_lh
              ! specific heat of water vapor at constant volume
              ! real, parameter :: C_vv = 1.0 / 1390.0
              real :: C_vv, c_p
              real :: specific_latent_heat, Q_heat, temp_c, delta_t, T0, T1, &
                   p0, p1, q_dry, q_wet, potential_temp0, q_new_dry, q_dif
              real :: water_vapor0,  water_vapor1
              real :: cloud_water0,  cloud_water1
              real :: potential_T0, potential_T1
              integer :: repeat
              logical :: only_dry
              T0 = particle%temperature
              p0 = particle%pressure
              potential_T0 = particle%potential_temp
              call dry_lapse_rate(particle%pressure, particle%temperature, &
                   particle%potential_temp, z_displacement)
              only_dry = .true.
              T1 = particle%temperature
              p1 = particle%pressure
              q_dry = 1004 * 1 * (abs(t1-t0))  ! q = c_p x m x delta_T

              do iter = 1,4
              saturate = sat_mr(particle%temperature, particle%pressure)
              RH = particle%water_vapor / saturate
              potential_T1 = particle%potential_temp
              water_vapor0 = particle%water_vapor
              cloud_water0 = particle%cloud_water

              particle%relative_humidity = RH
              ! https://en.wikipedia.org/wiki/Latent_heat#Specific_latent_heat
              ! specific latent heat for condensation and evaporation
              specific_latent_heat = 2.5 * 10**6 ! J kg^-1

              ! Particle is falling, using evaporation of cloud water to keep
              ! the relative humidity at 1 if possible
              vapor_needed = saturate - particle%water_vapor

              if (particle%cloud_water .gt. 0.0 .and. RH .lt. 1.0 &
                   .and. vapor_needed .gt. 0.0000001) then
                if (debug .eqv. .true.) &
                     print*, "==== cloud_water .gt. 0, rh .lt. 1, wet ===="

                only_dry = .false.
                if (vapor_needed > particle%cloud_water) then
                  vapor = particle%cloud_water
                  vapor = vapor / (6-iter)                ! Saturated
                  particle%cloud_water = 0
                else
                  vapor = vapor_needed
                  vapor = vapor / (6-iter)                ! Saturated
                  particle%cloud_water = particle%cloud_water - vapor
                end if

                particle%water_vapor = particle%water_vapor + vapor

                ! heat required by phase change
                Q_heat = specific_latent_heat * vapor ! kJ
                q_wet = Q_heat
                c_p = (1004 * (1 + 1.84 * vapor)) ! 3.3
                ! c_p = 1004 ! specific heat of dry air at 0C
                delta_t = Q_heat / c_p   ! 3.2c
                particle%temperature = T1 - delta_t

                if (debug .eqv. .true.) &
                     potential_temp0 = particle%potential_temp

                ! update potential temperature, assumming pressure is constant
                particle%potential_temp = particle%temperature / exner_function(particle%pressure)

             ! Particle is raising and condensation is occurring
             else if (RH .gt. 1.0) then
           ! ==== rh .gt. 1 ====
           ! water_vapor 5.271018017E-4 saturate 5.271018017E-4 cloud water 0.
           ! condensate 0. new water_vapor 5.271018017E-4 new cloud water 0.
           ! Q_heat 0.
           ! ============= process done ===============

                if (debug .eqv. .true.) print*, "==== rh .gt. 1, wet ===="

                only_dry = .false.
                condensate = particle%water_vapor - saturate
                condensate = condensate / (6-iter) ! Saturated
                particle%water_vapor = particle%water_vapor - condensate
                particle%cloud_water = particle%cloud_water + condensate

                !--------------------------------------------------------------
                ! a different way to calculate specific latent heat
                !--------------------------------------------------------------
                ! if (T1 .lt. 248.15) then
                !   specific_latent_heat = 2600
                ! else if (T1 .gt. 314.15) then
                !   specific_latent_heat = 2400
                ! else
                !   T_C = T1 - 273.15
                !   specific_latent_heat = 2500.8 - 2.36*T_C + 0.0016 * T_C**2 - &
                !       0.00006 * T_C**3
                ! end if

                ! heat from phase change
                Q_heat = specific_latent_heat * condensate ! kJ
                q_wet = Q_heat
                ! print *, "Q_heat", Q_heat
                ! exit
                !--------------------------------------------------------------
                ! calculate change in heat using specific heat (c_p)
                !--------------------------------------------------------------
                ! Stull: Practical Meteorology
                c_p = (1004 * (1 + 1.84 * condensate)) ! 3.3
                ! c_p = 1004 ! specific heat of dry air at 0C
                ! print *, "c_p", c_p
                delta_T = Q_heat / c_p   ! 3.2c
                ! print *, "delta_T", delta_t
                particle%temperature = T1 + delta_T

                ! update potential temperature, assumming pressure is constant
                ! particle%potential_temp = exner_function(particle%pressure) / &
                !      particle%temperature
                particle%potential_temp = particle%temperature / exner_function(particle%pressure)
                ! call dry_lapse_rate(particle%pressure, particle%temperature, &
                !      particle%potential_temp, z_displacement)

                ! stop
                ! -- is pressure constant during this process?
                ! using Poisson's equation
                ! particle%pressure = p0/ ((T0/particle%temperature)**(1/0.286))

             else if (iter .eq. 1) then
                if (debug .eqv. .true.) then
                   print*, "==== was dry process ===="
                end if
                exit
             end if

             if (debug .eqv. .true.) then
                print *, "     pressure  |  temp      |   ~heat    | potential"
                print *, "pre ", p0, t0, ", -none-       ,", potential_t0

                q_new_dry = &
                     1004 * (1) * (abs(particle%temperature-t0))
                q_dif = abs(q_dry-(q_new_dry+q_wet))
                print *, q_dry, q_new_dry, q_wet, q_dif, &
                     1004 * (1) * q_dif
             end if
             ! if ((debug .eqv. .true.) .and. (only_dry .eqv. .false.)) then
             !    print *, "post", p1, t1, q_dry, potential_t1
             !    print *, "new ", &
             !         particle%pressure, particle%temperature, &
             !         q_wet,  particle%potential_temp

                ! print *, "heat: q_dry = q_new_dry + q_wet"
                ! print *, " ", q_dry, "=", q_new_dry, "+", q_wet
                ! print *, "dif         =", q_dif, "which is ~ temp diff", &
                !      1004 * (1) * q_dif

                ! print *, "--test--"
                ! print *, " t? ", t0 - (q_new_dry / (1004 * (1)) )

                ! print *, "vapor_needed", vapor_needed, &
                !      "new water_vapor", particle%water_vapor, &
                !      "new cloud water", particle%cloud_water, &
                !      "water_vapor0", water_vapor0, &
                !      "cloud water0", cloud_water0
             ! end if

            end do
             ! saturate = sat_mr(particle%temperature, particle%pressure)
             ! RH = particle%water_vapor / saturate
             ! particle%relative_humidity = RH

            end block
          end if ! ---- end of relative humidity seciton ----

          !-----------------------------------------------------------------
          ! Move particle if needed
          !-----------------------------------------------------------------
          associate (x => particle%x, y => particle%y, z => particle%z)
            if (caf_comm_message .eqv. .true.) then
                if (  x .lt. its-1 .or. x .gt. ite+1 .or. &
                      z .lt. kms-1 .or. z .gt. kme   .or. &
                      y .lt. jts-1 .or. y .gt. jte+1 .or. &
                      x .lt. 1 .or. x .gt. nx_global .or. &
                      y .lt. 1 .or. y .gt. ny_global &
                    ) then
                    print *, "PUTTING", particle%x, particle%y, particle%z_meters, &
                          "FROM", this_image(), "id:", particle%particle_id, &
                          "M", ims,ime, kms, kme, jms, jme, "T", its,ite,jts,jte
                end if
            end if

            xx = x
            yy = y
            ! If particle is getting wrapped the x and y values need to be
            ! properly updated
            if (wrap_neighbors .eqv. .true.) then
              if (x > nx_global) then
                ! if (caf_comm_message .eqv. .true.) print *, "WRAPPED" &
                !     , particle%particle_id
                x = x - nx_global + 1
                xx = xx + 2
              else if (x < 1) then
                ! if (caf_comm_message .eqv. .true.) print *, "WRAPPED" &
                !     , particle%particle_id
                x = x + nx_global - 1
                xx = xx - 2
              end if

              if (y > ny_global) then
                ! if (caf_comm_message .eqv. .true.) print *, "WRAPPED" &
                !     , particle%particle_id
                y = y - ny_global + 1
                yy = yy + 2
              else if (y < 1) then
                ! if (caf_comm_message .eqv. .true.) print *, "WRAPPED" &
                !     , particle%particle_id
                y = y + ny_global - 1
                yy = yy - 2
              end if
            end if

            ! Check values to know where to send particle
            if (yy .lt. jts-1) then      ! "jts  <   y    <  jte"
              if (xx .lt. its-1) then
                call this%put_southwest(particle)
                if (count_p_comm .eqv. .true.) &
                     particles_communicated = particles_communicated + 1
              else if (xx .gt. ite+1) then
                call this%put_southeast(particle)
                if (count_p_comm .eqv. .true.) &
                     particles_communicated = particles_communicated + 1
              else
                call this%put_south(particle)
                if (count_p_comm .eqv. .true.) &
                     particles_communicated = particles_communicated + 1
              end if
            else if (yy .gt. jte+1) then ! jts will be 1
              if (xx .lt. its-1) then
                call this%put_northwest(particle)
                if (count_p_comm .eqv. .true.) &
                     particles_communicated = particles_communicated + 1
              else if (xx .gt. ite+1) then
                call this%put_northeast(particle)
                if (count_p_comm .eqv. .true.) &
                     particles_communicated = particles_communicated + 1
              else
                call this%put_north(particle)
                if (count_p_comm .eqv. .true.) &
                     particles_communicated = particles_communicated + 1
              endif
            else if (xx .lt. its-1) then ! "its  <   x    <  ite"
              call this%put_west(particle) ! need to double check this!
              if (count_p_comm .eqv. .true.) &
                   particles_communicated = particles_communicated + 1
            else if (xx .gt. ite+1) then
              call this%put_east(particle)
              if (count_p_comm .eqv. .true.) &
                   particles_communicated = particles_communicated + 1
            end if
          end associate
        end if
      end associate
    end do

    if (brunt_vaisala_data .eqv. .true.) then
      do image=1,num_images()
      if (me .eq. image) then
         write (filename,"(A17)") "brunt_vaisala.txt"
         inquire(file=filename, exist=exist)
         if (exist) then
            open(unit=me, file=filename, status='old', position='append')
         else
            open(unit=me, file=filename, status='new')
         end if
         do i=1,bv_i-1
            write(me,*) me, timestep, particle_id(i), bv(i)
         end do
         close(me)
      end if
      sync all
      end do

   end if
   if (debug .eqv. .true.) print *, "============= process done ==============="
  end subroutine process

  module subroutine send(this)
    class(convection_exchangeable_t), intent(inout) :: this
    ! if (.not. this%north_boundary) call this%put_north
    ! if (.not. this%south_boundary) call this%put_south
    ! if (.not. this%east_boundary)  call this%put_east
    ! if (.not. this%west_boundary)  call this%put_west
  end subroutine

  module subroutine retrieve(this, no_sync)
    class(convection_exchangeable_t), intent(inout) :: this
    logical,               intent(in),   optional :: no_sync

    if (.not. present(no_sync)) then
      ! sync images (neighbors) ! sync neighbors currently broken
      sync all
    else
      if (.not. no_sync) then
        ! sync images (neighbors) ! sync neighbors currently broken
        sync all
      endif
    endif

    if (.not. this%north_boundary) call this%retrieve_buf(this%buf_north_in)
    if (.not. this%south_boundary) call this%retrieve_buf(this%buf_south_in)
    if (.not. this%east_boundary) call this%retrieve_buf(this%buf_east_in)
    if (.not. this%west_boundary) call this%retrieve_buf(this%buf_west_in)
    if (.not. this%northeast_boundary) &
        call this%retrieve_buf(this%buf_northeast_in)
    if (.not. this%northwest_boundary) &
        call this%retrieve_buf(this%buf_northwest_in)
    if (.not. this%southeast_boundary) &
        call this%retrieve_buf(this%buf_southeast_in)
    if (.not. this%southwest_boundary) &
        call this%retrieve_buf(this%buf_southwest_in)

    this%north_i = 1
    this%south_i = 1
    this%east_i  = 1
    this%west_i  = 1
    this%northeast_i = 1
    this%northwest_i = 1
    this%southeast_i = 1
    this%southwest_i = 1
    sync all
  end subroutine

  module subroutine exchange(this)
    class(convection_exchangeable_t), intent(inout) :: this
    ! if (.not. this%north_boundary) call this%put_north
    ! if (.not. this%south_boundary) call this%put_south
    ! if (.not. this%east_boundary)  call this%put_east
    ! if (.not. this%west_boundary)  call this%put_west

    sync images( neighbors )

    if (.not. this%north_boundary) call this%retrieve_buf(this%buf_north_in)
    if (.not. this%south_boundary) call this%retrieve_buf(this%buf_south_in)
    if (.not. this%east_boundary) call this%retrieve_buf(this%buf_east_in)
    if (.not. this%west_boundary) call this%retrieve_buf(this%buf_west_in)
    if (.not. this%northeast_boundary) &
        call this%retrieve_buf(this%buf_northeast_in)
    if (.not. this%northwest_boundary) &
        call this%retrieve_buf(this%buf_northwest_in)
    if (.not. this%southeast_boundary) &
        call this%retrieve_buf(this%buf_southeast_in)
    if (.not. this%southwest_boundary) &
        call this%retrieve_buf(this%buf_southwest_in)

    this%north_i = 1
    this%south_i = 1
    this%east_i  = 1
    this%west_i  = 1
    this%northeast_i = 1
    this%northwest_i = 1
    this%southeast_i = 1
    this%southwest_i = 1
  end subroutine

  module subroutine retrieve_buf(this, buf)
    implicit none
    class(convection_exchangeable_t), intent(inout) :: this
    type(convection_particle), intent(inout) :: buf(:)[*]
    integer :: i, buf_n, local_i, local_n
    buf_n = ubound(buf, dim=1)
    local_n = ubound(this%local, dim=1)
    local_i = 1
    do i=1,buf_n
      associate (particle=>buf(i))
        do while (particle%exists .eqv. .true.)
          if (local_i .gt. local_n) then
            stop "retrieve_buf is out of bounds"
          end if
          if (this%local(local_i)%exists .eqv. .false.) then
            call particle%move_to(this%local(local_i))
            local_i = local_i + 1
            exit
          end if
          local_i = local_i + 1
       end do
      end associate
    end do
  end subroutine

  module subroutine put_north(this, particle)
    class(convection_exchangeable_t), intent(inout) :: this
    type(convection_particle), intent(inout) :: particle
    if (caf_comm_message .eqv. .true.) then
       print*, "from", this_image(), "to", north_con_neighbor, particle%particle_id
    end if

    if (this%north_boundary) then
      particle%exists = .false.
      return
    end if

    call check_buf_size(this%south_i)
    !dir$ pgas defer_sync
    this%buf_south_in(this%south_i)[north_con_neighbor] = particle
    particle%exists = .false.
    this%south_i = this%south_i + 1
  end subroutine

  module subroutine put_south(this, particle)
    class(convection_exchangeable_t), intent(inout) :: this
    type(convection_particle), intent(inout) :: particle
    if (caf_comm_message .eqv. .true.) then
       print*, "from", this_image(), "to", south_con_neighbor, particle%particle_id
    end if

    if (this%south_boundary) then
      particle%exists = .false.
      return
    end if

    call check_buf_size(this%north_i)
    !dir$ pgas defer_sync
    this%buf_north_in(this%north_i)[south_con_neighbor] = particle
    particle%exists = .false.
    this%north_i = this%north_i + 1
  end subroutine

  module subroutine put_east(this, particle)
    class(convection_exchangeable_t), intent(inout) :: this
    type(convection_particle), intent(inout) :: particle
    if (caf_comm_message .eqv. .true.) then
       print*, "from", this_image(), "to", east_con_neighbor, particle%particle_id
    end if

    if (this%east_boundary) then
      particle%exists = .false.
      return
    end if

    call check_buf_size(this%west_i)
    !dir$ pgas defer_sync
    this%buf_west_in(this%west_i)[east_con_neighbor] = particle
    particle%exists = .false.
    this%west_i = this%west_i + 1
  end subroutine

  module subroutine put_west(this, particle)
    class(convection_exchangeable_t), intent(inout) :: this
    type(convection_particle), intent(inout) :: particle
    if (caf_comm_message .eqv. .true.) then
       print*, "from", this_image(), "to", west_con_neighbor, particle%particle_id
    end if

    if (this%west_boundary) then
      particle%exists = .false.
      return
    end if

    call check_buf_size(this%east_i)
    !dir$ pgas defer_sync
    this%buf_east_in(this%east_i)[west_con_neighbor] = particle
    particle%exists = .false.
    this%east_i = this%east_i + 1
  end subroutine

  module subroutine put_northeast(this, particle)
    class(convection_exchangeable_t), intent(inout) :: this
    type(convection_particle), intent(inout) :: particle
    if (caf_comm_message .eqv. .true.) then
       print*, "from", this_image(), "to", northeast_con_neighbor, particle%particle_id
    end if

    if (this%northeast_boundary) then
      particle%exists = .false.
      return
    end if

    call check_buf_size(this%southwest_i)
    !dir$ pgas defer_sync
    this%buf_southwest_in(this%southwest_i)[northeast_con_neighbor] = particle
    particle%exists = .false.
    this%southwest_i = this%southwest_i + 1
  end subroutine

  module subroutine put_northwest(this, particle)
    class(convection_exchangeable_t), intent(inout) :: this
    type(convection_particle), intent(inout) :: particle
    if (caf_comm_message .eqv. .true.) then
       print*, "from", this_image(), "to", northwest_con_neighbor, particle%particle_id
    end if

    if (this%northwest_boundary) then
      particle%exists = .false.
      return
    end if

    call check_buf_size(this%southeast_i)
    !dir$ pgas defer_sync
    this%buf_southeast_in(this%southeast_i)[northwest_con_neighbor] = particle
    particle%exists = .false.
    this%southeast_i = this%southeast_i + 1
  end subroutine

  module subroutine put_southeast(this, particle)
    class(convection_exchangeable_t), intent(inout) :: this
    type(convection_particle), intent(inout) :: particle
    if (caf_comm_message .eqv. .true.) then
       print*, "from", this_image(), "to", southeast_con_neighbor, particle%particle_id
    end if

    if (this%southeast_boundary) then
      particle%exists = .false.
      return
    end if

    call check_buf_size(this%northwest_i)
    !dir$ pgas defer_sync
    this%buf_northwest_in(this%northwest_i)[southeast_con_neighbor] = particle
    particle%exists = .false.
    this%northwest_i = this%northwest_i + 1
  end subroutine

  module subroutine put_southwest(this, particle)
    class(convection_exchangeable_t), intent(inout) :: this
    type(convection_particle), intent(inout) :: particle
    if (caf_comm_message .eqv. .true.) then
       print*, "from", this_image(), "to", southwest_con_neighbor, particle%particle_id
    end if

    if (this%southwest_boundary) then
      particle%exists = .false.
      return
    end if

    call check_buf_size(this%northeast_i)
    !dir$ pgas defer_sync
    this%buf_northeast_in(this%northeast_i)[southwest_con_neighbor] = particle
    particle%exists = .false.
    this%northeast_i = this%northeast_i + 1
  end subroutine

  module subroutine create_particle_id(this)
    use iso_fortran_env, only : int32
    implicit none
    class(convection_exchangeable_t), intent(inout) :: this
    integer :: id_range, h
    if (this%particle_id_count .eq. -1) then
      id_range = huge(int32) / num_images()
      this%particle_id_count = (this_image()-1) * id_range
    else
      this%particle_id_count = this%particle_id_count + 1
    end if
  end subroutine

  module subroutine setup_neighbors(this, grid)
    implicit none
    class(convection_exchangeable_t), intent(inout) :: this
    type(grid_t), intent(in)      :: grid
    integer :: current, n_neighbors, n_images

    ! --- setup boundaries ---
    if (this%north_boundary) then
      this%northeast_boundary = .true.
      this%northwest_boundary = .true.
    end if
    if (this%south_boundary) then
      this%southeast_boundary = .true.
      this%southwest_boundary = .true.
    end if
    if (this%east_boundary) then
      this%northeast_boundary = .true.
      this%southeast_boundary = .true.
    end if
    if (this%west_boundary) then
      this%northwest_boundary = .true.
      this%southwest_boundary = .true.
    end if

    if (.not.allocated(neighbors)) then
      associate(me=>this_image())
        north_con_neighbor = me + grid%ximages
        south_con_neighbor = me - grid%ximages
        east_con_neighbor  = me + 1
        west_con_neighbor  = me - 1
        northeast_con_neighbor = me + grid%ximages + 1
        northwest_con_neighbor = me + grid%ximages - 1
        southeast_con_neighbor = me - grid%ximages + 1
        southwest_con_neighbor = me - grid%ximages - 1

        n_neighbors = &
             merge(0,1,this%south_boundary) &
            +merge(0,1,this%north_boundary) &
            +merge(0,1,this%east_boundary)  &
            +merge(0,1,this%west_boundary)  &
            +merge(0,1,this%northeast_boundary) &
            +merge(0,1,this%northwest_boundary) &
            +merge(0,1,this%southeast_boundary) &
            +merge(0,1,this%southwest_boundary)
        n_neighbors = max(1, n_neighbors)

        allocate(neighbors(n_neighbors))

        current = 1
        if (.not. this%south_boundary) then
          neighbors(current) = south_con_neighbor
          current = current+1
        endif
        if (.not. this%north_boundary) then
          neighbors(current) = north_con_neighbor
          current = current+1
        endif
        if (.not. this%east_boundary) then
          neighbors(current) = east_con_neighbor
          current = current+1
        endif
        if (.not. this%west_boundary) then
          neighbors(current) = west_con_neighbor
          current = current+1
        endif
        ! if current = 1 then all of the boundaries were set, just store ourself as our "neighbor"
        if (current == 1) then
          neighbors(current) = me
        endif

        ! Wrap boundaries: so particles in the xy direction don't disappear
        associate(nx => grid%ximages, ny => grid%yimages, &
            nimages => grid%ximages * grid%yimages)
          if (wrap_neighbors .eqv. .true.) then
            n_images = num_images()
            ! --- handle diagonals
            if (this%north_boundary .eqv. .true.) then
              northeast_con_neighbor = modulo( (me+nx+1)-nimages, (nx+1))
              if (northeast_con_neighbor .eq. 0) northeast_con_neighbor = 1
              northwest_con_neighbor = (me+nx-1)-nimages
              if (northwest_con_neighbor .eq. 0) northwest_con_neighbor = nx
            else  if (this%east_boundary .eqv. .true.) then
              northeast_con_neighbor = me + 1
            else  if (this%west_boundary .eqv. .true.) then
              northwest_con_neighbor = me + nx * 2 - 1
            end if

            if (this%south_boundary .eqv. .true.) then
              southeast_con_neighbor = me + nimages - nx + 1
              if (southeast_con_neighbor > nimages) then
                southeast_con_neighbor = southeast_con_neighbor - nx
              end if
              southwest_con_neighbor = me + nimages - nx - 1
              if (modulo(southwest_con_neighbor,nx) == 0) then
                southwest_con_neighbor = nimages
              end if
              ! southwest_con_neighbor = - 2
            else  if (this%east_boundary .eqv. .true.) then
              southeast_con_neighbor = me - nx * 2 + 1
            else  if (this%west_boundary .eqv. .true.) then
              southwest_con_neighbor = me - 1
              ! southwest_con_neighbor = - 1
            end if
            this%northeast_boundary = .false.
            this%northwest_boundary = .false.
            this%southeast_boundary = .false.
            this%southwest_boundary = .false.

            ! --- handle up/down/left/right
            if (this%north_boundary .eqv. .true.) then
              north_con_neighbor = north_con_neighbor - n_images
              this%north_boundary = .false.
              this%wrapped_north = .true.
            end if
            if (this%south_boundary .eqv. .true.) then
              south_con_neighbor = south_con_neighbor + n_images
              this%south_boundary = .false.
              this%wrapped_south = .true.
            end if
            if (this%east_boundary .eqv. .true.) then
              east_con_neighbor = east_con_neighbor - grid%ximages
              this%east_boundary = .false.
              this%wrapped_east = .true.
            end if
            if (this%west_boundary .eqv. .true.) then
              west_con_neighbor = west_con_neighbor + grid%ximages
              this%west_boundary = .false.
              this%wrapped_west = .true.
            end if

            ! fix neighbors for when parcels are wrapped
            deallocate(neighbors)
            allocate(neighbors(8))
            neighbors = (/ &
                 north_con_neighbor, &
                 south_con_neighbor, &
                 east_con_neighbor, &
                 west_con_neighbor, &
                 northeast_con_neighbor, &
                 southeast_con_neighbor, &
                 northwest_con_neighbor, &
                 southwest_con_neighbor /)
          end if
        end associate
      end associate
    end if

  end subroutine

  function bilinear_interpolation(x, x0, x1, y, y0, y1, &
      c00, c01, c10, c11) result(c)
    real, intent(in) :: x, y
    real, intent(in) :: c00, c01, c10, c11
    integer, intent(in) :: x0, x1, y0, y1
    real :: xd, yd, c0, c1, c
    if (x0 .eq. x1) then
       if (y0 .eq. y1) then
          c = c00
          return
       end if
      c = c00 + (c11-c00) * (y-y0) / (y1-y0)
    else if (y0 .eq. y1) then
      c = c00 + (c11-c00) * (x-x0) / (x1-x0)
    else
      c0 = ((x1 - x)/(x1 - x0)) * c00 + ((x - x0)/(x1 - x0)) * c10
      c1 = ((x1 - x)/(x1 - x0)) * c01 + ((x - x0)/(x1 - x0)) * c11
      c = ((y1 - y)/(y1 - y0)) * c0 + ((y - y0)/(y1 - y0)) * c1
    end if
  end function bilinear_interpolation

  function trilinear_interpolation(x, x0, x1, z, z0, z1, y, y0, y1, &
      c000, c001, c010, c100, c011, c101, c110, c111) result(c)
    real, intent(in) :: x, z, y
    real, intent(in) :: c000, c001, c010, c100, c011, c101, c110, c111
    integer, intent(in) :: x0, x1, z0, z1, y0, y1
    real :: xd, zd, yd, c00, c01, c10, c11, c0, c1, c
    if (x0 .eq. x1) then
      c = bilinear_interpolation(z, z0, z1, y, y0, y1, &
          c000, c001, c010, c011)
    else if (y0 .eq. y1) then
      c = bilinear_interpolation(x, x0, x1, z, z0, z1, &
          c000, c010, c100, c110)
    else if (z0 .eq. z1 ) then
      c = bilinear_interpolation(x, x0, x1, y, y0, y1, &
          c000, c001, c100, c101)
    else
      xd = (x - x0) / (x1 - x0)
      zd = (z - z0) / (z1 - z0)
      yd = (y - y0) / (y1 - y0)

      c00 = c000 * (1 - xd) + c100 * xd
      c01 = c001 * (1 - xd) + c101 * xd
      c10 = c010 * (1 - xd) + c110 * xd
      c11 = c011 * (1 - xd) + c111 * xd

      c0 = c00 * (1 - zd) + c10 * zd
      c1 = c01 * (1 - zd) + c11 * zd

      c = c0 * (1 - yd) + c1 * yd
    end if
  end function trilinear_interpolation

  module function total_num_particles()
    integer :: total_num_particles
    total_num_particles = particles_per_image * num_images()
  end function total_num_particles

  module function num_particles_per_image()
    integer :: num_particles_per_image
    num_particles_per_image = particles_per_image
  end function num_particles_per_image

  module function num_particles_communicated()
    integer :: num_particles_communicated
    if (count_p_comm .eqv. .true.) then
       call co_sum(particles_communicated)
       num_particles_communicated = particles_communicated
    else
       num_particles_communicated = -1
       print *, "WARNING: number of particles communicated wasn't calculated"
    end if
  end function num_particles_communicated

  module function are_particles_dry()
    logical :: are_particles_dry
    are_particles_dry = dry_air_particles
  end function are_particles_dry

  module function get_wind_speed()
    real :: get_wind_speed
    if (use_input_wind .eqv. .true.) then
      get_wind_speed = input_wind
    end if
  end function get_wind_speed

  module function current_num_particles(convection_obj)
    integer :: current_num_particles
    type(convection_exchangeable_t),intent(in) :: convection_obj
    integer :: buf_size, i
    buf_size = size(convection_obj%local)
    current_num_particles = 0
    do i=1,buf_size
       if (convection_obj%local(i)%exists .eqv. .true.) &
            current_num_particles = current_num_particles + 1
    end do
  end function current_num_particles

  ! module subroutine create_particle(this, index)
  !   class(convection_exchangeable_t), intent(inout) :: this
  !   integer :: index
  !   integer :: a
  !   a = -1
  !   ! print *, "hi!"
  ! end subroutine create_particle
  module subroutine check_buf_size(i)
    integer, intent(in) :: i
    if (i .gt. particles_per_image) then
       print *, this_image(), ": ERROR put buffer overflow"
       call exit
    end if
  end subroutine check_buf_size

  module subroutine initialize_from_file()
    integer :: total_parcels
    logical :: parcel_is_dry
    real    :: wind_speed
    namelist/parcel_parameters/ total_parcels, parcel_is_dry, wind_speed

    character(len=*), parameter :: file = 'parcel-parameters.txt'
    integer :: unit, rc
    logical :: exists

    if (this_image() .eq. 1) &
         print *, "Initializing convection parcels from file"
    inquire(file=file, exist=exists)

    if (exists .neqv. .true.) then
       if (this_image() .eq. 1) &
            print*, trim(file), " does not exist, please create file"
       call exit
    end if

    unit = 10
    open(unit, file=file, action='read', status='old', iostat=rc)
    read(unit=unit, nml=parcel_parameters, iostat=rc)
    close(unit)

    particles_per_image = nint(total_parcels / real(num_images()))
    local_buf_size = particles_per_image * 4
    dry_air_particles = parcel_is_dry
    input_wind = wind_speed
  end subroutine

  !-----------------------------------------------------------------
  ! p = p_0 * e^( ((9.81/287.058)*dz) / t_mean )
  !-----------------------------------------------------------------
  ! Method one: physics
  !        a) change pressure         b) update temperature
  !-----------------------------------------------------------------
  module procedure dry_lapse_rate
  real, parameter :: gravity = 9.80665
  real ::  p0, T_original
  p0 = pressure
  pressure = p0 - z_displacement * &
       gravity / (287.05 * temperature) * p0

  T_original = temperature
  temperature = exner_function(pressure) * &
       potential_temp

  if (temperature /= temperature) then
     print *, this_image(), ":: ~~~~~~NAN ERROR~~~~~~", &
          p0, pressure, z_displacement, T_original, temperature, &
          exner_function(pressure), potential_temp
     call exit
  end if
  end procedure dry_lapse_rate
  !-----------------------------------------------------------------
  ! Method two: adiabatic lapse rate, not using
  !-----------------------------------------------------------------
  ! if (particle%cloud_water .gt. 0.0) then
  !    gamma = 0.006 ! 6 celsius, not sure if this conversion is correct
  ! else
  !    gamma = 0.01 ! 10 celcius
  ! end if

end submodule


*+ clean_image

       subroutine clean_image(residual_map, user_name, map, beam,
     *                        cc_values, cc_posns, cc_list, status )
C      -------------------------------------------------------------
C
C Open the existing residual map file and CLEAN / RESTORE
C
C Given:
C   File name of the residual file
       character*(*)      residual_map
C   User name
       character*(*)      user_name
C   work space for the map
       real*4             map(*)
C   work space for the beam
       real*4             beam(*)
C   work space for the clean components
       real*4             cc_values(*)
       integer*2          cc_posns(2,*)
       integer*2          cc_list(*)
C Returned:
C   error status
       integer            status

C
C The CLEAN routine requires:
C  A) File name of an existing RESDIUAL map
C  B) Work space for the map, beam and clean components
C
C If the beam is in fact a BEAM-SET, then the routine panels the beam
C into a number of beam windows - one for each sub-beam in the beam-set.
C CLEANing proceeds using the beam window appropriate to the local
C maxima found on the map.
C
C Search-Windows, Clean-Windows and an overall Beam-Window may be
C specified by the user.
*-

       include      '/mrao/anmap/include/clean_record.inc'
       include      '/mrao/include/chrlib_functions.inc'
       include      '/mrao/include/maplib_redtape.inc'

C additional file names
       character*60   def_dir, clean_components_map, cleaned_map
       integer        len_file
C output unit
       integer        iout
C buffer for clean-components redtape and extra redtape
       integer        redt_cc(1024), extra_RT(1024)
C descriptors for extra redtape
       integer        ndesc
       character*8    desc_list(12)
C unit numbers for residual map, beam and clean map
       integer        iresi, ibeam, icc, iclean
C logical flag indicating a beam set clean
       logical        bset_clean
C number of beams in a beam set clean
       integer        n_beam
C map/beam areas
       integer        clean_area(4),
     *                search_area(4,10),
     *                beam_area(4,500),
     *                box_area(4), bset_window(4)
C centres of beams on beam set
       integer        bset_u, bset_v
C UV-ranges on beam and map and size of map, beam
       integer        uv_beam(4), uv_map(4),
     *                ixmap, iymap, ixbeam, iybeam
C loop counter
       integer        n, nn_ext, nn_style
C array used in SORT clean
       integer        index(1)
C variables used in defining redtape of output maps
       real*4         zmnx(10)
       integer        iuv(4),izmnx(10)
       integer        count

C check status
       if (status.ne.0) return

C determine output file
       call io_enqout(iout)

C open the residual map file and read the control record
       write(iout,'(1X/1X,''CLEAN: Starting clean of '',A/1X)')
     *       residual_map(1:chr_lenb(residual_map))
       call opemap(iresi, residual_map(1:chr_lenb(residual_map)),
     *               'WRITE', 1, status)
       call rdredt(iresi, 1, status )
       call enxrdt(nn_ext,nn_style,status)
       call enxrec(clean_text_header, clean_record, status)
       call enmdir( ' ', def_dir, status )
       def_dir = '/home/pa/images'
       call io_makfil( def_dir(1:chr_lenb(def_dir)),
     *              generic_name(1:chr_lenb(generic_name)),
     *              'ccmp', clean_components_map, len_file )
       call io_makfil( def_dir(1:chr_lenb(def_dir)),
     *              generic_name(1:chr_lenb(generic_name)),
     *              'cln', cleaned_map, len_file )
       call dpredt( redt_map, status )
       call iuv_load( uv_map, status )
       call iuv_load( iuv, status )
       ixmap = ixmax
       iymap = iymax
       call rdmap(iresi,map,status)
       if (status.ne.0) then
         call cmd_err(STATUS,'CLEAN','Error on residual: CLEAN failed')
         goto 999
       end if

C .. create the clean map file
       call io_wrout('CLEAN: creating CLEANed map')
       call opemap( iclean, cleaned_map(1:chr_lenb(cleaned_map)),
     *             'WRITE', 0, status )
       call wrredt( iclean, 0, status )
       close (iclean)

C open the clean components map and read
       call opemap(icc,
     *      clean_components_map(1:chr_lenb(clean_components_map)),
     *      'UPDATE', 0, status)
       call rdredt(icc, 0, status )
       call enxrec(clean_text_header, clean_record, status)
       call dpredt(redt_cc, status)
       call dpxrdt(extra_RT, 1, status)
       call rdmapc(icc,cc_posns,cc_values,max_cc_iter,number_cc,status)
       if (status.ne.0) then
         call cmd_err(STATUS,'CLEAN',
     *                'Error on clean components: CLEAN failed')
         goto 999
       end if

C Open the beam and read
       call opemap( ibeam, beam_name(1:chr_lenb(beam_name)), 'READ',
     *              0, status )
       call rdredt( ibeam, 0, status)
       call dpredt( redt_beam, status)
       call iuv_load( uv_beam, status )
       ixbeam = ixmax
       iybeam = iymax
       call rdmap(ibeam,beam,status)
       close (ibeam)
       if (status.ne.0) then
         call cmd_err(status,'CLEAN','Error on beam: CLEAN failed')
         goto 999
       end if

C take special action if a beam set clean is required
C check for a beam set clean
       bset_clean = maptyp.eq.3
       if (bset_clean .and. lclean) then
         call ldredt( redt_beam, status )
         n_beam = 0
         do bset_v = v0set, v0set+(nvset-1)*dvset, dvset
           do bset_u = u0set, u0set+(nuset-1)*duset, duset
C .. Set up a window on the current beam in the beamset
             bset_window(1) = bset_u-duset/2
             bset_window(2) = bset_u+duset/2
             bset_window(3) = bset_v+dvset/2
             bset_window(4) = bset_v-dvset/2

C .. Only include whole beams
             if ((bset_window(1) .ge. beam_window(1)) .and.
     *           (bset_window(2) .le. beam_window(2)) .and.
     *           (bset_window(3) .le. beam_window(3)) .and.
     *           (bset_window(4) .ge. beam_window(4))       ) then
                 n_beam = n_beam + 1
                 call uv_conv(uv_beam, bset_window, beam_area(1,n_beam))
              end if
           end do
         end do

       else

         n_beam = 1
         call uv_conv(uv_beam, beam_window, beam_area(1,1))

       end if

       call uv_conv(uv_map, clean_window, clean_area)
       call uv_conv(uv_map, box_window, box_area)
       do n = 1,number_search
         call uv_conv(uv_map, search_window(1,n), search_area(1,n))
       end do

C do CLEAN
       if (lclean) then
         itlim = itlim + number_it_done
         call ldredt( redt_map, status )
         call clean_map ( map, ixmap, iymap,
     *                    clean_area, search_area, box_area,
     *                    beam, ixbeam, iybeam, n_beam, beam_area,
     *                    cc_values, cc_posns, cc_list, number_cc,
     *                    number_it_done, index, status           )

C .. write the clean components
         itlim = 0
         call ldredt( redt_cc, status )
         call ldxrdt( extra_RT, 1, status )
         times_cleaned = times_cleaned + 1
         call io_wrout('CLEAN: writing CLEAN COMPONENTS map')
         zmnx(1) = -1.0E+30
         zmnx(2) = 1.0E+30
         do n=1,number_cc
           if (cc_values(n).gt.zmnx(1)) then
             zmnx(1) = cc_values(n)
             izmnx(1) = cc_posns(1,n)
             izmnx(2) = cc_posns(2,n)
           end if
           if (cc_values(n).lt.zmnx(2)) then
             zmnx(2) = cc_values(n)
             izmnx(3) = cc_posns(1,n)
             izmnx(4) = cc_posns(2,n)
           end if
         end do
         call adredt('owner',user_name,status)
         call adredt('history','CLEAN',status)
         hpfbwu = usamp
         hpfbwv = vsamp
         beampa = 0.0
         call stxrec( clean_text_header, clean_record, status )
         if (status.ne.0) then
           status = 0
           call enxdsc( desc_list, ndesc, status )
           print *,'***(CLEAN-IMAGE) Number of descriptors = ',ndesc
           do n=1,ndesc
             print *,'***(CLEAN-IMAGE) Descriptor = ',desc_list(n)
           end do
           status = 0
         end if
         call stscal( zmnx, izmnx, status )
         call wrredt( icc, 0, status )
         call wrmapc( icc, cc_posns, cc_values,
     *                number_cc, status )

C .. save residual map
         call ldredt( redt_map, status )
         call io_wrout('CLEAN: writing RESIDUAL map')
         call adredt('created','CLEAN',status)
         call adredt('owner',user_name,status)
         call iuv_load(iuv,status)
         call stxrec( clean_text_header, clean_record, status )
         call scnmap( map, iuv, zmnx, izmnx, status )
         call stredt( iuv, 3, status )
         call stscal( zmnx, izmnx, status )
         call wrredt( iresi, 0, status )
         call wrmap( iresi, map, status )
       end if

C restore sources if required
       if (lrest) then

         write(iout,
     *       '(''+CLEAN: RESTORing with '',i5,
     *         '' CLEAN components'',30X)')
     *         number_cc
         call restore_map(map, ixmap, iymap, clean_area,
     *                    beam, ixbeam, iybeam, beam_area,
     *                    cc_values, cc_posns, number_cc,
     *                    status                  )

C .. open the clean map file
         call ldredt( redt_map, status )
         call io_wrout('CLEAN: writing CLEANed map')
         call adredt('owner',user_name,status)
         call adredt('history','CLEAN',status)
C .. set beam sizes on CLEANed map
         hpfbwu = beam_size_u
         hpfbwv = beam_size_v
         beampa = beam_pa
         call opemap( iclean, cleaned_map(1:chr_lenb(cleaned_map)),
     *               'WRITE', 0, status )
         call stxrec( clean_text_header, clean_record, status )
         call scnmap( map, iuv, zmnx, izmnx, status )
         call stredt( iuv, 3, status )
         call stscal( zmnx, izmnx, status )
         call wrredt( iclean, 0, status )
         call wrmap( iclean, map, status )
         close ( iclean )
         call mapcat_addtocat(cleaned_map(1:chr_lenb(cleaned_map)),
     *                        .false.,count,status)
       end if

999    close (iresi)
       close (icc)
       end

c+uv_conv

      subroutine uv_conv( map_uv, window, area )
C     ------------------------------------------
C
C Converts a uv window into a set of x-y coordinates
C
C Given:
C    Map UV limits
              integer     map_uv(4)
C    UV limits of window
              integer     window(4)

C Returned:
C    X-Y coordinates of u-v window
              integer     area(4)

C     NPR     5 July 1988
C-

      area(1) =  window(1) - map_uv(1) + 1
      area(2) =  window(2) - map_uv(1) + 1
      area(3) = -window(3) + map_uv(3) + 1
      area(4) = -window(4) + map_uv(3) + 1
      end
C
C
*+ clean_map

       subroutine clean_map ( map,  m1, m2,
     *                        clean_area, search_area, not_box_area,
     *                        bset, n1, n2, n_beam, beam_area,
     *                        cc_values, cc_posns, cc_list, num_cc,
     *                        num_iter, index, status              )

C     Cleans a specified region of the map with the given beam-set.
C
C     Given:
C         Dimensions of map array and map array
              integer     m1, m2
C         Area of map to clean
              integer     clean_area(4)
C         Search areas
              integer     search_area(4,*)
C         Not-Box area
              integer     not_box_area(4)
C         Beam-set and it's array dimensions
              integer     n1, n2
              real        bset(n1,n2)
C         Number of beams in the beamset and windows on each beam
              integer     n_beam, beam_area(4, n_beam)
C         Index array used in SORT option
              integer     index(1)

C     Updated:
C         Map data
              real        map(m1,m2)
C         Current number of clean components
              integer     num_cc
C         List of clean components (CCs)
              real        cc_values(*)
C         Positions of each CC
              integer*2   cc_posns(2,*)
C         Work space arrays used for compacting CC's
              integer*2   cc_list(*)
C         Current number of iterations
              integer     num_iter

C     Returned
C         Status - must be zero on entry
              integer     status

C
C Perform a number of CLEAN iterations on the map data passed as an
C argument to the routine. Multiple windows are allowed on:
C    search-windows      --      to enable individual sources to be
C                                singled out.
C    beam-window         --      to allow for beam-set CLEANing
C
C PA MRAO, Cambridge
C NPR, MRAO, Cambridge. Modified to allow multiple beam windows.
C PA, MRAO. Modified to use the CLEAN-RECORD and simplify the call
C
*-
       include    '/mrao/anmap/include/clean_record.inc'

C local variables
      logical         inter
      character       io_attn_char*1, job_action*4
      character*80    string
      integer         i,j,x,y, out, not_box(4), beam_posn(2,100), npts,
     *                beam_centre(2,100), iprint
      integer         ic, ijob, chr_lenb
      real            beam_max(100), max, min, mean, sigma
      common /notbox/ not_box

C test status on entry
      if (status .ne. 0) return

C find print frequency -- chech and reset status if required
      call cmd_enqparam( 'report-frequency', string, status )
      if (chr_lenb(string).gt.0) then
        call chr_chctoi( string, iprint, status )
      else
        iprint = 100
      end if
      if (iprint.le.10 .or. status.ne.0) iprint = 100
      status = 0

C set up interaction variables
      call io_enqout(out)
      call io_enqbch( inter )
      inter = .not. inter
      io_attn_char = 'X'

C write out windows used
      write(out,'(/,A,4I6)') ' CLEAN: Cleaning the window:',
     *                         clean_window
      write(out,'(1('' CLEAN: Search window '',I1,''    :'',4I6))')
     *    ( j, ((search_window(i,j)), i=1,4), j = 1, number_search )
      if (lnotbx) then
          do i = 1, 4
              not_box(i) = not_box_area(i)
          end do
      end if

C determine noise on input map
      call noise_map( map, m1, m2,
     *                clean_area(1), clean_area(2),
     *                clean_area(3), clean_area(4),
     *                mean, sigma, npts, status             )
      write(out,601)
     *    ' Dirty  ', mean, sigma
601    format(' CLEAN: Statistics [',A,'] Mean = ',1PE10.2,
     >        ' SD = ',1PE10.2/1X)

C find maximum value and position of each beam
      do i = 1, n_beam
        call maxmin( bset, n1, n2,
     *               beam_area(1,i), beam_area(2,i),
     *               beam_area(3,i), beam_area(4,i),
     *               beam_max(i), beam_posn(1,i), beam_posn(2,i),
     *               min, x, y, status                            )

C define beam centre for beam (where beam "should" be
        if (n_beam.gt.1) then
C .. beam set case
          beam_centre(1,i) = (beam_area(1,i)+beam_area(2,i))/2
          beam_centre(2,i) = (beam_area(3,i)+beam_area(4,i))/2
        else
C .. single beam case
          beam_centre(1,i) = beam_posn(1,i)
          beam_centre(2,i) = beam_posn(2,i)
        end if

C apply Prussian-Hot modification if required
        if (lprhat) then
          call make_phbm(bset,n1,n2,beam_posn(1,i),
     *                   beam_posn(2,i),status)
        end if
      end do

C find position to subtract next clean component from.
      ic = 0
      call find_cc( map, m1, m2,
     *              search_area, number_search, lnotbx,
     *              lsort, sort_depth, sort_inner, sort_gate, index,
     *              max, x, y, ic, status                   )

      do while ( (abs(max)  .gt. fllim ) .and.
     *           (num_iter  .lt. itlim ) .and.
     *           .not.(max.le.0.and.lstop0)     )

*     *           (io_attn_char .ne. 'Q'        ) .and.

C .. if output working information
          if (inter .and. (mod(num_iter,iprint).eq.0)) then
              write(out,'(A,I6,A,1PE9.2)')
     *            '+CLEAN: component: ',num_iter,' maximum: ',max
          end if

C .. find nearest beam
          call nearest_pt( x, y, beam_posn, n_beam, i, status)

C .. subtract from clean position.
          call subtrc( map, m1, m2,
     *                 clean_area(1), clean_area(2),
     *                 clean_area(3), clean_area(4),
     *                 bset, n1, n2,
     *                 beam_area(1,i), beam_area(2,i),
     *                 beam_area(3,i), beam_area(4,i),
     *                 max, x, y,
     *                 beam_max(i), beam_posn(1,i), beam_posn(2,i),
     *                 fract, status                               )
          num_cc = num_cc + 1
          cc_values(num_cc)  = max*fract/beam_max(i)
          cc_posns(1,num_cc) = x + beam_centre(1,i) - beam_posn(1,i)
          cc_posns(2,num_cc) = y + beam_centre(2,i) - beam_posn(2,i)
          num_iter = num_iter + 1

C .. find position of next clean component.
          call find_cc( map, m1, m2,
     *                  search_area, number_search, lnotbx,
     *                  lsort, sort_depth, sort_inner, sort_gate, index,
     *                  max, x, y, ic, status                       )

C .. look for attention if interactive and suspend CLEANing
*          if (inter) then
*              io_attn_char = 'X'
*              call io_getatt(
*     *         '.. CLEAN halted - type c(ontinue) or q(uit) : ',
*     *                     'C', 'QC', io_attn_char, status             )
*          end if
      end do

C . tidy up
      i = num_cc
      call make_ccsl( cc_values, cc_posns, cc_list, num_cc, status )

      if (status .ne. 0) then
          how_ended = status
      else if (num_iter .ge. itlim) then
          how_ended = 1
      else if (max .le. fllim) then
          how_ended = 2
      else if (io_attn_char.eq.'Q') then
          how_ended = 4
      else
          how_ended = 3
      end if
      max_on_resid = max

      call cmd_err(status, 'CLEAN', 'Cleaning Failed; Fatal Error' )

      end

*+find_cc

      subroutine find_cc( map, m, n,
     *                    search_area, n_search, not_box,
     *                    lsort, sort_depth, sort_inner, sort_gate,
     *                    index,
     *                    map_val, x, y, ic, status                )

C     Returns the position to subtract the next clean component.
C
C     Input
C         Map array and bounds
              integer         m, n
              real            map(m,n)
C         Number of search areas and their bounds
              integer         n_search, search_area(4,n_search)
C         Flag set if not-box is being used.
              logical         not_box
C         Sort options
              logical         lsort
              integer         sort_depth, sort_inner
              real*4          sort_gate
C         Work space for sort
              integer         index(1)

C     Updated
C         Inner counter
              integer         ic

C     Returned:
C         Map value and x-y coordinates of next clean-component
              real            map_val
              integer         x, y
C         Error flag
              integer         status
C         Maximum length of index
              integer         max_index

C     NPR  6 July 1988
C     PA  15 September 1988
*-
      real        max, min
      integer     i, i2, k, l, len_index,
     *            x_max, x_min, y_max, y_min

      common /cln_hold_1/ len_index

      if (status.ne.0) return

      if (lsort) then
C .. use sorted list of image maxima for sort_inner iterations

        max_index = 2000
        if (ic.eq.0) then
          len_index = 0
          do i = 1,n_search
            do l = search_area(3,i),search_area(4,i)
              do k = search_area(1,i),search_area(2,i)
                if (abs(map(k,l)).gt.sort_gate) then
                  len_index = len_index + 1
                  index(len_index) = (l-1)*m + k
                end if
                if (len_index.eq.max_index) then
                  call sort_index(map,m*n,sort_depth,index,len_index)
                end if
              end do
            end do
          end do
          call sort_index(map,m*n,sort_depth,index,len_index)
          ic = sort_inner
        end if

        max = -1.0E+30
        do i = 1,len_index
          l  = index(i)/m + 1
          k  = index(i) - (l-1)*m
          if (abs(map(k,l)) .gt. max) then
            max = abs(map(k,l))
            i2 = index(i)
          end if
        end do
        y = i2/m + 1
        x = i2 - (y-1)*m
        map_val = map(x,y)
        ic = ic - 1

      else
C .. normal clean seach for next CC
        max = -1.0E+30
        min =  1.0E+30

        do i = 1, n_search
          if (not_box) then
            call boxmin_map( map, m, n,
     *                       search_area(1,i), search_area(2,i),
     *                       search_area(3,i), search_area(4,i),
     *                       max, x_max, y_max,
     *                       min, x_min, y_min, status           )
          else
            call maxmin_map( map, m, n,
     *                       search_area(1,i), search_area(2,i),
     *                       search_area(3,i), search_area(4,i),
     *                       max, x_max, y_max,
     *                       min, x_min, y_min, status           )
          end if
        end do

        if (abs(max) .ge. abs(min)) then
          map_val = max
          x       = x_max
          y       = y_max
        else
          map_val = min
          x       = x_min
          y       = y_min
        end if

      end if

      end
C
C
*+nearest_pt

      subroutine nearest_pt( x, y, a, n_pts, nearest, status )

C     Finds the nearest point in a given array.

C     Given:
C         Coordinates of given point
              integer     x, y
C         An array of cartesian positions and its size
              integer     n_pts, a(2,n_pts)

C     Returned:
C         Index in array of point nearest to the given one.
              integer     nearest
C     Error flag
              integer     status

C     If n_pts is less than 1 then nearest is returned as zero.
C-

      integer     i, distance, temp

      if (n_pts .le. 0) then
          nearest = 0
      else
          nearest  = 1
          distance = (x-a(1,1))*(x-a(1,1)) + (y-a(2,1))*(y-a(2,1))

          do i = 2, n_pts
              temp = (x-a(1,i))*(x-a(1,i))+(y-a(2,i))*(y-a(2,i))
              if (temp .lt. distance) then
                  distance = temp
                  nearest  = i
              end if
          end do
      end if

      return
      end
C
C
*+ sort_index

       subroutine sort_index(map,m,depth,index,len_index)
C      --------------------------------------------------
C
C Sort and reset the index
C
       integer    m, depth, index(1), len_index, ii, i
       real*4     map(1)
       integer    i1, i2, i3

C sort indexed array
       call qindxr1(map,m,index,len_index)

C find depth entries
       if (len_index.le.depth) then
         return
       end if

       i1 = 1
       i2 = len_index
       i3 = 0

       do while (i3.le.depth)

         if (map(index(i1)).gt.abs(map(index(i2))) ) then
           i1 = i1 + 1
         else
           i2 = i2 - 1
         end if
         i3 = i3 + 1

       end do

C re-write array
       ii = len_index + 1
       do i = i1,i3
         ii = ii - 1
         index(i) = index(ii)
       end do

C reset the length of the index array
       len_index = i3

       end
C
C
*+ restore_map

       subroutine restore_map(map, m1, m2, clean_area,
     *                        beam, n1, n2, beam_area,
     *                        cc_values, cc_posns, ncc,
     *                        status                   )
C      -------------------------------------------------
C
C restore sources to map with specified opions
C
C Given:
C    size of map
       integer      m1, m2
C    map area to restore
       integer      clean_area(4)
C    beam size and array
       integer      n1 ,n2
       real*4       beam(n1,n2)
C    area on beam
       integer      beam_area(4)
C    CC values
       real*4       cc_values(*)
C    CC positions
       integer*2    cc_posns(2,*)
C    number of CC's
       integer      ncc
C Updated:
C    map data
       real*4       map(m1,m2)
C Returned:
C    error status
       integer      status
C
C
C local variables
       integer    im1, im2, jm1, jm2, ib1, ib2, jb1, jb2,
     *            ib3, ib4, jb3, jb4, ibc, jbc, ius1, jus1
       integer    iout, npts
       real*4     xbar, xsd, bmin, bmax, angle, cbsig1, cbsig2

       include '/mrao/anmap/include/clean_record.inc'
       include '/mrao/include/maplib_redtape.inc'

C check status on entry
       if (status.ne.0) return
       im1 = clean_area(1)
       im2 = clean_area(2)
       jm1 = clean_area(3)
       jm2 = clean_area(4)
       ib1 = beam_area(1)
       ib2 = beam_area(2)
       jb1 = beam_area(3)
       jb2 = beam_area(4)

C output unit
       call io_enqout(iout)

C information on residual map
       call noise_map(map,m1,m2,im1,im2,jm1,jm2,xbar,xsd,npts,status)
       write(iout,601) 'Residual-Map',xbar,xsd
C
C find maximum value of beam and position corresponding (IBC,JBC)
       call maxmin(beam,n1,n2,ib1,ib2,jb1,jb2,bmax,ibc,jbc,
     *             bmin,ius1,jus1,status)
C
C Make clean beam.
C Find the noise on the residual map.
C Restore the sources to the residual map.
       ib3=ib1
       ib4=ib2
       jb3=jb1
       jb4=jb2
C
C Make clean beam
       if (ltrbm) then
         write(iout,'(''+'',a,20x)')'CLEAN: truncating dirty beam'
         call make_trbm(beam,n1,n2,bmax,ibc,jbc,ib3,ib4,jb3,jb4,
     *                  flxnrm,status)

       else if (.not.loldbm) then
         write(iout,'(''+'',a,20x)')'CLEAN: making clean beam'
         bmax = 1.0
         ibc = n1/2
         jbc = n2/2
         cbsig1 = beam_size_u*0.4246609/usamp
         cbsig2 = beam_size_v*0.4246609/vsamp
         angle  = beam_pa*3.14159265/180.0
         call make_clbm(beam,n1,n2,cbsig1,cbsig2,angle,
     *                  bmax,ibc,jbc,ib3,ib4,
     *                  jb3,jb4,flxnrm,status)
       end if
C
C Restore removed sources
       write(iout,'(''+'',a,20x)')'CLEAN: restoring sources'
       call restor(cc_values,cc_posns,ncc,map,m1,m2,im1,im2,jm1,jm2,
     *             beam,n1,n2,ib3,ib4,jb3,jb4,bmax,ibc,jbc,status)
C
       call noise_map(map,m1,m2,im1,im2,jm1,jm2,xbar,xsd,npts,status)
       write(iout,601)'Restored-Map',xbar,xsd
       write(iout,602)flxnrm
602    format(1h0,
     >    'CLEAN: Factor for converting sum of numbers to flux :',
     >     2x,f8.5)
       return
C
601    format(' CLEAN: Statistics [',A,'] Mean = ',1PE10.2,
     >        ' SD = ',1PE10.2/1X)
       end
C
C
*+ clean_batch_report

       subroutine clean_batch_report( string )
C      ---------------------------------------
C
C Report progress of clean to user
C
C Given:
C   character string to send
       character*(*)    string
C
C The character string STRING is sent as a message to the user who owns
C the current CLEAN job.
C-
       include '/mrao/include/chrlib_functions.inc'
C
       integer         status
       character*80    comment
       character*80    job_name, job_task, user_name
       common /clean_batch_rep_incl/ job_name, job_task, user_name,
     *                               comment

       status = 0
       call io_wrout(string(1:chr_lenb(string)))

       end


! wind_cdhf_alloc_def.for - wind/waves telemetry words, values are minor frame
! word numbers (0...255)
! Note: file wind_cdhf_rec_def.for must be included prior to including this
! file.

	integer*4	fixed_col_science_alloc( size_science_allocation)
	1		/17, 18, 24, 28, 32, 36, 40, 44, 48, 52, 56,
	1		 60, 64, 68, 72, 76, 80, 84, 88, 92, 96, 100, 104,
	1		108, 112, 116, 120, 124, 128, 132, 136, 140, 144,
	1		148, 152,
	1		156, 160, 164, 168, 172, 176, 180, 184, 188, 192/

	integer*4	fixed_col_maneuver_alloc(size_maneuver_allocation)
	1		/17, 18, 32, 33, 36, 37, 40, 41, 44, 45, 48, 49, 52,
	1		 53, 56, 57, 60, 61, 64, 65, 68, 69, 72, 73, 76, 77,
	1		 80, 81, 84, 85, 88, 89, 92, 93, 96, 97, 100, 101,
	1		104, 108, 112, 116, 120, 124, 128, 132, 136, 140, 144,
	1		148,
	1		152, 156, 160, 164, 168, 172, 176, 180, 184, 188, 192/