                   module bgrid_advection_mod

!-----------------------------------------------------------------------
!
!            performs vertical and horizontal advection
!              and negative tracer borrowing/filling
!
!-----------------------------------------------------------------------
!--------------------------- modules -----------------------------------
!-----------------------------------------------------------------------
use bgrid_horiz_mod       , only: horiz_grid_type
use bgrid_vert_mod        , only: vert_grid_type, compute_pres_depth
use bgrid_masks_mod       , only: grid_mask_type
use bgrid_prog_var_mod    , only: prog_var_type
use bgrid_polar_filter_mod, only: pfilt_control_type, polar_filter, &
                                  polar_filter_wind, TGRID
use bgrid_halo_mod        , only: update_halo, vel_flux_boundary,   &
                                  EAST, WEST, SOUTH, NORTH, NOPOLE, &
                                  TEMP, UWND, VWND, WIND, POLEONLY
use bgrid_change_grid_mod , only: change_grid, EQUAL, AREA, &
                                  UFLX_GRID, VFLX_GRID, TEMP_GRID, WIND_GRID
use vert_advection_mod    , only: vert_advection, vert_advection_end, &
                                  SECOND_CENTERED, FOURTH_CENTERED, &
                                  SECOND_CENTERED_WTS, FOURTH_CENTERED_WTS, &
                                  FINITE_VOLUME_LINEAR, FINITE_VOLUME_PARABOLIC, &
                                  FLUX_FORM, WEIGHTED_TENDENCY
!!!use horiz_advection_mod   , only: horiz_advection, &
!!!                                  FINITE_VOLUME_LINEAR_HORIZ=>FINITE_VOLUME_LINEAR, &
!!!                                  FINITE_VOLUME_PARABOLIC_HORIZ=>FINITE_VOLUME_PARABOLIC

use fms_mod, only: error_mesg, FATAL, write_version_number,      &
                   file_exist, open_namelist_file,               &
                   check_nml_error, close_file,                  &
                   mpp_pe, mpp_root_pe, stdlog, uppercase,       &
                   mpp_clock_id, mpp_clock_begin, mpp_clock_end, &
                   MPP_CLOCK_SYNC, CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP
use mpp_mod, only: mpp_max
use  field_manager_mod, only: MODEL_ATMOS, parse
use tracer_manager_mod, only: query_method, get_tracer_names, get_number_tracers
!-----------------------------------------------------------------------

implicit none
private

 public :: advection_init, advection, advection_end

!-----------------------------------------------------------------------
!------------ namelist: bgrid_advection_nml -------------

!  vert_advec_scheme_wind      The vertical advection scheme.
!  vert_advec_scheme_temp      Possible values are NONE, SECOND_CENTERED, FOURTH_CENTERED,
!  vert_advec_scheme_tracer    FINITE_VOLUME_LINEAR, or FINITE_VOLUME_PARABOLIC.
!                              Using finite volume schemes for momentum has not been
!                              tested and may produce poor results.

   character(len=24) ::  vert_advec_scheme_wind   = 'SECOND_CENTERED'
   character(len=24) ::  vert_advec_scheme_temp   = 'SECOND_CENTERED'
   character(len=24) ::  vert_advec_scheme_tracer = 'SECOND_CENTERED'

!  horiz_advec_scheme_wind     The horizontal advection scheme.
!  horiz_advec_scheme_temp     Possible values are NONE, SECOND_CENTERED, FOURTH_CENTERED.
!  horiz_advec_scheme_tracer

   character(len=24) :: horiz_advec_scheme_wind   = 'SECOND_CENTERED'
   character(len=24) :: horiz_advec_scheme_temp   = 'SECOND_CENTERED'
   character(len=24) :: horiz_advec_scheme_tracer = 'SECOND_CENTERED'

!  advec_weight_wind     Weights used for modified Euler-backward time differencing
!  advec_weight_temp     (i.e., when the scheme is SECOND_CENTERED or FOURTH_CENTERED).
!  advec_weight_tracer        0.0 = full Euler-forward (not recommended)
!                             1.0 = full Euler-backward

   real :: advec_weight_wind   = 0.7
   real :: advec_weight_temp   = 0.7
   real :: advec_weight_tracer = 0.7

!  num_fill_pass      The number of successive repetitions of the tracer borrowing scheme.
!                     This value applies to both the horizontal and vertical schemes.

   integer :: num_fill_pass = 1

!  temporary undocumented developer flags

logical :: compute_vert_wind_flux = .false.
character(len=16) ::  vert_vel_flux =  'area_weight'
character(len=16) :: horiz_vel_flux = 'equal_weight'

namelist /bgrid_advection_nml/ horiz_advec_scheme_wind,   vert_advec_scheme_wind,   &
                               horiz_advec_scheme_temp,   vert_advec_scheme_temp,   &
                               horiz_advec_scheme_tracer, vert_advec_scheme_tracer, &
                               advec_weight_wind, advec_weight_temp, advec_weight_tracer, &
                               num_fill_pass    ,&
                               compute_vert_wind_flux, vert_vel_flux, horiz_vel_flux

!-----------------------------------------------------------------------
!----- private data -----

! derived-type containing tracer filling parameters
 type trfill_control_type
    integer, pointer :: fill_scheme(:) =>NULL(), &
                        npass_horiz(:) =>NULL(), &
                        npass_vert(:)  =>NULL()
 end type trfill_control_type

! derived-type containing advection parameters
 type advec_control_type
    type(trfill_control_type) :: Fill
    integer, pointer  :: scheme(:,:) =>NULL()
    real   , pointer  :: weight(:) =>NULL()
    logical  ::  do_mask4_tmp, do_mask4_vel, &
                 do_finite_volume_tmp, do_finite_volume_trs
 end type advec_control_type

 integer, parameter :: NONE = 7000, &  ! may apply to advection or filling
            ! filling schemes
              EQUAL_BORROW  = 8005, &
              BOTTOM_BORROW = 8006, &  ! not implemented
              GLOBAL_BORROW = 8007     ! not implemented

! advection control parameters
! set via values in namelist or field table
 type(advec_control_type),save :: Control

 real, parameter :: c4  = -1./6.       ! weights for 4th order centered schemes
 real, parameter :: c2  = 1. - 2.*c4

 logical :: do_log = .true.
 logical :: stability_check = .false.  ! perform stability check for horizontal
                                       ! finite volume (Lin-Rood) schemes

!  performance timing info
 integer :: id_tmp, id_trs, id_vel, id_fill
 logical :: do_clock_init = .true.

 character(len=128) :: version='$Id: bgrid_advection.f90,v 12.0 2005/04/14 15:33:49 fms Exp $'
 character(len=128) :: tagname='$Name: latest $'

!-----------------------------------------------------------------------

contains

!#######################################################################

subroutine advection ( Pfilt, Hgrid, Vgrid, Masks,   &
                       pfilt_opt, dt, dpde_old, dpde,         &
                       few, fns, etadot, u, v, t, Var, Var_dt )

type(pfilt_control_type), intent(in) :: Pfilt
type(horiz_grid_type), intent(inout) :: Hgrid
type (vert_grid_type), intent(in)    :: Vgrid
type (grid_mask_type), intent(in)    :: Masks
              integer, intent(in)    :: pfilt_opt
                 real, intent(in)    :: dt
real, intent(in), dimension(Hgrid%ilb:,Hgrid%jlb:,:) ::  &
                                            dpde_old, dpde, u, v, t
real, intent(inout), dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: &
                                            few, fns, etadot
type (prog_var_type), intent(in)    :: Var
type (prog_var_type), intent(inout) :: Var_dt

!-----------------------------------------------------------------------
!
!  Pfilt    = polar filter constants
!  Hgrid    = horizontal grid constants
!  Vgrid    = vertical grid constants
!  Masks    = grid masking constants
!  pf_opt   = polar filter option flag
!  dt       = adjustment time step
!  dpde_old = pressure thickness of model layers at the end of the
!              last advective time step
!  dpde     = current pressure thickness of model layers
!  few, fns = zonal, meridional mass fluxes (Pa-m2/s)
!              (a summation since the last call to advection)
!  etadot   = vertical mass flux (Pa/s) (summation since the last call to advection)
!  u, v, t  = prognostic variables at the end of the last advective time
!              step, note that tracers have not been updated since the last
!              advective time step, therefore, r = Var%r + dt*Var_dt%r
!  Var      = prognostic variables at the end of the last dynamics time
!              step, current values would be, uc = Var%u + dt*Var_dt%u
!  Var_dt   = prognostic variable tendencies, accumulated since the
!              variable were updated in Var
!
!-----------------------------------------------------------------------
  real, dimension(Hgrid%ilb:Hgrid%iub, Hgrid%jlb:Hgrid%jub,  &
                  Vgrid%nlev) :: dpdt, dpde_xy, r, uc, vc
  real, dimension(Hgrid%ilb:Hgrid%iub, Hgrid%jlb:Hgrid%jub,  &
                  Vgrid%nlev,2) :: mask4
  integer :: i, j, k, n, is, ie, js, je
!-----------------------------------------------------------------------

!  ---- update halos for fluxes ----

   call update_halo (Hgrid, TEMP, few)
   call update_halo (Hgrid, VWND, fns)

!  ---- compute pressure tendency in each layer ----

   dpdt = (dpde - dpde_old) / dt

! ---- stability diagnostic (CFL for horizontal finite volume schemes) ----
   if (stability_check) call stability_diag ( Hgrid, dt, few, dpde_old, dpde )

!-----------------------------------------------------------------------
!------------------ advection of mass fields ---------------------------
!-----------------------------------------------------------------------

!------ initialize fourth-order mask ----

   if (Control%do_mask4_tmp) &
         call mask4_init (Hgrid, 1, Masks%sigma, Masks%Tmp%mask, mask4)

 ! compute wind components for horizontal finite-volume advection schemes
   if (Control%do_finite_volume_tmp .or. Control%do_finite_volume_trs) then
        call compute_advecting_wind (Hgrid, dpde_old, dpde, few, fns, uc, vc)
   else
        uc = 0.
        vc = 0.
   endif

!------ temperature advection ------

   call mpp_clock_begin (id_tmp)
   if (Masks%sigma) then
       call advect_mass (Hgrid, Pfilt, Control % scheme(:,0), &
                         Control % weight(0), pfilt_opt,      &
                         dt, dpdt, dpde, few, fns, etadot,    &
                         uc, vc, Var%t, t, Var_dt%t)
   else
       call advect_mass (Hgrid, Pfilt, Control % scheme(:,0), &
                         Control % weight(0), pfilt_opt,      &
                         dt, dpdt, dpde, few, fns, etadot,    &
                         uc, vc, Var%t, t, Var_dt%t,          &
                         mask=Masks%Tmp%mask, mask4=mask4)
   endif
   call mpp_clock_end   (id_tmp)

!------ tracer advection -----------
!  (need to pass all tracers to update pressure tendency part)

   call mpp_clock_begin (id_trs)
   do n = 1, Var_dt%ntrace

      r = Var%r(:,:,:,n) + dt*Var_dt%r(:,:,:,n)

      if (Masks%sigma) then
          call advect_mass (Hgrid, Pfilt, Control%scheme(:,n),   &
                            Control % weight(n),                 &
                            pfilt_opt, dt, dpdt, dpde,           &
                            few, fns, etadot, uc, vc,            &
                            Var%r(:,:,:,n), r, Var_dt%r(:,:,:,n) )
      else
          call advect_mass (Hgrid, Pfilt, Control%scheme(:,n),   &
                            Control % weight(n),                 &
                            pfilt_opt, dt, dpdt, dpde,           &
                            few, fns, etadot, uc, vc,            &
                            Var%r(:,:,:,n), r, Var_dt%r(:,:,:,n),&
                            mask=Masks%Tmp%mask, mask4=mask4     )
      endif

   enddo
   call mpp_clock_end   (id_trs)

!------ tracer hole filling -------
!  (remove negative tracer values with vert/horiz borrowing)

     call mpp_clock_begin (id_fill)
     call vert_borrow ( dt, dpde, Var%r(:,:,:,1:Var_dt%ntrace), &
                               Var_dt%r(:,:,:,1:Var_dt%ntrace), &
                                  iters = Control % Fill % npass_vert  )

     if (Masks%sigma) then
         call horiz_borrow ( Hgrid, dt, dpde,                 &
                                Var%r(:,:,:,1:Var_dt%ntrace), &
                             Var_dt%r(:,:,:,1:Var_dt%ntrace), &
                               iters = Control % Fill % npass_horiz  )
     else
         call horiz_borrow ( Hgrid, dt, dpde,                 &
                                Var%r(:,:,:,1:Var_dt%ntrace), &
                             Var_dt%r(:,:,:,1:Var_dt%ntrace), &
                                mask = Masks%Tmp%mask,        &
                               iters = Control % Fill % npass_horiz  )
     endif
     call mpp_clock_end   (id_fill)

