!========================================================================
!
!                          T o m o f a s t - x
!                        -----------------------
!
!              Main authors: Vitaliy Ogarko, Roland Martin,
!                   Jeremie Giraud, Dimitri Komatitsch.
!
! (c) CNRS, France, and University of Western Australia. January 2018
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

!======================================================================================================
! In the Finite Volume formulation one has the nodes of the unknowns located at the center of a cell,
! and the nodes of the fluxes located in the middle of each edge of the cell.
! Permittivities are defined at the same location at a corner of a cell.
! It is necessary to do that because one can not impose two different permittivities
! at a sharp interface of the tube (at the electrodes and at i = i1).
!======================================================================================================
module geometry

  use global_typedefs
  use parameters_ect

  implicit none

  private

  public :: get_refined_ntheta
  public :: set_geometry
  public :: compute_grid_coordinates
  public :: compute_shifted_grid_coordinates
  public :: refine_geometry
  public :: calculate_cell_volumes

  private :: calc_electrode_coordinates

contains

!========================================================
! Returns the number of points per electrode.
!========================================================
function get_npelec(ntheta, nel)
  integer, intent(in) :: ntheta, nel
  integer :: get_npelec

  get_npelec = 2*ntheta/nel/3
  return
end function get_npelec

!========================================================
! Returns the number of points per gaps.
!========================================================
function get_npgaps(ntheta, nel)
  integer, intent(in) :: ntheta, nel
  integer :: get_npgaps

  get_npgaps = ntheta/nel - get_npelec(ntheta, nel)
  return
end function get_npgaps

!========================================================
! Returns the ntheta for the refined mesh.
!========================================================
function get_refined_ntheta(ntheta, nel)
  integer, intent(in) :: ntheta, nel
  integer :: get_refined_ntheta

  get_refined_ntheta = ntheta + get_npelec(ntheta,nel)-1 + 2*(get_npgaps(ntheta,nel)+1)
  return
end function get_refined_ntheta

!=============================================================================================
! Calculate the bottom and top (z-direction) grid coordinates of the electrodes.
!=============================================================================================
subroutine calc_electrode_coordinates(nrings, nel, kguards, elecs)
  integer, intent(in) :: nrings, nel, kguards
  type(t_electrode), intent(inout) :: elecs(:)

  integer :: ielectrode
  integer :: height, iring

  ! TODO: Add (vertical) gaps between the rings.

  if (mod(2 * kguards, nrings) /= 0) then
    print *, "2 * kguards is not a multiple of nrings; exiting..."
    stop
  endif

  if (mod(nel, nrings) /= 0) then
    print *, "nel is not a multiple of nrings; exiting..."
    stop
  endif

  height = 2 * kguards / nrings

  do ielectrode = 1, nel
    ! The ring number to which this electrode belongs, e.g.,
    ! 1-12 electrodes belong to the 1st rings, 13-24 electrodes to the 2nd ring etc.
    iring = (ielectrode - 1) / (nel / nrings) + 1

    elecs(ielectrode)%izmin = kguards + 1 + (iring - 1) * height
    elecs(ielectrode)%izmax = elecs(ielectrode)%izmin + height - 1

    !print *, '---->', ielectrode, iring, elecs(ielectrode)%izmin, elecs(ielectrode)%izmax
  enddo

end subroutine calc_electrode_coordinates

!=============================================================================================
! Sets the system geometry.
!=============================================================================================
subroutine set_geometry(ilevel, par, nr, ntheta, nz, r, dr, theta, dz, z, izspace, kguards, &
                        i1, i2, elecs, guards)
  ! Parameters.
  type(t_parameters_ect), intent(in) :: par
  ! Dimensions (locally).
  integer, intent(in) :: nr, ntheta, nz, kguards
  integer, intent(in) :: ilevel
  ! theta, r and z angle, radius and size of each point, step along r and z
  real(kind=CUSTOM_REAL), intent(out) :: r(0:)
  real(kind=CUSTOM_REAL), intent(out) :: dr(0:)
  real(kind=CUSTOM_REAL), intent(out) :: theta(0:)
  real(kind=CUSTOM_REAL), intent(out) :: dz(0:)
  real(kind=CUSTOM_REAL), intent(out) :: z(0:)
  integer, intent(out) :: izspace
  integer, intent(out) :: i1, i2
  type(t_electrode), intent(out) :: elecs(:)
  type(t_guards), intent(out) :: guards

  ! Local variables --------------------------------------
  real(kind=CUSTOM_REAL) :: dtheta_elec, dtheta_gap, heiguard
  real(kind=CUSTOM_REAL) :: dr1, dr2, dr3, dz1, dz2, dz3, dz4, dz5
  integer :: i, j, k, i1_read, i2_read
  integer :: npelec, npgaps, ielec, ielectrode, jelectrode
  integer :: nr1, nr2
  integer :: igaps_on_theta,igaps_on_z
  integer :: jleft
  integer :: nelr

  !=======================================================
  ! Compute radii.
  !=======================================================

  if (par%ifixed_elecgeo == 1) then
    nr1 = int(par%sens%radiusin * par%dims%nr / par%sens%radiusoutout)
    nr2 = int((par%sens%radiusout - par%sens%radiusin) * par%dims%nr / par%sens%radiusoutout)
    i1_read = nr1-mod(nr1,8)
    i2_read = i1_read+nr2-mod(nr2,8)
    nr1 = i1_read
    nr2 = i2_read

    i1 = i1_read/2**(ilevel-1)
    i2 = i2_read/2**(ilevel-1)
    nr1 = i1
    nr2 = i2
  else
    i2 = 8*nr/9
    i1 = 3*i2/4
    nr1 = i1
    nr2 = i2
  endif

! VO VO RM RM 6 Jan 2015 fixed the mapping according to Mapping #3 in the document Mappings.pdf
! VO VO RM RM cell index i --> radius index 2i-1,
! VO VO RM RM with ghost points i=0 and i=nr+1 separated by 2dr from regular points i=1 and i=nr.
! VO VO RM RM To be consistent with matrix_init and r(2i1-1)=R1, r(2i2-1)=R2 and r(2(nr+1)-1)=R3
  dr1 = (par%sens%radiusin) / dble(2*nr1)
  dr2 = (par%sens%radiusout - par%sens%radiusin) / dble(2*nr2-2*nr1)
  dr3 = (par%sens%radiusoutout - par%sens%radiusout) / dble(2*nr-2*nr2+2)

  do i=0,2*i1-1
    r(i) = dr1+dble(i)*dr1
  enddo

  do i=2*i1,2*i2-1
    r(i) = par%sens%radiusin+dble(i-2*nr1+1)*dr2
  enddo

  do i=2*i2,2*nr+1
    r(i) = par%sens%radiusout+dble(i-2*nr2+1)*dr3
  enddo
! VO VO RM RM 6 Jan 2015 End of the fix.

   !Set equal dr everywhere.
!  do i=0,2*nr+1
!    r(i) = dble(i)*sens%radiusoutout/dble(2*nr+1)
!  enddo

! VO VO 9 Jan fixed dr(0)=r(0)-r(-1) according to radius index Mapping #3.
  dr(0) = r(0)
  do i=1,2*nr+1
    dr(i) = r(i)-r(i-1)
  enddo

  !=======================================================
  ! Compute theta angles.
  !=======================================================

  ! Number of electrodes per ring.
  nelr = par%nel / par%nrings

  igaps_on_theta = nint(par%sens%space_electrodes)
  !if (myrank == 0) print *,'ilevel, igaps_on_theta=', ilevel, igaps_on_theta

! VO VO 8 Jan 2015 Fixed to have the same angle at the tips of electrodes at different level.
! VO VO 8 Jan 2015 Added unit tests for this check marked with (***)
! VO VO 8 Jan 2015 Made the calculation robust, i.e., avoiding iterative summation in the loop.
! VO VO 14 Jan 2015 Made sure that there is at least one point on the gap, i.e., a point without Dirichlet BCs.
! VO VO So for ntheta=36 electrode points will be 1-2, 4-5, 7-8, etc.
  if (igaps_on_theta /= 0) then
    ! The number of points per electrode.
    npelec = get_npelec(ntheta, nelr)
    ! The number of points per gap, i.e., points without Dirichlet BCs.
    npgaps = get_npgaps(ntheta, nelr)
    ! Compute angles.
    dtheta_elec = (2._CUSTOM_REAL*PI/nelr - par%sens%space_electrodes*PI/180._CUSTOM_REAL) / dble(npelec-1)
    dtheta_gap = par%sens%space_electrodes*PI/180._CUSTOM_REAL / dble(npgaps+1)

    theta(0) = dtheta_gap
    do j=1,ntheta+1
      ielec = (j-1) / (npelec+npgaps)
      jleft = (j-1) - ielec*(npelec+npgaps)

      if (jleft <= npelec-1) then
        theta(j) = -2._CUSTOM_REAL*PI/nelr*ielec - dtheta_elec*jleft
      else
        theta(j) = -2._CUSTOM_REAL*PI/nelr*ielec - dtheta_elec*(npelec-1) - dtheta_gap*(jleft-npelec+1)
      endif
    enddo

    ! Calculate the first and the last indices in the theta-array for the electrodes.
    do ielectrode=1,nelr
      elecs(ielectrode)%ithetamin = (ielectrode-1)*(npelec+npgaps)+1
      elecs(ielectrode)%ithetamax = (ielectrode-1)*(npelec+npgaps)+npelec
    enddo
! VO VO 14 Jan 2015 End of the fix.

  else
    ! The number of points per electrode.
    npelec = ntheta/nelr
    ! Compute angle.
    dtheta_elec = (2._CUSTOM_REAL*PI/nelr)/dble(npelec)

    do j=0,ntheta+1
      theta(j) = dtheta_elec*dble(1-j)
    enddo

    ! Calculate the first and the last indices in the theta-array for the electrodes.
    do ielectrode=1,nelr
      elecs(ielectrode)%ithetamin = (ielectrode-1)*(npelec)+1
      elecs(ielectrode)%ithetamax = (ielectrode-1)*(npelec)+npelec
    enddo
  endif
! VO VO 8 Jan 2015 End of the fix.

  if (par%nrings > 1) then
  ! Copy the theta angles from the first to the other electrode rings.
    do ielectrode = nelr + 1, par%nel
      jelectrode = mod(ielectrode, nelr)
      if (jelectrode == 0) jelectrode = nelr

      elecs(ielectrode)%ithetamin = elecs(jelectrode)%ithetamin
      elecs(ielectrode)%ithetamax = elecs(jelectrode)%ithetamax
    enddo
  endif

  !-------------------------------------------------------------------
  ! Calculate top and bottom z-coordinates of the electrodes.
  !-------------------------------------------------------------------
  call calc_electrode_coordinates(par%nrings, par%nel, kguards, elecs)

  !=======================================================
  ! Compute height interval along z-axis, and spacing.
  !=======================================================

! VO VO 13 Jan 2015 Fixed problems of different electrode top and bottom position at different levels.
  igaps_on_z = nint(par%sens%space_elec_guards / (par%sens%heicyl/dble(nz+1)))

  if (igaps_on_z /= 0) then

    ! izspace = the number of points on the gap, i.e., those which will not get any Dirichlet BCs.
    if (par%ifixed_elecgeo == 1) then
      izspace = par%dims%nz/36 / 2**(ilevel-1)
    else
      izspace = igaps_on_z
    endif

    dz1 = (0.25_CUSTOM_REAL*par%sens%heicyl - par%sens%space_elec_guards) / dble(kguards+1-izspace-1)
    dz2 = par%sens%space_elec_guards / dble(izspace+1)
    dz3 = 0.5_CUSTOM_REAL*par%sens%heicyl / dble(3*kguards-kguards-1)
    dz4 = dz2
    dz5 = dz1

    ! lower guard.
    do k=0,kguards+1-izspace-1
      dz(k) = dz1
      z(k)  = dble(k)*dz1
    enddo

    ! lower gap.
    do k=kguards+1-izspace,kguards+1
      dz(k) = dz2
      z(k)  = (0.25_CUSTOM_REAL*par%sens%heicyl - par%sens%space_elec_guards) + dble(k-kguards+izspace)*dz2
    enddo

    ! electrode.
    do k=kguards+2,3*kguards
      dz(k) = dz3
      z(k)  = 0.25_CUSTOM_REAL*par%sens%heicyl + dble(k-kguards-1)*dz3
    enddo

    ! upper gap.
    do k=3*kguards+1,3*kguards+izspace+1
      dz(k) = dz4
      z(k)  = 0.75_CUSTOM_REAL*par%sens%heicyl + dble(k-3*kguards)*dz4
    enddo

    ! upper guard.
    do k=3*kguards+izspace+2,nz+1
      dz(k) = dz5
      z(k)  = (0.75_CUSTOM_REAL*par%sens%heicyl + par%sens%space_elec_guards) + dble(k-3*kguards-izspace-1)*dz5
    enddo
! VO VO 13 Jan 2015 End of the fix.

  else
! VO VO 9 Jan 2015 Fixed problems of different electrode top and bottom position at different levels.
    izspace = 0

    ! The guard height.
    heiguard = 0.25_CUSTOM_REAL*par%sens%heicyl

    dz1 = heiguard/dble(kguards+1)
    dz2 = (par%sens%heicyl-2._CUSTOM_REAL*heiguard) / dble(3*kguards-kguards-1)
    dz3 = dz1

    do k=0,kguards+1
      dz(k) = dz1
      z(k)  = dble(k)*dz1
    enddo

    do k=kguards+2,3*kguards
      dz(k) = dz2
      z(k)  = heiguard + dble(k-kguards-1)*dz2
    enddo

    do k=3*kguards+1,nz+1
      dz(k) = dz3
      z(k)  = (par%sens%heicyl - heiguard) + dble(k-3*kguards)*dz3
    enddo
! VO VO 9 Jan 2015 End of the fix.
  endif

  !------------------------------------------------------------------
  ! Calculate the z grid coordinates for the guards.
  guards%lower_izmax = kguards+1-izspace-1
  guards%upper_izmin = 3*kguards+izspace+1

end subroutine set_geometry

!===========================================================================================
! Compute grid coordinates.
! This grid is used for model initialization and visualization.
!===========================================================================================
subroutine compute_grid_coordinates(nr, ntheta, nz, r, theta, z, xgrid, ygrid, zgrid)
  integer, intent(in) :: nr, ntheta, nz
  real(kind=CUSTOM_REAL), intent(in) :: r(0:)
  real(kind=CUSTOM_REAL), intent(in) :: theta(0:)
  real(kind=CUSTOM_REAL), intent(in) :: z(0:)

  real(kind=CUSTOM_REAL), intent(out) :: xgrid(0:,0:,0:)
  real(kind=CUSTOM_REAL), intent(out) :: ygrid(0:,0:,0:)
  real(kind=CUSTOM_REAL), intent(out) :: zgrid(0:,0:,0:)

  ! Local variables.
  integer :: i,j,k
  real(kind=CUSTOM_REAL), allocatable :: x(:,:)
  real(kind=CUSTOM_REAL), allocatable :: y(:,:)

  allocate(x(0:2*nr+1,0:ntheta+1))
  allocate(y(0:2*nr+1,0:ntheta+1))

  ! x-y-z coordinates of r-theta points
  do j=0,ntheta+1
    do i=0,2*nr+1
      x(i,j) = r(i)*cos(theta(j))
      y(i,j) = r(i)*sin(theta(j))
    enddo
  enddo

  ! x-y-z coordinates of r-theta points 1 over 2 points
  ! DG DG and DK DK: create a cutplane in (r,theta) direction, and extend
  ! it in the z direction
  ! DG DG and DK DK: staggered grid, thus only use corner points
  ! VO VO 6 Jan 2015 fixed according to the new, correct radii indices mapping i-->2*i-1
  do k=0,nz+1
    do j=0,ntheta+1
      xgrid(0,j,k) = 0._CUSTOM_REAL
      ygrid(0,j,k) = 0._CUSTOM_REAL
      zgrid(0,j,k) = z(k)

      do i=1,nr+1
        xgrid(i,j,k) = x(2*i-1,j)
        ygrid(i,j,k) = y(2*i-1,j)
        zgrid(i,j,k) = z(k)
      enddo
    enddo
  enddo

  deallocate(x)
  deallocate(y)

end subroutine compute_grid_coordinates

!===========================================================================================
! Calculate the volume of the cells which is used to calculate the sensitivity or
! to scale the columns of the sensitivity matrix and the model.
!===========================================================================================
subroutine calculate_cell_volumes(dims, volume, volume_avg, r, theta, z, myrank, nbproc)
  type(t_dimensions), intent(in) :: dims
  real(kind=CUSTOM_REAL), intent(in) :: r(0:)
  real(kind=CUSTOM_REAL), intent(in) :: theta(0:)
  real(kind=CUSTOM_REAL), intent(in) :: z(0:)
  integer, intent(in) :: myrank, nbproc

  real(kind=CUSTOM_REAL), intent(out) :: volume(:,:,:)
  real(kind=CUSTOM_REAL), intent(out) :: volume_avg

  integer :: i,j,k,k1
  real(kind=CUSTOM_REAL) :: dz,dtheta
  integer :: n_avg

  volume_avg = 0._CUSTOM_REAL
  n_avg = 0

  do k=1,dims%nzlocal + (myrank+1)/nbproc
    k1 = myrank*dims%nzlocal+k
    dz = z(k1)-z(k1-1)

    do j=1,dims%ntheta
      dtheta = abs(theta(j+1)-theta(j))

      do i=1,dims%nr+1
        if (i == 1) then
          ! Initialize also these elements (not used). Note that r(-1) = 0 by definition.
          volume(i,j,k) = 0.5_CUSTOM_REAL * r(2*i-1)**2 * dtheta * dz
        else
          volume(i,j,k) = 0.5_CUSTOM_REAL * (r(2*i-1)**2 - r(2*i-3)**2) * dtheta * dz
        endif

        volume_avg = volume_avg + volume(i,j,k)
        n_avg = n_avg + 1
      enddo
    enddo
  enddo

  ! TODO: Gather volume_avg for parallel version.
  volume_avg = volume_avg / dble(n_avg)

end subroutine calculate_cell_volumes

!===========================================================================================
! Shift grid coordinates to the nodes where the permittivity is defined.
! This is needed to for example visualize the sensitivity data which is calculated on those nodes.
!===========================================================================================
subroutine compute_shifted_grid_coordinates(nr,ntheta,nz,r,theta,z,xgrid,ygrid,zgrid)
  integer, intent(in) :: nr, ntheta, nz
  real(kind=CUSTOM_REAL), intent(in) :: r(0:)
  real(kind=CUSTOM_REAL), intent(in) :: theta(0:)
  real(kind=CUSTOM_REAL), intent(in) :: z(0:)

  real(kind=CUSTOM_REAL), intent(out) :: xgrid(0:,0:,0:)
  real(kind=CUSTOM_REAL), intent(out) :: ygrid(0:,0:,0:)
  real(kind=CUSTOM_REAL), intent(out) :: zgrid(0:,0:,0:)

  real(kind=CUSTOM_REAL), allocatable :: r_shifted(:)
  real(kind=CUSTOM_REAL), allocatable :: theta_shifted(:)
  real(kind=CUSTOM_REAL), allocatable :: z_shifted(:)
  integer :: i,j,k

  allocate(r_shifted(0:2*nr+1))
  allocate(theta_shifted(0:ntheta+1))
  allocate(z_shifted(0:nz+1))

  ! Shift the radius r.
  ! Permittivity permit(i,:,:) is located between phi(i-1,:,:) and phi(i,:,:).
  do i=1,2*nr+1
    r_shifted(i) = r(i-1)
  enddo
  ! Since we have a mapping i-->2*i-1 and therefore r(-1)=0.
  r_shifted(0) = 0._CUSTOM_REAL

  ! Shift the angle theta.
  ! Permittivity permit(:,j,:) is located between phi(:,j,:) and phi(:,j+1,:).
  do j=1,ntheta
    theta_shifted(j) = theta(j) + 0.5_CUSTOM_REAL*(theta(j+1)-theta(j))
  enddo

  ! Apply periodic BCs.
  theta_shifted(0) = theta_shifted(ntheta) + 2._CUSTOM_REAL*PI
  theta_shifted(ntheta+1) = theta_shifted(1) - 2._CUSTOM_REAL*PI

  ! Shift the height z.
  ! Permittivity permit(:,:,k) is located between phi(:,:,k-1) and phi(:,:,k).
  do k=1,nz+1
    z_shifted(k) = z(k) - 0.5_CUSTOM_REAL*(z(k)-z(k-1))
  enddo
  ! We do not have permittivity defined between z(0)=0 and z(-1).
  ! So just define z_shifted(0) to do not have undefined elements.
  z_shifted(0) = 0._CUSTOM_REAL

  call compute_grid_coordinates(nr,ntheta,nz,r_shifted,theta_shifted,z_shifted,xgrid,ygrid,zgrid)

  deallocate(z_shifted)
  deallocate(theta_shifted)
  deallocate(r_shifted)

end subroutine compute_shifted_grid_coordinates

!===========================================================================================
! Increase twice the theta-dimension for the electrode ielectrode and its gaps.
subroutine refine_geometry(ielectrode,ntheta,theta,nel,elecs,&
                           ntheta0,theta0,elecs0,ithetamap)

  integer, intent(in) :: ielectrode,ntheta,nel,ntheta0
  real(kind=CUSTOM_REAL), intent(inout) :: theta0(0:), theta(0:)
  type(t_electrode), intent(inout) :: elecs(:)
  type(t_electrode), intent(inout) :: elecs0(:)
  integer, intent(inout) :: ithetamap(0:)

  integer, save :: originalValuesStored = 0
  integer, save :: npelec,npgaps

  integer :: j,l,el
  logical :: toInsert

  if (originalValuesStored == 0) then
    theta0(:) = theta(:)
    elecs0(:) = elecs(:)

    npelec = get_npelec(ntheta0, nel)
    npgaps = get_npgaps(ntheta0, nel)

    originalValuesStored = 1
  endif

  l=0
  do j=1,ntheta0+1
    toInsert = .false.

    if (ielectrode > 1 .and. ielectrode < 12) then
      if (j > elecs0(ielectrode-1)%ithetamax .and. j <= elecs0(ielectrode+1)%ithetamin) toInsert = .true.
    else if (ielectrode == 1) then
      if ((j > elecs0(ielectrode)%ithetamin .and. j <= elecs0(ielectrode+1)%ithetamin) &
          .or. (j > elecs0(nel)%ithetamax)) toInsert = .true.
    else if (ielectrode == 12) then
      if (j > elecs0(ielectrode-1)%ithetamax) toInsert = .true.
    endif

    if (toInsert) then
    ! Insert an extra grid dimension between theta(j-1) and theta(j).
      l=l+1
      theta(l) = 0.5_CUSTOM_REAL*(theta0(j-1)+theta0(j))
    endif

    l=l+1
    theta(l) = theta0(j)

    ithetamap(j) = l

    ! Sanity check.
    if (j == ntheta0+1) then
      if (l /= ntheta+1) then
        print *, "Error in mesh refinement! j=", j, ", l=", l
        stop
      endif
    endif
  enddo

  do el=1,nel
    if (el < ielectrode) then
        elecs(el)%ithetamin = elecs0(el)%ithetamin
        elecs(el)%ithetamax = elecs0(el)%ithetamax
    else if (el == ielectrode) then
      if (ielectrode == 1) then
        elecs(el)%ithetamax = elecs0(el)%ithetamax + (npelec-1)
      else  if (ielectrode > 1) then
        elecs(el)%ithetamin = elecs0(el)%ithetamin + npgaps+1
        elecs(el)%ithetamax = elecs0(el)%ithetamax + npgaps + npelec
      endif
    else if (el > ielectrode) then
      if (ielectrode == 1) then
        elecs(el)%ithetamin = elecs0(el)%ithetamin + npgaps + npelec
        elecs(el)%ithetamax = elecs0(el)%ithetamax + npgaps + npelec
      else
        elecs(el)%ithetamin = elecs0(el)%ithetamin + 2*(npgaps+1) + (npelec-1)
        elecs(el)%ithetamax = elecs0(el)%ithetamax + 2*(npgaps+1) + (npelec-1)
      endif
    endif
  enddo

  ! Periodic boundaries.
  theta(0) = theta(ntheta) + 2.0_CUSTOM_REAL*PI
  ithetamap(0) = ithetamap(ntheta0)

end subroutine refine_geometry

end module geometry


!
!     (c) 2019-2020 Guide Star Engineering, LLC
!     This Software was developed for the US Nuclear Regulatory Commission (US NRC) under contract
!     "Multi-Dimensional Physics Implementation into Fuel Analysis under Steady-state and Transients (FAST)",
!     contract # NRC-HQ-60-17-C-0007
!
module spatial_derivative_procedures
  implicit none
  integer ,parameter :: digits=8  ! num. digits of kind
  integer ,parameter :: decades=9 ! num. representable decades
  integer ,parameter :: rkind = selected_real_kind(digits)
  integer ,parameter :: ikind = selected_int_kind(decades)

  type grid_block
    real(rkind), allocatable :: v(:,:,:,:)
    real(rkind), allocatable :: ddx2(:,:,:,:)
  end type grid_block

  integer(ikind)  :: i,j,k
  integer(ikind) ,parameter :: nx=21, ny=25, nz=30

  type(grid_block) :: global_grid_block

contains

  impure function position_vectors(nx,ny,nz) result(vector_field)
    integer(ikind), intent(in) :: nx, ny, nz
    integer(ikind), parameter :: components=3
    real(rkind), parameter :: dx=0.75/(5.0), dy=0.75/(5.0)
    real(rkind), parameter :: dx_s=0.25/5.0, dy_s=0.25/5.0
    real(rkind), dimension(:,:,:,:) ,allocatable  :: vector_field

    allocate( vector_field(nx,ny,nz,components) )

    associate( dz=>10.0/(nz-1) )
      do concurrent( i=1:nx, j=1:ny, k=1:nz )
        vector_field(i,j,k,1) = merge(-0.75+(i-6)*dx, merge( -1.0+(i-1)*dx_s, 0.75+(i-16)*dx_s, i<6), i>=6 .and. i<=16)
        vector_field(i,j,k,2) = merge(-0.75+(j-6)*dy, merge( -1.0+(j-1)*dy_s, 0.75+(j-16)*dy_s, j<6), j>=6 .and. j<=16)
        vector_field(i,j,k,3) = (k-1)*dz
      end do
    end associate
  end function

  ! Below is a dummy conductivity function which assumed to a constant value, 1.0.
  ! User will need change this function if the conductivity is vary with Temetrature or space.
  ! kc in the deriveative calculation is assumed to be varying with x for ddx2, varying with y for ddy2 and varying with z
  ! for ddz2;
  ! User need change kc term based on kc function in the derivative calculation.
  pure real(rkind) function kc(x)
    real(rkind), intent(in)   :: x
    kc=1.0
    associate( unused=>x )
      !! eliminate "unused variable" compiler warnings
    end associate
  end function

  subroutine set_scalar_fluxes(this)
    !! compute each directional term in the divergence of scalar flux: .div. ( k .grad. T)
    type(grid_block), intent(inout) :: this
    integer(ikind) i, j, k

    associate( n=>shape(this%v), s=>this%v(:,:,:,4) )
      associate( x=>this%v(:,:,:,1))
        do concurrent(k=1:n(3), j=1:n(2), i=2:n(1)-1)
          associate( &
            dx_m => 0.5_rkind*(x(i+1,j,k) - x(i-1,j,k)), &
            dx_f =>  x(i+1,j,k) - x(i,j,k), &
            dx_b =>  x(i,j,k)-x(i-1,j,k) )
            this%ddx2(i,j,k,1) = &
              kc(0.5_rkind*(x(i+1,j,k) + x(i,j,k))  )*(s(i+1,j,k) - s(i,j,k)  )/(dx_f*dx_m) - &
              kc(0.5_rkind*(x(i,j,k)   + x(i-1,j,k)))*(s(i,j,k)   - s(i-1,j,k))/(dx_b*dx_m)
          end associate
        end do
      end associate

      associate( y=>this%v(:,:,:,2) )
        do concurrent(k=1:n(3), j=2:n(2)-1, i=1:n(1))
          associate( &
            dy_m => 0.5_rkind*(y(i,j+1,k) - y(i,j-1,k)), &
            dy_f =>     y(i,j+1,k) - y(i,j,k ), &
            dy_b =>     y(i,j,k)   - y(i,j-1,k) )
            this%ddx2(i,j,k,2) = &
              kc(0.5_rkind*(y(i,j+1,k)+y(i,j,k)))*(s(i,j+1,k) - s(i,j,k))/(dy_f*dy_m) - &
              kc(0.5_rkind*(y(i,j,k)+y(i,j-1,k)))*(s(i,j,k) - s(i,j-1,k))/(dy_b*dy_m)
           end associate
        end do
      end associate

      associate( z=>this%v(:,:,:,3) )
        do concurrent(k=2:n(3)-1, j=1:n(2), i=1:n(1))
          associate( &
            dz_m => 0.5*(z(i,j,k+1)-z(i,j,k-1)), &
            dz_f => z(i,j,k+1)-z(i,j,k), &
            dz_b => z(i,j,k)-z(i,j,k-1) )
            this%ddx2(i,j,k,3) = &
              kc(0.5*(z(i,j,k+1)+z(i,j,k)))*(s(i,j,k+1) - s(i,j,k))/(dz_f*dz_m) - &
              kc(0.5*(z(i,j,k)+z(i,j,k-1)))*(s(i,j,k) - s(i,j,k-1))/(dz_b*dz_m)
          end associate
        end do
      end associate
    end associate
  end subroutine

end module spatial_derivative_procedures

program main
  use spatial_derivative_procedures
  implicit none
  real(rkind) ::  minimum_dx=0.25/5.0
  allocate(global_grid_block%v(nx,ny,nz,4), global_grid_block%ddx2(nx,ny,nz,3), source=0._rkind)

  associate( p => position_vectors(nx,ny,nz) )
    associate( x => p(:,:,:,1), y => p(:,:,:,2), z => p(:,:,:,3) )
      global_grid_block%v(:,:,:,1) = x
      global_grid_block%v(:,:,:,2) = y
      global_grid_block%v(:,:,:,3) = z
      global_grid_block%v(:,:,:,4) = x**2 * y ! T = x^2*y => (d^2/dx^2)x = 2y, (d^2/dy^2)y = 0
    end associate
  end associate

  call set_scalar_fluxes(global_grid_block)

  associate( y => global_grid_block%v(2:nx-1,:,:,2) )
    associate( exact_answer => 2*y, approximation =>  global_grid_block%ddx2(2:nx-1,:,:,1) )
      associate( avg_err => sum ( abs( approximation - exact_answer ) )/ SIZE(exact_answer) )
        if (avg_err <= minimum_dx**2) print *, "Test passed."
      end associate
    end associate
  end associate

  end program main


!==========================================================================
elemental function gsw_fdelta (p, long, lat)
!==========================================================================
!
! Calculates fdelta.
!
! p      : sea pressure                                    [dbar]
! long   : longitude                                       [deg E]
! lat    : latitude                                        [deg N]
!
! gsw_fdelta : Absolute Salinty Anomaly                    [unitless]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_saar

use gsw_mod_error_functions, only : gsw_error_code, gsw_error_limit

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: p, long, lat

real (r8) :: gsw_fdelta

real (r8) ::  saar

character (*), parameter :: func_name = "gsw_fdelta"

saar = gsw_saar(p,long,lat)

if (saar.gt.gsw_error_limit) then
   gsw_fdelta = gsw_error_code(1,func_name)
else
   gsw_fdelta = ((1.0_r8 + 0.35_r8)*saar)/(1.0_r8 - 0.35_r8*saar)
end if