!-----------------------------------------------------------------------
!------------------ advection of momentum fields -----------------------
!-----------------------------------------------------------------------

   call mpp_clock_begin (id_vel)

   is = Hgrid % Vel % is;  ie = Hgrid % Vel % ie
   js = Hgrid % Vel % js;  je = Hgrid % Vel % je

  !--- mass fluxes between velocity points ---

   if (trim(horiz_vel_flux(1:5)) == 'equal') then
      call change_grid (Hgrid, UFLX_GRID, VFLX_GRID, few, few, weight=EQUAL)
      call change_grid (Hgrid, VFLX_GRID, UFLX_GRID, fns, fns, weight=EQUAL)
   else
      call change_grid (Hgrid, UFLX_GRID, VFLX_GRID, few, few, weight=AREA)
      call change_grid (Hgrid, VFLX_GRID, UFLX_GRID, fns, fns, weight=AREA)
   endif

 ! compute vertical flux for momentum from horizonal momentum fluxes
   if (compute_vert_wind_flux) then
       call compute_etadot_vel (Hgrid, Vgrid, Masks, few, fns, etadot )
   endif

 ! no flux across pole
   call vel_flux_boundary (Hgrid, fns)

  !--- interpolate mass fields to momentum grid ---
   if (.not.compute_vert_wind_flux) then
       if (trim(vert_vel_flux(1:4)) == 'area') then
          call change_grid (Hgrid, TEMP_GRID, WIND_GRID, etadot, etadot, weight=AREA)
       else
          call change_grid (Hgrid, TEMP_GRID, WIND_GRID, etadot, etadot, weight=EQUAL)
       endif
   endif
   ! always area-weighted (the default)
   call change_grid (Hgrid, TEMP_GRID, WIND_GRID, dpde, dpde_xy)
   call change_grid (Hgrid, TEMP_GRID, WIND_GRID, dpdt,    dpdt)

 ! advection of momentum
 ! determine whether step-mountain mask are needed
   if (Control%do_mask4_vel .and. .not.Masks%sigma) then
       call mask4_init (Hgrid, 2, Masks%sigma, Masks%Vel%mask, mask4)

       call advect_vel (Hgrid, Pfilt, Control % scheme(:,-1), &
                        Control % weight(-1),                 &
                        pfilt_opt, dt, dpdt, dpde_xy,         &
                        few, fns, etadot, Var%u, Var%v, u, v, &
                        Var_dt%u, Var_dt%v,                   &
                        mask=Masks%Vel%mask, mask4=mask4)
   else
       ! sigma case
       call advect_vel (Hgrid, Pfilt, Control % scheme(:,-1), &
                        Control % weight(-1),                 &
                        pfilt_opt, dt, dpdt, dpde_xy,         &
                        few, fns, etadot, Var%u, Var%v, u, v, &
                        Var_dt%u, Var_dt%v)
   endif

   call mpp_clock_end (id_vel)
!-----------------------------------------------------------------------
!------ done with fluxes - zero-out ??? -------

   few    = 0.0
   fns    = 0.0
   etadot = 0.0

!-----------------------------------------------------------------------

end subroutine advection

!#######################################################################

subroutine advect_mass ( Hgrid, Pfilt, scheme, coeff, fopt, dt, &
                         dpdt, dpn, few, fns, fud, uc, vc,      &
                         ro, r, r_dt, mask, mask4 )

  type(horiz_grid_type),    intent(inout) :: Hgrid
  type(pfilt_control_type), intent(in) :: Pfilt
  integer,                  intent(in) :: scheme(2)
  integer,                  intent(in) :: fopt
  real, intent(in)                     :: coeff, dt
  real, intent(in),  dimension(Hgrid%ilb:,Hgrid%jlb:,:)   :: dpdt, dpn,&
                                           few, fns, fud, ro, r, uc, vc
  real, intent(inout), dimension(Hgrid%ilb:,Hgrid%jlb:,:)   :: r_dt
  real, intent(in),    dimension(Hgrid%ilb:,Hgrid%jlb:,:),   optional :: mask
  real, intent(in),    dimension(Hgrid%ilb:,Hgrid%jlb:,:,:), optional :: mask4

!-----------------------------------------------------------------------

  real, dimension(Hgrid%ilb:Hgrid%iub, Hgrid%jlb:Hgrid%jub,  &
                  size(r,3)) :: rst, rst_dt, rst_dt_v, rdpdt

  real    :: rcoef
  integer :: pass, npass, j, k
  integer :: vert_scheme, horiz_scheme
  integer, parameter :: FINITE_VOLUME = 1234567 !can not match other numbers?

!-----------------------------------------------------------------------

 ! set the vertical and horizontal differencing scheme
    horiz_scheme = scheme(1)
     vert_scheme = scheme(2)
 ! rename horizontal finite volume schemes to correct horizontal name
 !  if (horiz_scheme == FINITE_VOLUME_LINEAR)    horiz_scheme = FINITE_VOLUME_LINEAR_HORIZ
 !  if (horiz_scheme == FINITE_VOLUME_PARABOLIC) horiz_scheme = FINITE_VOLUME_PARABOLIC_HORIZ