return
end function

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


 !***********************************************************************************
    subroutine Convolution(num1,xtmp,ytmp,ztmp,den,speed,rarry)
    !c----------------------------------------------------------------------
    !c
    !c----------------------------------------------------------------------
    use varmod
    implicit none
    integer::num1
    integer::i,j,k,xtmp,ytmp,ztmp
    real::dt,f0,sinang
    real,dimension(0:nz-1)::reflect
    real,dimension(MAXZ)::den,speed,speeds,EI,kk
    real,dimension(0:nz+NumSampledWalve-1)::sny
    real,dimension(num1)::rarry

    sny(0:nz+NumSampledWalve-1)=0.0
    reflect(0)=0.0
    EI(1)=den(1)*speed(1)
    do k=1,nz-1
        EI(k+1)=den(k+1)*speed(k+1)
        reflect(k)=(EI(k+1)-EI(k))/(EI(k+1)+EI(k))
    end do

    if(NumSampledWalve.gt.nz)then
        do i=0,nz+NumSampledWalve-1
            if(i.lt.nz)then
                sny(i)=0.0
                do j=0,i
                    sny(i)=sny(i)+wavelet(j)*reflect(i-j)
                end do
            else if(i.ge.nz.and.i.lt.NumSampledWalve)then
                sny(i)=0.0
                do j=i-nz+1,i
                    sny(i)=sny(i)+wavelet(j)*reflect(i-j)
                end do
            else if(i.ge.NumSampledWalve)then
                sny(i)=0.0
                do j=i-nz+1,NumSampledWalve
                    sny(i)=sny(i)+wavelet(j)*reflect(i-j)
                end do
            end if
        end do
    else
        do i=0,nz+NumSampledWalve-1
            if(i.lt.NumSampledWalve)then
                sny(i)=0.0
                do j=0,i
                    sny(i)=sny(i)+wavelet(j)*reflect(i-j)
                end do
            else if(i.ge.NumSampledWalve.and.i.lt.nz-1)then
                sny(i)=0.0
                do j=0,NumSampledWalve
                    sny(i)=sny(i)+wavelet(j)*reflect(i-j)
                end do
            else if(i.ge.nz-1)then
                sny(i)=0.0
                do j=i-nz+1,NumSampledWalve
                    sny(i)=sny(i)+wavelet(j)*reflect(i-j)
                end do
            end if
        end do
    end if

    do i=1,num1
        rarry(i)=sny(i+HalfNumSampledWalve+ztmp)
    end do
    sny(0:num1+NumSampledWalve-1)=0.0
    end subroutine Convolution
    !***********************************************************************************


C*************************************************************
C PLEASE KEEP THIS NOTE OF MODEL-DEVELOPMENT HISTORY
C Matrix solve uses Thomas algorithm, 10/1991, Jinlun Zhang
C Spherical coordinate system, 10/27/93, Jinlun Zhang
C Latest finite differencing scheme for treatment of NP,
C 9/9/1996,Jinlun Zhang
C Alternating direction implicit (ADI) method is used, 10/1998,
C Jinlun Zhang
C For details about ADI dynamics model, see Zhang and Rothrock,
C "Modeling
C Arctic Sea ice with an efficient plastic solution",
C submitted to JGR, 1999
C Adapted for GISS coupled model Jiping Liu/Gavin Schmidt 2000
C - Further modularised May 2001
C*************************************************************

      MODULE ICEDYN
!@sum  ICEDYN holds local variables for dynamic sea ice
!@auth Gavin Schmidt (based on code from Jinlun Zhang)
      USE CONSTANT, only : radian,radius
      USE MODEL_COM, only : im,jm
      USE SEAICE, only : osurf_tilt
      IMPLICIT NONE
      SAVE
C**** Definition for ice advection grid (EDIT FOR ADVSI GRID CHANGE)
      INTEGER, PARAMETER :: IMIC=IM, JMIC=JM

C**** local grid variables for ice rheology scheme
C**** Edit the definition of nx1,ny1 to change the grid for the
C**** rheology calculations without changing ADVSI grid.

!@var nx1 number of grid points in the longitudinal direction
!@+  (calculated points from 2 through nx1-1. End points are boundaries)
!@var ny1 number of grid points in the latitudinal direction
!@+  (calculated points from 2 through ny1-1. End points are boundaries)
      integer, parameter :: nx1=imic+2, ny1=jmic
      INTEGER, parameter :: NYPOLE=NY1-1,NXLCYC=NX1-1
      integer :: NPOL=1,LCYC=1

!@var FOCEAN land/ocean mask on ice dynamic grid
      REAL*8, DIMENSION(NX1-2,NY1) :: FOCEAN

C**** input
!@var HEFFM ice mass mask (1/0)
!@var UVM ice velocity mask (1/0)
!@var COR coriolis term for ice dynamic equation
!@var GAIRX,GAIRY atmosphere-ice stress (B grid)
!@var GWATX,GWATY ocean velocities (B grid) (m/s)
!@var PGFUB,PGFVB pressure accelaration force
!@var AMASS ice mass (kg/m^2)
!@var UICEC,VICEC velocity arrays  (m/s)
!@var UICE,VICE velocity arrays  (m/s)
!@var HEFF ice thickness (mean over box) (m)
!@var AREA ice area (frac)
!@var UIB,VIB velocity arrays (m/s)  (????)
C**** internal variables
!@var PRESS ice internal pressure (Pa)
!@var FORCEX,FORCEY external force
!@var DRAGS,DRAGA symmetric/anti-symmetric drag terms
!@var ZMAX,ZMIN max,min values of ZETA
!@var ETA,ZETA viscosities
C**** output
!@var DWATN non-linear water drag term
!@var DMU,DMV ice-ocean stress
      REAL*8, DIMENSION(NX1,NY1) :: PRESS,HEFFM,UVM,DWATN,COR
     *     ,ZMAX,ZMIN,ETA,ZETA,DRAGS,DRAGA,GAIRX,GAIRY
     *     ,GWATX,GWATY,PGFUB,PGFVB,FORCEX,FORCEY,AMASS,UICEC,VICEC,UIB
     *     ,VIB,DMU,DMV,HEFF,AREA
      REAL*8, DIMENSION(NX1,NY1,3) :: UICE,VICE
C**** Geometry
!@var SINEN sin(phi)
!@var BYDXDY
!@var DXT,DXU x-direction distances on tracer and velocity grid
!@var DYT,DYU y-direction distances on tracer and velocity grid
      REAL*8, DIMENSION(NX1,NY1) :: SINEN,BYDXDY
      REAL*8, DIMENSION(NX1) :: DXT,DXU,BYDX2,BYDXR
      REAL*8, DIMENSION(NY1) :: DYT,DYU,BYDY2,BYDYR,CST,CSU,TNGT,TNG
     *     ,BYCSU

!@var OIPHI ice-ocean turning angle (25 degrees)
!@var ECCEN value of eccentricity for yield curve ellipse
      REAL*8, PARAMETER :: ECCEN=2.0, OIPHI=25d0*radian
!@var SINWAT,COSWAT sin and cos of ice-ocean turning angle
      REAL*8 SINWAT,COSWAT

!@var PSTAR maximum sea ice pressure (Pa)
      REAL*8, PARAMETER :: PSTAR=2.75d4

!@var BYDTS reciprocal of timestep in ice dynamics code
      REAL*8 :: BYDTS

      CONTAINS

      SUBROUTINE FORM
!@sum  FORM calculates ice dynamics input parameters for relaxation
!@auth Jiping Liu/Gavin Schmidt (based on code from J. Zhang)
!@ver  1.0
      IMPLICIT NONE
      INTEGER I,J
      REAL*8 AAA
C****
C**** Set up non linear water drag
C****
      DO J=1,NY1-1
      DO I=1,NX1-1
        DWATN(I,J)=5.5*SQRT((UICE(I,J,1)-GWATX(I,J))**2
     1       +(VICE(I,J,1)-GWATY(I,J))**2)
      END DO
      END DO
C NOW SET UP SYMMETRIC DRAG
      DO J=1,NY1-1
      DO I=1,NX1-1
        DRAGS(I,J)=DWATN(I,J)*COSWAT
      END DO
      END DO
C NOW SET UP ANTI SYMMETRIC DRAG PLUS CORIOLIS
      DO J=1,NY1
      DO I=1,NX1
        IF(J.GT.NY1/2) THEN
          DRAGA(I,J)=DWATN(I,J)*SINWAT+COR(I,J)
        ELSE
          DRAGA(I,J)=DWATN(I,J)*(-SINWAT)+COR(I,J)
        END IF
      END DO
      END DO
C NOW SET UP FORCING FIELD
      DO J=1,NY1
      DO I=1,NX1

C FIRST DO WIND
        FORCEX(I,J)=GAIRX(i,j)
        FORCEY(I,J)=GAIRY(i,j)

C NOW ADD IN CURRENT FORCE
        IF(J.GT.NY1/2) THEN
          FORCEX(I,J)=FORCEX(I,J)+DWATN(I,J)*(COSWAT*GWATX(I,J)
     1         -SINWAT*GWATY(I,J))
          FORCEY(I,J)=FORCEY(I,J)+DWATN(I,J)*(SINWAT*GWATX(I,J)
     1         +COSWAT*GWATY(I,J))
        ELSE
          FORCEX(I,J)=FORCEX(I,J)+DWATN(I,J)*(COSWAT*GWATX(I,J)
     1         +SINWAT*GWATY(I,J))
          FORCEY(I,J)=FORCEY(I,J)+DWATN(I,J)*(-SINWAT*GWATX(I,J)
     1         +COSWAT*GWATY(I,J))
        END IF

C     NOW ADD IN TILT
        if (osurf_tilt.eq.1) then
C**** This assumes explicit knowledge of sea surface tilt
          FORCEX(I,J)=FORCEX(I,J)+AMASS(I,J)*PGFUB(I,J)
          FORCEY(I,J)=FORCEY(I,J)+AMASS(I,J)*PGFVB(I,J)
        else
C**** Otherwise estimate tilt using geostrophy
          FORCEX(I,J)=FORCEX(I,J)-COR(I,J)*GWATY(I,J)
          FORCEY(I,J)=FORCEY(I,J)+COR(I,J)*GWATX(I,J)
        end if
      END DO
      END DO

C NOW SET UP ICE PRESSURE AND VISCOSITIES
      DO J=1,NY1
      DO I=1,NX1
        PRESS(I,J)=PSTAR*HEFF(I,J)*EXP(-20.0*(1.0-AREA(I,J)))
        ZMAX(I,J)=(5d12/2d4)*PRESS(I,J)
c       ZMIN(I,J)=0.0D+00
        ZMIN(I,J)=4d8
      END DO
      END DO

      CALL PLAST

      AAA=0.0
      DO I=2,NX1-1
        AAA=AAA+PRESS(I,NY1-1)
      END DO
      AAA=AAA/FLOAT(NX1-2)
      DO I=1,NX1
        PRESS(I,NY1)=AAA
      END DO

 8481 CONTINUE

      DO J=1,NY1
        PRESS(1,J)=PRESS(NX1-1,J)
        PRESS(NX1,J)=PRESS(2,J)
      END DO

C NOW SET VISCOSITIES AND PRESSURE EQUAL TO ZERO AT OUTFLOW PTS

      DO J=1,NY1
      DO I=1,NX1
        PRESS(I,J)=PRESS(I,J)*HEFFM(I,J)
        ETA(I,J)=ETA(I,J)*HEFFM(I,J)
        ZETA(I,J)=ZETA(I,J)*HEFFM(I,J)
      END DO
      END DO

C NOW CALCULATE PRESSURE FORCE AND ADD TO EXTERNAL FORCE
      DO J=1,NY1-1
      DO I=1,NX1-1
      FORCEX(I,J)=FORCEX(I,J)-(0.25/(DXU(I)*CSU(J)))
     1  *(PRESS(I+1,J)+PRESS(I+1,J+1)-PRESS(I,J)-PRESS(I,J+1))
      FORCEY(I,J)=FORCEY(I,J)-0.25/DYU(J)
     1  *(PRESS(I,J+1)+PRESS(I+1,J+1)-PRESS(I,J)-PRESS(I+1,J))
C NOW PUT IN MINIMAL MASS FOR TIME STEPPING CALCULATIONS
      END DO
      END DO

      DO J=1,NY1
        FORCEX(1,J)=FORCEX(NX1-1,J)
        FORCEY(1,J)=FORCEY(NX1-1,J)
        FORCEX(NX1,J)=FORCEX(2,J)
        FORCEY(NX1,J)=FORCEY(2,J)
      END DO

      RETURN
      END SUBROUTINE FORM

      SUBROUTINE PLAST
!@sum  PLAST Calculates strain rates and viscosity for dynamic ice
!@auth Jiping Liu/Gavin Schmidt (based on code from J. Zhang)
!@ver  1.0
      IMPLICIT NONE
      REAL*8, DIMENSION(NX1,NY1) :: E11,E22,E12
c      REAL*8 :: SS11
      REAL*8, PARAMETER :: ECM2 = 1.0/(ECCEN**2),GMIN=1d-20
      REAL*8 DELT,DELT1,AAA
      INTEGER I,J

C EVALUATE STRAIN RATES
      DO J=2,NY1-1
        DO I=2,NX1-1
          E11(I,J)=0.5/(DXT(I)*CST(J))*(UICE(I,J,1)+UICE(I,J-1,1)
     *         -UICE(I-1,J,1)-UICE(I-1,J-1,1))-0.25*(VICE(I,J,1)+
     *         VICE(I-1,J,1)+VICE(I-1,J-1,1)+VICE(I,J-1,1))*TNGT(J)
     *         /RADIUS
          E22(I,J)=0.5/DYT(J)*(VICE(I,J,1)+VICE(I-1,J,1)
     *         -VICE(I,J-1,1)-VICE(I-1,J-1,1))
          E12(I,J)=0.5*(0.5/DYT(J)*(UICE(I,J,1)+UICE(I-1,J,1)-
     *         UICE(I,J-1,1)-UICE(I-1,J-1,1))+0.5/(DXT(I)*CST(J))*
     *         (VICE(I,J,1)+VICE(I,J-1,1)-VICE(I-1,J,1)-VICE(I-1,J-1,1))
     *         +0.25*(UICE(I,J,1)+UICE(I-1,J,1)+UICE(I-1,J-1,1)+UICE(I,J
     *         -1,1))*TNGT(J)/RADIUS)
C NOW EVALUATE VISCOSITIES
          DELT=(E11(I,J)**2+E22(I,J)**2)*(1.0+ECM2)+4.0*ECM2*E12(I,J)**2
     *         +2.0*E11(I,J)*E22(I,J)*(1.0-ECM2)
          DELT1=SQRT(DELT)
          DELT1=MAX(GMIN,DELT1)
          ZETA(I,J)=0.5*PRESS(I,J)/DELT1
        END DO
      END DO

C NOW PUT MIN AND MAX VISCOSITIES IN
      DO J=1,NY1
        DO I=1,NX1
          ZETA(I,J)=MIN(ZMAX(I,J),ZETA(I,J))
          ZETA(I,J)=MAX(ZMIN(I,J),ZETA(I,J))
        END DO
      END DO

      AAA=0.0
      DO I=2,NX1-1
        AAA=AAA+ZETA(I,NY1-1)
      END DO
      AAA=AAA/FLOAT(NX1-2)
      DO I=1,NX1
        ZETA(I,NY1)=AAA
      END DO

      DO J=1,NY1
        ZETA(1,J)=ZETA(NX1-1,J)
        ZETA(NX1,J)=ZETA(2,J)
      END DO

      DO J=1,NY1
        DO I=1,NX1
          ETA(I,J)=ECM2*ZETA(I,J)
c         E11(I,J)=E11(I,J)*HEFFM(I,J)
c         E22(I,J)=E22(I,J)*HEFFM(I,J)
c         E12(I,J)=E12(I,J)*HEFFM(I,J)
c         SS11=(ZETA(I,J)-ETA(I,J))*(E11(I,J)+E22(I,J))-PRESS(I,J)*0.5
        END DO
      END DO
      RETURN
      END SUBROUTINE PLAST

      SUBROUTINE RELAX
!@sum  RELAX calculates ice dynamics relaxation method
!@auth Jiping Liu/Gavin Schmidt (based on code from J. Zhang)
!@ver  1.0
      IMPLICIT NONE
      REAL*8, DIMENSION(NX1,NY1) :: AU,BU,CU,FXY,FXY1
      REAL*8, DIMENSION(NY1,NX1) :: AV,BV,CV,FXYa,FXY1a
      REAL*8, DIMENSION(NX1) :: CUU,URT         !CUU,
      REAL*8, DIMENSION(NY1) :: CVV,VRT,U_tmp   !CVV,
      REAL*8, PARAMETER :: BYRAD2 = 1./(RADIUS*RADIUS)
      INTEGER I,J,J1,J2,IMD,JMD
      REAL*8 DELXY,DELXR,DELX2,DELY2,DELYR,ETAMEAN,ZETAMEAN,AA1,AA2
     *     ,AA3,AA4,AA5,AA6,AA9

      DO J=1,NY1
        DO I=1,NX1
          FORCEX(I,J)=FORCEX(I,J)*UVM(I,J)
          FORCEY(I,J)=FORCEY(I,J)*UVM(I,J)
        END DO
      END DO
C MUST UPDATE HEFF BEFORE CALLING RELAX
C FIRST SET U(2)=U(1)
      DO J=1,NY1
        DO I=1,NX1
C NOW MAKE SURE BDRY PTS ARE EQUAL TO ZERO
          UICE(I,J,2)=UICE(I,J,1)
          VICE(I,J,2)=VICE(I,J,1)
          UICE(I,J,1)=UICE(I,J,3)*UVM(I,J)
          VICE(I,J,1)=VICE(I,J,3)*UVM(I,J)
        END DO
      END DO

      DO I=1,NX1/2
      UICE(I,NY1,1)=-UICEC(I+(NX1-2)/2,NY1-1)
      VICE(I,NY1,1)=-VICEC(I+(NX1-2)/2,NY1-1)
      UICE(I,NY1,3)=-UICEC(I+(NX1-2)/2,NY1-1)
      VICE(I,NY1,3)=-VICEC(I+(NX1-2)/2,NY1-1)

      UICEC(I,NY1)=-UICEC(I+(NX1-2)/2,NY1-1)
      VICEC(I,NY1)=-VICEC(I+(NX1-2)/2,NY1-1)
      END DO

      DO I=NX1/2+1,NX1-1
      UICE(I,NY1,1)=-UICEC(I-(NX1-2)/2,NY1-1)
      VICE(I,NY1,1)=-VICEC(I-(NX1-2)/2,NY1-1)
      UICE(I,NY1,3)=-UICEC(I-(NX1-2)/2,NY1-1)
      VICE(I,NY1,3)=-VICEC(I-(NX1-2)/2,NY1-1)

      UICEC(I,NY1)=-UICEC(I-(NX1-2)/2,NY1-1)
      VICEC(I,NY1)=-VICEC(I-(NX1-2)/2,NY1-1)
      END DO

      DO J=1,NY1
      UICE(1,J,1)=UICEC(NX1-1,J)
      VICE(1,J,1)=VICEC(NX1-1,J)
      UICE(NX1,J,1)=UICEC(2,J)
      VICE(NX1,J,1)=VICEC(2,J)
      UICE(1,J,3)=UICEC(NX1-1,J)
      VICE(1,J,3)=VICEC(NX1-1,J)
      UICE(NX1,J,3)=UICEC(2,J)
      VICE(NX1,J,3)=VICEC(2,J)

      UICEC(1,J)=UICEC(NX1-1,J)
      VICEC(1,J)=VICEC(NX1-1,J)
      UICEC(NX1,J)=UICEC(2,J)
      VICEC(NX1,J)=VICEC(2,J)
      END DO

C FIRST DO UICE
C THE FIRST HALF

      DO J=2,NYPOLE
      DO I=2,NXLCYC
      DELXY=BYDXDY(I,J)    ! 0.5/(DXU(I)*DYU(J))
      DELXR=BYDXR(I)       ! 0.5/(DXU(I)*RADIUS)
      DELX2=BYDX2(I)       ! 0.5/(DXU(I)*DXU(I))
      ETAMEAN=0.25*(ETA(I,J+1)+ETA(I+1,J+1)+ETA(I,J)+ETA(I+1,J))
      ZETAMEAN=0.25*(ZETA(I,J+1)+ZETA(I+1,J+1)+ZETA(I,J)+ZETA(I+1,J))

      FXY(I,J)=DRAGA(I,J)*VICEC(I,J)+FORCEX(I,J)
     3+0.5*(ZETA(I+1,J+1)*(VICEC(I+1,J+1)+VICEC(I,J+1)
     3-VICEC(I+1,J)-VICEC(I,J))+ZETA(I+1,J)*(VICEC(I+1,J)
     3+VICEC(I,J)-VICEC(I+1,J-1)-VICEC(I,J-1))+ZETA(I,J+1)
     3*(VICEC(I,J)+VICEC(I-1,J)-VICEC(I,J+1)-VICEC(I-1,J+1))
     3+ZETA(I,J)*(VICEC(I,J-1)+VICEC(I-1,J-1)-VICEC(I,J)
     3-VICEC(I-1,J)))*DELXY*BYCSU(J)
     3
     4-0.5*(ETA(I+1,J+1)*(VICEC(I+1,J+1)+VICEC(I,J+1)
     4-VICEC(I+1,J)-VICEC(I,J))+ETA(I+1,J)*(VICEC(I+1,J)
     4+VICEC(I,J)-VICEC(I+1,J-1)-VICEC(I,J-1))+ETA(I,J+1)
     4*(VICEC(I,J)+VICEC(I-1,J)-VICEC(I,J+1)-VICEC(I-1,J+1))
     4+ETA(I,J)*(VICEC(I,J-1)+VICEC(I-1,J-1)-VICEC(I,J)
     4-VICEC(I-1,J)))*DELXY*BYCSU(J)
     4
     5+0.5*(VICEC(I+1,J)-VICEC(I-1,J))*(ETA(I,J+1)+ETA(I+1,J+1)
     5-ETA(I,J)-ETA(I+1,J))*DELXY*BYCSU(J)+0.5*ETAMEAN*((VICEC(I+1,J+1)
     5-VICEC(I-1,J+1))*BYCSU(J+1)-(VICEC(I+1,J-1)-VICEC(I-1,J-1))
     5*BYCSU(J-1))*DELXY
     5
     6-((ZETA(I+1,J+1)+ZETA(I+1,J)-ZETA(I,J)-ZETA(I,J+1))
     6+(ETA(I+1,J+1)+ETA(I+1,J)-ETA(I,J)-ETA(I,J+1)))
     6*TNG(J)*VICEC(I,J)*DELXR*BYCSU(J)
     6-(ETAMEAN+ZETAMEAN)*TNG(J)*(VICEC(I+1,J)-VICEC(I-1,J))
     6*DELXR*BYCSU(J)
     6
     7-ETAMEAN*2.0*TNG(J)*(VICEC(I+1,J)-VICEC(I-1,J))*DELXR*BYCSU(J)

      END DO
      END DO

      DO J=2,NYPOLE
      DO I=2,NXLCYC
      DELX2=BYDX2(I)       ! 0.5/(DXU(I)*DXU(I))
      DELY2=BYDY2(J)       ! 0.5/(DYU(J)*DYU(J))
      DELYR=BYDYR(J)       ! 0.5/(DYU(J)*RADIUS)
      ETAMEAN=0.25*(ETA(I,J+1)+ETA(I+1,J+1)+ETA(I,J)+ETA(I+1,J))
      AA1=((ETA(I+1,J)  +ZETA(I+1,J)  )*BYCSU(J)+
     *     (ETA(I+1,J+1)+ZETA(I+1,J+1))*BYCSU(J))*BYCSU(J)
      AA2=((ETA(I,J)+ZETA(I,J))*BYCSU(J)+(ETA(I,J+1)+ZETA(I,J+1))
     &     *BYCSU(J))*BYCSU(J)
      AA3=ETA(I,J+1)+ETA(I+1,J+1)
      AA4=ETA(I,J)+ETA(I+1,J)
      AA5=-(ETA(I,J+1)+ETA(I+1,J+1)-ETA(I,J)-ETA(I+1,J))*TNG(J)
      AA6=2.0*ETAMEAN*TNG(J)*TNG(J)
      AU(I,J)=-AA2*DELX2*UVM(I,J)
      BU(I,J)=((AA1+AA2)*DELX2+AA6*BYRAD2
     &+AMASS(I,J)*BYDTS*2.0+DRAGS(I,J))*UVM(I,J)+(1.0-UVM(I,J))
      CU(I,J)=-AA1*DELX2*UVM(I,J)
      END DO
      END DO
      DO J=2,NYPOLE
      AU(2,J)=0.0
      CU(NXLCYC,J)=0.0
c      CU(2,J)=CU(2,J)/BU(2,J)  ! absorbed into TRIDIAG
      END DO

      DO 1200 J=2,NYPOLE
      DO I=2,NXLCYC

      DELX2=BYDX2(I)       ! 0.5/(DXU(I)*DXU(I))
      DELY2=BYDY2(J)       ! 0.5/(DYU(J)*DYU(J))
      DELYR=BYDYR(J)       ! 0.5/(DYU(J)*RADIUS)
      ETAMEAN=0.25*(ETA(I,J+1)+ETA(I+1,J+1)+ETA(I,J)+ETA(I+1,J))

      AA1=((ETA(I+1,J)  +ZETA(I+1,J)  )*BYCSU(J)+
     *     (ETA(I+1,J+1)+ZETA(I+1,J+1))*BYCSU(J))*BYCSU(J)
      AA2=((ETA(I,J)+ZETA(I,J))*BYCSU(J)+(ETA(I,J+1)+ZETA(I,J+1))
     &     *BYCSU(J))*BYCSU(J)
      AA3=ETA(I,J+1)+ETA(I+1,J+1)
      AA4=ETA(I,J)+ETA(I+1,J)
      AA5=-(ETA(I,J+1)+ETA(I+1,J+1)-ETA(I,J)-ETA(I+1,J))*TNG(J)
      AA6=2.0*ETAMEAN*TNG(J)*TNG(J)

      IF(I.EQ.2) THEN
      AA9=AA2*DELX2*UICEC(I-1,J)*UVM(I,J)*FLOAT(LCYC-0)
      ELSE IF(I.EQ.NXLCYC) THEN
      AA9=AA1*DELX2*UICEC(I+1,J)*UVM(I,J)*FLOAT(LCYC-0)
      ELSE
      AA9=0.0
      END IF

      URT(I)=AA9+FXY(I,J)-AA5*DELYR*UICE(I,J,2)
     1-(AA3+AA4)*DELY2*UICE(I,J,2)
     1+(ETA(I,J+1)+ETA(I+1,J+1))*UICE(I,J+1,2)*DELY2
     2+(ETA(I,J)+ETA(I+1,J))*UICE(I,J-1,2)*DELY2
     3+ETAMEAN*DELYR*(UICE(I,J+1,2)*TNG(J+1)-UICE(I,J-1,2)*TNG(J-1))
     4-ETAMEAN*DELYR*2.0*TNG(J)*(UICE(I,J+1,2)-UICE(I,J-1,2))
      URT(I)=(URT(I)+AMASS(I,J)*BYDTS*UICE(I,J,2)*2.0)*UVM(I,J)
      END DO

      CALL TRIDIAG(AU(2,J),BU(2,J),CU(2,J),URT(2),UICE(2,J,1),NXLCYC-1)

c      DO I=2,NXLCYC
c       CUU(I)=CU(I,J)
c      END DO
c      URT(2)=URT(2)/BU(2,J)
c      DO I=3,NXLCYC
c       IMD=I-1
c       CUU(I)=CUU(I)/(BU(I,J)-AU(I,J)*CUU(IMD))
c       URT(I)=(URT(I)-AU(I,J)*URT(IMD))/(BU(I,J)-AU(I,J)*CUU(IMD))
c      END DO
c      DO I=1,NXLCYC-2
c       J1=NXLCYC-I
c       J2=J1+1
c       URT(J1)=URT(J1)-CUU(J1)*URT(J2)
c      END DO
c      DO I=2,NXLCYC
c       UICE(I,J,1)=URT(I)
c      END DO

 1200 CONTINUE

      DO I=2,NXLCYC
      DO J=2,NYPOLE
      UICE(I,J,3)=UICE(I,J,1)
      END DO
      END DO

C NOW THE SECOND HALF
      DO I=2,NXLCYC
      DO J=2,NYPOLE
      DELX2=BYDX2(I)       ! 0.5/(DXU(I)*DXU(I))
      DELY2=BYDY2(J)       ! 0.5/(DYU(J)*DYU(J))
      DELYR=BYDYR(J)       ! 0.5/(DYU(J)*RADIUS)
      ETAMEAN=0.25*(ETA(I,J+1)+ETA(I+1,J+1)+ETA(I,J)+ETA(I+1,J))
      ZETAMEAN=0.25*(ZETA(I,J+1)+ZETA(I+1,J+1)+ZETA(I,J)+ZETA(I+1,J))

      AA1=ETA(I,J+1)+ETA(I+1,J+1)
      AA2=ETA(I,J)+ETA(I+1,J)
      AA5=-(ETA(I,J+1)+ETA(I+1,J+1)-ETA(I,J)-ETA(I+1,J))*TNG(J)
      AA6=2.0*ETAMEAN*TNG(J)*TNG(J)

      AV(J,I)=(-AA2*DELY2+ETAMEAN*DELYR*(TNG(J-1)-2.0*TNG(J)))*UVM(I,J)
      BV(J,I)=((AA1+AA2)*DELY2+AA5*DELYR+AA6*BYRAD2
     &+AMASS(I,J)*BYDTS*2.0+DRAGS(I,J))*UVM(I,J)+(1.0-UVM(I,J))
      CV(J,I)=(-AA1*DELY2-ETAMEAN*DELYR*(TNG(J+1)-2.0*TNG(J)))*UVM(I,J)
      END DO
      END DO
      DO I=2,NXLCYC
      AV(2,I)=0.0
      CV(NYPOLE,I)=0.0
c      CV(2,I)=CV(2,I)/BV(2,I)  ! absorbed into TRIDIAG
      END DO

      DO I=2,NXLCYC
      DO J=2,NYPOLE
      DELX2=BYDX2(I)       ! 0.5/(DXU(I)*DXU(I))
      DELY2=BYDY2(J)       ! 0.5/(DYU(J)*DYU(J))
      DELYR=BYDYR(J)       ! 0.5/(DYU(J)*RADIUS)
      ETAMEAN=0.25*(ETA(I,J+1)+ETA(I+1,J+1)+ETA(I,J)+ETA(I+1,J))

      AA1=((ETA(I+1,J)  +ZETA(I+1,J)  )*BYCSU(J)+
     *     (ETA(I+1,J+1)+ZETA(I+1,J+1))*BYCSU(J))*BYCSU(J)
      AA2=((ETA(I,J)+ZETA(I,J))*BYCSU(J)+(ETA(I,J+1)+ZETA(I,J+1))
     &     *BYCSU(J))*BYCSU(J)

      IF(J.EQ.NYPOLE) THEN
      AA9=( (ETA(I,J+1)+ETA(I+1,J+1))*DELY2*UICEC(I,J+1)
     &     +ETAMEAN*DELYR*(TNG(J+1)-2.0*TNG(J))*UICEC(I,J+1) )*UVM(I,J)
     &*FLOAT(NPOL-0)
      ELSE
      AA9=0.0
      END IF

      FXY1a(J,I)=AA9+AMASS(I,J)*BYDTS*UICE(I,J,1)*2.0
     5-(AA1+AA2)*DELX2*UICE(I,J,1)
     6+((ETA(I+1,J)+ZETA(I+1,J)+ETA(I+1,J+1)+ZETA(I+1,J+1))
     6*UICE(I+1,J,1)
     6+(ETA(I,J)+ZETA(I,J)+ETA(I,J+1)+ZETA(I,J+1))*UICE(I-1,J,1))
     6*DELX2*BYCSU(J)*BYCSU(J)

      END DO
      END DO

      DO 1300 I=2,NXLCYC
      DO J=2,NYPOLE
      VRT(J)=FXY(I,J)+FXY1a(J,I)
      VRT(J)=VRT(J)*UVM(I,J)
      END DO

      CALL TRIDIAG(AV(2,I),BV(2,I),CV(2,I),VRT(2),U_tmp(2),NYPOLE-1)

c      DO J=2,NYPOLE
c      CVV(J)=CV(J,I)
c      END DO
c      VRT(2)=VRT(2)/BV(2,I)
c      DO J=3,NYPOLE
c      JMD=J-1
c      CVV(J)=CVV(J)/(BV(J,I)-AV(J,I)*CVV(JMD))
c      VRT(J)=(VRT(J)-AV(J,I)*VRT(JMD))/(BV(J,I)-AV(J,I)*CVV(JMD))
c      END DO
c      DO J=1,NYPOLE-2
c      J1=NYPOLE-J
c      J2=J1+1
c      VRT(J1)=VRT(J1)-CVV(J1)*VRT(J2)
c      END DO
      DO J=2,NYPOLE
        UICE(I,J,1)=U_tmp(J)     ! VRT(J)   !
      END DO
 1300 CONTINUE