!-----------------------------------------------------------------------

   rst = ro + dt * r_dt  ! use updated value
   rdpdt = r*dpdt
   rcoef = coeff

                      npass = 1
   if (rcoef > 1.e-4) npass = 2
 ! no advection, psdt correction only
   if (vert_scheme ==  NONE) then
       rst_dt_v = 0.0
       if (horiz_scheme == NONE) npass = 1
   endif
 ! both vert and horiz are using finite volume
   if ( (vert_scheme == FINITE_VOLUME_LINEAR .or.       &
         vert_scheme == FINITE_VOLUME_PARABOLIC) .and.  &
       (horiz_scheme == FINITE_VOLUME_LINEAR .or. &
        horiz_scheme == FINITE_VOLUME_PARABOLIC) ) then
      !(horiz_scheme == FINITE_VOLUME_LINEAR_HORIZ .or. &
      ! horiz_scheme == FINITE_VOLUME_PARABOLIC_HORIZ) ) then
          npass = 2
          rcoef = 1.
   endif

   do pass = 1, npass

     !---- vertical tendency ----
         ! finite volume schemes on pass 1 only
      if (vert_scheme == SECOND_CENTERED .or. vert_scheme == SECOND_CENTERED_WTS .or. &
          vert_scheme == FOURTH_CENTERED .or. vert_scheme == FOURTH_CENTERED_WTS .or. &
        ((vert_scheme == FINITE_VOLUME_LINEAR .or. &
          vert_scheme == FINITE_VOLUME_PARABOLIC) .and. pass == 1)) then
         call vert_advection ( dt, fud, dpn, rst, rst_dt_v,   &
                               mask=mask, scheme=vert_scheme, &
                               form=FLUX_FORM, flags=WEIGHTED_TENDENCY )
      endif

     !---- horizontal tendency ----

      if (horiz_scheme == SECOND_CENTERED) then
         call advect_mass_horiz_2nd (Hgrid, few, fns, rst, rst_dt)
         if ( fopt >= 1 ) call polar_filter (Pfilt, rst_dt, TGRID, mask)
         call update_halo (Hgrid, TEMP, rst_dt)

      else if (horiz_scheme == FOURTH_CENTERED) then
         call advect_mass_horiz_4th (Hgrid, few, fns, rst, rst_dt, mask4)
         if ( fopt >= 1 ) call polar_filter (Pfilt, rst_dt, TGRID, mask)
         call update_halo (Hgrid, TEMP, rst_dt)

    ! compute horizontal finite volume scheme on 2nd pass
      else if ((horiz_scheme == FINITE_VOLUME_LINEAR .or. &
                horiz_scheme == FINITE_VOLUME_PARABOLIC) .and. pass == 2) then
        ! temporary error check
         call error_mesg ('bgrid_advection_mod', &
                          'horizontal finite volume schemes &
                          &are not implemented with this release', FATAL)
        !call horiz_advection ( Hgrid%Tmp%Domain, dt, Hgrid%Tmp%dx, Hgrid%Tmp%dy, &
        !                       uc, vc, few, fns, rst, rst_dt, scheme=horiz_scheme )
       ! halos updated by finite volume scheme
       ! need update only poles (model b.c. differs)
         call update_halo (Hgrid, TEMP, rst_dt, flags=POLEONLY)

      else
            rst_dt = 0.0
      endif

     !---- combine vertical and horizontal tendencies ----
     !---- adjust for pressure tendency ----
        rst_dt = (rst_dt + rst_dt_v - rdpdt) / dpn
      ! apply step-mountain mask?
        if (present(mask)) rst_dt = rst_dt*mask

     !---- compute new value or return tendency ----
        if (pass < npass) then
            rst = ro + dt * (r_dt + rcoef*rst_dt)
        else
            r_dt = r_dt + rst_dt
        endif

   enddo

!-----------------------------------------------------------------------

end subroutine advect_mass

!#######################################################################

subroutine advect_vel ( Hgrid, Pfilt, scheme, coeff, fopt, dt,  &
                        dpdt, dpn, few, fns, fud,               &
                        uo, vo, u, v, u_dt, v_dt, mask, mask4  )

  type(horiz_grid_type),    intent(inout) :: Hgrid
  type(pfilt_control_type), intent(in) :: Pfilt
  integer,                  intent(in) :: scheme(2)
  integer,                  intent(in) :: fopt
  real, intent(in)                     :: coeff, dt
  real, intent(in),  dimension(Hgrid%ilb:,Hgrid%jlb:,:)   :: dpdt, dpn,&
                                           few, fns, fud, uo, vo, u, v
  real, intent(inout), dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: u_dt, v_dt
  real, intent(in),    dimension(Hgrid%ilb:,Hgrid%jlb:,:),   optional :: mask
  real, intent(in),    dimension(Hgrid%ilb:,Hgrid%jlb:,:,:), optional :: mask4

!-----------------------------------------------------------------------

  real, dimension(Hgrid%ilb:Hgrid%iub, Hgrid%jlb:Hgrid%jub,  &
                  size(u,3)) :: ust_dt, ust_dt_v, &
                                vst_dt, vst_dt_v
! store ust & vst components together to create larger halo updates
  real, dimension(Hgrid%ilb:Hgrid%iub, Hgrid%jlb:Hgrid%jub,  &
                  size(u,3),2) :: uvst
  integer, parameter :: UCOMP=1, VCOMP=2

  integer :: vert_scheme, horiz_scheme
  integer :: pass, npass, i, j, k, is, ie, js, je, nlev

!-----------------------------------------------------------------------

 ! set the vertical differencing scheme
   horiz_scheme = scheme(1)
    vert_scheme = scheme(2)

!-----------------------------------------------------------------------

   is = Hgrid%Vel%is; ie = Hgrid%Vel%ie
   js = Hgrid%Vel%js; je = Hgrid%Vel%je
   nlev = size(u,3)

   uvst(:,:,:,UCOMP) = uo + dt * u_dt   ! use updated values
   uvst(:,:,:,VCOMP) = vo + dt * v_dt

 ! tendency halos are not up-to-date
 ! need to update halos
   call update_halo ( Hgrid, WIND, uvst )

                      npass = 1
   if (coeff > 1.e-4) npass = 2

   do pass = 1, npass

     !---- vertical tendency ----
         ! finite volume schemes on pass 1 only
      if (vert_scheme == SECOND_CENTERED .or. vert_scheme == SECOND_CENTERED_WTS .or. &
          vert_scheme == FOURTH_CENTERED .or. vert_scheme == FOURTH_CENTERED_WTS .or. &
        ((vert_scheme == FINITE_VOLUME_LINEAR .or. &
          vert_scheme == FINITE_VOLUME_PARABOLIC) .and. pass == 1)) then
          call vert_advection ( dt, fud, dpn, uvst(:,:,:,UCOMP), ust_dt_v, &
                                mask=mask, scheme=vert_scheme,             &
                                form=FLUX_FORM, flags=WEIGHTED_TENDENCY )
          call vert_advection ( dt, fud, dpn, uvst(:,:,:,VCOMP), vst_dt_v, &
                                mask=mask, scheme=vert_scheme,             &
                                form=FLUX_FORM, flags=WEIGHTED_TENDENCY )
      else if (vert_scheme == NONE .and. pass == 1) then
          ust_dt_v = 0.0
          vst_dt_v = 0.0
      endif

     !---- horizontal tendency ----
      if (horiz_scheme == SECOND_CENTERED) then
        call advect_vel_horiz_2nd (Hgrid, few, fns, uvst(:,:,:,UCOMP), &
                                   uvst(:,:,:,VCOMP), ust_dt, vst_dt   )

      else if (horiz_scheme == FOURTH_CENTERED) then
        call advect_vel_horiz_4th (Hgrid, few, fns,         &
                               uvst(:,:,:,UCOMP), uvst(:,:,:,VCOMP), &
                               ust_dt, vst_dt, mask4 )
      endif

     ! polar filter horizontal tendency
        if (fopt >= 2) then
           call polar_filter_wind (Pfilt, ust_dt, vst_dt, mask)
        endif

     !---- combine vertical and horizontal tendencies ----
     !---- adjust for pressure tendency ----
      do k = 1, nlev
      do j = js, je
      do i = is, ie
         ust_dt(i,j,k) = (ust_dt(i,j,k) + ust_dt_v(i,j,k) - &
                       u(i,j,k)*dpdt(i,j,k)) / dpn(i,j,k)
         vst_dt(i,j,k) = (vst_dt(i,j,k) + vst_dt_v(i,j,k) - &
                       v(i,j,k)*dpdt(i,j,k)) / dpn(i,j,k)
      enddo
      enddo
      enddo
    ! apply step-mountain mask?
      if (present(mask)) then
        do k = 1, nlev
        ust_dt(is:ie,js:je,k) = ust_dt(is:ie,js:je,k)*mask(is:ie,js:je,k)
        vst_dt(is:ie,js:je,k) = vst_dt(is:ie,js:je,k)*mask(is:ie,js:je,k)
        enddo
      endif

     !---- compute new value or return tendency ----
      if (pass < npass) then
         do k = 1, nlev
         do j = js, je
         do i = is, ie
           uvst(i,j,k,UCOMP) = uo(i,j,k) + dt * (u_dt(i,j,k) + coeff*ust_dt(i,j,k))
           uvst(i,j,k,VCOMP) = vo(i,j,k) + dt * (v_dt(i,j,k) + coeff*vst_dt(i,j,k))
         enddo
         enddo
         enddo
         call update_halo (Hgrid, WIND, uvst)
      else
         do k = 1, nlev
         do j = js, je
         do i = is, ie
           u_dt(i,j,k) = u_dt(i,j,k) + ust_dt(i,j,k)
           v_dt(i,j,k) = v_dt(i,j,k) + vst_dt(i,j,k)
         enddo
         enddo
         enddo
       ! NOTE: halos not updated for output tendencies
       !  do this in the dynamical core for efficiency
      endif

   enddo

!-----------------------------------------------------------------------

end subroutine advect_vel

!#######################################################################

 subroutine advect_mass_horiz_2nd (Hgrid, few, fns, r, rdt)

  type(horiz_grid_type),    intent(in) :: Hgrid
  real, intent(in),  dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: few, fns, r
  real, intent(out), dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: rdt

  real, dimension(Hgrid%ilb:Hgrid%iub, Hgrid%jlb:Hgrid%jub) :: frew, frns
  integer :: i, j, k

! second order centered differencing on B-grid temperature grid
! constant grid spacing assumed
! minimum halo size = 1

      do k = 1, size(r,3)

       !--- horizontal fluxes ---
        do j = Hgrid%Tmp%js-1, Hgrid%Tmp%je
        do i = Hgrid%Tmp%is-1, Hgrid%Tmp%ie
          frew(i,j) = few(i,j,k) * (r(i+1,j,k) + r(i,j,k))
          frns(i,j) = fns(i,j,k) * (r(i,j+1,k) + r(i,j,k))
        enddo
        enddo

       !--- horizontal advective tendency ---
        do j = Hgrid%Tmp%js, Hgrid%Tmp%je
        do i = Hgrid%Tmp%is, Hgrid%Tmp%ie
           rdt(i,j,k) = -0.5*Hgrid%Tmp%rarea(j)*       &
                           ((frew(i  ,j)+frns(i,j  ))  &
                           -(frew(i-1,j)+frns(i,j-1)))
        enddo
        enddo

      enddo

 end subroutine advect_mass_horiz_2nd

!#######################################################################

 subroutine advect_mass_horiz_4th (Hgrid, few, fns, r, rdt, mask4)

  type(horiz_grid_type),    intent(inout) :: Hgrid
  real, intent(in),  dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: few, fns, r
  real, intent(out), dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: rdt
  real, intent(in),  dimension(Hgrid%ilb:,Hgrid%jlb:,:,:), optional :: &
                                                           mask4

  real, dimension(Hgrid%ilb:Hgrid%iub, Hgrid%jlb:Hgrid%jub, &
                  size(r,3)) :: rew, rns, frew, frns
  real, dimension(Hgrid%ilb:Hgrid%iub) :: x2, x4
  real, dimension(Hgrid%ilb:Hgrid%iub) :: y2, y4
  integer :: i, j, k, is, ie, js, je

! fourth order centered differencing on B-grid temperature grid
! constant grid spacing assumed
! assumed halo size = 1

   is = Hgrid % Tmp % is;  ie = Hgrid % Tmp % ie
   js = Hgrid % Tmp % js;  je = Hgrid % Tmp % je

      rns(:,Hgrid%jub,:) = 0.0
      do k = 1, size(r,3)
        do j = Hgrid%jlb,Hgrid%jub
        do i = Hgrid%ilb,Hgrid%iub-1
           rew(i,j,k) = r(i+1,j,k)+r(i,j,k)
        enddo
        enddo
        do j = Hgrid%jlb,Hgrid%jub-1
        do i = Hgrid%ilb,Hgrid%iub
           rns(i,j,k) = r(i,j+1,k)+r(i,j,k)
        enddo
        enddo
      enddo
      ! assumed halosize = 1
      call update_halo (Hgrid,TEMP,rew,halos=EAST)
      call update_halo (Hgrid,UWND,rns,halos=NORTH+NOPOLE)

!     ---- horizontal fluxes ----

      if (present(mask4)) then
         frew=0.0;  frns=0.0
         do k = 1, size(r,3)
           do j = js,          je
           do i = Hgrid%ilb+1, ie
             x4(i) = mask4(i,j,k,1)
             x2(i) = 1.0 - 2.*x4(i)
             frew(i,j,k) = few(i,j,k) * ( x2(i) * rew(i,j,k) &
                          + x4(i) * (rew(i-1,j,k) + rew(i+1,j,k)) )
           enddo
           enddo
           do j = Hgrid%jlb+1, je
           do i = is,          ie
             y4(i) = mask4(i,j,k,2)
             y2(i) = 1.0 - 2.*y4(i)
             frns(i,j,k) = fns(i,j,k) * ( y2(i) * rns(i,j,k) &
                          + y4(i) * (rns(i,j-1,k) + rns(i,j+1,k)) )
           enddo
           enddo
         enddo
      else
         frew=0.0;  frns=0.0
         do k = 1, size(r,3)
           do j = js,          je
           do i = Hgrid%ilb+1, ie
             frew(i,j,k) = few(i,j,k) * ( c2 * rew(i,j,k) &
                          + c4 * (rew(i-1,j,k) + rew(i+1,j,k)) )
           enddo
           enddo
           do j = Hgrid%jlb+1, je
           do i = is,          ie
             frns(i,j,k) = fns(i,j,k) * ( c2 * rns(i,j,k) &
                          + c4 * (rns(i,j-1,k) + rns(i,j+1,k)) )
           enddo
           enddo
         enddo
      endif

      ! assumed halosize = 1
      call update_halo (Hgrid,TEMP,frew,halos=WEST)
      call update_halo (Hgrid,VWND,frns,halos=SOUTH)

!     ---- horizontal advective tendency ----

      do k = 1, size(r,3)
      do j = js, je
      do i = is, ie
         rdt(i,j,k) = -0.5*Hgrid%Tmp%rarea(j)*           &
                         ((frew(i  ,j,k)+frns(i,j  ,k))  &
                         -(frew(i-1,j,k)+frns(i,j-1,k)))
      enddo
      enddo
      enddo

 end subroutine advect_mass_horiz_4th

!#######################################################################

 subroutine advect_vel_horiz_2nd (Hgrid, few, fns, u, v, udt, vdt)

  type(horiz_grid_type),    intent(in) :: Hgrid
  real, intent(in),  dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: few, fns, &
                                                            u, v
  real, intent(out), dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: udt, vdt

  real, dimension(Hgrid%ilb:Hgrid%iub, Hgrid%jlb:Hgrid%jub) :: &
                                             fuew, funs, fvew, fvns
  integer :: i, j, k

! second order centered differencing on B-grid momentum grid
! constant grid spacing assumed
! minimum halo size = 1

     do k = 1, size(u,3)

          !--- horizontal fluxes ---
           do j = Hgrid%Vel%js, Hgrid%Vel%je
           do i = Hgrid%Vel%is, Hgrid%Vel%ie+1
             fuew(i,j) = few(i,j,k) * (u(i-1,j,k) + u(i,j,k))
             fvew(i,j) = few(i,j,k) * (v(i-1,j,k) + v(i,j,k))
           enddo
           enddo
           do j = Hgrid%Vel%js, Hgrid%Vel%je+1
           do i = Hgrid%Vel%is, Hgrid%Vel%ie
             funs(i,j) = fns(i,j,k) * (u(i,j-1,k) + u(i,j,k))
             fvns(i,j) = fns(i,j,k) * (v(i,j-1,k) + v(i,j,k))
           enddo
           enddo

          !--- horizontal advective tendency ----
           do j = Hgrid%Vel%js, Hgrid%Vel%je
           do i = Hgrid%Vel%is, Hgrid%Vel%ie
              udt(i,j,k) = -0.5*Hgrid%Vel%rarea(j)*       &
                              ((fuew(i+1,j)+funs(i,j+1))  &
                              -(fuew(i  ,j)+funs(i,j  )))
              vdt(i,j,k) = -0.5*Hgrid%Vel%rarea(j)*       &
                              ((fvew(i+1,j)+fvns(i,j+1))  &
                              -(fvew(i  ,j)+fvns(i,j  )))
           enddo
           enddo

     enddo

 end subroutine advect_vel_horiz_2nd

!#######################################################################

 subroutine advect_vel_horiz_4th (Hgrid, few, fns, u, v, udt, vdt, &
                                  mask4)

  type(horiz_grid_type),    intent(inout) :: Hgrid
  real, intent(in),  dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: few, fns, u, v
  real, intent(out), dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: udt, vdt
  real, intent(in),  dimension(Hgrid%ilb:,Hgrid%jlb:,:,:), optional :: &
                                                           mask4

! compress u & v components into 4th dimension
! this will create larger and more efficient halo updates
  real, dimension(Hgrid%ilb:Hgrid%iub, Hgrid%jlb:Hgrid%jub, &
                  size(u,3),2) :: uvew, uvns, fuvew, fuvns
  integer, parameter :: UCOMP=1, VCOMP=2

  real, dimension(Hgrid%ilb:Hgrid%iub) :: x2, x4
  real, dimension(Hgrid%ilb:Hgrid%iub) :: y2, y4
  real :: z2, z4
  integer :: i, j, k, is, ie, js, je

! fourth order centered differencing on B-grid momentum grid
! constant grid spacing assumed
! assumed halo size = 1

   is = Hgrid % Vel % is;  ie = Hgrid % Vel % ie
   js = Hgrid % Vel % js;  je = Hgrid % Vel % je

      do k = 1, size(u,3)
        do j = Hgrid%jlb  ,Hgrid%jub
        do i = Hgrid%ilb+1,Hgrid%iub
           uvew(i,j,k,UCOMP) = u(i-1,j,k)+u(i,j,k)
           uvew(i,j,k,VCOMP) = v(i-1,j,k)+v(i,j,k)
        enddo
        enddo
        do j = Hgrid%jlb+1,Hgrid%jub
        do i = Hgrid%ilb  ,Hgrid%iub
           uvns(i,j,k,UCOMP) = u(i,j-1,k)+u(i,j,k)
           uvns(i,j,k,VCOMP) = v(i,j-1,k)+v(i,j,k)
        enddo
        enddo
      enddo
      ! assumed halosize = 1
      call update_halo (Hgrid,WIND,uvew,halos=WEST)
      call update_halo (Hgrid,TEMP,uvns,halos=SOUTH)

     !---- horizontal fluxes ----

      if (present(mask4)) then
         do k = 1, size(u,3)
           do j = js, je
           do i = is, Hgrid%iub-1
             x4(i) = mask4(i,j,k,1)
             x2(i) = 1.0 - 2.*x4(i)
             fuvew(i,j,k,UCOMP) = few(i,j,k) * ( x2(i) * uvew(i,j,k,UCOMP) &
                            + x4(i) * (uvew(i-1,j,k,UCOMP) + uvew(i+1,j,k,UCOMP)) )
             fuvew(i,j,k,VCOMP) = few(i,j,k) * ( x2(i) * uvew(i,j,k,VCOMP) &
                            + x4(i) * (uvew(i-1,j,k,VCOMP) + uvew(i+1,j,k,VCOMP)) )
           enddo
           enddo
           do j = js, Hgrid%jub-1
           do i = is, ie
             y4(i) = mask4(i,j,k,2)
             y2(i) = 1.0 - 2.*y4(i)
             fuvns(i,j,k,UCOMP) = fns(i,j,k) * ( y2(i) * uvns(i,j,k,UCOMP) &
                                + y4(i) * (uvns(i,j-1,k,UCOMP) + uvns(i,j+1,k,UCOMP)) )
             fuvns(i,j,k,VCOMP) = fns(i,j,k) * ( y2(i) * uvns(i,j,k,VCOMP) &
                                + y4(i) * (uvns(i,j-1,k,VCOMP) + uvns(i,j+1,k,VCOMP)) )
           enddo
           enddo
         enddo
      else
         do k = 1, size(u,3)
           do j = js, je
           do i = is, Hgrid%iub-1
             fuvew(i,j,k,UCOMP) = few(i,j,k) * ( c2 * uvew(i,j,k,UCOMP) &
                            + c4 * (uvew(i-1,j,k,UCOMP) + uvew(i+1,j,k,UCOMP)) )
             fuvew(i,j,k,VCOMP) = few(i,j,k) * ( c2 * uvew(i,j,k,VCOMP) &
                            + c4 * (uvew(i-1,j,k,VCOMP) + uvew(i+1,j,k,VCOMP)) )
           enddo
           enddo
           do j = js, Hgrid%jub-1
           ! second order near poles
             z4 = c4
             if (j <= Hgrid%Vel%jsg+1) z4 = 0.
             if (j >= Hgrid%Vel%jeg  ) z4 = 0.
             z2 = 1.-2.*z4
           do i = is, ie
             fuvns(i,j,k,UCOMP) = fns(i,j,k) * ( z2 * uvns(i,j,k,UCOMP) &
                                + z4 * (uvns(i,j-1,k,UCOMP) + uvns(i,j+1,k,UCOMP)) )
             fuvns(i,j,k,VCOMP) = fns(i,j,k) * ( z2 * uvns(i,j,k,VCOMP) &
                                + z4 * (uvns(i,j-1,k,VCOMP) + uvns(i,j+1,k,VCOMP)) )
           enddo
           enddo
         enddo
      endif
      ! assumed halosize = 1
      call update_halo (Hgrid,WIND,fuvew,halos=EAST)
      call update_halo (Hgrid,TEMP,fuvns,halos=NORTH)

     !---- horizontal advective tendency ----

      do k = 1, size(u,3)
      do j = js, je
      do i = is, ie
         udt(i,j,k) = -0.5*Hgrid%Vel%rarea(j)*                        &
                        ((fuvew(i+1,j,k,UCOMP)+fuvns(i,j+1,k,UCOMP))  &
                        -(fuvew(i  ,j,k,UCOMP)+fuvns(i,j  ,k,UCOMP)))
         vdt(i,j,k) = -0.5*Hgrid%Vel%rarea(j)*                        &
                        ((fuvew(i+1,j,k,VCOMP)+fuvns(i,j+1,k,VCOMP))  &
                        -(fuvew(i  ,j,k,VCOMP)+fuvns(i,j  ,k,VCOMP)))
      enddo
      enddo
      enddo

 end subroutine advect_vel_horiz_4th

!#######################################################################
! computes advecting wind for horizontal finite-volume advection

 subroutine compute_advecting_wind ( Hgrid, dpo, dpn, few, fns, uc, vc )
 type(horiz_grid_type), intent(inout) :: Hgrid
 real, intent(in),  dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: dpo, dpn, few, fns
 real, intent(out), dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: uc, vc

 real :: dp
 integer :: i, j, k

   do k = 1, size(uc,3)
   do j = Hgrid%jlb, Hgrid%jub
   do i = Hgrid%ilb, Hgrid%iub-1
     dp = (dpo(i,j,k)+dpn(i,j,k)+dpo(i+1,j,k)+dpn(i+1,j,k))*0.25
     uc(i,j,k) = few(i,j,k)/(dp*Hgrid%Tmp%dy)
   enddo
   enddo
   enddo

   do k = 1, size(uc,3)
   do j = Hgrid%jlb, Hgrid%jub-1
   do i = Hgrid%ilb, Hgrid%iub
     dp = (dpo(i,j,k)+dpn(i,j,k)+dpo(i,j+1,k)+dpn(i,j+1,k))*0.25
     vc(i,j,k) = fns(i,j,k)/(dp*Hgrid%Vel%dx(j))
   enddo
   enddo
   enddo

   call update_halo ( Hgrid, TEMP, uc, halos=EAST )
   call update_halo ( Hgrid, VWND, vc, halos=NORTH )

 end subroutine compute_advecting_wind

!#######################################################################
!--- stability diagnostic (CFL for horizontal finite volume scheme) ----

 subroutine stability_diag ( Hgrid, dt, few, dpo, dpn )
 type(horiz_grid_type), intent(inout) :: Hgrid
 real, intent(in)                     :: dt
 real, intent(in), dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: few, dpo, dpn

 real, dimension(Hgrid%ilb:Hgrid%iub,Hgrid%jlb:Hgrid%jub) :: uc
 real    :: cflmax, cfl, dpa
 integer :: i, j, k

    cflmax = 0.
    do k = 1, size(few,3)
     ! compute zonal wind
       do j = Hgrid%Tmp%js  , Hgrid%Tmp%je
       do i = Hgrid%Tmp%is-1, Hgrid%Tmp%ie
         dpa = (dpo(i,j,k)+dpn(i,j,k)+dpo(i+1,j,k)+dpn(i+1,j,k))*0.25
         uc(i,j) = few(i,j,k)/(dpa*Hgrid%Tmp%dy)
       enddo
       enddo
       do j = Hgrid%Tmp%js, Hgrid%Tmp%je
       do i = Hgrid%Tmp%is, Hgrid%Tmp%ie
          cfl = abs(uc(i,j)-uc(i-1,j))*dt/Hgrid%Tmp%dx(j)
          cflmax = max(cflmax,cfl)
       enddo
       enddo
    enddo
    call mpp_max (cflmax)
    if (mpp_pe() == mpp_root_pe()) then
        if (cflmax > 1.0) then
            print *, 'x-axis stability violated, cfl = ', cflmax
        endif
    endif

 end subroutine stability_diag

!#######################################################################

 subroutine mask4_init (Hgrid, grid, sigma, mask, mask4)

 type(horiz_grid_type), intent(inout) :: Hgrid
 integer, intent(in)                                      :: grid
 logical, intent(in)                                      :: sigma
 real, intent(in),   dimension(Hgrid%ilb:,Hgrid%jlb:,:)   :: mask
 real, intent(out),  dimension(Hgrid%ilb:,Hgrid%jlb:,:,:) :: mask4
 real, dimension(Hgrid%ilb:Hgrid%iub,Hgrid%jlb:Hgrid%jub, &
                 size(mask,3)) :: mew, mns

 integer :: i,j,k,is,ie,js,je,n

! horizontal masks

  select case (grid)

  case (1)
     if (sigma) then
        mask4(:,:,:,1:2) = c4
     else

      ! initialize
        mask4 = 0.0
        mns(:,Hgrid%jub,:) = 0.0

        do k = 1, size(mask,3)
          do j = Hgrid%jlb,Hgrid%jub
          do i = Hgrid%ilb,Hgrid%iub-1
             mew(i,j,k) = mask(i+1,j,k)*mask(i,j,k)
          enddo
          enddo
          do j = Hgrid%jlb,Hgrid%jub-1
          do i = Hgrid%ilb,Hgrid%iub
             mns(i,j,k) = mask(i,j+1,k)*mask(i,j,k)
          enddo
          enddo
        enddo
        ! assumed halosize = 1
        call update_halo (Hgrid,TEMP,mew,halos=EAST)
        call update_halo (Hgrid,UWND,mns,halos=NORTH,flags=NOPOLE)

         do k = 1, size(mask,3)
         ! x-axis
           do j = Hgrid%Tmp%js, Hgrid%Tmp%je
           do i = Hgrid%ilb+1,  Hgrid%Tmp%ie
             !mask4(i,j,k,1) = mew(i-1,j,k)<.01 .or. mew(i,j,k)<.01 .or. mew(i+1,j,k)<.01
             !mask4(i,j,k,1) = mew(i-1,j,k) * mew(i,j,k) * mew(i+1,j,k)
              mask4(i,j,k,1) = c4 * mew(i-1,j,k) * mew(i+1,j,k)
           enddo
           enddo
         ! y-axis
           do j = Hgrid%jlb+1,  Hgrid%Tmp%je
           do i = Hgrid%Tmp%is, Hgrid%Tmp%ie
             !mask4(i,j,k,2) = mns(i,j-1,k)<.01 .or. mns(i,j,k)<.01 .or. mns(i,j-1,k)<.01
             !mask4(i,j,k,2) = mns(i,j-1,k) * mns(i,j,k) * mns(i,j+1,k)
              mask4(i,j,k,2) = c4 * mns(i,j-1,k) * mns(i,j+1,k)
           enddo
           enddo
         enddo
     endif

  case (2)
     if (sigma) then
        mask4(:,:,:,1:2) = c4
        mns = 1.0
     else
      ! initialize
        mask4 = 0.0
        do k = 1, size(mask,3)
          do j = Hgrid%jlb  ,Hgrid%jub
          do i = Hgrid%ilb+1,Hgrid%iub
             mew(i,j,k) = mask(i-1,j,k)*mask(i,j,k)
          enddo
          enddo
          do j = Hgrid%jlb+1,Hgrid%jub
          do i = Hgrid%ilb  ,Hgrid%iub
             mns(i,j,k) = mask(i,j-1,k)*mask(i,j,k)
          enddo
          enddo
        enddo
        ! assumed halosize = 1
        call update_halo (Hgrid,UWND,mew,halos=WEST)
        call update_halo (Hgrid,TEMP,mns,halos=SOUTH,flags=NOPOLE)
      endif
    ! use second order in meridional direction near poles
      call vel_flux_boundary (Hgrid,mns)

      if (.not.sigma) then
        do k = 1, size(mask,3)
          do j = Hgrid%Vel%js, Hgrid%Vel%je
          do i = Hgrid%Vel%is, Hgrid%iub-1
             mask4(i,j,k,1) = c4 * mew(i-1,j,k) * mew(i+1,j,k)
          enddo
          enddo
        enddo
      endif

      do k = 1, size(mask,3)
        do j = Hgrid%Vel%js, Hgrid%jub-1
        do i = Hgrid%Vel%is, Hgrid%Vel%ie
           mask4(i,j,k,2) = c4 * mns(i,j-1,k) * mns(i,j+1,k)
        enddo
        enddo
      enddo

  end select

 end subroutine mask4_init

!#######################################################################
! initialization routine

  subroutine advection_init ( Hgrid )

! INPUT:  Hgrid = horizontal grid constants
! RESULT: reads bgrid_advection_nml namelist
!         defines advection control parameters (stored in advec_control_type)

  type(horiz_grid_type), intent(in) :: Hgrid

 real    :: wt
 integer :: n, m, np, ntrace, unit, ierr, io
 character(len=32)  :: advec_methods(2) = (/ 'advec_horiz', 'advec_vert ' /)
 character(len=128) :: scheme, params, name
!-----------------------------------------------------------------------
! read namelist
   if (file_exist('input.nml')) then
       unit = open_namelist_file ( )
       ierr=1; do while (ierr /= 0)
          read (unit, nml=bgrid_advection_nml, iostat=io, end=5)
          ierr = check_nml_error (io, 'bgrid_advection_nml')
       enddo
 5     call close_file (unit)
   endif
! write version, namelist info to log file
   if (do_log) then
      call write_version_number (version,tagname)
      if (mpp_pe() == mpp_root_pe()) write (stdlog(), nml=bgrid_advection_nml)
      do_log = .false.
   endif

 ! determine the number of prognostic tracers
   call get_number_tracers ( MODEL_ATMOS, num_prog=ntrace )

 ! allocate space for the control parameters
   allocate ( Control%scheme (2,-1:ntrace), &
              Control%weight   (-1:ntrace)  )
   allocate ( Control%Fill%fill_scheme (ntrace), &
              Control%Fill%npass_horiz (ntrace), &
              Control%Fill%npass_vert  (ntrace)  )

 ! set namelist values of control parameters

   Control%scheme(1,-1) = set_advec_scheme( horiz_advec_scheme_wind )
   Control%scheme(2,-1) = set_advec_scheme(  vert_advec_scheme_wind )
   Control%weight  (-1) = advec_weight_wind
   Control%scheme(1, 0) = set_advec_scheme( horiz_advec_scheme_temp )
   Control%scheme(2, 0) = set_advec_scheme(  vert_advec_scheme_temp )
   Control%weight  ( 0) = advec_weight_temp
 do n = 1, ntrace
   Control%scheme(1, n) = set_advec_scheme( horiz_advec_scheme_tracer )
   Control%scheme(2, n) = set_advec_scheme(  vert_advec_scheme_tracer )
   Control%weight  ( n) = advec_weight_tracer
   ! parameters for tracer filling/borrowing
   Control%Fill%npass_horiz(n) = num_fill_pass
   Control%Fill%npass_vert (n) = num_fill_pass
   Control%Fill%fill_scheme(n) = NONE
 enddo
   ! currently only one possible filling scheme
   if (maxval(Control%Fill%npass_horiz) > 0 .or. maxval(Control%Fill%npass_vert) > 0) &
                            Control%Fill%fill_scheme = EQUAL_BORROW

 ! process tracer table information for advection methods
   do n = 1, ntrace
      do m = 1, 2
         if (query_method(trim(advec_methods(m)), MODEL_ATMOS, n, scheme, params)) then
             Control%scheme(m,n) = set_advec_scheme( scheme )
             ! parse e-b weight
             if (Control%scheme(m,n) == SECOND_CENTERED .or. &
                 Control%scheme(m,n) == FOURTH_CENTERED) then
                   if (parse(params,'wt', wt) == 1) Control%weight(n) = wt
             endif
         endif
      enddo
   enddo

 ! error check for all Euler weights
   do n = -1, ntrace
        if (Control%weight(n) < 0.0 .or. Control%weight(n) > 1.0) &
                          call error_mesg ('bgrid_advection_mod', &
                            'E-B weight out of range [0,1]', FATAL)
   enddo

 ! process tracer table information for filling method
   do n = 1, ntrace
      if (query_method('filling', MODEL_ATMOS, n, scheme, params)) then
          if (uppercase(trim(scheme)) == 'LOCAL') then
              Control%Fill%fill_scheme(n) = EQUAL_BORROW
              Control%Fill%npass_horiz(n) = 1
              Control%Fill%npass_vert (n) = 1
         !else if (uppercase(trim(scheme)) == 'GLOBAL') then
         !    Control%Fill%fill_scheme(n) = GLOBAL_BORROW
          else if (uppercase(trim(scheme)) == 'NONE') then
              Control%Fill%fill_scheme(n) = NONE
              Control%Fill%npass_horiz(n) = 0
              Control%Fill%npass_vert (n) = 0
          else
              call error_mesg ('bgrid_advection_mod',  &
                   'invalid filling scheme, '//uppercase(trim(scheme)), FATAL)
          endif
         ! parse number of filling passes
           if (Control%Fill%fill_scheme(n) == EQUAL_BORROW) then
              if (parse(params,'hp', np) == 1) Control%Fill%npass_horiz(n) = np
              if (parse(params,'vp', np) == 1) Control%Fill%npass_vert (n) = np
           endif
      endif
   enddo

 ! print results
   if (mpp_pe() == mpp_root_pe()) then
           write (stdlog(),10) 'momentum', &
                 (trim(echo_advec_scheme(Control%scheme(m,-1))),m=1,2), Control%weight(-1)
           write (stdlog(),10) 'temperature', &
                 (trim(echo_advec_scheme(Control%scheme(m, 0))),m=1,2), Control%weight( 0)
      do n = 1, ntrace
           call get_tracer_names (MODEL_ATMOS, n, name)
           write (stdlog(),11) n, trim(name), &
                    ( trim(echo_advec_scheme(Control%scheme(m,n))),m=1,2), &
                                             Control%weight(n),            &
                                             Control%Fill%npass_horiz(n),  &
                                             Control%Fill%npass_vert(n)
        10 format (3x, a24, ', HORIZ=',a24, ', VERT=',a24, ', wt=',f7.3)
        11 format (i3, a24, ', HORIZ=',a24, ', VERT=',a24, ', wt=',f7.3, &
                   ', hp=',i2, ', vp=',i2)
      enddo
   endif

 ! check if fourth order centered horizontal scheme
   Control%do_mask4_vel = Control%scheme(1,-1) == FOURTH_CENTERED
   Control%do_mask4_tmp = .false.
   do n = 0, ntrace
     if (Control%scheme(1,n) == FOURTH_CENTERED) then
        Control%do_mask4_tmp = .true.
        exit
     endif
   enddo
 ! check if finite_volume horizontal scheme for temperature
     if (Control%scheme(1,0) == FINITE_VOLUME_LINEAR .or. &
         Control%scheme(1,0) == FINITE_VOLUME_PARABOLIC) then
         Control%do_finite_volume_tmp = .true.
     else
         Control%do_finite_volume_tmp = .false.
     endif
 ! check if finite_volume horizontal scheme for tracers
   Control%do_finite_volume_trs = .false.
   do n = 1, ntrace
     if (Control%scheme(1,n) == FINITE_VOLUME_LINEAR .or. &
         Control%scheme(1,n) == FINITE_VOLUME_PARABOLIC) then
         Control%do_finite_volume_trs = .true.
         exit
     endif
   enddo
 ! error checks
 ! many horizontal schemes are not support with this release
   do n = -1, ntrace
     if (Control%scheme(1,n) == FINITE_VOLUME_LINEAR    .or. &
         Control%scheme(1,n) == FINITE_VOLUME_PARABOLIC .or. &
         Control%scheme(1,n) == SECOND_CENTERED_WTS     .or. &
         Control%scheme(1,n) == FOURTH_CENTERED_WTS   ) then
         call error_mesg ('bgrid_advection_mod',  &
                   'advection scheme not supported', FATAL)
     endif
   enddo

! initialize code sections for performance timing

  if (do_clock_init) then
    id_tmp  = mpp_clock_id ('BGRID: temperature advection', &
                        flags=MPP_CLOCK_SYNC, grain=CLOCK_ROUTINE)
    id_trs  = mpp_clock_id ('BGRID: tracer advection',      &
                        flags=MPP_CLOCK_SYNC, grain=CLOCK_ROUTINE)
    id_vel  = mpp_clock_id ('BGRID: momentum advection',    &
                        flags=MPP_CLOCK_SYNC, grain=CLOCK_ROUTINE)
    id_fill = mpp_clock_id ('BGRID: tracer borrowing',    &
                        flags=MPP_CLOCK_SYNC, grain=CLOCK_ROUTINE)
    do_clock_init = .false.
  endif

!-----------------------------------------------------------------------

  end subroutine advection_init

!#######################################################################

 subroutine advection_end

  ! terminate vertical advection module
    call vert_advection_end

  ! terminate finite-volume advection module
  ! if (Control%do_finite_volume_tmp .or. Control%do_finite_volume_trs) then
  !     call horiz_advection_end
  ! endif

  ! free up memory used (although not much)
    deallocate ( Control%scheme, Control%weight, &
                 Control%Fill%fill_scheme,       &
                 Control%Fill%npass_horiz,       &
                 Control%Fill%npass_vert         )

 end subroutine advection_end

!#######################################################################
! converts character string names to integer parameters
! checks for all valid names, otherwise produces an error

 function set_advec_scheme ( scheme ) result ( advec_scheme )
 character(len=*), intent(in)  :: scheme
 integer                       :: advec_scheme

      if (uppercase(trim(scheme)) == 'SECOND_CENTERED') then
          advec_scheme = SECOND_CENTERED
      else if (uppercase(trim(scheme)) == 'FOURTH_CENTERED') then
          advec_scheme = FOURTH_CENTERED
      else if (uppercase(trim(scheme)) == 'FOURTH_CENTERED_WTS') then
          advec_scheme = FOURTH_CENTERED_WTS
      else if (uppercase(trim(scheme)) == 'SECOND_CENTERED_WTS') then
          advec_scheme = SECOND_CENTERED_WTS
      else if (uppercase(trim(scheme)) == 'FINITE_VOLUME_LINEAR') then
          advec_scheme = FINITE_VOLUME_LINEAR
      else if (uppercase(trim(scheme)) == 'FINITE_VOLUME_PARABOLIC') then
          advec_scheme = FINITE_VOLUME_PARABOLIC
      else if (uppercase(trim(scheme)) == 'NONE') then
          advec_scheme = NONE
      else
          call error_mesg ('bgrid_advection_mod',  &
               'invalid advection scheme, '//uppercase(trim(scheme)), FATAL)
      endif

 end function set_advec_scheme
!-----------------------------------------------
! converts integer parameter values to character string names
! checks for all valid schemes, otherwise produces an error

 function echo_advec_scheme ( scheme_number ) result ( scheme_name )
 integer, intent(in)  :: scheme_number
 character(len=24)    :: scheme_name

   select case (scheme_number)
       case(NONE)
            scheme_name = 'none                    '
       case(SECOND_CENTERED)
            scheme_name = 'second_centered         '
       case(FOURTH_CENTERED)
            scheme_name = 'fourth_centered         '
       case(SECOND_CENTERED_WTS)
            scheme_name = 'second_centered_wts     '
       case(FOURTH_CENTERED_WTS)
            scheme_name = 'fourth_centered_wts     '
       case(FINITE_VOLUME_LINEAR)
            scheme_name = 'finite_volume_linear    '
       case(FINITE_VOLUME_PARABOLIC)
            scheme_name = 'finite_volume_parabolic '
       case default
            call error_mesg  ('bgrid_advection_mod', &
                     'invalid advection scheme number', FATAL)
   end select

 end function echo_advec_scheme

!#######################################################################
!         routines to minimize negative tracer values
!        conservative horizontal and vertical borrowing
!#######################################################################

subroutine horiz_borrow (Hgrid, dt, dpde, var, var_dt, mask, iters)

!-----------------------------------------------------------------------
!
!       removes negative values by borrowing from horizontal
!       neighbors.  (usually for specific humidity or tke )
!
!-----------------------------------------------------------------------
   type(horiz_grid_type), intent(inout)                      :: Hgrid
   real, intent(in)                                          :: dt
   real, intent(in),    dimension(Hgrid%ilb:,Hgrid%jlb:,:)   :: dpde
   real, intent(in),    dimension(Hgrid%ilb:,Hgrid%jlb:,:,:) :: var
   real, intent(inout), dimension(Hgrid%ilb:,Hgrid%jlb:,:,:) :: var_dt
   real, intent(in),    dimension(Hgrid%ilb:,Hgrid%jlb:,:), optional :: mask
integer, intent(in),    dimension(:),                       optional :: iters
!-----------------------------------------------------------------------
!  ( note:   0.0 < flt <= 0.125 )
   real, parameter :: flt  = 0.125
   real, parameter :: flt4 = flt*0.25
   real, parameter :: rmin = 0.0
!-----------------------------------------------------------------------

   real, dimension(Hgrid%ilb:Hgrid%iub,Hgrid%jlb:Hgrid%jub,size(var,3)) ::  &
                                hew, hns, radp, few, fns, rcur, rdif

   real, dimension(Hgrid%ilb:Hgrid%iub,Hgrid%jlb:Hgrid%jub) :: rew, rns
   real, dimension(Hgrid%jlb:Hgrid%jub) :: areax, areay

integer :: i, j, k, n, is, ie, js, je, nlev, ntrace, knt, mxknt(size(var,4))
!-----------------------------------------------------------------------

   mxknt = 1;  if (present(iters)) mxknt = iters
   if (maxval(mxknt) == 0) return

   nlev   = size(var,3)
   ntrace = size(var,4)

   is = Hgrid%Tmp%is;  ie = Hgrid%Tmp%ie
   js = Hgrid%Tmp%js;  je = Hgrid%Tmp%je

!-----------------------------------------------------------------------
!------ compute flux coeff common to all variables -------

   do j = js-1, je
     areax(j) = Hgrid%Tmp%area(j)+Hgrid%Tmp%area(j)
     areay(j) = Hgrid%Tmp%area(j)+Hgrid%Tmp%area(j+1)
   enddo

   do k = 1, nlev
   do j = js-1, je
   do i = is-1, ie
     hew(i,j,k) = areax(j)*(dpde(i,j,k)+dpde(i+1,j,k))
     hns(i,j,k) = areay(j)*(dpde(i,j,k)+dpde(i,j+1,k))
   enddo
   enddo
   enddo
 ! apply step-mountain mask?
   if (present(mask)) then
       do k = 1, nlev
       do j = js-1, je
       do i = is-1, ie
         hew(i,j,k) = hew(i,j,k)*mask(i,j,k)*mask(i+1,j,k)
         hns(i,j,k) = hns(i,j,k)*mask(i,j,k)*mask(i,j+1,k)
       enddo
       enddo
       enddo
   endif

   do k = 1, nlev
   do j = js, je
     radp(:,j,k) = flt4/(Hgrid%Tmp%area(j)*dpde(:,j,k))
   enddo
   enddo

!-----------------------------------------------------------------------
!---- tracer loop -----
!---- store current value of tracer in rcur ----

   do n = 1, ntrace

      rcur(:,:,:) = var(:,:,:,n) + var_dt(:,:,:,n)*dt

!---- iteration loop -----

      few = 0.0;  fns = 0.0

   do knt = 1, mxknt(n)

!--------------2-nd order lat/lon contributions-------------------------

!     --- do borrowing where adjacent values have opposite sign ---
!            but do not turn off fluxes previously turned on

      do k = 1, nlev
         do j = js-1, je
         do i = is-1, ie
            ! east-west fluxes
            if ((rcur(i+1,j,k) <  rmin .and. rcur(i,j,k) >= rmin) .or. &
                (rcur(i+1,j,k) >= rmin .and. rcur(i,j,k) <  rmin))     &
            few(i,j,k) = hew(i,j,k)
            rew(i,j) = (rcur(i+1,j,k)-rcur(i,j,k))*few(i,j,k)
            ! north-south fluxes
            if ((rcur(i,j+1,k) <  rmin .and. rcur(i,j,k) >= rmin) .or. &
                (rcur(i,j+1,k) >= rmin .and. rcur(i,j,k) <  rmin))     &
            fns(i,j,k) = hns(i,j,k)
            rns(i,j) = (rcur(i,j+1,k)-rcur(i,j,k))*fns(i,j,k)
         enddo
         enddo

         do j = js, je
         do i = is, ie
            rdif(i,j,k) = (rew(i,j)-rew(i-1,j)+ &
                           rns(i,j)-rns(i,j-1))*radp(i,j,k)
         enddo
         enddo
      enddo

     !---- halo update (assumed that halo size = 1) ----

      call update_halo (Hgrid, TEMP, rdif)

     !---- update current value of tracer ----

      rcur(:,:,:) = rcur(:,:,:) + rdif(:,:,:)

!-----------------------------------------------------------------------
   enddo ! iteration loop
!-----------------------------------------------------------------------

     !---- return the tendency -----

      var_dt(:,:,:,n) = (rcur(:,:,:) - var(:,:,:,n)) / dt

!-----------------------------------------------------------------------
   enddo ! tracer loop
!-----------------------------------------------------------------------

end subroutine horiz_borrow

!#######################################################################

   subroutine vert_borrow (dt, dpde, var, var_dt, iters)

!-----------------------------------------------------------------------
!
!  This removes negative specific humidity/mixing ratios by borrowing
!  from the grid boxes immediately above and below. If not enough
!  is available to fill the negative then a negative will remain.
!
!-----------------------------------------------------------------------
   real, intent(in)    :: dt, dpde(:,:,:), var(:,:,:,:)
   real, intent(inout) :: var_dt(:,:,:,:)
integer, intent(in), optional :: iters(:)
!-----------------------------------------------------------------------
   real, dimension(size(var,3)) :: deficit, surplus, rdpdt
   real :: divid, ratio_dn, ratio_up, var_dp
   integer :: i, j, k, n, m, nlev, num_iters(size(var,4)), num, num_var
!-----------------------------------------------------------------------

   num_iters = 4; if (present(iters)) num_iters = iters
   if (maxval(num_iters) == 0) return

   num_var = size(var,4)
   if (num_var == 0) return
   nlev = size(var,3)

!---- variable loop and iteration loop -----

 do n = 1, num_var
 do m = 1, num_iters(n)

!---- existing negatives will not be corrected ----

   do j = 1, size(var,2)
   do i = 1, size(var,1)

   do k = 1, nlev
      var_dp = (var(i,j,k,n)+dt*var_dt(i,j,k,n))*dpde(i,j,k)
      deficit(k) = min(var_dp,0.0)
      surplus(k) = max(var_dp,0.0)
      rdpdt(k) = 1./(dpde(i,j,k)*dt)
   enddo

!---- top level ----

   if (deficit(1) < 0.0) then
      divid = max(-surplus(2)/deficit(1),1.0)
      ratio_dn = surplus(2)/divid
      var_dt(i,j,1,n) = var_dt(i,j,1,n) + ratio_dn*rdpdt(1)
      var_dt(i,j,2,n) = var_dt(i,j,2,n) - ratio_dn*rdpdt(2)
      surplus(2) = max(surplus(2)-ratio_dn,0.)
   endif

!---- interior levels ----

   do k = 2, nlev-1
     if (deficit(k) < 0.0) then
       divid = max(-(surplus(k-1)+surplus(k+1))/deficit(k),1.0)
       ratio_up = surplus(k-1)/divid
       ratio_dn = surplus(k+1)/divid
       var_dt(i,j,k,n)   = var_dt(i,j,k,n)+(ratio_up+ratio_dn)*rdpdt(k)
       var_dt(i,j,k-1,n) = var_dt(i,j,k-1,n)-ratio_up*rdpdt(k-1)
       var_dt(i,j,k+1,n) = var_dt(i,j,k+1,n)-ratio_dn*rdpdt(k+1)
       surplus(k+1) = max(surplus(k+1)-ratio_dn,0.)
     endif
   enddo

!---- bottom level ----

   if (deficit(nlev) < 0.0) then
      divid = max(-surplus(nlev-1)/deficit(nlev),1.0)
      ratio_up = surplus(nlev-1)/divid
      var_dt(i,j,nlev  ,n) = var_dt(i,j,nlev  ,n)+ratio_up*rdpdt(nlev)
      var_dt(i,j,nlev-1,n) = var_dt(i,j,nlev-1,n)-ratio_up*rdpdt(nlev-1)
   endif

 enddo
 enddo

 enddo
 enddo

!-----------------------------------------------------------------------

   end subroutine vert_borrow

!#######################################################################

subroutine compute_etadot_vel ( Hgrid, Vgrid, Masks, few, fns, etadot )
!subroutine compute_etadot_vel ( Hgrid, Vgrid, Masks, res, few, fns, etadot )

type(horiz_grid_type), intent(in) :: Hgrid
type (vert_grid_type), intent(in) :: Vgrid
type (grid_mask_type), intent(in) :: Masks
!real, intent(in),  dimension(Hgrid%ilb:,Hgrid%jlb:)   :: res
real, intent(in),  dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: few, fns
real, intent(out), dimension(Hgrid%ilb:,Hgrid%jlb:,:) :: etadot

real, dimension(Hgrid%ilb:Hgrid%iub,Hgrid%jlb:Hgrid%jub) :: sdiv
integer :: i, j, k, is, ie, js, je, nlev

! this code will not work with the eta coordinate
! the variable res need to be added as an argument
  if (.not.Masks%sigma) call error_mesg  ('bgrid_advection_mod', &
      'etadot cannot be recomputed for the eta coordinate', FATAL)

  is = Hgrid%Vel%is;  ie = Hgrid%Vel%ie
  js = Hgrid%Vel%js;  je = Hgrid%Vel%je
  nlev = size(few,3)

  etadot = 0.
  sdiv   = 0.

  do k = 1, nlev

      ! vertical integral of divergence at velocity points
      ! only need etadot for velocity compute domain
      do j = js, je
      do i = is, ie
         sdiv(i,j) = sdiv(i,j) + ((few(i+1,j,k)+fns(i,j+1,k))-  &
                                  (few(i  ,j,k)+fns(i,j  ,k)))  &
                                 *Hgrid%Vel%rarea(j)
      enddo
      enddo

      if (k < nlev) etadot(:,:,k+1) = -sdiv(:,:)

   enddo

   ! finally include d(ps)/dt term
   do k = 2, nlev
     !etadot(:,:,k) = etadot(:,:,k) + sdiv(:,:)*res(:,:)*Vgrid%eta(k))
      etadot(:,:,k) = etadot(:,:,k) + sdiv(:,:)*Vgrid%eta(k)
      if (.not.Masks%sigma) etadot(:,:,k) = etadot(:,:,k)*Masks%Vel%mask(:,:,k)
   enddo

end subroutine compute_etadot_vel

!#######################################################################

end module bgrid_advection_mod


module conti_mod
! Konti-Gleichung

USE Variablen
USE derivatives_x_mod
USE derivatives_y_mod
USE derivatives_z_mod
USE neumann_mod
contains

subroutine conti

IMPLICIT NONE
integer::i,j,k
real::rho_0
	!Ableitung rho_u nach x
rho_0=1.293
	CALL Dphi_Dx_p(rho_u,delta_u,qxi_i,qxi_nr,qxi_r)! !Dphi_Dx_p(phi,sphi,qi_i,qi_nr,qi_r,rel)

!	dphi(1:m_local,1:n_local)=solve(1:m_local,1:n_local)

	! Ableitung rho_v nach y
	CALL Dphi_Dy_p(rho_v,delta_v,qyi_i,qyi_nr,qyi_r)

	! Ableitung rho_w nach z
	CALL Dphi_Dz_p(rho_w,delta_w,qzi_i,qzi_nr,qzi_r)
	! neues rho Berechnen

!bc_2
!call bcneu

	rho_neu(1:m_local,1:n_local,1:o_local)=rho(1:m_local,1:n_local,1:o_local)&
-dt*(delta_u(1:m_local,1:n_local,1:o_local)+delta_v(1:m_local,1:n_local,1:o_local)&
+delta_w(1:m_local,1:n_local,1:o_local))

rho_neu(1:m_local,1:n_local,1:o_local)=rho_0
	CALL SYNC_NEIGHBOURS_P	! rho aktuell

	RETURN

end subroutine

end module


SUBROUTINE Bed_Evolution(SSC1)
    USE TEST
    USE FLOATPRECISION
    USE PARAMETERS
    USE DEPTH
    USE GRIDS
    USE ARRAYSIZE
    IMPLICIT NONE
    REAL(FP) , DIMENSION(:,:) , POINTER :: SXP , SXQ
    REAL(FP) :: DT05
    INTEGER :: I , J
    INTEGER :: I0 , J0
    DT05 = 0.5D0*DT

    DO I = ML+1 , MU-1 , 1
        DO J = NL+1 , NU-1 , 1
            IF(NDD(I,J)<=0.D0) THEN
                EVO(I,J) = + (SXP(I,J)-SXP(I,J-1))/DX*DT05 &
                         & + (SXQ(I,J)-SXQ(I-1,J))/DY*DT05
                IF(I>30) THEN
                    DEP0(I,J) = DEP0(I,J) + EVO(I,J)*MORACC
                END IF
                IF(DABS(EVO(I,J))>MAXEVO) THEN
                    MAXEVO = EVO(I,J)
                    MEI = I
                    MEJ = J
                END IF
            END IF
        END DO
    END DO

END SUBROUTINE BED_EVOLUTION


      program newHatoms
      implicit double precision(a-h,o-z)

      real*8, allocatable :: c(:,:)
      character*2, allocatable :: lab(:)
      character*80 filename

      dimension x(3),y(3),z(3),h(3)

      open(unit=1,file='xyzFILENAME',status='old')
      read(1,100)filename
      close(unit=1)
100   format(a80)
      open(unit=1,file=trim(filename),status='old')
      read(1,*)natom
      allocate(lab(natom))
      allocate(c(natom,3))
      read(1,*)
      do n=1,natom
       read(1,*)lab(n),(c(n,k),k=1,3)
      enddo
      close(unit=1)

      read(5,*) n1,n2,n3

      sumx=0.d0
      do k=1,3
       x(k)=c(n1,k)-c(n2,k)
       y(k)=c(n3,k)-c(n2,k)
       sumx=sumx+x(k)**2
      enddo
      sumx=sqrt(sumx)
      do k=1,3
      x(k)=x(k)/sumx
      enddo
      dot=0.d0
      do k=1,3
       dot=dot+x(k)*y(k)
      enddo
      sumy=0.d0
      do k=1,3
       y(k)=y(k)-dot*x(k)
       sumy=sumy+y(k)**2
      enddo
      sumy=sqrt(sumy)
      do k=1,3
       y(k)=y(k)/sumy
      enddo

      z(1)=x(2)*y(3)-x(3)*y(2)
      z(2)=x(3)*y(1)-x(1)*y(3)
      z(3)=x(1)*y(2)-x(2)*y(1)

c     sumx=0.d0
c     sumy=0.d0
c     dot=0.d0
c     do k=1,3
c      sumx=sumx+x(k)**2
c      sumy=sumy+y(k)**2
c      dot=dot+x(k)*y(k)
c     enddo
c     dz=0.d0
c     dot1=0.d0
c     dot2=0.d0
c     do k=1,3
c      dz=dz+z(k)**2
c      dot1=dot1+x(k)*z(k)
c      dot2=dot2+y(k)*z(k)
c     enddo
c     write(6,*)sumx,sumy,dz
c     write(6,*)dot,dot1,dot2

      read(5,*) theta, psi

      pi=2.d0*acos(0.d0)
      theta=theta*pi/180.0
      psi=psi*pi/180.d0
      ct=cos(theta)
      st=sqrt(1.d0-ct**2)
      cp=cos(psi)
      sp=sin(psi)
      do k=1,3
       h(k)=ct*z(k)+st*cp*x(k)+st*sp*y(k)+c(n2,k)
      enddo

c     sumh=0.d0
c      do k=1,3
c       sumh=sumh+h(k)**2
c      enddo
c      write(6,*)sumh

      write(6,200)'H ',(h(k),k=1,3)
200   format(a2,3f13.6)

      end


      subroutine fem_DruckerPrager_stiffness(i, j, D)
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!
! Returns the 6x6 material stiffness (D) matrix for Drucker Prager without cap
! model
!
! Author : Satish Karra
! Date : March 28, 2012
!
      use comsi, only: iPlastic, plasticModel, modelNumber, e1, e2, e3
      use comsi, only: isPlastic, plasticParam1, plastic_strain, du
      use comai, only: iout, iptty, ns
      use comfem

      implicit none
      real*8, dimension(1:6, 1:6)  :: D
      real*8, dimension(6)         :: dev_stress, N, DeN
      real*8, dimension(8)         :: lambda, G
      integer, dimension(8)        :: node
      real*8 lambda_bar, G_bar,  H, NDeN
      real*8 pressure, J2, eta
      integer i, j, k, l, m, itmp, iModel

      lambda_bar = 0.0
      G_bar = 0.0
      NDeN = 0.0
      pressure = 0.0

      if(iPlastic.eq.0) then
        write(iout,*) '***ERROR : elastic stiffness routine called
     &   without plastic flag being set '
      endif

      itmp = modelNumber(elnode(i, 1))
      iModel = plasticModel(itmp)

      eta = plasticParam1(itmp)

      do k = 2,ns
        itmp = modelNumber(elnode(i, k))
        if(iModel.ne.plasticModel(itmp)) then
          write(iout, *) 'Multiple plastic models being used !
     &        Not supported at this time! '
          write(iptty, *) 'Multiple plastic models being used !
     &        Not supported at this time! '
          stop
        endif
      enddo

      do k=1,ns
        node(k) = elnode(i, k)
        lambda(k) = e2(node(k))
        G(k) = 0.5d0*(e1(k) - e2(k))
        lambda_bar = lambda_bar + lambda(k)*Psi(i,j,k)
        G_bar = G_bar + G(k)*Psi(i,j,k)
      enddo

      D = 0.0d0
      if(iModel.eq.3) then
        ! First initialize D to the elastic matrix
        D(1:3, 1:3) = lambda_bar
        D(1,1) = D(1,1) + 2.0d0*G_bar
        D(2,2) = D(2,2) + 2.0d0*G_bar
        D(3,3) = D(3,3) + 2.0d0*G_bar
        D(4,4) = G_bar
        D(5,5) = G_bar
        D(6,6) = G_bar

        if(isPlastic(i,j).eq.1) then
          ! Compute deviatoric stress
          dev_stress = fem_stress(i, j, :)
          pressure = sum(dev_stress(1:3))/3.0d0
          dev_stress(1) = dev_stress(1) - pressure
          dev_stress(2) = dev_stress(2) - pressure
          dev_stress(3) = dev_stress(3) - pressure

          call J2Invariant(J2, dev_stress)

          N(1) = 1/2.d0*sqrt(J2)*dev_stress(1) + eta/3
          N(2) = 1/2.d0*sqrt(J2)*dev_stress(2) + eta/3
          N(3) = 1/2.d0*sqrt(J2)*dev_stress(3) + eta/3
          N(4) = 1/2.d0*sqrt(J2)*dev_stress(4)
          N(5) = 1/2.d0*sqrt(J2)*dev_stress(5)
          N(6) = 1/2.d0*sqrt(J2)*dev_stress(6)

!          N(4) = N(4)*2.0d0
!          N(5) = N(5)*2.0d0
!          N(6) = N(6)*2.0d0

          DeN = matmul(D, N)
          NDeN = sum(N*DeN)

          do l=1,6
            do m=1,6
                D(l,m) = D(l,m) - DeN(l)*DeN(m)/NDeN
            enddo
          enddo

        endif
      else
        write(iout,*) '***ERROR: Drucker Prager stiffness routine called for
     &   a node not set to be Drucker Prager'
      endif

      end subroutine fem_DruckerPrager_stiffness


!***********************************************************************
! Computes the potential evapotranspiration using the Hamon
! formulation (Hamon, 1961)
!***********************************************************************
      MODULE PRMS_POTET_HAMON
        IMPLICIT NONE
        ! Local Variables
        DOUBLE PRECISION, PARAMETER :: ONE_12TH = 1.0D0/12.0D0
        CHARACTER(LEN=11), SAVE :: MODNAME
        ! Declared Parameter
        REAL, SAVE, ALLOCATABLE :: Hamon_coef(:, :)
      END MODULE PRMS_POTET_HAMON

      INTEGER FUNCTION potet_hamon()
      USE PRMS_POTET_HAMON
      USE PRMS_MODULE, ONLY: Process, Nhru
      USE PRMS_BASIN, ONLY: Hru_area, Active_hrus, Hru_route_order, Basin_area_inv
      USE PRMS_CLIMATEVARS, ONLY: Tavgc, Basin_potet, Potet
      USE PRMS_SOLTAB, ONLY: Soltab_sunhrs
      USE PRMS_SET_TIME, ONLY: Nowmonth, Jday
      IMPLICIT NONE
! Functions
      INTRINSIC EXP, DBLE, SNGL
      INTEGER, EXTERNAL :: getparam, declparam
      EXTERNAL read_error, print_module
! Local Variables
      INTEGER :: i, j
      REAL :: dyl, vpsat, vdsat
      CHARACTER(LEN=80), SAVE :: Version_potet
!***********************************************************************
      potet_hamon = 0

      IF ( Process(:3)=='run' ) THEN
!******Compute potential et for each HRU using Hamon formulation
        Basin_potet = 0.0D0
        DO j = 1, Active_hrus
          i = Hru_route_order(j)
! Convert daylength from hours to 12 hour multiple (equal day and night period)
          dyl = SNGL( Soltab_sunhrs(Jday, i)*ONE_12TH )
          vpsat = 6.108*EXP(17.26939*Tavgc(i)/(Tavgc(i)+237.3)) ! in Hamon 1963, eqn. used 273.3??
          vdsat = 216.7*vpsat/(Tavgc(i)+273.3)
          Potet(i) = Hamon_coef(i, Nowmonth)*dyl*dyl*vdsat !??? why day length squared??? Hamon 1963 did not square dyl, it was squared in 1961 original
          ! pet = 0.1651*dyl*vdsat*HC  (default HC would be 1.2 for units mm/day
          ! hamon_coef includes conversion to inches and 0.1651. hamon_coef = x*0.1651/25.4 = x*0.0065 so potet = inches/day
          ! Potet(i) = hamoncoef*0.1651/25.4*dyl*vdsat  1963 version
          IF ( Potet(i)<0.0 ) Potet(i) = 0.0
          Basin_potet = Basin_potet + DBLE( Potet(i)*Hru_area(i) )
        ENDDO
        Basin_potet = Basin_potet*Basin_area_inv

      ELSEIF ( Process(:4)=='decl' ) THEN
        Version_potet = 'potet_hamon.f90 2015-12-04 23:29:08Z'
        CALL print_module(Version_potet, 'Potential Evapotranspiration', 90)
        MODNAME = 'potet_hamon'

        ALLOCATE ( Hamon_coef(Nhru,12) )
        IF ( declparam(MODNAME, 'hamon_coef', 'nhru,nmonths', 'real', &
     &       '0.0055', '0.004', '0.008', &
     &       'Monthly air temperature coefficient - Hamon', &
     &       'Monthly (January to December) air temperature coefficient used in Hamon potential ET computations for each HRU', &
     &       'none')/=0 ) CALL read_error(1, 'hamon_coef')

!******Get parameters
      ELSEIF ( Process(:4)=='init' ) THEN
        IF ( getparam(MODNAME, 'hamon_coef', Nhru*12, 'real', Hamon_coef)/=0 ) CALL read_error(2, 'hamon_coef')
      ENDIF

      END FUNCTION potet_hamon


*> \brief \b CGEQRT2 computes a QR factorization of a general real or complex matrix using the compact WY representation of Q.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CGEQRT2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE CGEQRT2( M, N, A, LDA, T, LDT, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER   INFO, LDA, LDT, M, N
*       ..
*       .. Array Arguments ..
*       COMPLEX   A( LDA, * ), T( LDT, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CGEQRT2 computes a QR factorization of a complex M-by-N matrix A,
*> using the compact WY representation of Q.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= N.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is COMPLEX array, dimension (LDA,N)
*>          On entry, the complex M-by-N matrix A.  On exit, the elements on and
*>          above the diagonal contain the N-by-N upper triangular matrix R; the
*>          elements below the diagonal are the columns of V.  See below for
*>          further details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*>          T is COMPLEX array, dimension (LDT,N)
*>          The N-by-N upper triangular factor of the block reflector.
*>          The elements on and above the diagonal contain the block
*>          reflector T; the elements below the diagonal are not used.
*>          See below for further details.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*>          LDT is INTEGER
*>          The leading dimension of the array T.  LDT >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0: successful exit
*>          < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complexGEcomputational
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The matrix V stores the elementary reflectors H(i) in the i-th column
*>  below the diagonal. For example, if M=5 and N=3, the matrix V is
*>
*>               V = (  1       )
*>                   ( v1  1    )
*>                   ( v1 v2  1 )
*>                   ( v1 v2 v3 )
*>                   ( v1 v2 v3 )
*>
*>  where the vi's represent the vectors which define H(i), which are returned
*>  in the matrix A.  The 1's along the diagonal of V are not stored in A.  The
*>  block reflector H is then given by
*>
*>               H = I - V * T * V**H
*>
*>  where V**H is the conjugate transpose of V.
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE CGEQRT2( M, N, A, LDA, T, LDT, INFO )
*
*  -- LAPACK computational routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      INTEGER   INFO, LDA, LDT, M, N
*     ..
*     .. Array Arguments ..
      COMPLEX   A( LDA, * ), T( LDT, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX  ONE, ZERO
      PARAMETER( ONE = (1.0,0.0), ZERO = (0.0,0.0) )
*     ..
*     .. Local Scalars ..
      INTEGER   I, K
      COMPLEX   AII, ALPHA
*     ..
*     .. External Subroutines ..
      EXTERNAL  CLARFG, CGEMV, CGERC, CTRMV, XERBLA
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGEQRT2', -INFO )
         RETURN
      END IF
*
      K = MIN( M, N )
*
      DO I = 1, K
*
*        Generate elem. refl. H(i) to annihilate A(i+1:m,i), tau(I) -> T(I,1)
*
         CALL CLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
     $                T( I, 1 ) )
         IF( I.LT.N ) THEN
*
*           Apply H(i) to A(I:M,I+1:N) from the left
*
            AII = A( I, I )
            A( I, I ) = ONE
*
*           W(1:N-I) := A(I:M,I+1:N)**H * A(I:M,I) [W = T(:,N)]
*
            CALL CGEMV( 'C',M-I+1, N-I, ONE, A( I, I+1 ), LDA,
     $                  A( I, I ), 1, ZERO, T( 1, N ), 1 )
*
*           A(I:M,I+1:N) = A(I:m,I+1:N) + alpha*A(I:M,I)*W(1:N-1)**H
*
            ALPHA = -CONJG(T( I, 1 ))
            CALL CGERC( M-I+1, N-I, ALPHA, A( I, I ), 1,
     $           T( 1, N ), 1, A( I, I+1 ), LDA )
            A( I, I ) = AII
         END IF
      END DO
*
      DO I = 2, N
         AII = A( I, I )
         A( I, I ) = ONE
*
*        T(1:I-1,I) := alpha * A(I:M,1:I-1)**H * A(I:M,I)
*
         ALPHA = -T( I, 1 )
         CALL CGEMV( 'C', M-I+1, I-1, ALPHA, A( I, 1 ), LDA,
     $               A( I, I ), 1, ZERO, T( 1, I ), 1 )
         A( I, I ) = AII
*
*        T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I)
*
         CALL CTRMV( 'U', 'N', 'N', I-1, T, LDT, T( 1, I ), 1 )
*
*           T(I,I) = tau(I)
*
            T( I, I ) = T( I, 1 )
            T( I, 1) = ZERO
      END DO

*
*     End of CGEQRT2
*
      END


*> \brief \b SGEQR
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGEQR( M, N, A, LDA, T, TSIZE, WORK, LWORK,
*                         INFO )
*
*       .. Scalar Arguments ..
*       INTEGER           INFO, LDA, M, N, TSIZE, LWORK
*       ..
*       .. Array Arguments ..
*       REAL              A( LDA, * ), T( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*> SGEQR computes a QR factorization of an M-by-N matrix A.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          On entry, the M-by-N matrix A.
*>          On exit, the elements on and above the diagonal of the array
*>          contain the min(M,N)-by-N upper trapezoidal matrix R
*>          (R is upper triangular if M >= N);
*>          the elements below the diagonal are used to store part of the
*>          data structure to represent Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*>          T is REAL array, dimension (MAX(5,TSIZE))
*>          On exit, if INFO = 0, T(1) returns optimal (or either minimal
*>          or optimal, if query is assumed) TSIZE. See TSIZE for details.
*>          Remaining T contains part of the data structure used to represent Q.
*>          If one wants to apply or construct Q, then one needs to keep T
*>          (in addition to A) and pass it to further subroutines.
*> \endverbatim
*>
*> \param[in] TSIZE
*> \verbatim
*>          TSIZE is INTEGER
*>          If TSIZE >= 5, the dimension of the array T.
*>          If TSIZE = -1 or -2, then a workspace query is assumed. The routine
*>          only calculates the sizes of the T and WORK arrays, returns these
*>          values as the first entries of the T and WORK arrays, and no error
*>          message related to T or WORK is issued by XERBLA.
*>          If TSIZE = -1, the routine calculates optimal size of T for the
*>          optimum performance and returns this value in T(1).
*>          If TSIZE = -2, the routine calculates minimal size of T and
*>          returns this value in T(1).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          (workspace) REAL array, dimension (MAX(1,LWORK))
*>          On exit, if INFO = 0, WORK(1) contains optimal (or either minimal
*>          or optimal, if query was assumed) LWORK.
*>          See LWORK for details.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK.
*>          If LWORK = -1 or -2, then a workspace query is assumed. The routine
*>          only calculates the sizes of the T and WORK arrays, returns these
*>          values as the first entries of the T and WORK arrays, and no error
*>          message related to T or WORK is issued by XERBLA.
*>          If LWORK = -1, the routine calculates optimal size of WORK for the
*>          optimal performance and returns this value in WORK(1).
*>          If LWORK = -2, the routine calculates minimal size of WORK and
*>          returns this value in WORK(1).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \par Further Details
*  ====================
*>
*> \verbatim
*>
*> The goal of the interface is to give maximum freedom to the developers for
*> creating any QR factorization algorithm they wish. The triangular
*> (trapezoidal) R has to be stored in the upper part of A. The lower part of A
*> and the array T can be used to store any relevant information for applying or
*> constructing the Q factor. The WORK array can safely be discarded after exit.
*>
*> Caution: One should not expect the sizes of T and WORK to be the same from one
*> LAPACK implementation to the other, or even from one execution to the other.
*> A workspace query (for T and WORK) is needed at each execution. However,
*> for a given execution, the size of T and WORK are fixed and will not change
*> from one query to the next.
*>
*> \endverbatim
*>
*> \par Further Details particular to this LAPACK implementation:
*  ==============================================================
*>
*> \verbatim
*>
*> These details are particular for this LAPACK implementation. Users should not
*> take them for granted. These details may change in the future, and are not likely
*> true for another LAPACK implementation. These details are relevant if one wants
*> to try to understand the code. They are not part of the interface.
*>
*> In this version,
*>
*>          T(2): row block size (MB)
*>          T(3): column block size (NB)
*>          T(6:TSIZE): data structure needed for Q, computed by
*>                           SLATSQR or SGEQRT
*>
*>  Depending on the matrix dimensions M and N, and row and column
*>  block sizes MB and NB returned by ILAENV, SGEQR will use either
*>  SLATSQR (if the matrix is tall-and-skinny) or SGEQRT to compute
*>  the QR factorization.
*>
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE SGEQR( M, N, A, LDA, T, TSIZE, WORK, LWORK,
     $                  INFO )
*
*  -- LAPACK computational routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
*     December 2016
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N, TSIZE, LWORK
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), T( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY, LMINWS, MINT, MINW
      INTEGER            MB, NB, MINTSZ, NBLCKS
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLATSQR, SGEQRT, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, MOD
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Executable statements ..
*
*     Test the input arguments
*
      INFO = 0
*
      LQUERY = ( TSIZE.EQ.-1 .OR. TSIZE.EQ.-2 .OR.
     $           LWORK.EQ.-1 .OR. LWORK.EQ.-2 )
*
      MINT = .FALSE.
      MINW = .FALSE.
      IF( TSIZE.EQ.-2 .OR. LWORK.EQ.-2 ) THEN
        IF( TSIZE.NE.-1 ) MINT = .TRUE.
        IF( LWORK.NE.-1 ) MINW = .TRUE.
      END IF
*
*     Determine the block size
*
      IF( MIN( M, N ).GT.0 ) THEN
        MB = ILAENV( 1, 'SGEQR ', ' ', M, N, 1, -1 )
        NB = ILAENV( 1, 'SGEQR ', ' ', M, N, 2, -1 )
      ELSE
        MB = M
        NB = 1
      END IF
      IF( MB.GT.M .OR. MB.LE.N ) MB = M
      IF( NB.GT.MIN( M, N ) .OR. NB.LT.1 ) NB = 1
      MINTSZ = N + 5
      IF ( MB.GT.N .AND. M.GT.N ) THEN
        IF( MOD( M - N, MB - N ).EQ.0 ) THEN
          NBLCKS = ( M - N ) / ( MB - N )
        ELSE
          NBLCKS = ( M - N ) / ( MB - N ) + 1
        END IF
      ELSE
        NBLCKS = 1
      END IF
*
*     Determine if the workspace size satisfies minimal size
*
      LMINWS = .FALSE.
      IF( ( TSIZE.LT.MAX( 1, NB*N*NBLCKS + 5 ) .OR. LWORK.LT.NB*N )
     $    .AND. ( LWORK.GE.N ) .AND. ( TSIZE.GE.MINTSZ )
     $    .AND. ( .NOT.LQUERY ) ) THEN
        IF( TSIZE.LT.MAX( 1, NB*N*NBLCKS + 5 ) ) THEN
          LMINWS = .TRUE.
          NB = 1
          MB = M
        END IF
        IF( LWORK.LT.NB*N ) THEN
          LMINWS = .TRUE.
          NB = 1
        END IF
      END IF
*
      IF( M.LT.0 ) THEN
        INFO = -1
      ELSE IF( N.LT.0 ) THEN
        INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
        INFO = -4
      ELSE IF( TSIZE.LT.MAX( 1, NB*N*NBLCKS + 5 )
     $   .AND. ( .NOT.LQUERY ) .AND. ( .NOT.LMINWS ) ) THEN
        INFO = -6
      ELSE IF( ( LWORK.LT.MAX( 1, N*NB ) ) .AND. ( .NOT.LQUERY )
     $   .AND. ( .NOT.LMINWS ) ) THEN
        INFO = -8
      END IF
*
      IF( INFO.EQ.0 ) THEN
        IF( MINT ) THEN
          T( 1 ) = MINTSZ
        ELSE
          T( 1 ) = NB*N*NBLCKS + 5
        END IF
        T( 2 ) = MB
        T( 3 ) = NB
        IF( MINW ) THEN
          WORK( 1 ) = MAX( 1, N )
        ELSE
          WORK( 1 ) = MAX( 1, NB*N )
        END IF
      END IF
      IF( INFO.NE.0 ) THEN
        CALL XERBLA( 'SGEQR', -INFO )
        RETURN
      ELSE IF( LQUERY ) THEN
        RETURN
      END IF
*
*     Quick return if possible
*
      IF( MIN( M, N ).EQ.0 ) THEN
        RETURN
      END IF
*
*     The QR Decomposition
*
      IF( ( M.LE.N ) .OR. ( MB.LE.N ) .OR. ( MB.GE.M ) ) THEN
        CALL SGEQRT( M, N, NB, A, LDA, T( 6 ), NB, WORK, INFO )
      ELSE
        CALL SLATSQR( M, N, MB, NB, A, LDA, T( 6 ), NB, WORK,
     $                LWORK, INFO )
      END IF
*
      WORK( 1 ) = MAX( 1, NB*N )
*
      RETURN
*
*     End of SGEQR
*
      END


      SUBROUTINE MB02UV( N, A, LDA, IPIV, JPIV, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute an LU factorization, using complete pivoting, of the
C     N-by-N matrix A. The factorization has the form A = P * L * U * Q,
C     where P and Q are permutation matrices, L is lower triangular with
C     unit diagonal elements and U is upper triangular.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A to be factored.
C             On exit, the leading N-by-N part of this array contains
C             the factors L and U from the factorization A = P*L*U*Q;
C             the unit diagonal elements of L are not stored. If U(k, k)
C             appears to be less than SMIN, U(k, k) is given the value
C             of SMIN, giving a nonsingular perturbed system.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1, N).
C
C     IPIV    (output) INTEGER array, dimension (N)
C             The pivot indices; for 1 <= i <= N, row i of the
C             matrix has been interchanged with row IPIV(i).
C
C     JPIV    (output) INTEGER array, dimension (N)
C             The pivot indices; for 1 <= j <= N, column j of the
C             matrix has been interchanged with column JPIV(j).
C
C     Error indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             = k:  U(k, k) is likely to produce owerflow if one tries
C                   to solve for x in Ax = b. So U is perturbed to get
C                   a nonsingular system. This is a warning.
C
C     FURTHER COMMENTS
C
C     In the interests of speed, this routine does not check the input
C     for errors. It should only be used to factorize matrices A of
C     very small order.
C
C     CONTRIBUTOR
C
C     Bo Kagstrom and Peter Poromaa, Univ. of Umea, Sweden, Nov. 1993.
C
C     REVISIONS
C
C     April 1998 (T. Penzl).
C     Sep. 1998 (V. Sima).
C     March 1999 (V. Sima).
C     March 2004 (V. Sima).
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, N
C     .. Array Arguments ..
      INTEGER            IPIV( * ), JPIV( * )
      DOUBLE PRECISION   A( LDA, * )
C     .. Local Scalars ..
      INTEGER            I, IP, IPV, JP, JPV
      DOUBLE PRECISION   BIGNUM, EPS, SMIN, SMLNUM, XMAX
C     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
C     .. External Subroutines ..
      EXTERNAL           DGER, DLABAD, DSCAL, DSWAP
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
C     .. Executable Statements ..
C
C     Set constants to control owerflow.

      INFO = 0
      EPS    = DLAMCH( 'Precision' )
      SMLNUM = DLAMCH( 'Safe minimum' ) / EPS
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
C
C     Find max element in matrix A.
C
      IPV = 1
      JPV = 1
      XMAX = ZERO
      DO 40 JP = 1, N
         DO 20 IP = 1, N
            IF ( ABS( A(IP, JP) ) .GT. XMAX ) THEN
               XMAX = ABS( A(IP, JP) )
               IPV  = IP
               JPV  = JP
            ENDIF
   20    CONTINUE
   40 CONTINUE
      SMIN =  MAX( EPS * XMAX, SMLNUM )
C
C     Swap rows.
C
      IF ( IPV .NE. 1 ) CALL DSWAP( N, A(IPV, 1), LDA, A(1, 1), LDA )
      IPIV(1) = IPV
C
C     Swap columns.
C
      IF ( JPV .NE. 1 ) CALL DSWAP( N, A(1, JPV), 1, A(1, 1), 1 )
      JPIV(1) = JPV
C
C     Check for singularity.
C
      IF ( ABS( A(1, 1) ) .LT. SMIN ) THEN
         INFO = 1
         A(1, 1) = SMIN
      ENDIF
      IF ( N.GT.1 ) THEN
         CALL DSCAL( N - 1, ONE / A(1, 1), A(2, 1), 1 )
         CALL DGER( N - 1, N - 1, -ONE, A(2, 1), 1, A(1, 2), LDA,
     $              A(2, 2), LDA )
      ENDIF
C
C     Factorize the rest of A with complete pivoting.
C     Set pivots less than SMIN to SMIN.
C
      DO 100 I = 2, N - 1
C
C        Find max element in remaining matrix.
C
         IPV = I
         JPV = I
         XMAX = ZERO
         DO 80 JP = I, N
            DO 60 IP = I, N
               IF ( ABS( A(IP, JP) ) .GT. XMAX ) THEN
                  XMAX = ABS( A(IP, JP) )
                  IPV = IP
                  JPV = JP
               ENDIF
   60       CONTINUE
   80    CONTINUE
C
C        Swap rows.
C
         IF ( IPV .NE. I ) CALL DSWAP( N, A(IPV, 1), LDA, A(I, 1), LDA )
         IPIV(I) = IPV
C
C        Swap columns.
C
         IF ( JPV .NE. I ) CALL DSWAP( N, A(1, JPV), 1, A(1, I), 1 )
         JPIV(I) = JPV
C
C        Check for almost singularity.
C
         IF ( ABS( A(I, I) ) .LT. SMIN ) THEN
            INFO = I
            A(I, I) = SMIN
         ENDIF
         CALL DSCAL( N - I, ONE / A(I, I), A(I + 1, I), 1 )
         CALL DGER( N - I, N - I, -ONE, A(I + 1, I), 1, A(I, I + 1),
     $              LDA, A(I + 1, I + 1), LDA )
  100 CONTINUE
      IF ( ABS( A(N, N) ) .LT. SMIN ) THEN
         INFO = N
         A(N, N) = SMIN
      ENDIF
C
      RETURN
C *** Last line of MB02UV ***
      END