C NOW DO VICE
C THE FIRST HALF

      DO I=2,NXLCYC
      DO J=2,NYPOLE
      DELXY=BYDXDY(I,J)    ! 0.5/(DXU(I)*DYU(J))
      DELXR=BYDXR(I)       ! 0.5/(DXU(I)*RADIUS)
      DELY2=BYDY2(J)       ! 0.5/(DYU(J)*DYU(J))
      DELYR=BYDYR(J)       ! 0.5/(DYU(J)*RADIUS)
      ETAMEAN=0.25*(ETA(I,J+1)+ETA(I+1,J+1)+ETA(I,J)+ETA(I+1,J))
      ZETAMEAN=0.25*(ZETA(I,J+1)+ZETA(I+1,J+1)+ZETA(I,J)+ZETA(I+1,J))

      FXYa(J,I)=-DRAGA(I,J)*UICEC(I,J)+FORCEY(I,J)
     3+(0.5*(UICEC(I+1,J)-UICEC(I-1,J))*(ZETA(I,J+1)+ZETA(I+1,J+1)
     3-ZETA(I,J)-ZETA(I+1,J))*DELXY*BYCSU(J)+0.5*ZETAMEAN*
     3((UICEC(I+1,J+1)
     3-UICEC(I-1,J+1))*BYCSU(J+1)-(UICEC(I+1,J-1)-UICEC(I-1,J-1))
     3*BYCSU(J-1))*DELXY)
     3
     4-(0.5*(UICEC(I+1,J)-UICEC(I-1,J))*(ETA(I,J+1)+ETA(I+1,J+1)
     4-ETA(I,J)-ETA(I+1,J))*DELXY*BYCSU(J)+0.5*ETAMEAN*((UICEC(I+1,J+1)
     4-UICEC(I-1,J+1))*BYCSU(J+1)-(UICEC(I+1,J-1)-UICEC(I-1,J-1))
     4*BYCSU(J-1))*DELXY)
     4
     5+0.5*(ETA(I+1,J+1)*(UICEC(I+1,J+1)+UICEC(I,J+1)
     5-UICEC(I+1,J)-UICEC(I,J))+ETA(I+1,J)*(UICEC(I+1,J)
     5+UICEC(I,J)-UICEC(I+1,J-1)-UICEC(I,J-1))+ETA(I,J+1)
     5*(UICEC(I,J)+UICEC(I-1,J)-UICEC(I,J+1)-UICEC(I-1,J+1))
     5+ETA(I,J)*(UICEC(I,J-1)+UICEC(I-1,J-1)-UICEC(I,J)
     5-UICEC(I-1,J)))*DELXY*BYCSU(J)
     5
     6+(ETA(I+1,J+1)+ETA(I+1,J)-ETA(I,J)-ETA(I,J+1))
     6*TNG(J)*UICEC(I,J)*DELXR*BYCSU(J)
     6+ETAMEAN*TNG(J)*(UICEC(I+1,J)-UICEC(I-1,J))*DELXR*BYCSU(J)
     6
     7+ETAMEAN*2.0*TNG(J)*(UICEC(I+1,J)-UICEC(I-1,J))*DELXR*BYCSU(J)

      END DO
      END DO

      DO I=2,NXLCYC
      DO J=2,NYPOLE
      DELX2=BYDX2(I)       ! 0.5/(DXU(I)*DXU(I))
      DELY2=BYDY2(J)       ! 0.5/(DYU(J)*DYU(J))
      DELYR=BYDYR(J)       ! 0.5/(DYU(J)*RADIUS)
      ETAMEAN=0.25*(ETA(I,J+1)+ETA(I+1,J+1)+ETA(I,J)+ETA(I+1,J))
      ZETAMEAN=0.25*(ZETA(I,J+1)+ZETA(I+1,J+1)+ZETA(I,J)+ZETA(I+1,J))
      AA1=ETA(I,J+1)+ZETA(I,J+1)+ETA(I+1,J+1)+ZETA(I+1,J+1)
      AA2=ETA(I,J)+ZETA(I,J)+ETA(I+1,J)+ZETA(I+1,J)
      AA3=(ETA(I+1,J)*BYCSU(J)+ETA(I+1,J+1)*BYCSU(J))*BYCSU(J)
      AA4=(ETA(I,J)*BYCSU(J)+ETA(I,J+1)*BYCSU(J))*BYCSU(J)
      AA5=((ZETA(I,J+1)-ETA(I,J+1))+(ZETA(I+1,J+1)-ETA(I+1,J+1))
     &-(ZETA(I,J)-ETA(I,J))-(ZETA(I+1,J)-ETA(I+1,J)))*TNG(J)
      AA6=2.0*ETAMEAN*TNG(J)*TNG(J)

      AV(J,I)=(-AA2*DELY2-(ZETAMEAN-ETAMEAN)*TNG(J-1)*DELYR
     &-ETAMEAN*2.0*TNG(J)*DELYR)*UVM(I,J)
      BV(J,I)=((AA1+AA2)*DELY2+AA5*DELYR+AA6*BYRAD2
     &+AMASS(I,J)*BYDTS*2.0+DRAGS(I,J))*UVM(I,J)+(1.0-UVM(I,J))
      CV(J,I)=(-AA1*DELY2+(ZETAMEAN-ETAMEAN)*TNG(J+1)*DELYR
     &+ETAMEAN*2.0*TNG(J)*DELYR)*UVM(I,J)
      END DO
      END DO
      DO I=2,NXLCYC
      AV(2,I)=0.0
      CV(NYPOLE,I)=0.0
c      CV(2,I)=CV(2,I)/BV(2,I)  ! absorbed into TRIDIAG
      END DO

      DO 1301 I=2,NXLCYC
      DO J=2,NYPOLE
      DELX2=BYDX2(I)       ! 0.5/(DXU(I)*DXU(I))
      DELY2=BYDY2(J)       ! 0.5/(DYU(J)*DYU(J))
      DELYR=BYDYR(J)       ! 0.5/(DYU(J)*RADIUS)

      ETAMEAN=0.25*(ETA(I,J+1)+ETA(I+1,J+1)+ETA(I,J)+ETA(I+1,J))
      ZETAMEAN=0.25*(ZETA(I,J+1)+ZETA(I+1,J+1)+ZETA(I,J)+ZETA(I+1,J))

      AA1=ETA(I,J+1)+ZETA(I,J+1)+ETA(I+1,J+1)+ZETA(I+1,J+1)
      AA2=ETA(I,J)+ZETA(I,J)+ETA(I+1,J)+ZETA(I+1,J)
      AA3=(ETA(I+1,J)*BYCSU(J)+ETA(I+1,J+1)*BYCSU(J))*BYCSU(J)
      AA4=(ETA(I,J)*BYCSU(J)+ETA(I,J+1)*BYCSU(J))*BYCSU(J)
      AA5=((ZETA(I,J+1)-ETA(I,J+1))+(ZETA(I+1,J+1)-ETA(I+1,J+1))
     &-(ZETA(I,J)-ETA(I,J))-(ZETA(I+1,J)-ETA(I+1,J)))*TNG(J)
      AA6=2.0*ETAMEAN*TNG(J)*TNG(J)

      IF(J.EQ.NYPOLE) THEN
      AA9=(AA1*DELY2-(ZETAMEAN-ETAMEAN)*TNG(J+1)*DELYR
     &-ETAMEAN*2.0*TNG(J)*DELYR)*VICEC(I,J+1)*UVM(I,J)*FLOAT(NPOL-0)
      ELSE
      AA9=0.0
      END IF

      VRT(J)=AA9+FXYa(J,I)-(AA3+AA4)*DELX2*VICE(I,J,2)
     6+((ETA(I+1,J)*BYCSU(J)+ETA(I+1,J+1)*BYCSU(J))*VICE(I+1,J,2)*DELX2
     7     +(ETA(I,J)*BYCSU(J)+ETA(I,J+1)*BYCSU(J))*VICE(I-1,J,2)*DELX2)
     *     *BYCSU(J)
      VRT(J)=(VRT(J)+AMASS(I,J)*BYDTS*VICE(I,J,2)*2.0)*UVM(I,J)
      END DO

      CALL TRIDIAG(AV(2,I),BV(2,I),CV(2,I),VRT(2),U_tmp(2),NYPOLE-1)

c      DO J=2,NYPOLE
c      CVV(J)=CV(J,I)
c      END DO
c      VRT(2)=VRT(2)/BV(2,I)
c      DO J=3,NYPOLE
c      JMD=J-1
c      CVV(J)=CVV(J)/(BV(J,I)-AV(J,I)*CVV(JMD))
c      VRT(J)=(VRT(J)-AV(J,I)*VRT(JMD))/(BV(J,I)-AV(J,I)*CVV(JMD))
c      END DO
c      DO J=1,NYPOLE-2
c      J1=NYPOLE-J
c      J2=J1+1
c      VRT(J1)=VRT(J1)-CVV(J1)*VRT(J2)
c      END DO
      DO J=2,NYPOLE
        VICE(I,J,1)=U_tmp(J)   ! VRT(J)   !
      END DO
 1301 CONTINUE

      DO I=2,NXLCYC
      DO J=2,NYPOLE
      VICE(I,J,3)=VICE(I,J,1)
      END DO
      END DO

C NOW THE SECOND HALF

      DO J=2,NYPOLE
      DO I=2,NXLCYC
      DELX2=BYDX2(I)       ! 0.5/(DXU(I)*DXU(I))
      DELY2=BYDY2(J)       ! 0.5/(DYU(J)*DYU(J))
      DELYR=BYDYR(J)       ! 0.5/(DYU(J)*RADIUS)
      ETAMEAN=0.25*(ETA(I,J+1)+ETA(I+1,J+1)+ETA(I,J)+ETA(I+1,J))
      ZETAMEAN=0.25*(ZETA(I,J+1)+ZETA(I+1,J+1)+ZETA(I,J)+ZETA(I+1,J))

      AA1=ETA(I,J+1)+ZETA(I,J+1)+ETA(I+1,J+1)+ZETA(I+1,J+1)
      AA2=ETA(I,J)+ZETA(I,J)+ETA(I+1,J)+ZETA(I+1,J)
      AA3=(ETA(I+1,J)*BYCSU(J)+ETA(I+1,J+1)*BYCSU(J))*BYCSU(J)
      AA4=(ETA(I,J)*BYCSU(J)+ETA(I,J+1)*BYCSU(J))*BYCSU(J)
      AA6=2.0*ETAMEAN*TNG(J)*TNG(J)

      AU(I,J)=-AA4*DELX2*UVM(I,J)
      BU(I,J)=((AA3+AA4)*DELX2+AA6*BYRAD2
     &+AMASS(I,J)*BYDTS*2.0+DRAGS(I,J))*UVM(I,J)+(1.0-UVM(I,J))
      CU(I,J)=-AA3*DELX2*UVM(I,J)
      END DO
      END DO
      DO J=2,NYPOLE
      AU(2,J)=0.0
      CU(NXLCYC,J)=0.0
c      CU(2,J)=CU(2,J)/BU(2,J)   ! absorbed into TRIDIAG
      END DO

      DO J=2,NYPOLE
      DO I=2,NXLCYC

      DELX2=BYDX2(I)       ! 0.5/(DXU(I)*DXU(I))
      DELY2=BYDY2(J)       ! 0.5/(DYU(J)*DYU(J))
      DELYR=BYDYR(J)       ! 0.5/(DYU(J)*RADIUS)
      ETAMEAN=0.25*(ETA(I,J+1)+ETA(I+1,J+1)+ETA(I,J)+ETA(I+1,J))
      ZETAMEAN=0.25*(ZETA(I,J+1)+ZETA(I+1,J+1)+ZETA(I,J)+ZETA(I+1,J))

      AA1=ETA(I,J+1)+ZETA(I,J+1)+ETA(I+1,J+1)+ZETA(I+1,J+1)
      AA2=ETA(I,J)+ZETA(I,J)+ETA(I+1,J)+ZETA(I+1,J)
      AA3=(ETA(I+1,J)*BYCSU(J)+ETA(I+1,J+1)*BYCSU(J))*BYCSU(J)
      AA4=(ETA(I,J)*BYCSU(J)+ETA(I,J+1)*BYCSU(J))*BYCSU(J)
      AA5=((ZETA(I,J+1)-ETA(I,J+1))+(ZETA(I+1,J+1)-ETA(I+1,J+1))
     &-(ZETA(I,J)-ETA(I,J))-(ZETA(I+1,J)-ETA(I+1,J)))*TNG(J)
      AA6=2.0*ETAMEAN*TNG(J)*TNG(J)

      IF(I.EQ.2) THEN
      AA9=AA4*DELX2*VICEC(I-1,J)*UVM(I,J)*FLOAT(LCYC-0)
      ELSE IF(I.EQ.NXLCYC) THEN
      AA9=AA3*DELX2*VICEC(I+1,J)*UVM(I,J)*FLOAT(LCYC-0)
      ELSE
      AA9=0.0
      END IF
      FXY1(I,J)=AA9+AMASS(I,J)*BYDTS*VICE(I,J,1)*2.0
     1-AA5*DELYR*VICE(I,J,1)
     1-(AA1+AA2)*DELY2*VICE(I,J,1)
     1+AA1*DELY2*VICE(I,J+1,1)-((ZETAMEAN-ETAMEAN)*TNG(J+1)*DELYR
     1+ETAMEAN*2.0*TNG(J)*DELYR)*VICE(I,J+1,1)
     2+AA2*DELY2*VICE(I,J-1,1)+((ZETAMEAN-ETAMEAN)*TNG(J-1)*DELYR
     2+ETAMEAN*2.0*TNG(J)*DELYR)*VICE(I,J-1,1)
      END DO
      END DO

      DO 1201 J=2,NYPOLE
      DO I=2,NXLCYC
      URT(I)=FXYa(J,I)+FXY1(I,J)
      URT(I)=URT(I)*UVM(I,J)
      END DO

      CALL TRIDIAG(AU(2,J),BU(2,J),CU(2,J),URT(2),VICE(2,J,1),NXLCYC-1)

c      DO I=2,NXLCYC
c      CUU(I)=CU(I,J)
c      END DO
c      URT(2)=URT(2)/BU(2,J)
c      DO I=3,NXLCYC
c      IMD=I-1
c      CUU(I)=CUU(I)/(BU(I,J)-AU(I,J)*CUU(IMD))
c      URT(I)=(URT(I)-AU(I,J)*URT(IMD))/(BU(I,J)-AU(I,J)*CUU(IMD))
c      END DO
c      DO I=1,NXLCYC-2
c      J1=NXLCYC-I
c      J2=J1+1
c      URT(J1)=URT(J1)-CUU(J1)*URT(J2)
c      END DO
c      DO I=2,NXLCYC
c      VICE(I,J,1)=URT(I)
c      END DO
 1201 CONTINUE

      DO J=2,NYPOLE
      DO I=2,NXLCYC
      UICE(I,J,1)=UICE(I,J,1)*UVM(I,J)
      VICE(I,J,1)=VICE(I,J,1)*UVM(I,J)
      END DO
      END DO

      RETURN
      END SUBROUTINE RELAX

      SUBROUTINE setup_icedyn_grid
      USE MODEL_COM, only : dts=>dtsrc
      IMPLICIT NONE
      REAL*8 :: dlat,dlon,phit,phiu,hemi,rms
      INTEGER I,J,n,k,kki,sumk,l
C****
C**** calculate grid and initialise arrays
c****
      dlat=nint(180./(ny1-1))*radian
      dlon=nint(360./(nx1-2))*radian
      bydts = 1./dts
c****
      do j = 1,ny1
        dyt(j) = dlat*radius
        dyu(j) = dlat*radius
      enddo
      do i=1,nx1
        dxt(i) = dlon*radius
        dxu(i) = dlon*radius
      enddo
      dxt(1) = dxt(nx1-1)
      dxt(nx1) = dxt(2)
      dxu(1) = dxu(nx1-1)
      dxu(nx1) = dxu(2)

      do i=1,nx1
        bydx2(i)=0.5/(dxu(i)*dxu(i))
        bydxr(i)=0.5/(dxu(i)*radius)
      end do
      do j=1,ny1
        bydy2(j)=0.5/(dyu(j)*dyu(j))
        bydyr(j)=0.5/(dyu(j)*radius)
        do i=1,nx1
          bydxdy(i,j) = 0.5/(dxu(i)*dyu(j))
        end do
      end do

      do j = 1,ny1
       phit = (-90.+(j-1)*4.)*radian
       phiu = (-88.+(j-1)*4.)*radian
       cst(j) = cos(phit)
       csu(j) = cos(phiu)
       bycsu(j) = 1./csu(j)
       tng(j) = sin(phiu)/csu(j)
       TNGT(J)=SIN(PHIT)/CST(J)
       DO I=1,NX1
         SINEN(I,J)=SIN(PHIU)
       enddo
      enddo
      TNGT(NY1)=TNGT(NY1-1)
      TNG(NY1)=TNG(NY1-1)
      CSU(NY1)=CSU(NY1-1)
      bycsu(NY1) = 1./csu(NY1)

C**** sin/cos ice-ocean turning angle
      SINWAT=SIN(OIPHI)
      COSWAT=COS(OIPHI)

C**** Set land masks for tracer and velocity points
      do j=1,ny1
        do i=2,nx1-1
          heffm(i,j)=nint(focean(i-1,j))
        enddo
        heffm(1,j)=heffm(nx1-1,j)
        heffm(nx1,j)=heffm(2,j)
      enddo
C**** define velocity points (including exterior corners)
      do j=1,ny1-1
        do i=1,nx1-1
c          sumk=heffm(i,j)+heffm(i+1,j)+heffm(i,j+1)+heffm(i+1,j+1)
c          if (sumk.ge.3) uvm(i,j)=1  ! includes exterior corners
          uvm(i,j) = nint(min(heffm(i,j), heffm(i+1,j), heffm(i,j+1),
     *         heffm(i+1,j+1)))
        end do
      end do
C**** reset tracer points to surround velocity points (except for single
      do j=2,ny1-1
        do i=2,nx1-1
          k = nint(max (uvm(i,j), uvm(i-1,j), uvm(i,j-1), uvm(i-1,j-1)))
c         sumk = nint(uvm(i,j)+uvm(i+1,j)+uvm(i,j+1)+uvm(i+1,j+1))
c set to k except if an island
c         if (.not. (sumk.eq.4.and.focean(i-1,j).eq.0) ) then
            heffm(i,j) = k
c         end if
        enddo
      enddo
C**** final sweep to reinstate islands
c      do j=2,ny1-1
c        do i=2,nx1-1
c          sumk = nint(uvm(i,j)+uvm(i+1,j)+uvm(i,j+1)+uvm(i+1,j+1))
c          if (sumk.eq.4.and.heffm(i,j).eq.0.) then
c            uvm(i,j)=0 ; uvm(i+1,j)=0 ; uvm(i,j+1)=0 ; uvm(i+1,j+1)=0
c          end if
c        enddo
c      enddo
c set lateral boundary conditions
      do j=1,ny1
        heffm(1,j)   = heffm(nx1-1,j)
        heffm(nx1,j) = heffm(2,j)
      enddo
      do j=1,ny1-1
        do i=1,nx1-1
          uvm(i,j) = nint(min(heffm(i,j), heffm(i+1,j), heffm(i,j+1),
     *         heffm(i+1,j+1)))
        end do
      end do
c set cyclic conditions on eastern and western boundary
      do j=1,ny1
        uvm(1,j) = uvm(nx1-1,j)
        uvm(nx1,j) = uvm(2,j)
      enddo

      RETURN
      END SUBROUTINE setup_icedyn_grid

      END MODULE ICEDYN

      SUBROUTINE VPICEDYN
!@sum  vpicedyn is the entry point into the viscous-plastic ice
!@+    dynamics code
!@auth Gavin Schmidt (based on code from J. Zhang)
      USE ICEDYN, only : nx1,ny1,form,relax,uice,vice,uicec,vicec
      IMPLICIT NONE
      REAL*8, DIMENSION(NX1,NY1) :: USAVE,VSAVE
      REAL*8 rms
      INTEGER kki,i,j

      rms=0.
C KKI LOOP IS FOR PSEUDO-TIMESTEPPING
      KKI=0.
 10   KKI=KKI+1

C FIRST DO PREDICTOR
      DO J=1,NY1
      DO I=1,NX1
       UICE(I,J,3)=UICE(I,J,1)
       VICE(I,J,3)=VICE(I,J,1)
       UICEC(I,J)=UICE(I,J,1)
       VICEC(I,J)=VICE(I,J,1)
      END DO
      END DO

      CALL FORM
      CALL RELAX

      DO J=1,NY1
       UICE(1,J,1)=UICE(NX1-1,J,1)
       VICE(1,J,1)=VICE(NX1-1,J,1)
       UICE(NX1,J,1)=UICE(2,J,1)
       VICE(NX1,J,1)=VICE(2,J,1)
      END DO

C NOW DO REGULAR TIME STEP
C NOW DO MODIFIED EULER STEP
c
      DO J=1,NY1
      DO I=1,NX1
       UICE(I,J,1)=0.5*(UICE(I,J,1)+UICE(I,J,2))
       VICE(I,J,1)=0.5*(VICE(I,J,1)+VICE(I,J,2))
      END DO
      END DO

      CALL FORM

C NOW SET U(1)=U(2) AND SAME FOR V
      DO J=1,NY1
      DO I=1,NX1
       UICE(I,J,3)=UICE(I,J,1)
       VICE(I,J,3)=VICE(I,J,1)
       UICEC(I,J)=UICE(I,J,1)
       VICEC(I,J)=VICE(I,J,1)
       UICE(I,J,1)=UICE(I,J,2)
       VICE(I,J,1)=VICE(I,J,2)
      END DO
      END DO

      CALL RELAX

      DO J=1,NY1
       UICE(1,J,1)=UICE(NX1-1,J,1)
       VICE(1,J,1)=VICE(NX1-1,J,1)
       UICE(NX1,J,1)=UICE(2,J,1)
       VICE(NX1,J,1)=VICE(2,J,1)
      END DO

      if (kki.gt.1) then ! test convergence
        rms=0.
        do i=1,nx1
          do j=1,ny1
            rms=rms+(USAVE(i,j)-UICE(i,j,1))**2+(VSAVE(i,j)-VICE(i,j,1))
     *           **2
          end do
        end do
      end if

      if (kki.eq.20) then
        write(6,*) "Too many iterations in VPICEDYN. kki:",kki,rms
      elseif (kki.eq.1 .or. rms.gt.0.01d0) then
        USAVE=UICE(:,:,1)
        VSAVE=VICE(:,:,1)
        goto 10
      end if

      RETURN
      END SUBROUTINE VPICEDYN


MODULE module_mp_radar
      USE module_wrf_error
      PUBLIC :: rayleigh_soak_wetgraupel
      PUBLIC :: radar_init
      PRIVATE :: m_complex_water_ray
      PRIVATE :: m_complex_ice_maetzler
      PRIVATE :: m_complex_maxwellgarnett
      PRIVATE :: get_m_mix_nested
      PRIVATE :: get_m_mix
      PRIVATE :: WGAMMA
      PRIVATE :: GAMMLN
      INTEGER, PARAMETER, PUBLIC:: nrbins = 50
      DOUBLE PRECISION, DIMENSION(nrbins+1), PUBLIC:: xxDx
      DOUBLE PRECISION, DIMENSION(nrbins), PUBLIC:: xxDs,xdts,xxDg,xdtg
      DOUBLE PRECISION, PARAMETER, PUBLIC:: lamda_radar = 0.10
      DOUBLE PRECISION, PUBLIC:: K_w, PI5, lamda4
      COMPLEX*16, PUBLIC:: m_w_0, m_i_0
      DOUBLE PRECISION, DIMENSION(nrbins+1), PUBLIC:: simpson
      DOUBLE PRECISION, DIMENSION(3), PARAMETER, PUBLIC:: basis = &
                           (/1.d0/3.d0, 4.d0/3.d0, 1.d0/3.d0/)
      REAL, DIMENSION(4), PUBLIC:: xcre, xcse, xcge, xcrg, xcsg, xcgg
      REAL, PUBLIC:: xam_r, xbm_r, xmu_r, xobmr
      REAL, PUBLIC:: xam_s, xbm_s, xmu_s, xoams, xobms, xocms
      REAL, PUBLIC:: xam_g, xbm_g, xmu_g, xoamg, xobmg, xocmg
      REAL, PUBLIC:: xorg2, xosg2, xogg2
      INTEGER, PARAMETER, PUBLIC:: slen = 20
      CHARACTER(len=slen), PUBLIC:: &
              mixingrulestring_s, matrixstring_s, inclusionstring_s, &
              hoststring_s, hostmatrixstring_s, hostinclusionstring_s, &
              mixingrulestring_g, matrixstring_g, inclusionstring_g, &
              hoststring_g, hostmatrixstring_g, hostinclusionstring_g
      DOUBLE PRECISION, PARAMETER:: melt_outside_s = 0.9d0
      DOUBLE PRECISION, PARAMETER:: melt_outside_g = 0.9d0
      CHARACTER*256:: radar_debug
CONTAINS
      subroutine radar_init
      IMPLICIT NONE
      INTEGER:: n
      PI5 = 3.14159*3.14159*3.14159*3.14159*3.14159
      lamda4 = lamda_radar*lamda_radar*lamda_radar*lamda_radar
      m_w_0 = m_complex_water_ray (lamda_radar, 0.0d0)
      m_i_0 = m_complex_ice_maetzler (lamda_radar, 0.0d0)
      K_w = (ABS( (m_w_0*m_w_0 - 1.0) /(m_w_0*m_w_0 + 2.0) ))**2
      do n = 1, nrbins+1
         simpson(n) = 0.0d0
      enddo
      do n = 1, nrbins-1, 2
         simpson(n) = simpson(n) + basis(1)
         simpson(n+1) = simpson(n+1) + basis(2)
         simpson(n+2) = simpson(n+2) + basis(3)
      enddo
      do n = 1, slen
         mixingrulestring_s(n:n) = char(0)
         matrixstring_s(n:n) = char(0)
         inclusionstring_s(n:n) = char(0)
         hoststring_s(n:n) = char(0)
         hostmatrixstring_s(n:n) = char(0)
         hostinclusionstring_s(n:n) = char(0)
         mixingrulestring_g(n:n) = char(0)
         matrixstring_g(n:n) = char(0)
         inclusionstring_g(n:n) = char(0)
         hoststring_g(n:n) = char(0)
         hostmatrixstring_g(n:n) = char(0)
         hostinclusionstring_g(n:n) = char(0)
      enddo
      mixingrulestring_s = 'maxwellgarnett'
      hoststring_s = 'air'
      matrixstring_s = 'water'
      inclusionstring_s = 'spheroidal'
      hostmatrixstring_s = 'icewater'
      hostinclusionstring_s = 'spheroidal'
      mixingrulestring_g = 'maxwellgarnett'
      hoststring_g = 'air'
      matrixstring_g = 'water'
      inclusionstring_g = 'spheroidal'
      hostmatrixstring_g = 'icewater'
      hostinclusionstring_g = 'spheroidal'
      xxDx(1) = 100.D-6
      xxDx(nrbins+1) = 0.02d0
      do n = 2, nrbins
         xxDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nrbins) &
                  *DLOG(xxDx(nrbins+1)/xxDx(1)) +DLOG(xxDx(1)))
      enddo
      do n = 1, nrbins
         xxDs(n) = DSQRT(xxDx(n)*xxDx(n+1))
         xdts(n) = xxDx(n+1) - xxDx(n)
      enddo
      xxDx(1) = 100.D-6
      xxDx(nrbins+1) = 0.05d0
      do n = 2, nrbins
         xxDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nrbins) &
                  *DLOG(xxDx(nrbins+1)/xxDx(1)) +DLOG(xxDx(1)))
      enddo
      do n = 1, nrbins
         xxDg(n) = DSQRT(xxDx(n)*xxDx(n+1))
         xdtg(n) = xxDx(n+1) - xxDx(n)
      enddo
      xcre(1) = 1. + xbm_r
      xcre(2) = 1. + xmu_r
      xcre(3) = 1. + xbm_r + xmu_r
      xcre(4) = 1. + 2.*xbm_r + xmu_r
      do n = 1, 4
         xcrg(n) = WGAMMA(xcre(n))
      enddo
      xorg2 = 1./xcrg(2)
      xcse(1) = 1. + xbm_s
      xcse(2) = 1. + xmu_s
      xcse(3) = 1. + xbm_s + xmu_s
      xcse(4) = 1. + 2.*xbm_s + xmu_s
      do n = 1, 4
         xcsg(n) = WGAMMA(xcse(n))
      enddo
      xosg2 = 1./xcsg(2)
      xcge(1) = 1. + xbm_g
      xcge(2) = 1. + xmu_g
      xcge(3) = 1. + xbm_g + xmu_g
      xcge(4) = 1. + 2.*xbm_g + xmu_g
      do n = 1, 4
         xcgg(n) = WGAMMA(xcge(n))
      enddo
      xogg2 = 1./xcgg(2)
      xobmr = 1./xbm_r
      xoams = 1./xam_s
      xobms = 1./xbm_s
      xocms = xoams**xobms
      xoamg = 1./xam_g
      xobmg = 1./xbm_g
      xocmg = xoamg**xobmg
      end subroutine radar_init
      COMPLEX*16 FUNCTION m_complex_water_ray(lambda,T)
      IMPLICIT NONE
      DOUBLE PRECISION, INTENT(IN):: T,lambda
      DOUBLE PRECISION:: epsinf,epss,epsr,epsi
      DOUBLE PRECISION:: alpha,lambdas,sigma,nenner
      COMPLEX*16, PARAMETER:: i = (0d0,1d0)
      DOUBLE PRECISION, PARAMETER:: PIx=3.1415926535897932384626434d0
      epsinf = 5.27137d0 + 0.02164740d0 * T - 0.00131198d0 * T*T
      epss = 78.54d+0 * (1.0 - 4.579d-3 * (T - 25.0) &
              + 1.190d-5 * (T - 25.0)*(T - 25.0) &
              - 2.800d-8 * (T - 25.0)*(T - 25.0)*(T - 25.0))
      alpha = -16.8129d0/(T+273.16) + 0.0609265d0
      lambdas = 0.00033836d0 * exp(2513.98d0/(T+273.16)) * 1e-2
      nenner = 1.d0+2.d0*(lambdas/lambda)**(1d0-alpha)*sin(alpha*PIx*0.5) &
             + (lambdas/lambda)**(2d0-2d0*alpha)
      epsr = epsinf + ((epss-epsinf) * ((lambdas/lambda)**(1d0-alpha) &
           * sin(alpha*PIx*0.5)+1d0)) / nenner
      epsi = ((epss-epsinf) * ((lambdas/lambda)**(1d0-alpha) &
           * cos(alpha*PIx*0.5)+0d0)) / nenner &
           + lambda*1.25664/1.88496
      m_complex_water_ray = SQRT(CMPLX(epsr,-epsi))
      END FUNCTION m_complex_water_ray
      COMPLEX*16 FUNCTION m_complex_ice_maetzler(lambda,T)
      IMPLICIT NONE
      DOUBLE PRECISION, INTENT(IN):: T,lambda
      DOUBLE PRECISION:: f,c,TK,B1,B2,b,deltabeta,betam,beta,theta,alfa
      c = 2.99d8
      TK = T + 273.16
      f = c / lambda * 1d-9
      B1 = 0.0207
      B2 = 1.16d-11
      b = 335.0d0
      deltabeta = EXP(-10.02 + 0.0364*(TK-273.16))
      betam = (B1/TK) * ( EXP(b/TK) / ((EXP(b/TK)-1)**2) ) + B2*f*f
      beta = betam + deltabeta
      theta = 300. / TK - 1.
      alfa = (0.00504d0 + 0.0062d0*theta) * EXP(-22.1d0*theta)
      m_complex_ice_maetzler = 3.1884 + 9.1e-4*(TK-273.16)
      m_complex_ice_maetzler = m_complex_ice_maetzler &
                             + CMPLX(0.0d0, (alfa/f + beta*f))
      m_complex_ice_maetzler = SQRT(CONJG(m_complex_ice_maetzler))
      END FUNCTION m_complex_ice_maetzler
      subroutine rayleigh_soak_wetgraupel (x_g, a_geo, b_geo, fmelt, &
                     meltratio_outside, m_w, m_i, lambda, C_back, &
                     mixingrule,matrix,inclusion, &
                     host,hostmatrix,hostinclusion)
      IMPLICIT NONE
      DOUBLE PRECISION, INTENT(in):: x_g, a_geo, b_geo, fmelt, lambda, &
                                     meltratio_outside
      DOUBLE PRECISION, INTENT(out):: C_back
      COMPLEX*16, INTENT(in):: m_w, m_i
      CHARACTER(len=*), INTENT(in):: mixingrule, matrix, inclusion, &
                                     host, hostmatrix, hostinclusion
      COMPLEX*16:: m_core, m_air
      DOUBLE PRECISION:: D_large, D_g, rhog, x_w, xw_a, fm, fmgrenz, &
                         volg, vg, volair, volice, volwater, &
                         meltratio_outside_grenz, mra
      INTEGER:: error
      DOUBLE PRECISION, PARAMETER:: PIx=3.1415926535897932384626434d0
      m_air = (1.0d0,0.0d0)
      fm = DMAX1(DMIN1(fmelt, 1.0d0), 0.0d0)
      mra = DMAX1(DMIN1(meltratio_outside, 1.0d0), 0.0d0)
      mra = mra + (1.0d0-mra)*fm
      x_w = x_g * fm
      D_g = a_geo * x_g**b_geo
      if (D_g .ge. 1d-12) then
       vg = PIx/6. * D_g**3
       rhog = DMAX1(DMIN1(x_g / vg, 900.0d0), 10.0d0)
       vg = x_g / rhog
       meltratio_outside_grenz = 1.0d0 - rhog / 1000.
       if (mra .le. meltratio_outside_grenz) then
        volg = vg * (1.0d0 - mra * fm)
       else
        fmgrenz=(900.0-rhog)/(mra*900.0-rhog+900.0*rhog/1000.)
        if (fm .le. fmgrenz) then
         volg = (1.0 - mra * fm) * vg
        else
         volg = (x_g - x_w) / 900.0 + x_w / 1000.
        endif
       endif
       D_large = (6.0 / PIx * volg) ** (1./3.)
       volice = (x_g - x_w) / (volg * 900.0)
       volwater = x_w / (1000. * volg)
       volair = 1.0 - volice - volwater
       m_core = get_m_mix_nested (m_air, m_i, m_w, volair, volice, &
                         volwater, mixingrule, host, matrix, inclusion, &
                         hostmatrix, hostinclusion, error)
       if (error .ne. 0) then
        C_back = 0.0d0
        return
       endif
       C_back = (ABS((m_core**2-1.0d0)/(m_core**2+2.0d0)))**2 &
                * PI5 * D_large**6 / lamda4
      else
       C_back = 0.0d0
      endif
      end subroutine rayleigh_soak_wetgraupel
      complex*16 function get_m_mix_nested (m_a, m_i, m_w, volair, &
                     volice, volwater, mixingrule, host, matrix, &
                     inclusion, hostmatrix, hostinclusion, cumulerror)
      IMPLICIT NONE
      DOUBLE PRECISION, INTENT(in):: volice, volair, volwater
      COMPLEX*16, INTENT(in):: m_a, m_i, m_w
      CHARACTER(len=*), INTENT(in):: mixingrule, host, matrix, &
                     inclusion, hostmatrix, hostinclusion
      INTEGER, INTENT(out):: cumulerror
      DOUBLE PRECISION:: vol1, vol2
      COMPLEX*16:: mtmp
      INTEGER:: error
      cumulerror = 0
      get_m_mix_nested = CMPLX(1.0d0,0.0d0)
      if (host .eq. 'air') then
       if (matrix .eq. 'air') then
        write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix
        CALL wrf_debug(150, radar_debug)
        cumulerror = cumulerror + 1
       else
        vol1 = volice / MAX(volice+volwater,1d-10)
        vol2 = 1.0d0 - vol1
        mtmp = get_m_mix (m_a, m_i, m_w, 0.0d0, vol1, vol2, &
                         mixingrule, matrix, inclusion, error)
        cumulerror = cumulerror + error
        if (hostmatrix .eq. 'air') then
         get_m_mix_nested = get_m_mix (m_a, mtmp, 2.0*m_a, &
                         volair, (1.0d0-volair), 0.0d0, mixingrule, &
                         hostmatrix, hostinclusion, error)
         cumulerror = cumulerror + error
        elseif (hostmatrix .eq. 'icewater') then
         get_m_mix_nested = get_m_mix (m_a, mtmp, 2.0*m_a, &
                         volair, (1.0d0-volair), 0.0d0, mixingrule, &
                         'ice', hostinclusion, error)
         cumulerror = cumulerror + error
        else
         write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', &
                           hostmatrix
         CALL wrf_debug(150, radar_debug)
         cumulerror = cumulerror + 1
        endif
       endif
      elseif (host .eq. 'ice') then
       if (matrix .eq. 'ice') then
        write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix
        CALL wrf_debug(150, radar_debug)
        cumulerror = cumulerror + 1
       else
        vol1 = volair / MAX(volair+volwater,1d-10)
        vol2 = 1.0d0 - vol1
        mtmp = get_m_mix (m_a, m_i, m_w, vol1, 0.0d0, vol2, &
                         mixingrule, matrix, inclusion, error)
        cumulerror = cumulerror + error
        if (hostmatrix .eq. 'ice') then
         get_m_mix_nested = get_m_mix (mtmp, m_i, 2.0*m_a, &
                         (1.0d0-volice), volice, 0.0d0, mixingrule, &
                         hostmatrix, hostinclusion, error)
         cumulerror = cumulerror + error
        elseif (hostmatrix .eq. 'airwater') then
         get_m_mix_nested = get_m_mix (mtmp, m_i, 2.0*m_a, &
                         (1.0d0-volice), volice, 0.0d0, mixingrule, &
                         'air', hostinclusion, error)
         cumulerror = cumulerror + error
        else
         write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', &
                           hostmatrix
         CALL wrf_debug(150, radar_debug)
         cumulerror = cumulerror + 1
        endif
       endif
      elseif (host .eq. 'water') then
       if (matrix .eq. 'water') then
        write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix
        CALL wrf_debug(150, radar_debug)
        cumulerror = cumulerror + 1
       else
        vol1 = volair / MAX(volice+volair,1d-10)
        vol2 = 1.0d0 - vol1
        mtmp = get_m_mix (m_a, m_i, m_w, vol1, vol2, 0.0d0, &
                         mixingrule, matrix, inclusion, error)
        cumulerror = cumulerror + error
        if (hostmatrix .eq. 'water') then
         get_m_mix_nested = get_m_mix (2*m_a, mtmp, m_w, &
                         0.0d0, (1.0d0-volwater), volwater, mixingrule, &
                         hostmatrix, hostinclusion, error)
         cumulerror = cumulerror + error
        elseif (hostmatrix .eq. 'airice') then
         get_m_mix_nested = get_m_mix (2*m_a, mtmp, m_w, &
                         0.0d0, (1.0d0-volwater), volwater, mixingrule, &
                         'ice', hostinclusion, error)
         cumulerror = cumulerror + error
        else
         write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', &
                           hostmatrix
         CALL wrf_debug(150, radar_debug)
         cumulerror = cumulerror + 1
        endif
       endif
      elseif (host .eq. 'none') then
       get_m_mix_nested = get_m_mix (m_a, m_i, m_w, &
                       volair, volice, volwater, mixingrule, &
                       matrix, inclusion, error)
       cumulerror = cumulerror + error
      else
       write(radar_debug,*) 'GET_M_MIX_NESTED: unknown matrix: ', host
       CALL wrf_debug(150, radar_debug)
       cumulerror = cumulerror + 1
      endif
      IF (cumulerror .ne. 0) THEN
       write(radar_debug,*) 'GET_M_MIX_NESTED: error encountered'
       CALL wrf_debug(150, radar_debug)
       get_m_mix_nested = CMPLX(1.0d0,0.0d0)
      endif
      end function get_m_mix_nested
      COMPLEX*16 FUNCTION get_m_mix (m_a, m_i, m_w, volair, volice, &
                     volwater, mixingrule, matrix, inclusion, error)
      IMPLICIT NONE
      DOUBLE PRECISION, INTENT(in):: volice, volair, volwater
      COMPLEX*16, INTENT(in):: m_a, m_i, m_w
      CHARACTER(len=*), INTENT(in):: mixingrule, matrix, inclusion
      INTEGER, INTENT(out):: error
      error = 0
      get_m_mix = CMPLX(1.0d0,0.0d0)
      if (mixingrule .eq. 'maxwellgarnett') then
       if (matrix .eq. 'ice') then
        get_m_mix = m_complex_maxwellgarnett(volice, volair, volwater, &
                           m_i, m_a, m_w, inclusion, error)
       elseif (matrix .eq. 'water') then
        get_m_mix = m_complex_maxwellgarnett(volwater, volair, volice, &
                           m_w, m_a, m_i, inclusion, error)
       elseif (matrix .eq. 'air') then
        get_m_mix = m_complex_maxwellgarnett(volair, volwater, volice, &
                           m_a, m_w, m_i, inclusion, error)
       else
        write(radar_debug,*) 'GET_M_MIX: unknown matrix: ', matrix
        CALL wrf_debug(150, radar_debug)
        error = 1
       endif
      else
       write(radar_debug,*) 'GET_M_MIX: unknown mixingrule: ', mixingrule
       CALL wrf_debug(150, radar_debug)
       error = 2
      endif
      if (error .ne. 0) then
       write(radar_debug,*) 'GET_M_MIX: error encountered'
       CALL wrf_debug(150, radar_debug)
      endif
      END FUNCTION get_m_mix
      COMPLEX*16 FUNCTION m_complex_maxwellgarnett(vol1, vol2, vol3, &
                     m1, m2, m3, inclusion, error)
      IMPLICIT NONE
      COMPLEX*16 :: m1, m2, m3
      DOUBLE PRECISION :: vol1, vol2, vol3
      CHARACTER(len=*) :: inclusion
      COMPLEX*16 :: beta2, beta3, m1t, m2t, m3t
      INTEGER, INTENT(out) :: error
      error = 0
      if (DABS(vol1+vol2+vol3-1.0d0) .gt. 1d-6) then
       write(radar_debug,*) 'M_COMPLEX_MAXWELLGARNETT: sum of the ', &
              'partial volume fractions is not 1...ERROR'
       CALL wrf_debug(150, radar_debug)
       m_complex_maxwellgarnett=CMPLX(-999.99d0,-999.99d0)
       error = 1
       return
      endif
      m1t = m1**2
      m2t = m2**2
      m3t = m3**2
      if (inclusion .eq. 'spherical') then
       beta2 = 3.0d0*m1t/(m2t+2.0d0*m1t)
       beta3 = 3.0d0*m1t/(m3t+2.0d0*m1t)
      elseif (inclusion .eq. 'spheroidal') then
       beta2 = 2.0d0*m1t/(m2t-m1t) * (m2t/(m2t-m1t)*LOG(m2t/m1t)-1.0d0)
       beta3 = 2.0d0*m1t/(m3t-m1t) * (m3t/(m3t-m1t)*LOG(m3t/m1t)-1.0d0)
      else
       write(radar_debug,*) 'M_COMPLEX_MAXWELLGARNETT: ', &
                         'unknown inclusion: ', inclusion
       CALL wrf_debug(150, radar_debug)
       m_complex_maxwellgarnett=DCMPLX(-999.99d0,-999.99d0)
       error = 1
       return
      endif
      m_complex_maxwellgarnett = &
       SQRT(((1.0d0-vol2-vol3)*m1t + vol2*beta2*m2t + vol3*beta3*m3t) / &
       (1.0d0-vol2-vol3+vol2*beta2+vol3*beta3))
      END FUNCTION m_complex_maxwellgarnett
      REAL FUNCTION GAMMLN(XX)
      IMPLICIT NONE
      REAL, INTENT(IN):: XX
      DOUBLE PRECISION, PARAMETER:: STP = 2.5066282746310005D0
      DOUBLE PRECISION, DIMENSION(6), PARAMETER:: &
               COF = (/76.18009172947146D0, -86.50532032941677D0, &
                       24.01409824083091D0, -1.231739572450155D0, &
                      .1208650973866179D-2, -.5395239384953D-5/)
      DOUBLE PRECISION:: SER,TMP,X,Y
      INTEGER:: J
      X=XX
      Y=X
      TMP=X+5.5D0
      TMP=(X+0.5D0)*LOG(TMP)-TMP
      SER=1.000000000190015D0
      DO 11 J=1,6
        Y=Y+1.D0
        SER=SER+COF(J)/Y
11 CONTINUE
      GAMMLN=TMP+LOG(STP*SER/X)
      END FUNCTION GAMMLN
      REAL FUNCTION WGAMMA(y)
      IMPLICIT NONE
      REAL, INTENT(IN):: y
      WGAMMA = EXP(GAMMLN(y))
      END FUNCTION WGAMMA
END MODULE module_mp_radar


c---------------------------------------------------------------------
c---------------------------------------------------------------------

       subroutine y_solve

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c this function performs the solution of the approximate factorization
c step in the y-direction for all five matrix components
c simultaneously. The Thomas algorithm is employed to solve the
c systems for the y-lines. Boundary conditions are non-periodic
c---------------------------------------------------------------------

       include 'header.h'

       integer i, j, k, n, j1, j2, m
       double precision ru1, fac1, fac2

c---------------------------------------------------------------------
c---------------------------------------------------------------------

       if (timeron) call timer_start(t_ysolve)
!hpf$ independent, new(ru1,cv,rhoq,fac1,fac2,lhs,lhsp,lhsm)
       do  k = 1, grid_points(3)-2
          do  i = 1, grid_points(1)-2

c---------------------------------------------------------------------
c Computes the left hand side for the three y-factors
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c      first fill the lhs for the u-eigenvalue
c---------------------------------------------------------------------

             do  j = 0, grid_points(2)-1
                ru1 = c3c4*rho_i(i,j,k)
                cv(j) = vs(i,j,k)
                rhoq(j) = dmax1( dy3 + con43 * ru1,
     >                           dy5 + c1c5*ru1,
     >                           dymax + ru1,
     >                           dy1)
             end do

        do j = 0, grid_points(2)-1, grid_points(2)-1
          do   n = 1, 5
             lhs (n,j) = 0.0d0
             lhsp(n,j) = 0.0d0
             lhsm(n,j) = 0.0d0
          end do
          lhs (3,j) = 1.0d0
          lhsp(3,j) = 1.0d0
          lhsm(3,j) = 1.0d0
        end do
             do  j = 1, grid_points(2)-2
                lhs(1,j) =  0.0d0
                lhs(2,j) = -dtty2 * cv(j-1) - dtty1 * rhoq(j-1)
                lhs(3,j) =  1.0 + c2dtty1 * rhoq(j)
                lhs(4,j) =  dtty2 * cv(j+1) - dtty1 * rhoq(j+1)
                lhs(5,j) =  0.0d0
             end do

c---------------------------------------------------------------------
c      add fourth order dissipation
c---------------------------------------------------------------------

             j = 1

             lhs(3,j) = lhs(3,j) + comz5
             lhs(4,j) = lhs(4,j) - comz4
             lhs(5,j) = lhs(5,j) + comz1

             lhs(2,j+1) = lhs(2,j+1) - comz4
             lhs(3,j+1) = lhs(3,j+1) + comz6
             lhs(4,j+1) = lhs(4,j+1) - comz4
             lhs(5,j+1) = lhs(5,j+1) + comz1

             do   j=3, grid_points(2)-4

                lhs(1,j) = lhs(1,j) + comz1
                lhs(2,j) = lhs(2,j) - comz4
                lhs(3,j) = lhs(3,j) + comz6
                lhs(4,j) = lhs(4,j) - comz4
                lhs(5,j) = lhs(5,j) + comz1
             end do

             j = grid_points(2)-3
             lhs(1,j) = lhs(1,j) + comz1
             lhs(2,j) = lhs(2,j) - comz4
             lhs(3,j) = lhs(3,j) + comz6
             lhs(4,j) = lhs(4,j) - comz4

             lhs(1,j+1) = lhs(1,j+1) + comz1
             lhs(2,j+1) = lhs(2,j+1) - comz4
             lhs(3,j+1) = lhs(3,j+1) + comz5

c---------------------------------------------------------------------
c      subsequently, do the other two factors
c---------------------------------------------------------------------
             do    j = 1, grid_points(2)-2
                lhsp(1,j) = lhs(1,j)
                lhsp(2,j) = lhs(2,j) -
     >                            dtty2 * speed(i,j-1,k)
                lhsp(3,j) = lhs(3,j)
                lhsp(4,j) = lhs(4,j) +
     >                            dtty2 * speed(i,j+1,k)
                lhsp(5,j) = lhs(5,j)
                lhsm(1,j) = lhs(1,j)
                lhsm(2,j) = lhs(2,j) +
     >                            dtty2 * speed(i,j-1,k)
                lhsm(3,j) = lhs(3,j)
                lhsm(4,j) = lhs(4,j) -
     >                            dtty2 * speed(i,j+1,k)
                lhsm(5,j) = lhs(5,j)
             end do

c---------------------------------------------------------------------
c                          FORWARD ELIMINATION
c---------------------------------------------------------------------

             do    j = 0, grid_points(2)-3
                j1 = j  + 1
                j2 = j  + 2
                fac1      = 1.d0/lhs(3,j)
                lhs(4,j)  = fac1*lhs(4,j)
                lhs(5,j)  = fac1*lhs(5,j)
                do    m = 1, 3
                   rhs(m,i,j,k) = fac1*rhs(m,i,j,k)
                end do
                lhs(3,j1) = lhs(3,j1) -
     >                         lhs(2,j1)*lhs(4,j)
                lhs(4,j1) = lhs(4,j1) -
     >                         lhs(2,j1)*lhs(5,j)
                do    m = 1, 3
                   rhs(m,i,j1,k) = rhs(m,i,j1,k) -
     >                         lhs(2,j1)*rhs(m,i,j,k)
                end do
                lhs(2,j2) = lhs(2,j2) -
     >                         lhs(1,j2)*lhs(4,j)
                lhs(3,j2) = lhs(3,j2) -
     >                         lhs(1,j2)*lhs(5,j)
                do    m = 1, 3
                   rhs(m,i,j2,k) = rhs(m,i,j2,k) -
     >                         lhs(1,j2)*rhs(m,i,j,k)
                end do
             end do

c---------------------------------------------------------------------
c      The last two rows in this grid block are a bit different,
c      since they do not have two more rows available for the
c      elimination of off-diagonal entries
c---------------------------------------------------------------------

             j  = grid_points(2)-2
             j1 = grid_points(2)-1
             fac1      = 1.d0/lhs(3,j)
             lhs(4,j)  = fac1*lhs(4,j)
             lhs(5,j)  = fac1*lhs(5,j)
             do    m = 1, 3
                rhs(m,i,j,k) = fac1*rhs(m,i,j,k)
             end do
             lhs(3,j1) = lhs(3,j1) -
     >                      lhs(2,j1)*lhs(4,j)
             lhs(4,j1) = lhs(4,j1) -
     >                      lhs(2,j1)*lhs(5,j)
             do    m = 1, 3
                rhs(m,i,j1,k) = rhs(m,i,j1,k) -
     >                      lhs(2,j1)*rhs(m,i,j,k)
             end do
c---------------------------------------------------------------------
c            scale the last row immediately
c---------------------------------------------------------------------
             fac2      = 1.d0/lhs(3,j1)
             do    m = 1, 3
                rhs(m,i,j1,k) = fac2*rhs(m,i,j1,k)
             end do

c---------------------------------------------------------------------
c      do the u+c and the u-c factors
c---------------------------------------------------------------------
             do    j = 0, grid_points(2)-3
             	j1 = j  + 1
             	j2 = j  + 2
	     	m = 4
             	fac1	   = 1.d0/lhsp(3,j)
             	lhsp(4,j)  = fac1*lhsp(4,j)
             	lhsp(5,j)  = fac1*lhsp(5,j)
             	rhs(m,i,j,k) = fac1*rhs(m,i,j,k)
             	lhsp(3,j1) = lhsp(3,j1) -
     >       		    lhsp(2,j1)*lhsp(4,j)
             	lhsp(4,j1) = lhsp(4,j1) -
     >       		    lhsp(2,j1)*lhsp(5,j)
             	rhs(m,i,j1,k) = rhs(m,i,j1,k) -
     >       		    lhsp(2,j1)*rhs(m,i,j,k)
             	lhsp(2,j2) = lhsp(2,j2) -
     >       		    lhsp(1,j2)*lhsp(4,j)
             	lhsp(3,j2) = lhsp(3,j2) -
     >       		    lhsp(1,j2)*lhsp(5,j)
             	rhs(m,i,j2,k) = rhs(m,i,j2,k) -
     >       		    lhsp(1,j2)*rhs(m,i,j,k)
	     	m = 5
             	fac1	   = 1.d0/lhsm(3,j)
             	lhsm(4,j)  = fac1*lhsm(4,j)
             	lhsm(5,j)  = fac1*lhsm(5,j)
             	rhs(m,i,j,k) = fac1*rhs(m,i,j,k)
             	lhsm(3,j1) = lhsm(3,j1) -
     >       		    lhsm(2,j1)*lhsm(4,j)
             	lhsm(4,j1) = lhsm(4,j1) -
     >       		    lhsm(2,j1)*lhsm(5,j)
             	rhs(m,i,j1,k) = rhs(m,i,j1,k) -
     >       		    lhsm(2,j1)*rhs(m,i,j,k)
             	lhsm(2,j2) = lhsm(2,j2) -
     >       		    lhsm(1,j2)*lhsm(4,j)
             	lhsm(3,j2) = lhsm(3,j2) -
     >       		    lhsm(1,j2)*lhsm(5,j)
             	rhs(m,i,j2,k) = rhs(m,i,j2,k) -
     >       		    lhsm(1,j2)*rhs(m,i,j,k)
             end do

c---------------------------------------------------------------------
c         And again the last two rows separately
c---------------------------------------------------------------------
             j  = grid_points(2)-2
             j1 = grid_points(2)-1
	     m = 4
             fac1	= 1.d0/lhsp(3,j)
             lhsp(4,j)  = fac1*lhsp(4,j)
             lhsp(5,j)  = fac1*lhsp(5,j)
             rhs(m,i,j,k) = fac1*rhs(m,i,j,k)
             lhsp(3,j1) = lhsp(3,j1) -
     >       		 lhsp(2,j1)*lhsp(4,j)
             lhsp(4,j1) = lhsp(4,j1) -
     >       		 lhsp(2,j1)*lhsp(5,j)
             rhs(m,i,j1,k)   = rhs(m,i,j1,k) -
     >       		 lhsp(2,j1)*rhs(m,i,j,k)
	     m = 5
             fac1	= 1.d0/lhsm(3,j)
             lhsm(4,j)  = fac1*lhsm(4,j)
             lhsm(5,j)  = fac1*lhsm(5,j)
             rhs(m,i,j,k) = fac1*rhs(m,i,j,k)
             lhsm(3,j1) = lhsm(3,j1) -
     >       		 lhsm(2,j1)*lhsm(4,j)
             lhsm(4,j1) = lhsm(4,j1) -
     >       		 lhsm(2,j1)*lhsm(5,j)
             rhs(m,i,j1,k)   = rhs(m,i,j1,k) -
     >       		 lhsm(2,j1)*rhs(m,i,j,k)
c---------------------------------------------------------------------
c               Scale the last row immediately
c---------------------------------------------------------------------
             rhs(4,i,j1,k)   = rhs(4,i,j1,k)/lhsp(3,j1)
             rhs(5,i,j1,k)   = rhs(5,i,j1,k)/lhsm(3,j1)

c---------------------------------------------------------------------
c                         BACKSUBSTITUTION
c---------------------------------------------------------------------

             j  = grid_points(2)-2
             j1 = grid_points(2)-1
             do   m = 1, 3
                rhs(m,i,j,k) = rhs(m,i,j,k) -
     >                           lhs(4,j)*rhs(m,i,j1,k)
             end do

             rhs(4,i,j,k) = rhs(4,i,j,k) -
     >                           lhsp(4,j)*rhs(4,i,j1,k)
             rhs(5,i,j,k) = rhs(5,i,j,k) -
     >                           lhsm(4,j)*rhs(5,i,j1,k)

c---------------------------------------------------------------------
c      The first three factors
c---------------------------------------------------------------------
             do   j = grid_points(2)-3, 0, -1
                j1 = j  + 1
                j2 = j  + 2
                do   m = 1, 3
                   rhs(m,i,j,k) = rhs(m,i,j,k) -
     >                          lhs(4,j)*rhs(m,i,j1,k) -
     >                          lhs(5,j)*rhs(m,i,j2,k)
                end do

c---------------------------------------------------------------------
c      And the remaining two
c---------------------------------------------------------------------
                rhs(4,i,j,k) = rhs(4,i,j,k) -
     >                          lhsp(4,j)*rhs(4,i,j1,k) -
     >                          lhsp(5,j)*rhs(4,i,j2,k)
                rhs(5,i,j,k) = rhs(5,i,j,k) -
     >                          lhsm(4,j)*rhs(5,i,j1,k) -
     >                          lhsm(5,j)*rhs(5,i,j2,k)
             end do
          end do
       end do
       if (timeron) call timer_stop(t_ysolve)

       if (timeron) call timer_start(t_pinvr)
       call pinvr
       if (timeron) call timer_stop(t_pinvr)

       return
       end


module state_deriv
  use thickness
  use io
  use bernoulli
  use vorticity
  use momentum

  implicit none

  contains

  ! ----------------------------- Auxiliary routines --------------------------
  !> Compute the forward state derivative

  subroutine state_derivative(dhdt, dudt, dvdt, h, u, v, depth, &
      dx, dy, wetmask, hfacW, hfacE, hfacN, hfacS, fu, fv, &
      au, ar, botDrag, kh, kv, hmin, slip, &
      RedGrav, hAdvecScheme, g_vec, rho0, wind_x, wind_y, &
      wind_depth, RelativeWind, Cd, &
      spongeHTimeScale, spongeH, &
      spongeUTimeScale, spongeU, &
      spongeVTimeScale, spongeV, &
      nx, ny, layers, ilower, iupper, xlow, xhigh, ylow, yhigh, &
      OL, num_procs, myid, n, debug_level)
    implicit none

    double precision, intent(out) :: dhdt(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(out) :: dudt(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(out) :: dvdt(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in) :: h(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in) :: u(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in) :: v(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in) :: depth(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in) :: dx, dy
    double precision, intent(in) :: wetmask(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in) :: hfacW(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in) :: hfacE(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in) :: hfacN(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in) :: hfacS(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in) :: fu(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in) :: fv(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in) :: au, ar, botDrag
    double precision, intent(in) :: kh(layers), kv
    double precision, intent(in) :: hmin
    double precision, intent(in) :: slip
    logical,          intent(in) :: RedGrav
    integer,          intent(in) :: hAdvecScheme
    double precision, intent(in) :: g_vec(layers)
    double precision, intent(in) :: rho0
    double precision, intent(in) :: wind_x(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in) :: wind_y(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in) :: wind_depth
    logical,          intent(in) :: RelativeWind
    double precision, intent(in) :: Cd
    double precision, intent(in) :: spongeHTimeScale(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in) :: spongeH(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in) :: spongeUTimeScale(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in) :: spongeU(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in) :: spongeVTimeScale(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in) :: spongeV(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    integer,          intent(in) :: nx, ny, layers
    integer,          intent(in) :: ilower(0:num_procs-1,2)
    integer,          intent(in) :: iupper(0:num_procs-1,2)
    integer,          intent(in) :: xlow, xhigh, ylow, yhigh, OL
    integer,          intent(in) :: num_procs, myid
    integer,          intent(in) :: n
    integer,          intent(in) :: debug_level

    ! Bernoulli potential
    double precision :: b(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    ! Relative vorticity
    double precision :: zeta(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)

    ! Calculate Bernoulli potential
    if (RedGrav) then
      call evaluate_b_RedGrav(b, h, u, v, g_vec, nx, ny, layers, xlow, xhigh, ylow, yhigh, OL, &
                                 ilower, iupper, num_procs, myid)
      if (debug_level .ge. 4) then
        call write_output_3d(b, nx, ny, layers, ilower, iupper, &
                          xlow, xhigh, ylow, yhigh, OL, 0, 0, &
          n, 'output/snap.BP.', num_procs, myid)
      end if
    else
      call evaluate_b_iso(b, h, u, v, g_vec, depth, &
                          nx, ny, layers, xlow, xhigh, ylow, yhigh, OL, &
                          ilower, iupper, num_procs, myid)
      if (debug_level .ge. 4) then
        call write_output_3d(b, nx, ny, layers, ilower, iupper, &
                          xlow, xhigh, ylow, yhigh, OL, 0, 0, &
          n, 'output/snap.BP.', num_procs, myid)
      end if
    end if

    ! Calculate relative vorticity
    call evaluate_zeta(zeta, u, v, dx, dy, nx, ny, layers, &
                        xlow, xhigh, ylow, yhigh, OL, &
                        ilower, iupper, num_procs, myid)
    if (debug_level .ge. 4) then
      call write_output_3d(zeta, nx, ny, layers, ilower, iupper, &
                          xlow, xhigh, ylow, yhigh, OL, 1, 1, &
        n, 'output/snap.zeta.', num_procs, myid)
    end if

    ! Calculate dhdt, dudt, dvdt at current time step
    call evaluate_dhdt(dhdt, h, u, v, kh, hmin, kv, dx, dy, xlow, xhigh, ylow, yhigh, &
      nx, ny, layers, OL, spongeHTimeScale, spongeH, wetmask, RedGrav, hAdvecScheme, n, &
      ilower, iupper, num_procs, myid)

    call evaluate_dudt(dudt, h, u, v, b, zeta, wind_x, wind_y, wind_depth, &
        fu, au, ar, slip, dx, dy, hfacN, hfacS, xlow, xhigh, ylow, yhigh, &
        nx, ny, layers, OL, rho0, &
        RelativeWind, Cd, spongeUTimeScale, spongeU, RedGrav, botDrag, &
        ilower, iupper, num_procs, myid)

    call evaluate_dvdt(dvdt, h, u, v, b, zeta, wind_x, wind_y, wind_depth, &
        fv, au, ar, slip, dx, dy, hfacW, hfacE, xlow, xhigh, ylow, yhigh, &
        nx, ny, layers, OL, rho0, &
        RelativeWind, Cd, spongeVTimeScale, spongeV, RedGrav, botDrag, &
        ilower, iupper, num_procs, myid)

    return
  end subroutine state_derivative

end module state_deriv


      subroutine wet_initial

      use reservoir_module
      use reservoir_data_module
      use reservoir_data_module
      use hydrograph_module
      use hru_module, only : hru, ihru
      use maximum_data_module
      use water_body_module

      implicit none

      integer :: iprop          !              |
      integer :: ihyd           !none          |counter
      integer :: init           !              |
      real :: cnv               !none          |conversion factor (mm => m^3)
      real :: x1                !              |
      real :: wet_h             !              |
      real :: wet_h1            !              |
      real :: wet_fr            !              |
      integer :: init_om

      do ihru = 1, sp_ob%hru
        !! set initial volumes and convert units
        iprop = hru(ihru)%dbs%surf_stor
        if (iprop > 0) then
          ihyd = wet_dat(iprop)%hyd
          !! ha*mm*10. => m**3
          wet_ob(ihru)%evol = wet_hyd(ihyd)%esa * hru(ihru)%area_ha * wet_hyd(ihyd)%edep * 10.
          wet_ob(ihru)%pvol = wet_hyd(ihyd)%psa * hru(ihru)%area_ha * wet_hyd(ihyd)%pdep * 10.
          wet_ob(ihru)%psa = wet_hyd(ihyd)%psa * hru(ihru)%area_ha
          wet_ob(ihru)%esa = wet_hyd(ihyd)%esa * hru(ihru)%area_ha

          !!set initial n and p concentrations --> (ppm) * (m^3) / 1000 = kg    !! ppm = t/m^3 * 10^6
          init = wet_dat(iprop)%init
          init_om = wet_init(init)%org_min
          cnv = om_init_water(init_om)%flo * wet_ob(ihru)%pvol / 1000.
          wet(ihru) = cnv * om_init_water(init_om)
          wet(ihru)%flo = om_init_water(init_om)%flo * wet_ob(ihru)%pvol
          wet_om_init(ihru) = wet(ihru)

          !! update surface area
          !! wetland on hru - solve quadratic to find new depth
          wet_wat_d(ihru)%area_ha = 0.
          if (wet(ihru)%flo > 0.) then
            x1 = wet_hyd(ihyd)%bcoef ** 2 + 4. * wet_hyd(ihyd)%ccoef * (1. - wet(ihru)%flo / wet_ob(ihru)%pvol)
            if (x1 < 1.e-6) then
              wet_h = 0.
            else
              wet_h1 = (-wet_hyd(ihyd)%bcoef - sqrt(x1)) / (2. * wet_hyd(ihyd)%ccoef)
              wet_h = wet_h1 + wet_hyd(ihyd)%bcoef
            end if
            wet_fr = (1. + wet_hyd(ihyd)%acoef * wet_h)
            wet_fr = min(wet_fr,1.)
            wet_wat_d(ihru)%area_ha = hru(ihru)%area_ha * wet_hyd(ihyd)%psa * wet_fr
          end if

        end if

      end do
      close(105)

      return
      end subroutine wet_initial