!*****************************************************************************80
!
!  Sets up the elemental matrices
!
!  Discussion:
!             Generates the elemental matrices K_ij, M_ij, S_ij
!             calculates coefficients in this suboutine
!  Input:
!       n - element number
!       nl_iter - nonlinear iteration counter
!  Output:
!         elem_matrix_A
!         elem_matrix_U
!         elem_vec_F
!         elem_vec_Q
!*****************************************************************************80

subroutine spatial_matrices (n, nl_iter)

    USE element_matrices_M
    USE flags_M
    USE gauss_integration_M
    USE global_parameters_M
    USE material_info_M
    USE mesh_info_M
    USE time_info_M
    USE solution_vectors_M

    use Mod_SetupOutputFiles

    implicit none

!---Dummy variables
    integer, intent(in) :: n
    integer, intent(in) :: nl_iter

!---Local variables
    integer :: g, j, i,ii, ni
    real(dp) :: cnst,h,xi,wt
    real(dp) :: evaluated_spatial_power, evaluated_velocity

    !---Inversion routine parameters
    integer :: lda, info, lwork,length
    integer , dimension(3) :: ipiv
    real(dp), dimension(3) :: work

    length = 3
!---Initialize inversion routine parms
    ipiv =  0.0
    work =  0.0
    lda =   length
    lwork = length

!---Initialize
    matrix_W_left_face  = 0.0_dp
    elem_matrix_U       = 0.0_dp
    elem_matrix_A       = 0.0_dp
    elem_vec_q          = 0.0_dp
    elem_vol_int(n,:)   = 0.0_dp

!---Integrate over Gauss pts
    gaussintegration: do g = 1 , num_gaus_pts
    !---Get gauss pt and weight
        xi = gauspt(g)
        wt = gauswt(g)
        h  = global_coord(n,3) - global_coord(n,1)

        !---Evaluate shape functions at gauss pt
        call inter_shape_fcns(xi,h)
        cnst = g_jacobian*wt
        !---Evaluate velocity and power at gauss pt
        !evaluated_velocity      = 0.0_dp
        !evaluated_spatial_power = 0.0_dp
        !do i = 1, nodes_per_elem
        !    evaluated_velocity = evaluated_velocity + &
        !                         shape_fcn(i)*velocity_soln_prev(n,i)
        !
        !    evaluated_spatial_power = evaluated_spatial_power + &
        !                              shape_fcn(i)*spatial_power_frac_fcn(n,i)*&
        !                              total_power_initial*power_amplitude_prev
        !end do

        do i=1, nodes_per_elem

            !---Only needed if we are changing length of elements
            elem_vol_int(n,i) = elem_vol_int(n,i) + cnst*shape_fcn(i)

            elem_vec_q(i) = elem_vec_q(i) + cnst*shape_fcn(i)

            do j = 1, nodes_per_elem
                !---Determine A matrix - only needs to be done once
                    elem_matrix_A(i,j) = elem_matrix_A(i,j) + &
                                     cnst*shape_fcn(i)*shape_fcn(j)

                   elem_matrix_U(i,j) = elem_matrix_U(i,j) + &
                                    cnst*shape_fcn(j)*&
                                     global_der_shape_fcn(i)

            end do !---End loop over j matrix entries
        end do !---End loop over i matrix entries
     enddo gaussintegration!---end do over gauss pts

    do i = 1, nodes_per_elem
        do j = 1, nodes_per_elem
            elem_matrix_U(i,j) = velocity_soln_prev(n,j)*elem_matrix_U(i,j)
        end do
    end do

    !---Invert A matrix, only needs to be done once
    !if( (n == 1) .and. (nl_iter == 1) .and. (t0 == 0.0)) then
        do i = 1, nodes_per_elem
            do j = 1, nodes_per_elem
                inverse_A_matrix(i,j) = elem_matrix_A(i,j)
            end do
        end do

        !---Factorize matrix
        call dgetrf ( length, length, inverse_A_matrix, lda, ipiv, info )
        !---Compute the inverse matrix.
        call dgetri ( length, inverse_A_matrix, lda, ipiv, work, lwork, info )
    !end if

!-------------------------------------------------------------------------------
    if (DEBUG .eqv. .TRUE. ) then
        write(outfile_unit,fmt='(a,12es14.3)'), '@ time = ', t0

        write(outfile_unit,fmt='(a)'),' '
        write(outfile_unit,fmt='(a,4I6)'),  'Nonlinear iteration ', nl_iter
        write(outfile_unit,fmt='(a)'),  'Elemental matrices '
        write(outfile_unit,fmt='(a)'),'*****************************************'
        write(outfile_unit,fmt='(a,4I6)'),'[A] element Matrix gaussian integration | element --> ',n
        do j=1,nodes_per_elem
               write(outfile_unit,fmt='(12es14.3)') &
                    (elem_matrix_A(j,i),i=1,nodes_per_elem)
        end do
        write(outfile_unit,fmt='(a)'),' '
        write(outfile_unit,fmt='(a,4I6)'),'[A^-1] element Matrix  | element --> ',n
        do j=1,nodes_per_elem
               write(outfile_unit,fmt='(12es14.3)') &
                    (inverse_A_matrix(j,i),i=1,nodes_per_elem)
        end do

        write(outfile_unit,fmt='(a)'),' '
        write(outfile_unit,fmt='(a,4I6)'),'[U] element Matrix gaussian integration | element --> ',n
        do j=1,nodes_per_elem
               write(outfile_unit,fmt='(12es14.3)') &
                    (elem_matrix_U(j,i),i=1,nodes_per_elem)
        end do
   end if !---End matrix write out
!------------------------------------------------------------------------------

end subroutine spatial_matrices


      SUBROUTINE PETASCE( CANHT, DOY, MSALB, MEEVP, SRAD, TDEW, TMAX, TMIN, WINDHT, WINDRUN, XHLAI, XLAT, XELEV, EO)

      IMPLICIT NONE
      SAVE
      REAL CANHT, MSALB, SRAD, TDEW, TMAX, TMIN, WINDHT, WINDRUN
      REAL XHLAI, XLAT, XELEV
      INTEGER DOY
      CHARACTER*1 MEEVP
      REAL EO
      REAL TAVG, PATM, PSYCON, UDELTA, EMAX, EMIN, ES, EA, FC, FEW, FW
      REAL ALBEDO, RNS, PIE, DR, LDELTA, WS, RA1, RA2, RA, RSO, RATIO
      REAL FCD, TK4, RNL, RN, G, WINDSP, WIND2m, Cn, Cd, KCMAX, RHMIN
      REAL WND, CHT
      REAL REFET, SKC, KCBMIN, KCBMAX, KCB, KE, KC
      TAVG = (TMAX + TMIN) / 2.0
      PATM = 101.3 * ((293.0 - 0.0065 * XELEV)/293.0) ** 5.26
      PSYCON = 0.000665 * PATM
      UDELTA = 2503.0*EXP(17.27*TAVG/(TAVG+237.3))/(TAVG+237.3)**2.0
      EMAX = 0.6108*EXP((17.27*TMAX)/(TMAX+237.3))
      EMIN = 0.6108*EXP((17.27*TMIN)/(TMIN+237.3))
      ES = (EMAX + EMIN) / 2.0
      EA = 0.6108*EXP((17.27*TDEW)/(TDEW+237.3))
      RHMIN = MAX(20.0, MIN(80.0, EA/EMAX*100.0))
      IF (XHLAI .LE. 0.0) THEN
        ALBEDO = MSALB
      ELSE
        ALBEDO = 0.23
      ENDIF
      RNS = (1.0-ALBEDO)*SRAD
      PIE = 3.14159265359
      DR = 1.0+0.033*COS(2.0*PIE/365.0*DOY)
      LDELTA = 0.409*SIN(2.0*PIE/365.0*DOY-1.39)
      WS = ACOS(-1.0*TAN(XLAT*PIE/180.0)*TAN(LDELTA))
      RA1 = WS*SIN(XLAT*PIE/180.0)*SIN(LDELTA)
      RA2 = COS(XLAT*PIE/180.0)*COS(LDELTA)*SIN(WS)
      RA = 24.0/PIE*4.92*DR*(RA1+RA2)
      RSO = (0.75+2E-5*XELEV)*RA
      RATIO = SRAD/RSO
      IF (RATIO .LT. 0.3) THEN
        RATIO = 0.3
      ELSEIF (RATIO .GT. 1.0) THEN
        RATIO = 1.0
      END IF
      FCD = 1.35*RATIO-0.35
      TK4 = ((TMAX+273.16)**4.0+(TMIN+273.16)**4.0)/2.0
      RNL = 4.901E-9*FCD*(0.34-0.14*SQRT(EA))*TK4
      RN = RNS - RNL
      G = 0.0
      WINDSP = WINDRUN * 1000.0 / 24.0 / 60.0 / 60.0
      WIND2m = WINDSP * (4.87/LOG(67.8*WINDHT-5.42))
      Cn = 0.0
      Cd = 0.0
      IF (MEEVP .EQ. 'A') THEN
        Cn = 1600.0
        Cd = 0.38
      ELSE IF (MEEVP .EQ. 'G') THEN
        Cn = 900.0
        Cd = 0.34
      END IF
      REFET =0.408*UDELTA*(RN-G)+PSYCON*(Cn/(TAVG+273.0))*WIND2m*(ES-EA)
      REFET = REFET/(UDELTA+PSYCON*(1.0+Cd*WIND2m))
      REFET = MAX(0.0001, REFET)
      SKC = 0.8
      KCBMIN = 0.3
      KCBMAX = 1.2
      IF (XHLAI .LE. 0.0) THEN
         KCB = 0.0
      ELSE
         KCB = MAX(0.0,KCBMIN+(KCBMAX-KCBMIN)*(1.0-EXP(-1.0*SKC*XHLAI)))
      ENDIF
      WND = MAX(1.0,MIN(WIND2m,6.0))
      CHT = MAX(0.001,CANHT)
      KCMAX = 0.5
      IF (MEEVP .EQ. 'A') THEN
        KCMAX = MAX(1.0,KCB+0.05)
      ELSE IF (MEEVP .EQ. 'G') THEN
        KCMAX = MAX((1.2+(0.04*(WND-2.0)-0.004*(RHMIN-45.0)) *(CHT/3.0)**(0.3)),KCB+0.05)

      END IF
      IF (KCB .LE. KCBMIN) THEN
         FC = 0.0
      ELSE
         FC = ((KCB-KCBMIN)/(KCMAX-KCBMIN))**(1.0+0.5*CANHT)
      ENDIF
      FW = 1.0
      FEW = MIN(1.0-FC,FW)
      KE = MAX(0.0, MIN(1.0*(KCMAX-KCB), FEW*KCMAX))
      EO = (KCB + KE) * REFET
      EO = MAX(EO,0.0001)
      RETURN
      END SUBROUTINE PETASCE


module mpas_sw_module
  implicit none

  integer, parameter :: RKIND  = selected_real_kind(12)
  integer, parameter :: StrKIND = 512

  ! ========== constants ==========
  real (kind=RKIND), parameter :: pii     = 3.141592653589793   !< Constant: Pi
  real (kind=RKIND), parameter :: a       = 6371229.0           !< Constant: Spherical Earth radius [m]
  real (kind=RKIND), parameter :: omega   = 7.29212e-5          !< Constant: Angular rotation rate of the Earth [s-1]
  real (kind=RKIND), parameter :: gravity = 9.80616             !< Constant: Acceleration due to gravity [m s-2]
  real (kind=RKIND), parameter :: rgas    = 287.0               !< Constant: Gas constant for dry air [J kg-1 K-1]
  real (kind=RKIND), parameter :: rv      = 461.6               !< Constant: Gas constant for water vapor [J kg-1 K-1]
  real (kind=RKIND), parameter :: rvord   = rv/rgas             !
  real (kind=RKIND), parameter :: cp      = 7.*rgas/2.          !< Constant: Specific heat of dry air at constant pressure [J kg-1 K-1]
  real (kind=RKIND), parameter :: cv      = cp - rgas           !< Constant: Specific heat of dry air at constant volume [J kg-1 K-1]
  real (kind=RKIND), parameter :: cvpm    = -cv/cp              !
  real (kind=RKIND), parameter :: prandtl = 1.0                 !< Constant: Prandtl number

  ! ========== end constants ==========

  ! ========== configurations ==========
  integer :: config_test_case = 5
  character(len=StrKIND) :: config_time_integration = 'RK4'
  real(kind=RKIND) :: config_dt = 150.0
  character(len=StrKIND) :: config_start_time = '2000-01-01_00:00:00'
  character(len=StrKIND) :: config_stop_time = 'none'
  character(len=StrKIND) :: config_run_duration = 'none'
  integer :: config_stats_interval = 100
  logical :: config_h_ScaleWithMesh = .false.
  real(kind=RKIND) :: config_h_mom_eddy_visc2 = 0.0
  real(kind=RKIND) :: config_h_mom_eddy_visc4 = 0.0
  real(kind=RKIND) :: config_h_tracer_eddy_diff2 = 0.0
  real(kind=RKIND) :: config_h_tracer_eddy_diff4 = 0.0
  integer :: config_thickness_adv_order = 2
  integer :: config_tracer_adv_order = 2
  logical :: config_positive_definite = .false.
  logical :: config_monotonic = .false.
  logical :: config_wind_stress = .false.
  logical :: config_bottom_drag = .false.
  real(kind=RKIND) :: config_apvm_upwinding = 0.5
  integer :: config_num_halos = 2

  ! ========== dimensions ==========
  integer :: nVertLevels=1
  integer :: nCells, nEdges, nVertices, nTracers
  integer :: cellStart, cellEnd
  integer :: vertexStart, vertexEnd
  integer :: edgeStart, edgeEnd
  integer :: vertexDegree
  integer :: nCellsSolve, nEdgesSolve
  integer :: maxEdges, maxEdges2
  integer :: cellSolveStart, cellSolveEnd
  integer :: edgeSolveStart, edgeSolveEnd
  integer :: R3

  ! ========== state ==========
  real(kind=RKIND), dimension(:,:,:), allocatable :: u
  real(kind=RKIND), dimension(:,:,:), allocatable :: h
  real(kind=RKIND), dimension(:,:,:,:), allocatable :: tracers

  ! ========== state TLM ==========
  real(kind=RKIND), dimension(:,:,:), allocatable :: u_tl
  real(kind=RKIND), dimension(:,:,:), allocatable :: h_tl
  real(kind=RKIND), dimension(:,:,:,:), allocatable :: tracers_tl

  ! ========== state ADJ ==========
  real(kind=RKIND), dimension(:,:,:), allocatable :: u_ad
  real(kind=RKIND), dimension(:,:,:), allocatable :: h_ad
  real(kind=RKIND), dimension(:,:,:,:), allocatable :: tracers_ad

  ! ========== top level ==========
  logical :: on_a_sphere
  logical :: is_periodic
  real(kind=RKIND) :: x_period, y_period

  ! ========== mesh ==========
  real(kind=RKIND), dimension(:,:), allocatable :: u_src
  real(kind=RKIND), dimension(:), allocatable :: h_s
  real(kind=RKIND), dimension(:), allocatable :: fCell
  real(kind=RKIND), dimension(:), allocatable :: fVertex
  real(kind=RKIND), dimension(:), allocatable :: fEdge
  real(kind=RKIND), dimension(:), allocatable :: areaCell
  real(kind=RKIND), dimension(:), allocatable :: invAreaCell
  real(kind=RKIND), dimension(:), allocatable :: dvEdge
  real(kind=RKIND), dimension(:), allocatable :: dcEdge
  real(kind=RKIND), dimension(:,:), allocatable :: weightsOnEdge
  real(kind=RKIND), dimension(:,:), allocatable :: kiteAreasOnVertex
  real(kind=RKIND), dimension(:), allocatable :: meshDensity
  real(kind=RKIND), dimension(:), allocatable :: areaTriangle
  integer, dimension(:,:), allocatable :: boundaryCell
  integer, dimension(:,:), allocatable :: boundaryEdge
  integer, dimension(:,:), allocatable :: advCells
  integer, dimension(:,:), allocatable :: cellsOnCell
  integer, dimension(:,:), allocatable :: cellsOnEdge
  integer, dimension(:,:), allocatable :: cellsOnVertex
  integer, dimension(:,:), allocatable :: edgesOnCell
  integer, dimension(:,:), allocatable :: edgesOnEdge
  integer, dimension(:,:), allocatable :: edgesOnVertex
  integer, dimension(:,:), allocatable :: verticesOnCell
  integer, dimension(:,:), allocatable :: verticesOnEdge
  integer, dimension(:), allocatable :: nEdgesOnCell
  integer, dimension(:), allocatable :: nEdgesOnEdge
  real(kind=RKIND), dimension(:), allocatable :: latCell
  real(kind=RKIND), dimension(:), allocatable :: lonCell
  real(kind=RKIND), dimension(:), allocatable :: xCell, yCell, zCell
  real(kind=RKIND), dimension(:), allocatable :: meshScalingDel2
  real(kind=RKIND), dimension(:), allocatable :: meshScalingDel4
  real(kind=RKIND), dimension(:,:,:), allocatable :: deriv_two
  real(kind=RKIND), dimension(:), allocatable :: latEdge
  real(kind=RKIND), dimension(:), allocatable :: lonEdge
  real(kind=RKIND), dimension(:), allocatable :: xEdge, yEdge, zEdge
  real(kind=RKIND), dimension(:), allocatable :: angleEdge
  real(kind=RKIND), dimension(:), allocatable :: latVertex
  real(kind=RKIND), dimension(:), allocatable :: lonVertex
  real(kind=RKIND), dimension(:), allocatable :: xVertex, yVertex, zVertex
  real(kind=RKIND) :: sphere_radius
  real(kind=RKIND), dimension(:,:), allocatable :: defc_a
  real(kind=RKIND), dimension(:,:), allocatable :: defc_b
  real(kind=RKIND), dimension(:,:), allocatable :: localVerticalUnitVectors
  real(kind=RKIND), dimension(:,:), allocatable :: edgeNormalVectors
  real(kind=RKIND), dimension(:,:,:), allocatable :: cellTangentPlane
  real(kind=RKIND), dimension(:,:,:), allocatable :: coeffs_reconstruct

  ! ========== diag ==========
  real(kind=RKIND), dimension(:,:), allocatable :: uReconstructX
  real(kind=RKIND), dimension(:,:), allocatable :: uReconstructY
  real(kind=RKIND), dimension(:,:), allocatable :: uReconstructZ
  real(kind=RKIND), dimension(:,:), allocatable :: uReconstructZonal
  real(kind=RKIND), dimension(:,:), allocatable :: uReconstructMeridional
  real(kind=RKIND), dimension(:,:), allocatable :: v
  real(kind=RKIND), dimension(:,:), allocatable :: h_edge
  real(kind=RKIND), dimension(:,:), allocatable :: h_vertex
  real(kind=RKIND), dimension(:,:), allocatable :: pv_edge
  real(kind=RKIND), dimension(:,:), allocatable :: pv_vertex
  real(kind=RKIND), dimension(:,:), allocatable :: pv_cell
  real(kind=RKIND), dimension(:,:), allocatable :: circulation
  real(kind=RKIND), dimension(:,:), allocatable :: vorticity
  real(kind=RKIND), dimension(:,:), allocatable :: divergence
  real(kind=RKIND), dimension(:,:), allocatable :: ke
  real(kind=RKIND), dimension(:,:), allocatable :: vh
  real(kind=RKIND), dimension(:,:), allocatable :: vorticity_cell
  real(kind=RKIND), dimension(:,:), allocatable :: gradPVn
  real(kind=RKIND), dimension(:,:), allocatable :: gradPVt

  ! ========== diag TLM ==========
  real(kind=RKIND), dimension(:,:), allocatable :: uReconstructX_tl
  real(kind=RKIND), dimension(:,:), allocatable :: uReconstructY_tl
  real(kind=RKIND), dimension(:,:), allocatable :: uReconstructZ_tl
  real(kind=RKIND), dimension(:,:), allocatable :: uReconstructZonal_tl
  real(kind=RKIND), dimension(:,:), allocatable :: uReconstructMeridional_tl
  real(kind=RKIND), dimension(:,:), allocatable :: v_tl
  real(kind=RKIND), dimension(:,:), allocatable :: h_edge_tl
  real(kind=RKIND), dimension(:,:), allocatable :: h_vertex_tl
  real(kind=RKIND), dimension(:,:), allocatable :: pv_edge_tl
  real(kind=RKIND), dimension(:,:), allocatable :: pv_vertex_tl
  real(kind=RKIND), dimension(:,:), allocatable :: pv_cell_tl
  real(kind=RKIND), dimension(:,:), allocatable :: circulation_tl
  real(kind=RKIND), dimension(:,:), allocatable :: vorticity_tl
  real(kind=RKIND), dimension(:,:), allocatable :: divergence_tl
  real(kind=RKIND), dimension(:,:), allocatable :: ke_tl
  real(kind=RKIND), dimension(:,:), allocatable :: vh_tl
  real(kind=RKIND), dimension(:,:), allocatable :: vorticity_cell_tl
  real(kind=RKIND), dimension(:,:), allocatable :: gradPVn_tl
  real(kind=RKIND), dimension(:,:), allocatable :: gradPVt_tl

  ! ========== diag ADJ ==========
  real(kind=RKIND), dimension(:,:), allocatable :: uReconstructX_ad
  real(kind=RKIND), dimension(:,:), allocatable :: uReconstructY_ad
  real(kind=RKIND), dimension(:,:), allocatable :: uReconstructZ_ad
  real(kind=RKIND), dimension(:,:), allocatable :: uReconstructZonal_ad
  real(kind=RKIND), dimension(:,:), allocatable :: uReconstructMeridional_ad
  real(kind=RKIND), dimension(:,:), allocatable :: v_ad
  real(kind=RKIND), dimension(:,:), allocatable :: h_edge_ad
  real(kind=RKIND), dimension(:,:), allocatable :: h_vertex_ad
  real(kind=RKIND), dimension(:,:), allocatable :: pv_edge_ad
  real(kind=RKIND), dimension(:,:), allocatable :: pv_vertex_ad
  real(kind=RKIND), dimension(:,:), allocatable :: pv_cell_ad
  real(kind=RKIND), dimension(:,:), allocatable :: circulation_ad
  real(kind=RKIND), dimension(:,:), allocatable :: vorticity_ad
  real(kind=RKIND), dimension(:,:), allocatable :: divergence_ad
  real(kind=RKIND), dimension(:,:), allocatable :: ke_ad
  real(kind=RKIND), dimension(:,:), allocatable :: vh_ad
  real(kind=RKIND), dimension(:,:), allocatable :: vorticity_cell_ad
  real(kind=RKIND), dimension(:,:), allocatable :: gradPVn_ad
  real(kind=RKIND), dimension(:,:), allocatable :: gradPVt_ad

  ! ========== tend ==========
  real(kind=RKIND), dimension(:,:), allocatable :: tend_u
  real(kind=RKIND), dimension(:,:), allocatable :: tend_h
  real(kind=RKIND), dimension(:,:,:), allocatable :: tend_tracer

  ! ========== tend TLM ==========
  real(kind=RKIND), dimension(:,:), allocatable :: tend_u_tl
  real(kind=RKIND), dimension(:,:), allocatable :: tend_h_tl
  real(kind=RKIND), dimension(:,:,:), allocatable :: tend_tracer_tl

  ! ========== tend ADJ ==========
  real(kind=RKIND), dimension(:,:), allocatable :: tend_u_ad
  real(kind=RKIND), dimension(:,:), allocatable :: tend_h_ad
  real(kind=RKIND), dimension(:,:,:), allocatable :: tend_tracer_ad

  ! ========== end FWD storing ==========

  ! ===== transient indices =====
  integer :: rk_step
  real(kind=RKIND) :: LHS, RHS, pt

CONTAINS

  subroutine var_allocation()
    implicit none

    ! ===== allocating state =====
    allocate(u(2,nVertLevels,nEdges))
    u=0
    allocate(h(2,nVertLevels,nCells))
    h=0
    allocate(tracers(2,nTracers,nVertLevels,nCells))
    tracers=0

    ! ===== allocating mesh =====
    allocate(u_src(nVertLevels, nEdges))
    u_src=0
    allocate(h_s(nCells))
    h_s=0
    allocate(fCell(nCells))
    fCell=0
    allocate(fVertex(nVertices))
    fVertex=0
    allocate(fEdge(nEdges))
    fEdge=0
    allocate(areaTriangle(nVertices))
    areaTriangle=0
    allocate(areaCell(nCells))
    areaCell=0
    allocate(dvEdge(nEdges))
    dvEdge=0
    allocate(dcEdge(nEdges))
    dcEdge=0
    allocate(weightsOnEdge(maxEdges2,nEdges))
    weightsOnEdge=0
    allocate(kiteAreasOnVertex(vertexDegree,nVertices))
    kiteAreasOnVertex=0
    allocate(meshDensity(nCells))
    meshDensity=0
    allocate(boundaryCell(nVertLevels,nCells))
    boundaryCell=0
    allocate(boundaryEdge(nVertLevels,nEdges))
    boundaryEdge=0
    allocate(advCells(21, nCells))
    advCells=0
    allocate(cellsOnCell(maxEdges,nCells))
    cellsOnCell=0
    allocate(cellsOnEdge(2,nEdges))
    cellsOnEdge=0
    allocate(cellsOnVertex(vertexDegree,nVertices))
    cellsOnVertex=0
    allocate(edgesOnCell(maxEdges,nCells))
    edgesOnCell=0
    allocate(edgesOnEdge(maxEdges2,nEdges))
    edgesOnEdge=0
    allocate(edgesOnVertex(vertexDegree,nVertices))
    edgesOnVertex=0
    allocate(verticesOnCell(maxEdges,nCells))
    verticesOnCell=0
    allocate(verticesOnEdge(2,nEdges))
    verticesOnEdge=0
    allocate(nEdgesOnCell(nCells))
    nEdgesOnCell=0
    allocate(nEdgesOnEdge(nEdges))
    nEdgesOnEdge=0
    allocate(latCell(nCells))
    latCell=0
    allocate(lonCell(nCells))
    lonCell=0
    allocate(xCell(nCells), yCell(nCells), zCell(nCells))
    xCell=0
    yCell=0
    zCell=0
    allocate(meshScalingDel2(nEdges))
    meshScalingDel2=0
    allocate(meshScalingDel4(nEdges))
    meshScalingDel4=0
    allocate(deriv_two(15,2,nEdges))
    deriv_two=0
    allocate(latEdge(nEdges))
    latEdge=0
    allocate(lonEdge(nEdges))
    lonEdge=0
    allocate(xEdge(nEdges), yEdge(nEdges), zEdge(nEdges))
    xEdge=0
    yEdge=0
    zEdge=0
    allocate(angleEdge(nEdges))
    angleEdge=0
    allocate(latVertex(nVertices))
    latVertex=0
    allocate(lonVertex(nVertices))
    lonVertex=0
    allocate(xVertex(nVertices), yVertex(nVertices), zVertex(nVertices))
    xVertex=0
    yVertex=0
    zVertex=0
    allocate(defc_a(maxEdges,nCells))
    defc_a=0
    allocate(defc_b(maxEdges,nCells))
    defc_b=0
    allocate(localVerticalUnitVectors(R3,nCells))
    localVerticalUnitVectors=0
    allocate(edgeNormalVectors(R3,nEdges))
    edgeNormalVectors=0
    allocate(cellTangentPlane(R3,2,nCells))
    cellTangentPlane=0
    allocate(coeffs_reconstruct(R3,maxEdges,nCells))
    coeffs_reconstruct=0

    ! ===== allocating diag =====
    allocate(uReconstructX(nVertLevels,nCells))
    allocate(uReconstructY(nVertLevels,nCells))
    allocate(uReconstructZ(nVertLevels,nCells))
    allocate(uReconstructZonal(nVertLevels,nCells))
    allocate(uReconstructMeridional(nVertLevels,nCells))
    allocate(v(nVertLevels,nEdges))
    allocate(h_edge(nVertLevels,nEdges))
    allocate(h_vertex(nVertLevels,nVertices))
    allocate(pv_edge(nVertLevels,nEdges))
    allocate(pv_vertex(nVertLevels,nVertices))
    allocate(pv_cell(nVertLevels,nCells))
    allocate(circulation(nVertLevels,nVertices))
    allocate(vorticity(nVertLevels,nVertices))
    allocate(divergence(nVertLevels,nCells))
    allocate(ke(nVertLevels,nCells))
    allocate(vh(nVertLevels,nEdges))
    allocate(vorticity_cell(nVertLevels,nCells))
    allocate(gradPVn(nVertLevels,nEdges))
    allocate(gradPVt(nVertLevels,nEdges))

    uReconstructX=0
    uReconstructY=0
    uReconstructZ=0
    uReconstructZonal=0
    uReconstructMeridional=0
    v=0
    h_edge=0
    h_vertex=0
    pv_edge=0
    pv_vertex=0
    pv_cell=0
    circulation=0
    vorticity=0
    divergence=0
    ke=0
    vh=0
    vorticity_cell=0
    gradPVn=0
    gradPVt=0

    ! ===== allocating tend =====
    allocate(tend_u(nVertLevels,nEdges))
    allocate(tend_h(nVertLevels,nCells))
    allocate(tend_tracer(nTracers,nVertLevels,nCells))
    tend_u=0
    tend_h=0
    tend_tracer=0

  end subroutine var_allocation

  subroutine var_allocation_tlm()
    implicit none

    ! ===== allocating state =====
    allocate(u_tl(2,nVertLevels,nEdges))
    u_tl=0
    allocate(h_tl(2,nVertLevels,nCells))
    h_tl=0
    allocate(tracers_tl(2,nTracers,nVertLevels,nCells))
    tracers_tl=0

    ! ===== allocating diag =====
    allocate(uReconstructX_tl(nVertLevels,nCells))
    allocate(uReconstructY_tl(nVertLevels,nCells))
    allocate(uReconstructZ_tl(nVertLevels,nCells))
    allocate(uReconstructZonal_tl(nVertLevels,nCells))
    allocate(uReconstructMeridional_tl(nVertLevels,nCells))
    allocate(v_tl(nVertLevels,nEdges))
    allocate(h_edge_tl(nVertLevels,nEdges))
    allocate(h_vertex_tl(nVertLevels,nVertices))
    allocate(pv_edge_tl(nVertLevels,nEdges))
    allocate(pv_vertex_tl(nVertLevels,nVertices))
    allocate(pv_cell_tl(nVertLevels,nCells))
    allocate(circulation_tl(nVertLevels,nVertices))
    allocate(vorticity_tl(nVertLevels,nVertices))
    allocate(divergence_tl(nVertLevels,nCells))
    allocate(ke_tl(nVertLevels,nCells))
    allocate(vh_tl(nVertLevels,nEdges))
    allocate(vorticity_cell_tl(nVertLevels,nCells))
    allocate(gradPVn_tl(nVertLevels,nEdges))
    allocate(gradPVt_tl(nVertLevels,nEdges))

    uReconstructX_tl=0
    uReconstructY_tl=0
    uReconstructZ_tl=0
    uReconstructZonal_tl=0
    uReconstructMeridional_tl=0
    v_tl=0
    h_edge_tl=0
    h_vertex_tl=0
    pv_edge_tl=0
    pv_vertex_tl=0
    pv_cell_tl=0
    circulation_tl=0
    vorticity_tl=0
    divergence_tl=0
    ke_tl=0
    vh_tl=0
    vorticity_cell_tl=0
    gradPVn_tl=0
    gradPVt_tl=0

    ! ===== allocating tend =====
    allocate(tend_u_tl(nVertLevels,nEdges))
    allocate(tend_h_tl(nVertLevels,nCells))
    allocate(tend_tracer_tl(nTracers,nVertLevels,nCells))
    tend_u_tl=0
    tend_h_tl=0
    tend_tracer_tl=0

  end subroutine var_allocation_tlm

  subroutine var_allocation_adj()
    implicit none

    integer :: dynamics_split

    ! ===== allocating state =====
    allocate(u_ad(2,nVertLevels,nEdges))
    u_ad=0
    allocate(h_ad(2,nVertLevels,nCells))
    h_ad=0
    allocate(tracers_ad(2,nTracers,nVertLevels,nCells))
    tracers_ad=0

    ! ===== allocating diag =====
    allocate(uReconstructX_ad(nVertLevels,nCells))
    allocate(uReconstructY_ad(nVertLevels,nCells))
    allocate(uReconstructZ_ad(nVertLevels,nCells))
    allocate(uReconstructZonal_ad(nVertLevels,nCells))
    allocate(uReconstructMeridional_ad(nVertLevels,nCells))
    allocate(v_ad(nVertLevels,nEdges))
    allocate(h_edge_ad(nVertLevels,nEdges))
    allocate(h_vertex_ad(nVertLevels,nVertices))
    allocate(pv_edge_ad(nVertLevels,nEdges))
    allocate(pv_vertex_ad(nVertLevels,nVertices))
    allocate(pv_cell_ad(nVertLevels,nCells))
    allocate(circulation_ad(nVertLevels,nVertices))
    allocate(vorticity_ad(nVertLevels,nVertices))
    allocate(divergence_ad(nVertLevels,nCells))
    allocate(ke_ad(nVertLevels,nCells))
    allocate(vh_ad(nVertLevels,nEdges))
    allocate(vorticity_cell_ad(nVertLevels,nCells))
    allocate(gradPVn_ad(nVertLevels,nEdges))
    allocate(gradPVt_ad(nVertLevels,nEdges))

    uReconstructX_ad=0
    uReconstructY_ad=0
    uReconstructZ_ad=0
    uReconstructZonal_ad=0
    uReconstructMeridional_ad=0
    v_ad=0
    h_edge_ad=0
    h_vertex_ad=0
    pv_edge_ad=0
    pv_vertex_ad=0
    pv_cell_ad=0
    circulation_ad=0
    vorticity_ad=0
    divergence_ad=0
    ke_ad=0
    vh_ad=0
    vorticity_cell_ad=0
    gradPVn_ad=0
    gradPVt_ad=0

    ! ===== allocating tend =====
    allocate(tend_u_ad(nVertLevels,nEdges))
    allocate(tend_h_ad(nVertLevels,nCells))
    allocate(tend_tracer_ad(nTracers,nVertLevels,nCells))
    tend_u_ad=0
    tend_h_ad=0
    tend_tracer_ad=0

  end subroutine var_allocation_adj

  subroutine sw_mpas_init_block()
    implicit none

    call sw_compute_solve_diagnostics(config_dt, nCells, nEdges, nVertices,       &
         maxEdges, maxEdges2, nVertLevels, vertexDegree,                          &
         config_monotonic, config_thickness_adv_order, config_apvm_upwinding,     &
         h(1,:,:), u(1,:,:), v, vh, h_edge, h_vertex, circulation,                &
         vorticity, divergence, ke, pv_edge, pv_vertex, pv_cell, vorticity_cell,  &
         gradPVn, gradPVt, weightsOnEdge, kiteAreasOnVertex, cellsOnEdge,         &
         cellsOnVertex, cellsOnCell, verticesOnEdge, nEdgesOnCell, edgesOnCell,   &
         nEdgesOnEdge, edgesOnEdge, edgesOnVertex, dcEdge, dvEdge, areaCell,      &
         areaTriangle, fVertex, deriv_two, boundaryEdge, boundaryCell)

    call compute_mesh_scaling(nCells, nEdges, config_h_ScaleWithMesh, &
         cellsOnEdge, meshDensity, meshScalingDel2, meshScalingDel4)

    call mpas_initialize_vectors(nCells, nEdges, maxEdges, R3, &
         verticesOnEdge, cellsOnEdge, edgesOnCell, xCell, yCell, zCell, &
         xEdge, yEdge, zEdge, localVerticalUnitVectors, edgeNormalVectors, &
         cellTangentPlane, on_a_sphere, is_periodic, x_period, y_period)

    call mpas_init_reconstruct(nCells, nEdges, maxEdges, R3, edgesOnCell, &
         nEdgesOnCell, xCell, yCell, zCell, xEdge, yEdge, zEdge, &
         edgeNormalVectors, cellTangentPlane, coeffs_reconstruct, &
         is_periodic, x_period, y_period)

    call mpas_reconstruct_2d(nCells, nEdges, maxEdges, nVertLevels, R3, &
         on_a_sphere, edgesOnCell, nEdgesOnCell, latCell, lonCell, &
         coeffs_reconstruct, u(1,:,:), uReconstructX, uReconstructY, uReconstructZ,&
         uReconstructZonal, uReconstructMeridional)

  end subroutine sw_mpas_init_block

  subroutine sw_rk4()
    implicit none

    real(kind=RKIND) :: dt
    real (kind=RKIND), dimension(4) :: rk_weights, rk_substep_weights

    ! ----- local variables -----
    real(kind=RKIND), dimension(nVertLevels,nEdges) :: uProvis
    real(kind=RKIND), dimension(nVertLevels,nCells) :: hProvis
    real(kind=RKIND), dimension(nTracers,nVertLevels,nCells) :: tracersProvis
    ! ----- end local variables -----

    dt=config_dt
    ! ----- restarting combo -----

    call sw_compute_solve_diagnostics(dt, nCells, nEdges, nVertices, maxEdges, &
         maxEdges2, nVertLevels, vertexDegree, config_monotonic, &
         config_thickness_adv_order, config_apvm_upwinding, &
         h(1,:,:), u(1,:,:), v, vh, h_edge, h_vertex, circulation, vorticity, &
         divergence, ke, pv_edge, pv_vertex, pv_cell, vorticity_cell, &
         gradPVn, gradPVt, weightsOnEdge, kiteAreasOnVertex, cellsOnEdge, &
         cellsOnVertex, cellsOnCell, verticesOnEdge, nEdgesOnCell, edgesOnCell, &
         nEdgesOnEdge, edgesOnEdge, edgesOnVertex, dcEdge, dvEdge, areaCell, &
         areaTriangle, fVertex, deriv_two, boundaryEdge, boundaryCell)

    call mpas_reconstruct_2d(nCells, nEdges, maxEdges, nVertLevels, R3, &
         on_a_sphere, edgesOnCell, nEdgesOnCell, latCell, lonCell, &
         coeffs_reconstruct, u(1,:,:), uReconstructX, uReconstructY, uReconstructZ,&
         uReconstructZonal, uReconstructMeridional)
    ! ----- end restarting combo -----

    uProvis=u(1,:,:)
    hProvis=h(1,:,:)
    tracersProvis=tracers(1,:,:,:)

    u(2,:,:)=u(1,:,:)
    h(2,:,:)=h(1,:,:)
    tracers(2,:,:,:)=tracers(1,:,:,:)

    rk_weights(1) = dt/6.
    rk_weights(2) = dt/3.
    rk_weights(3) = dt/3.
    rk_weights(4) = dt/6.

    rk_substep_weights(1) = dt/2.
    rk_substep_weights(2) = dt/2.
    rk_substep_weights(3) = dt
    rk_substep_weights(4) = 0.

    do rk_step=1, 4
       call sw_compute_tend(nCells, nEdges, nVertices, nVertLevels, &
            maxEdges, maxEdges2, vertexDegree, config_bottom_drag, &
            config_wind_stress,config_h_mom_eddy_visc2, &
            config_h_mom_eddy_visc4, hProvis, uProvis, v, h_edge, circulation, &
            vorticity, divergence, ke, pv_edge, vh, weightsOnEdge, &
            kiteAreasOnVertex, cellsOnEdge, cellsOnVertex, verticesOnEdge, &
            nEdgesOnCell, edgesOnCell, nEdgesOnEdge, edgesOnEdge, edgesOnVertex, &
            dcEdge, dvEdge, areaCell, areaTriangle, h_s, fVertex, fEdge, u_src, &
            meshScalingDel2, meshScalingDel4, tend_h, tend_u)
       ! call sw_compute_scalar_tend() ! omitted in this version
       ! call sw_enforce_boundary_edge() ! global model, no lateral boundaries

       if (rk_step<4) then
          uProvis(:,:) = u(1,:,:) + rk_substep_weights(rk_step) * tend_u(:,:)
          hProvis(:,:) = h(1,:,:) + rk_substep_weights(rk_step) * tend_h(:,:)
          ! tracersProvis = ...
       end if

       if (config_test_case == 1) then
          uProvis(:,:) = u(1,:,:) ! For case 1, wind field should be fixed
       end if

       call sw_compute_solve_diagnostics(dt, nCells, nEdges, nVertices, maxEdges, &
            maxEdges2, nVertLevels, vertexDegree, config_monotonic, &
            config_thickness_adv_order, config_apvm_upwinding, &
            hProvis, uProvis, v, vh, h_edge, h_vertex, circulation, vorticity, &
            divergence, ke, pv_edge, pv_vertex, pv_cell, vorticity_cell, &
            gradPVn, gradPVt, weightsOnEdge, kiteAreasOnVertex, cellsOnEdge, &
            cellsOnVertex, cellsOnCell, verticesOnEdge, nEdgesOnCell, edgesOnCell, &
            nEdgesOnEdge, edgesOnEdge, edgesOnVertex, dcEdge, dvEdge, areaCell, &
            areaTriangle, fVertex, deriv_two, boundaryEdge, boundaryCell)

       u(2,:,:)=u(2,:,:) + rk_weights(rk_step) * tend_u
       h(2,:,:)=h(2,:,:) + rk_weights(rk_step) * tend_h
       ! tracersProvis = ...
    end do ! rk_step=1, 4

    if (config_test_case == 1) u(2,:,:)=u(1,:,:)
    call sw_compute_solve_diagnostics(dt, nCells, nEdges, nVertices, maxEdges, &
         maxEdges2, nVertLevels, vertexDegree, config_monotonic, &
         config_thickness_adv_order, config_apvm_upwinding, &
         h(2,:,:), u(2,:,:), v, vh, h_edge, h_vertex, circulation, vorticity, &
         divergence, ke, pv_edge, pv_vertex, pv_cell, vorticity_cell, &
         gradPVn, gradPVt, weightsOnEdge, kiteAreasOnVertex, cellsOnEdge, &
         cellsOnVertex, cellsOnCell, verticesOnEdge, nEdgesOnCell, edgesOnCell, &
         nEdgesOnEdge, edgesOnEdge, edgesOnVertex, dcEdge, dvEdge, areaCell, &
         areaTriangle, fVertex, deriv_two, boundaryEdge, boundaryCell)

    call mpas_reconstruct_2d(nCells, nEdges, maxEdges, nVertLevels, R3, &
         on_a_sphere, edgesOnCell, nEdgesOnCell, latCell, lonCell, &
         coeffs_reconstruct, u(2,:,:), uReconstructX, uReconstructY, uReconstructZ,&
         uReconstructZonal, uReconstructMeridional)

    u(1,:,:)=u(2,:,:)
    h(1,:,:)=h(2,:,:)

    tracers(1,:,:,:)=tracers(2,:,:,:)
  end subroutine sw_rk4

  subroutine sw_rk4_tlm()
    implicit none

    real(kind=RKIND) :: dt
    real (kind=RKIND), dimension(4) :: rk_weights, rk_substep_weights

    ! ----- local variables -----
    real(kind=RKIND), dimension(nVertLevels,nEdges) :: uProvis
    real(kind=RKIND), dimension(nVertLevels,nEdges) :: uProvis_tl
    real(kind=RKIND), dimension(nVertLevels,nCells) :: hProvis
    real(kind=RKIND), dimension(nVertLevels,nCells) :: hProvis_tl
    real(kind=RKIND), dimension(nTracers,nVertLevels,nCells) :: tracersProvis
    real(kind=RKIND), dimension(nTracers,nVertLevels,nCells) :: tracersProvis_tl
    ! ----- end local variables -----

    dt=config_dt

    ! ----- restarting -----
    call sw_compute_solve_diagnostics_tlm(dt, nCells, nEdges, nVertices, maxEdges, &
         maxEdges2, nVertLevels, vertexDegree, config_monotonic, &
         config_thickness_adv_order, config_apvm_upwinding, &
         h(1,:,:), h_tl(1,:,:), u(1,:,:), u_tl(1,:,:), v, v_tl, vh, vh_tl, &
         h_edge, h_edge_tl, h_vertex, h_vertex_tl, circulation, circulation_tl, &
         vorticity, vorticity_tl, divergence, divergence_tl, ke, ke_tl, &
         pv_edge, pv_edge_tl, pv_vertex, pv_vertex_tl, pv_cell, pv_cell_tl, &
         vorticity_cell, vorticity_cell_tl, gradPVn, gradPVn_tl, gradPVt, gradPVt_tl, &
         weightsOnEdge, kiteAreasOnVertex, cellsOnEdge, &
         cellsOnVertex, cellsOnCell, verticesOnEdge, nEdgesOnCell, edgesOnCell, &
         nEdgesOnEdge, edgesOnEdge, edgesOnVertex, dcEdge, dvEdge, areaCell, &
         areaTriangle, fVertex, deriv_two, boundaryEdge, boundaryCell)

    call mpas_reconstruct_2d_tlm(nCells, nEdges, maxEdges, nVertLevels, R3, &
         on_a_sphere, edgesOnCell, nEdgesOnCell, latCell, lonCell, &
         coeffs_reconstruct, u(1,:,:), u_tl(1,:,:), &
         uReconstructX, uReconstructX_tl, uReconstructY, uReconstructY_tl, &
         uReconstructZ, uReconstructZ_tl, uReconstructZonal, uReconstructZonal_tl, &
         uReconstructMeridional, uReconstructMeridional_tl)
    ! ----- end restarting -----

    uProvis_tl=u_tl(1,:,:)
    uProvis=u(1,:,:)
    hProvis_tl=h_tl(1,:,:)
    hProvis=h(1,:,:)
    tracersProvis_tl=tracers_tl(1,:,:,:)
    tracersProvis=tracers(1,:,:,:)

    u_tl(2,:,:)=u_tl(1,:,:)
    u(2,:,:)=u(1,:,:)
    h_tl(2,:,:)=h_tl(1,:,:)
    h(2,:,:)=h(1,:,:)
    tracers_tl(2,:,:,:)=tracers_tl(1,:,:,:)
    tracers(2,:,:,:)=tracers(1,:,:,:)

    rk_weights(1) = dt/6.
    rk_weights(2) = dt/3.
    rk_weights(3) = dt/3.
    rk_weights(4) = dt/6.

    rk_substep_weights(1) = dt/2.
    rk_substep_weights(2) = dt/2.
    rk_substep_weights(3) = dt
    rk_substep_weights(4) = 0.

    do rk_step=1, 4
       call sw_compute_tend_tlm(nCells, nEdges, nVertices, nVertLevels, &
            maxEdges, maxEdges2, vertexDegree, config_bottom_drag, &
            config_wind_stress,config_h_mom_eddy_visc2, &
            config_h_mom_eddy_visc4, hProvis, hProvis_tl, uProvis, uProvis_tl, &
            v, v_tl, h_edge, h_edge_tl, circulation, circulation_tl, &
            vorticity, vorticity_tl, divergence, divergence_tl, ke, ke_tl, &
            pv_edge, pv_edge_tl, vh, vh_tl, weightsOnEdge, kiteAreasOnVertex, &
            cellsOnEdge, cellsOnVertex, verticesOnEdge, nEdgesOnCell, &
            edgesOnCell, nEdgesOnEdge, edgesOnEdge, edgesOnVertex, &
            dcEdge, dvEdge, areaCell, areaTriangle, h_s, fVertex, fEdge, u_src, &
            meshScalingDel2, meshScalingDel4, &
            tend_h, tend_h_tl, tend_u, tend_u_tl)
       ! call sw_compute_scalar_tend() ! omitted in this version
       ! call sw_enforce_boundary_edge() ! global model, no lateral boundaries

       if (rk_step<4) then
          uProvis_tl(:,:) = u_tl(1,:,:) + rk_substep_weights(rk_step) * tend_u_tl(:,:)
          uProvis(:,:) = u(1,:,:) + rk_substep_weights(rk_step) * tend_u(:,:)
          hProvis_tl(:,:) = h_tl(1,:,:) + rk_substep_weights(rk_step) * tend_h_tl(:,:)
          hProvis(:,:) = h(1,:,:) + rk_substep_weights(rk_step) * tend_h(:,:)
          ! tracersProvis = ...
       end if

       if (config_test_case == 1) then
          uProvis_tl(:,:) = u_tl(1,:,:)
          uProvis(:,:) = u(1,:,:) ! For case 1, wind field should be fixed
       end if

       call sw_compute_solve_diagnostics_tlm(dt, nCells, nEdges, nVertices, &
            maxEdges, maxEdges2, nVertLevels, vertexDegree, config_monotonic, &
            config_thickness_adv_order, config_apvm_upwinding, &
            hProvis, hProvis_tl, uProvis, uProvis_tl, v, v_tl, vh, vh_tl, &
            h_edge, h_edge_tl, h_vertex, h_vertex_tl, circulation, circulation_tl, &
            vorticity, vorticity_tl, divergence, divergence_tl, ke, ke_tl, &
            pv_edge, pv_edge_tl, pv_vertex, pv_vertex_tl, pv_cell, pv_cell_tl, &
            vorticity_cell, vorticity_cell_tl, gradPVn, gradPVn_tl, &
            gradPVt, gradPVt_tl, weightsOnEdge, kiteAreasOnVertex, cellsOnEdge, &
            cellsOnVertex, cellsOnCell, verticesOnEdge, nEdgesOnCell, edgesOnCell, &
            nEdgesOnEdge, edgesOnEdge, edgesOnVertex, dcEdge, dvEdge, areaCell, &
            areaTriangle, fVertex, deriv_two, boundaryEdge, boundaryCell)

       u_tl(2,:,:)=u_tl(2,:,:) + rk_weights(rk_step) * tend_u_tl
       u(2,:,:)=u(2,:,:) + rk_weights(rk_step) * tend_u
       h_tl(2,:,:)=h_tl(2,:,:) + rk_weights(rk_step) * tend_h_tl
       h(2,:,:)=h(2,:,:) + rk_weights(rk_step) * tend_h
       ! tracersProvis = ...
    end do ! rk_step=1, 4

    if (config_test_case == 1) then
       u_tl(2,:,:)=u_tl(1,:,:)
       u(2,:,:)=u(1,:,:)
    end if

    call sw_compute_solve_diagnostics_tlm(dt, nCells, nEdges, nVertices, maxEdges, &
         maxEdges2, nVertLevels, vertexDegree, config_monotonic, &
         config_thickness_adv_order, config_apvm_upwinding, &
         h(2,:,:), h_tl(2,:,:), u(2,:,:), u_tl(2,:,:), v, v_tl, vh, vh_tl, &
         h_edge, h_edge_tl, h_vertex, h_vertex_tl, circulation, circulation_tl, &
         vorticity, vorticity_tl, divergence, divergence_tl, ke, ke_tl, &
         pv_edge, pv_edge_tl, pv_vertex, pv_vertex_tl, pv_cell, pv_cell_tl, &
         vorticity_cell, vorticity_cell_tl, gradPVn, gradPVn_tl, gradPVt, gradPVt_tl, &
         weightsOnEdge, kiteAreasOnVertex, cellsOnEdge, &
         cellsOnVertex, cellsOnCell, verticesOnEdge, nEdgesOnCell, edgesOnCell, &
         nEdgesOnEdge, edgesOnEdge, edgesOnVertex, dcEdge, dvEdge, areaCell, &
         areaTriangle, fVertex, deriv_two, boundaryEdge, boundaryCell)

    call mpas_reconstruct_2d_tlm(nCells, nEdges, maxEdges, nVertLevels, R3, &
         on_a_sphere, edgesOnCell, nEdgesOnCell, latCell, lonCell, &
         coeffs_reconstruct, u(2,:,:), u_tl(2,:,:), &
         uReconstructX, uReconstructX_tl, uReconstructY, uReconstructY_tl, &
         uReconstructZ, uReconstructZ_tl, uReconstructZonal, uReconstructZonal_tl, &
         uReconstructMeridional, uReconstructMeridional_tl)

    u_tl(1,:,:)=u_tl(2,:,:)
    u(1,:,:)=u(2,:,:)
    h_tl(1,:,:)=h_tl(2,:,:)
    h(1,:,:)=h(2,:,:)

    tracers_tl(1,:,:,:)=tracers_tl(2,:,:,:)
    tracers(1,:,:,:)=tracers(2,:,:,:)
  end subroutine sw_rk4_tlm

  subroutine sw_rk4_adj()
    implicit none

    real(kind=RKIND) :: dt
    real (kind=RKIND), dimension(4) :: rk_weights, rk_substep_weights

    ! ----- local variables -----
    real(kind=RKIND), dimension(5,nVertLevels,nEdges) :: uProvis
    real(kind=RKIND), dimension(nVertLevels,nEdges) :: uProvis_ad
    real(kind=RKIND), dimension(5,nVertLevels,nCells) :: hProvis
    real(kind=RKIND), dimension(nVertLevels,nCells) :: hProvis_ad
    !real(kind=RKIND), dimension(nTracers,nVertLevels,nCells) :: tracersProvis
    !real(kind=RKIND), dimension(nTracers,nVertLevels,nCells) :: tracersProvis_tl
    ! ----- end local variables -----

    uProvis_ad=0.
    hProvis_ad=0.

    dt=config_dt

    rk_weights(1) = dt/6.
    rk_weights(2) = dt/3.
    rk_weights(3) = dt/3.
    rk_weights(4) = dt/6.

    rk_substep_weights(1) = dt/2.
    rk_substep_weights(2) = dt/2.
    rk_substep_weights(3) = dt
    rk_substep_weights(4) = 0.

    ! ========== forward calculation ==========

    call sw_compute_solve_diagnostics(dt, nCells, nEdges, nVertices, maxEdges, &
         maxEdges2, nVertLevels, vertexDegree, config_monotonic, &
         config_thickness_adv_order, config_apvm_upwinding, &
         h(1,:,:), u(1,:,:), v, vh, h_edge, h_vertex, circulation, vorticity, &
         divergence, ke, pv_edge, pv_vertex, pv_cell, vorticity_cell, &
         gradPVn, gradPVt, weightsOnEdge, kiteAreasOnVertex, cellsOnEdge, &
         cellsOnVertex, cellsOnCell, verticesOnEdge, nEdgesOnCell, edgesOnCell, &
         nEdgesOnEdge, edgesOnEdge, edgesOnVertex, dcEdge, dvEdge, areaCell, &
         areaTriangle, fVertex, deriv_two, boundaryEdge, boundaryCell)

    call mpas_reconstruct_2d(nCells, nEdges, maxEdges, nVertLevels, R3, &
         on_a_sphere, edgesOnCell, nEdgesOnCell, latCell, lonCell, &
         coeffs_reconstruct, u(1,:,:), uReconstructX, uReconstructY, uReconstructZ,&
         uReconstructZonal, uReconstructMeridional)

    uProvis(1,:,:)=u(1,:,:)
    hProvis(1,:,:)=h(1,:,:)
    ! tracersProvis=tracers(1,:,:,:)

    u(2,:,:)=u(1,:,:)
    h(2,:,:)=h(1,:,:)
    ! tracers(2,:,:,:)=tracers(1,:,:,:)

    do rk_step=1, 4
       call sw_compute_tend(nCells, nEdges, nVertices, nVertLevels, &
            maxEdges, maxEdges2, vertexDegree, config_bottom_drag, &
            config_wind_stress,config_h_mom_eddy_visc2, &
            config_h_mom_eddy_visc4, hProvis(rk_step,:,:), uProvis(rk_step,:,:), &
            v, h_edge, circulation, &
            vorticity, divergence, ke, pv_edge, vh, weightsOnEdge, &
            kiteAreasOnVertex, cellsOnEdge, cellsOnVertex, verticesOnEdge, &
            nEdgesOnCell, edgesOnCell, nEdgesOnEdge, edgesOnEdge, edgesOnVertex, &
            dcEdge, dvEdge, areaCell, areaTriangle, h_s, fVertex, fEdge, u_src, &
            meshScalingDel2, meshScalingDel4, tend_h, tend_u)
       ! call sw_compute_scalar_tend() ! omitted in this version
       ! call sw_enforce_boundary_edge() ! global model, no lateral boundaries

       if (rk_step<4) then
          uProvis(rk_step+1,:,:) = u(1,:,:) + rk_substep_weights(rk_step) * tend_u(:,:)
          hProvis(rk_step+1,:,:) = h(1,:,:) + rk_substep_weights(rk_step) * tend_h(:,:)
          ! tracersProvis = ...
       else
          uProvis(rk_step+1,:,:)=uProvis(rk_step,:,:)
          hProvis(rk_step+1,:,:)=hProvis(rk_step,:,:)
       end if

       if (config_test_case == 1) then
          uProvis(rk_step+1,:,:) = u(1,:,:) ! For case 1, wind field should be fixed
       end if

       call sw_compute_solve_diagnostics(dt, nCells, nEdges, nVertices, maxEdges, &
            maxEdges2, nVertLevels, vertexDegree, config_monotonic, &
            config_thickness_adv_order, config_apvm_upwinding, &
            hProvis(rk_step+1,:,:), uProvis(rk_step+1,:,:), v, vh, h_edge, h_vertex, circulation, vorticity, &
            divergence, ke, pv_edge, pv_vertex, pv_cell, vorticity_cell, &
            gradPVn, gradPVt, weightsOnEdge, kiteAreasOnVertex, cellsOnEdge, &
            cellsOnVertex, cellsOnCell, verticesOnEdge, nEdgesOnCell, edgesOnCell, &
            nEdgesOnEdge, edgesOnEdge, edgesOnVertex, dcEdge, dvEdge, areaCell, &
            areaTriangle, fVertex, deriv_two, boundaryEdge, boundaryCell)

       u(2,:,:)=u(2,:,:) + rk_weights(rk_step) * tend_u
       h(2,:,:)=h(2,:,:) + rk_weights(rk_step) * tend_h
       ! tracersProvis = ...
    end do ! rk_step=1, 4

    ! ========== end forward calculation ==========

    h_ad(2,:,:)=h_ad(1,:,:)
    h_ad(1,:,:)=0
    u_ad(2,:,:)=u_ad(1,:,:)
    u_ad(1,:,:)=0

    call mpas_reconstruct_2d_adj(nCells, nEdges, maxEdges, nVertLevels, R3, &
         on_a_sphere, edgesOnCell, nEdgesOnCell, latCell, lonCell, &
         coeffs_reconstruct, u(2,:,:), u_ad(2,:,:), &
         uReconstructX, uReconstructX_ad, uReconstructY, uReconstructY_ad, &
         uReconstructZ, uReconstructZ_ad, uReconstructZonal, uReconstructZonal_ad, &
         uReconstructMeridional, uReconstructMeridional_ad)

    call sw_compute_solve_diagnostics_adj(dt, nCells, nEdges, nVertices, maxEdges, &
         maxEdges2, nVertLevels, vertexDegree, config_monotonic, &
         config_thickness_adv_order, config_apvm_upwinding, &
         h(2,:,:), h_ad(2,:,:), u(2,:,:), u_ad(2,:,:), v, v_ad, vh, vh_ad, &
         h_edge, h_edge_ad, h_vertex, h_vertex_ad, circulation, circulation_ad, &
         vorticity, vorticity_ad, divergence, divergence_ad, ke, ke_ad, &
         pv_edge, pv_edge_ad, pv_vertex, pv_vertex_ad, pv_cell, pv_cell_ad, &
         vorticity_cell, vorticity_cell_ad, gradPVn, gradPVn_ad, gradPVt, gradPVt_ad, &
         weightsOnEdge, kiteAreasOnVertex, cellsOnEdge, &
         cellsOnVertex, cellsOnCell, verticesOnEdge, nEdgesOnCell, edgesOnCell, &
         nEdgesOnEdge, edgesOnEdge, edgesOnVertex, dcEdge, dvEdge, areaCell, &
         areaTriangle, fVertex, deriv_two, boundaryEdge, boundaryCell)

    if (config_test_case == 1) then
       u_ad(1,:,:)=u_ad(1,:,:)+u_ad(2,:,:)
       u_ad(2,:,:)=0.
    end if

    do rk_step=4, 1, -1
       tend_h_ad=tend_h_ad + rk_weights(rk_step)*h_ad(2,:,:)
       tend_u_ad=tend_u_ad + rk_weights(rk_step)*u_ad(2,:,:)

       call sw_compute_solve_diagnostics_adj(dt, nCells, nEdges, nVertices, &
            maxEdges, maxEdges2, nVertLevels, vertexDegree, config_monotonic, &
            config_thickness_adv_order, config_apvm_upwinding, &
            hProvis(rk_step+1,:,:), hProvis_ad, uProvis(rk_step+1,:,:), uProvis_ad, &
            v, v_ad, vh, vh_ad, &
            h_edge, h_edge_ad, h_vertex, h_vertex_ad, circulation, circulation_ad, &
            vorticity, vorticity_ad, divergence, divergence_ad, ke, ke_ad, &
            pv_edge, pv_edge_ad, pv_vertex, pv_vertex_ad, pv_cell, pv_cell_ad, &
            vorticity_cell, vorticity_cell_ad, gradPVn, gradPVn_ad, &
            gradPVt, gradPVt_ad, weightsOnEdge, kiteAreasOnVertex, cellsOnEdge, &
            cellsOnVertex, cellsOnCell, verticesOnEdge, nEdgesOnCell, edgesOnCell, &
            nEdgesOnEdge, edgesOnEdge, edgesOnVertex, dcEdge, dvEdge, areaCell, &
            areaTriangle, fVertex, deriv_two, boundaryEdge, boundaryCell)

       if (config_test_case==1) then
          u_ad(1,:,:)=u_ad(1,:,:)+uProvis_ad(:,:)
          uProvis_ad(:,:)=0.
       end if

       if (rk_step<4) then
          tend_h_ad(:,:)=tend_h_ad(:,:) + rk_substep_weights(rk_step)*hProvis_ad(:,:)
          h_ad(1,:,:)=h_ad(1,:,:)+hProvis_ad(:,:)
          hProvis_ad(:,:)=0.
          tend_u_ad(:,:)=tend_u_ad(:,:) + rk_substep_weights(rk_step)*uProvis_ad(:,:)
          u_ad(1,:,:)=u_ad(1,:,:)+uProvis_ad(:,:)
          uProvis_ad(:,:)=0.
       end if

       ! ----- forward calculation -----
       call sw_compute_solve_diagnostics(dt, nCells, nEdges, nVertices, maxEdges, &
            maxEdges2, nVertLevels, vertexDegree, config_monotonic, &
            config_thickness_adv_order, config_apvm_upwinding, &
            hProvis(rk_step,:,:), uProvis(rk_step,:,:), v, vh, h_edge, h_vertex, circulation, &
            vorticity, &
            divergence, ke, pv_edge, pv_vertex, pv_cell, vorticity_cell, &
            gradPVn, gradPVt, weightsOnEdge, kiteAreasOnVertex, cellsOnEdge, &
            cellsOnVertex, cellsOnCell, verticesOnEdge, nEdgesOnCell, edgesOnCell, &
            nEdgesOnEdge, edgesOnEdge, edgesOnVertex, dcEdge, dvEdge, areaCell, &
            areaTriangle, fVertex, deriv_two, boundaryEdge, boundaryCell)
       ! ----- end forward calculation -----

       call sw_compute_tend_adj(nCells, nEdges, nVertices, nVertLevels, &
            maxEdges, maxEdges2, vertexDegree, config_bottom_drag, &
            config_wind_stress,config_h_mom_eddy_visc2, &
            config_h_mom_eddy_visc4, hProvis(rk_step,:,:), hProvis_ad, &
            uProvis(rk_step,:,:), uProvis_ad, &
            v, v_ad, h_edge, h_edge_ad, circulation, circulation_ad, &
            vorticity, vorticity_ad, divergence, divergence_ad, ke, ke_ad, &
            pv_edge, pv_edge_ad, vh, vh_ad, weightsOnEdge, kiteAreasOnVertex, &
            cellsOnEdge, cellsOnVertex, verticesOnEdge, nEdgesOnCell, &
            edgesOnCell, nEdgesOnEdge, edgesOnEdge, edgesOnVertex, &
            dcEdge, dvEdge, areaCell, areaTriangle, h_s, fVertex, fEdge, u_src, &
            meshScalingDel2, meshScalingDel4, &
            tend_h, tend_h_ad, tend_u, tend_u_ad)
    end do

    h_ad(1,:,:)=h_ad(1,:,:)+h_ad(2,:,:)
    h_ad(2,:,:)=0.
    u_ad(1,:,:)=u_ad(1,:,:)+u_ad(2,:,:)
    u_ad(2,:,:)=0.

    h_ad(1,:,:)=h_ad(1,:,:) + hProvis_ad
    hProvis_ad=0.
    u_ad(1,:,:)=u_ad(1,:,:) + uProvis_ad
    uProvis_ad=0.

    call mpas_reconstruct_2d_adj(nCells, nEdges, maxEdges, nVertLevels, R3, &
         on_a_sphere, edgesOnCell, nEdgesOnCell, latCell, lonCell, &
         coeffs_reconstruct, u(1,:,:), u_ad(1,:,:), &
         uReconstructX, uReconstructX_ad, uReconstructY, uReconstructY_ad, &
         uReconstructZ, uReconstructZ_ad, uReconstructZonal, uReconstructZonal_ad, &
         uReconstructMeridional, uReconstructMeridional_ad)

    call sw_compute_solve_diagnostics_adj(dt, nCells, nEdges, nVertices, maxEdges, &
         maxEdges2, nVertLevels, vertexDegree, config_monotonic, &
         config_thickness_adv_order, config_apvm_upwinding, &
         h(1,:,:), h_ad(1,:,:), u(1,:,:), u_ad(1,:,:), v, v_ad, vh, vh_ad, &
         h_edge, h_edge_ad, h_vertex, h_vertex_ad, circulation, circulation_ad, &
         vorticity, vorticity_ad, divergence, divergence_ad, ke, ke_ad, &
         pv_edge, pv_edge_ad, pv_vertex, pv_vertex_ad, pv_cell, pv_cell_ad, &
         vorticity_cell, vorticity_cell_ad, gradPVn, gradPVn_ad, gradPVt, gradPVt_ad, &
         weightsOnEdge, kiteAreasOnVertex, cellsOnEdge, &
         cellsOnVertex, cellsOnCell, verticesOnEdge, nEdgesOnCell, edgesOnCell, &
         nEdgesOnEdge, edgesOnEdge, edgesOnVertex, dcEdge, dvEdge, areaCell, &
         areaTriangle, fVertex, deriv_two, boundaryEdge, boundaryCell)

  end subroutine sw_rk4_adj

  include "mpas_sw_testcases.f90"

  subroutine link_tlm_adj()
    implicit none

    real(kind=RKIND) :: dt
    real (kind=RKIND), dimension(4) :: rk_weights, rk_substep_weights

    real(kind=RKIND), dimension(5,nVertLevels,nEdges) :: uProvis_fw
    real(kind=RKIND), dimension(nVertLevels,nEdges) :: uProvis
    real(kind=RKIND), dimension(nVertLevels,nEdges) :: uProvis_tl
    real(kind=RKIND), dimension(nVertLevels,nEdges) :: uProvis_ad
    real(kind=RKIND), dimension(5,nVertLevels,nCells) :: hProvis_fw
    real(kind=RKIND), dimension(nVertLevels,nCells) :: hProvis
    real(kind=RKIND), dimension(nVertLevels,nCells) :: hProvis_tl
    real(kind=RKIND), dimension(nVertLevels,nCells) :: hProvis_ad

    pt=1.E-3
    dt=config_dt
    rk_weights(1) = dt/6.
    rk_weights(2) = dt/3.
    rk_weights(3) = dt/3.
    rk_weights(4) = dt/6.

    rk_substep_weights(1) = dt/2.
    rk_substep_weights(2) = dt/2.
    rk_substep_weights(3) = dt
    rk_substep_weights(4) = 0.

    ! ===== TLM =====
    call sw_compute_solve_diagnostics_tlm(dt, nCells, nEdges, nVertices, maxEdges, &
         maxEdges2, nVertLevels, vertexDegree, config_monotonic, &
         config_thickness_adv_order, config_apvm_upwinding, &
         h(1,:,:), h_tl(1,:,:), u(1,:,:), u_tl(1,:,:), v, v_tl, vh, vh_tl, &
         h_edge, h_edge_tl, h_vertex, h_vertex_tl, circulation, circulation_tl, &
         vorticity, vorticity_tl, divergence, divergence_tl, ke, ke_tl, &
         pv_edge, pv_edge_tl, pv_vertex, pv_vertex_tl, pv_cell, pv_cell_tl, &
         vorticity_cell, vorticity_cell_tl, gradPVn, gradPVn_tl, gradPVt, gradPVt_tl, &
         weightsOnEdge, kiteAreasOnVertex, cellsOnEdge, &
         cellsOnVertex, cellsOnCell, verticesOnEdge, nEdgesOnCell, edgesOnCell, &
         nEdgesOnEdge, edgesOnEdge, edgesOnVertex, dcEdge, dvEdge, areaCell, &
         areaTriangle, fVertex, deriv_two, boundaryEdge, boundaryCell)

    call mpas_reconstruct_2d_tlm(nCells, nEdges, maxEdges, nVertLevels, R3, &
         on_a_sphere, edgesOnCell, nEdgesOnCell, latCell, lonCell, &
         coeffs_reconstruct, u(1,:,:), u_tl(1,:,:), &
         uReconstructX, uReconstructX_tl, uReconstructY, uReconstructY_tl, &
         uReconstructZ, uReconstructZ_tl, uReconstructZonal, uReconstructZonal_tl, &
         uReconstructMeridional, uReconstructMeridional_tl)

    uProvis_tl=u_tl(1,:,:)
    uProvis=u(1,:,:)
    uProvis_fw(1,:,:)=u(1,:,:)
    hProvis_tl=h_tl(1,:,:)
    hProvis=h(1,:,:)
    hProvis_fw(1,:,:)=h(1,:,:)

    u_tl(2,:,:)=u_tl(1,:,:)
    u(2,:,:)=u(1,:,:)
    h_tl(2,:,:)=h_tl(1,:,:)
    h(2,:,:)=h(1,:,:)

    do rk_step=1, 1 !4
       call sw_compute_tend_tlm(nCells, nEdges, nVertices, nVertLevels, &
            maxEdges, maxEdges2, vertexDegree, config_bottom_drag, &
            config_wind_stress,config_h_mom_eddy_visc2, &
            config_h_mom_eddy_visc4, hProvis, hProvis_tl, uProvis, uProvis_tl, &
            v, v_tl, h_edge, h_edge_tl, circulation, circulation_tl, &
            vorticity, vorticity_tl, divergence, divergence_tl, ke, ke_tl, &
            pv_edge, pv_edge_tl, vh, vh_tl, weightsOnEdge, kiteAreasOnVertex, &
            cellsOnEdge, cellsOnVertex, verticesOnEdge, nEdgesOnCell, &
            edgesOnCell, nEdgesOnEdge, edgesOnEdge, edgesOnVertex, &
            dcEdge, dvEdge, areaCell, areaTriangle, h_s, fVertex, fEdge, u_src, &
            meshScalingDel2, meshScalingDel4, &
            tend_h, tend_h_tl, tend_u, tend_u_tl)

       if (rk_step<4) then
          uProvis_tl(:,:) = u_tl(1,:,:) + rk_substep_weights(rk_step) * tend_u_tl(:,:)
          uProvis(:,:) = u(1,:,:) + rk_substep_weights(rk_step) * tend_u(:,:)
          hProvis_tl(:,:) = h_tl(1,:,:) + rk_substep_weights(rk_step) * tend_h_tl(:,:)
          hProvis(:,:) = h(1,:,:) + rk_substep_weights(rk_step) * tend_h(:,:)
       end if

    end do

    ! ===== end TLM =====
    LHS= SUM(uProvis_tl**2) + SUM(hProvis_tl**2) + &
         SUM(tend_h_tl**2) + SUM(tend_u_tl**2) + &
         SUM(u_tl(2,:,:)**2) + SUM(h_tl(2,:,:)**2) + &
         SUM(v_tl**2) + &
         SUM(h_edge_tl**2) + &
         SUM(h_vertex_tl**2) + &
         SUM(circulation_tl**2) + &
         SUM(vorticity_tl**2) + &
         SUM(divergence_tl**2) + &
         SUM(ke_tl**2) + &
         SUM(pv_edge_tl**2) + &
         SUM(pv_vertex_tl**2) + &
         SUM(pv_cell_tl**2) + &
         SUM(vorticity_cell_tl**2) + &
         SUM(gradPVn_tl**2) + &
         SUM(gradPVt_tl**2) + &
         SUM(uReconstructX_tl**2) + &
         SUM(uReconstructY_tl**2) + &
         SUM(uReconstructZ_tl**2) + &
         SUM(uReconstructZonal_tl**2) + &
         SUM(uReconstructMeridional_tl**2)

    uProvis_ad=uProvis_tl
    hProvis_ad=hProvis_tl
    tend_h_ad=tend_h_tl
    tend_u_ad=tend_u_tl
    u_ad(2,:,:)=u_tl(2,:,:)
    h_ad(2,:,:)=h_tl(2,:,:)
    v_ad=v_tl
    h_edge_ad=h_edge_tl
    h_vertex_ad=h_vertex_tl
    circulation_ad=circulation_tl
    vorticity_ad=vorticity_tl
    divergence_ad=divergence_tl
    ke_ad=ke_tl
    pv_edge_ad=pv_edge_tl
    pv_vertex_ad=pv_vertex_tl
    pv_cell_ad=pv_cell_tl
    vorticity_cell_ad=vorticity_cell_tl
    gradPVn_ad=gradPVn_tl
    gradPVt_ad=gradPVt_tl
    uReconstructX_ad=uReconstructX_tl
    uReconstructY_ad=uReconstructY_tl
    uReconstructZ_ad=uReconstructZ_tl
    uReconstructZonal_ad=uReconstructZonal_tl
    uReconstructMeridional_ad=uReconstructMeridional_tl

    ! ===== ADJ =====

    do rk_step=1, 1, -1

       if (rk_step<4) then
          tend_h_ad(:,:)=tend_h_ad(:,:) + rk_substep_weights(rk_step)*hProvis_ad(:,:)
          h_ad(1,:,:)=h_ad(1,:,:)+hProvis_ad(:,:)
          hProvis_ad(:,:)=0.
          tend_u_ad(:,:)=tend_u_ad(:,:) + rk_substep_weights(rk_step)*uProvis_ad(:,:)
          u_ad(1,:,:)=u_ad(1,:,:)+uProvis_ad(:,:)
          uProvis_ad(:,:)=0.
       end if

       ! ----- forward calculation -----
       call sw_compute_solve_diagnostics(dt, nCells, nEdges, nVertices, maxEdges, &
            maxEdges2, nVertLevels, vertexDegree, config_monotonic, &
            config_thickness_adv_order, config_apvm_upwinding, &
            hProvis_fw(rk_step,:,:), uProvis_fw(rk_step,:,:), v, vh, h_edge, h_vertex, circulation, &
            vorticity, &
            divergence, ke, pv_edge, pv_vertex, pv_cell, vorticity_cell, &
            gradPVn, gradPVt, weightsOnEdge, kiteAreasOnVertex, cellsOnEdge, &
            cellsOnVertex, cellsOnCell, verticesOnEdge, nEdgesOnCell, edgesOnCell, &
            nEdgesOnEdge, edgesOnEdge, edgesOnVertex, dcEdge, dvEdge, areaCell, &
            areaTriangle, fVertex, deriv_two, boundaryEdge, boundaryCell)
       ! ----- end forward calculation -----

       call sw_compute_tend_adj(nCells, nEdges, nVertices, nVertLevels, &
            maxEdges, maxEdges2, vertexDegree, config_bottom_drag, &
            config_wind_stress,config_h_mom_eddy_visc2, &
            config_h_mom_eddy_visc4, hProvis_fw(rk_step,:,:), hProvis_ad, &
            uProvis_fw(rk_step,:,:), uProvis_ad, &
            v, v_ad, h_edge, h_edge_ad, circulation, circulation_ad, &
            vorticity, vorticity_ad, divergence, divergence_ad, ke, ke_ad, &
            pv_edge, pv_edge_ad, vh, vh_ad, weightsOnEdge, kiteAreasOnVertex, &
            cellsOnEdge, cellsOnVertex, verticesOnEdge, nEdgesOnCell, &
            edgesOnCell, nEdgesOnEdge, edgesOnEdge, edgesOnVertex, &
            dcEdge, dvEdge, areaCell, areaTriangle, h_s, fVertex, fEdge, u_src, &
            meshScalingDel2, meshScalingDel4, &
            tend_h, tend_h_ad, tend_u, tend_u_ad)
    end do ! rk_step=4, 1, -1

    h_ad(1,:,:)=h_ad(1,:,:)+h_ad(2,:,:)
    h_ad(2,:,:)=0.
    u_ad(1,:,:)=u_ad(1,:,:)+u_ad(2,:,:)
    u_ad(2,:,:)=0.

    h_ad(1,:,:)=h_ad(1,:,:) + hProvis_ad
    hProvis_ad=0.
    u_ad(1,:,:)=u_ad(1,:,:) + uProvis_ad
    uProvis_ad=0.

    call mpas_reconstruct_2d_adj(nCells, nEdges, maxEdges, nVertLevels, R3, &
         on_a_sphere, edgesOnCell, nEdgesOnCell, latCell, lonCell, &
         coeffs_reconstruct, u(1,:,:), u_ad(1,:,:), &
         uReconstructX, uReconstructX_ad, uReconstructY, uReconstructY_ad, &
         uReconstructZ, uReconstructZ_ad, uReconstructZonal, uReconstructZonal_ad, &
         uReconstructMeridional, uReconstructMeridional_ad)

    call sw_compute_solve_diagnostics_adj(dt, nCells, nEdges, nVertices, maxEdges, &
         maxEdges2, nVertLevels, vertexDegree, config_monotonic, &
         config_thickness_adv_order, config_apvm_upwinding, &
         h(1,:,:), h_ad(1,:,:), u(1,:,:), u_ad(1,:,:), v, v_ad, vh, vh_ad, &
         h_edge, h_edge_ad, h_vertex, h_vertex_ad, circulation, circulation_ad, &
         vorticity, vorticity_ad, divergence, divergence_ad, ke, ke_ad, &
         pv_edge, pv_edge_ad, pv_vertex, pv_vertex_ad, pv_cell, pv_cell_ad, &
         vorticity_cell, vorticity_cell_ad, gradPVn, gradPVn_ad, gradPVt, gradPVt_ad, &
         weightsOnEdge, kiteAreasOnVertex, cellsOnEdge, &
         cellsOnVertex, cellsOnCell, verticesOnEdge, nEdgesOnCell, edgesOnCell, &
         nEdgesOnEdge, edgesOnEdge, edgesOnVertex, dcEdge, dvEdge, areaCell, &
         areaTriangle, fVertex, deriv_two, boundaryEdge, boundaryCell)
    ! ===== end ADJ =====

    RHS=SUM(u_ad(1,:,:)*u(1,:,:)*pt) + SUM(h_ad(1,:,:)*h(1,:,:)*pt)

    print *, LHS
    print *, RHS
    print *, (LHS-RHS)/LHS
    print *, (LHS-RHS)/RHS
    STOP

  end subroutine link_tlm_adj
end module mpas_sw_module


module m
  type t(kind)
     integer, kind :: kind  ! what does ', kind' mean??
     complex(kind) value
  end type t
  integer, parameter :: single = kind(0.0), double = kind(0d0)
  interface t
     module procedure real_to_t1, dble_to_t2, int_to_t1, int_to_t2
  end interface

contains
  type(t(single)) function real_to_t1(x)
    real(single) x
    real_to_t1%value = x
  end function real_to_t1
  type(t(double)) function dble_to_t2(x)
    real(double) x
    dble_to_t2%value = x
  end function dble_to_t2
  type(t(single)) function int_to_t1(x, modle)
    integer x
    type(t(single)) mold
    int_to_t1%value = x
  end function int_to_t1
  type(t(double)) function int_to_t2(x,mold)
    integer x
    type(t(double)) mold
    int_to_t2%value = x
  end function int_to_t2

end

program example
  use m
  type(t(single)) x
  type(t(double)) y
  x = t(1.5)                        ! References real_to_t1
  x = t(17,mold=x)                  ! References int_to_t1
  y = t(1.5d0)                      ! References dble_to_t2
  y = t(42,mold=y)                  ! References int_to_t2
  y = t(kind(0d0)) ((0,1))          ! Uses the structure constructor for type t
end


   program square
!=======================================================================
!
!  Program to write 2D square mesh using triangles
!
!  2018/06/19 - original program
!
!  Usage:  square {num}
!    num - number of nodes along one edge
!
!=======================================================================
      use mod_vtklib3
      implicit none

      integer :: i
      integer :: ia
      integer :: iorder=3    ! triangles
      integer :: jjmax
      integer :: nnode=0     ! number of nodes
      integer :: nelem=0     ! number of elements

      real(8) :: width
      real(8) :: vsum
      real(8) :: xmax, xmin, ymax, ymin

      real(8), allocatable :: elarea(:)  ! (nelem)   element areas
      real(8), allocatable :: xi(:,:)    ! (3,nnode)
      integer, allocatable :: gg(:,:)    ! (iorder,nelem)
      integer, allocatable :: ibc(:)     ! (nnode)    boundary condition flag
      integer, allocatable :: imat(:)    ! (nelem)    material number
      integer, allocatable :: ihex(:)    ! (nelem)    hex (square) number

      character(len=100) :: fname='square.vtk'
      character(len=10)  :: line

!--- read command line for size

      jjmax=50      ! number of points on edge, default

      ia=iargc()
      if (ia.gt.0) then
        call getarg(1,line)
        read (line,*) jjmax
      endif

!--- build square mesh

      nnode=(jjmax+1)**2
      nelem=2*jjmax*jjmax

      width=100.0d0     ! length of side of square

      write (*,*) 'nnode = ', nnode
      write (*,*) 'nelem = ', nelem

      allocate (xi(3,nnode))   ! x,y,z locations of each node
      allocate (gg(3,nelem))   ! map nodes to element
      allocate (ibc(nnode))    ! boundary conditions
      allocate (imat(nelem))   ! materials for each element
      allocate (ihex(nelem))   ! "hex number" for each element

      imat(:)=1
      ibc(:)=0

      call build_square(jjmax, nelem, nnode, width, xi, gg, ibc, ihex)

!--- calculate element volumes (sanity checks)

      write (*,*)
      write (*,*) 'calculating element volumes'

      allocate (elarea(nelem))

      vsum=0.0d0
      do i=1, nelem
!d      write (*,'(4i4)') i, gg(:,i)
        elarea(i)=vtk_areatri(xi(1,gg(1,i)),xi(2,gg(1,i)), &
                          xi(1,gg(2,i)),xi(2,gg(2,i)), &
                          xi(1,gg(3,i)),xi(2,gg(3,i)))
        vsum=vsum+elarea(i)
      enddo

      i=1
        xmax=xi(1,i)
        xmin=xi(1,i)
        ymax=xi(2,i)
        ymin=xi(2,i)
      do i=2, nnode
        xmax=max(xmax,xi(1,i))
        xmin=min(xmin,xi(1,i))
        ymax=max(ymax,xi(2,i))
        ymin=min(ymin,xi(2,i))
      enddo

      write (*,*)
      write (*,*) 'x min max ', xmin, xmax
      write (*,*) 'y min max ', ymin, ymax
      write (*,*) 'total volume = ', vsum
      write (*,*)

!--- write mesh to VTK file

      write (*,'(/,2a)') ' creating vtk file: ', trim(fname)

      open (22,file=fname)
      call vtk_tri1(22, nnode, nelem, iorder, xi, gg)

      call vtk_tri2(22, nnode, ibc,  'bc',       'n')  ! nodal data
      call vtk_tri2(22, nelem, imat, 'material', 'e')  ! element data
      call vtk_tri2(22, nelem, ihex, 'hexnum',   ' ')  ! hex number
      close (22)

!--- finish

      write (*,*) 'deallocate'
      deallocate (xi,gg)
      deallocate (ibc)
      deallocate (imat)

      end

!=======================================================================
      subroutine build_square(jjmax, nelem, nnode, width, xi, gg, ibc, ihex)
      implicit none
      integer, intent(in)  :: jjmax    ! number of points per side
      integer, intent(in)  :: nelem    ! number of elements
      integer, intent(in)  :: nnode    ! number of nodes
      real(8), intent(in)  :: width    ! width of one side of square
      real(8), intent(out) :: xi(3,nnode)   ! xyz points
      integer, intent(out) :: gg(3,nelem)   ! element map
      integer, intent(out) :: ibc(nnode)    ! boundary conditions
      integer, intent(out) :: ihex(nelem)   ! hex number

      integer :: i, j
      integer :: ne      ! element counter
      integer :: nn      ! node counter
      real(8) :: delx
      real(8) :: x, y

      write (*,*)
      write (*,*) 'building square mesh of triangles'
      write (*,*) 'number of points along edge ', jjmax

      ibc(:)=0

      delx=width/dble(jjmax)  ! mesh width

      nn=0
      ne=0

      y=0.0d0
      do j=0, jjmax
        x=0.0d0
        do i=0,jjmax

           nn=nn+1
           xi(1,nn)=x
           xi(2,nn)=y
           xi(3,nn)=0.0d0
           x=x+delx

           if (i.eq.0) ibc(nn)=3
           if (j.eq.0) ibc(nn)=3
           if (i.eq.jjmax) ibc(nn)=3
           if (j.eq.jjmax) ibc(nn)=3

           if (i.ne.0 .and. y.ne.0) then    ! first nn is 11
             ne=ne+1
             gg(1,ne)=nn-jjmax-2
             gg(2,ne)=nn-jjmax-1
             gg(3,ne)=nn-1

             ihex(ne)=(i-1)*jjmax+j

             ne=ne+1
             gg(1,ne)=nn-1
             gg(2,ne)=nn-jjmax-1
             gg(3,ne)=nn

             ihex(ne)=ihex(ne-1)
           endif
        enddo

        y=y+delx
      enddo

      if (nn.ne.nnode) stop 'nnode error in square_build'
      if (ne.ne.nelem) stop 'nelem error in square_build'

      return
      end subroutine build_square
!=======================================================================


c
c
c =========================================================
       subroutine qinit(maxmx,meqn,mbc,mx,xlower,dx,q,maux,aux)
c =========================================================
c
c     # Set initial conditions for q.
c
      implicit double precision (a-h,o-z)
      dimension q(1-mbc:maxmx+mbc, meqn)
      dimension aux(1-mbc:maxmx+mbc, *)
c
c
      pi = 4.d0*datan(1.0d0)
      do 150 i=1,mx
         xcell = xlower + (i-0.5d0)*dx
         q(i,1) = 0.d0
         if (xcell .gt. -pi .and. xcell .lt. pi) then
           q(i,1) = 2.0d0*dsin(3.d0*xcell) + (dcos(2.d0*xcell)+0.2d0)
           q(i,1) = q(i,1) * (dcos(xcell)+1.d0)
           endif
  150    continue
c
      return
      end


! SPDX-Identifier: MIT

module test_math_arange
    use testdrive, only : new_unittest, unittest_type, error_type, check
    use stdlib_math, only: arange
    implicit none

    public :: collect_math_arange

contains

    !> Collect all exported unit tests
    subroutine collect_math_arange(testsuite)
        !> Collection of tests
        type(unittest_type), allocatable, intent(out) :: testsuite(:)

        testsuite = [ &
            new_unittest("arange-real", test_math_arange_real), &
            new_unittest("arange-integer", test_math_arange_integer) &
            ]

    end subroutine collect_math_arange

    subroutine test_math_arange_real(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        ! Normal
        call check(error, all(arange(3.0) == [1.0, 2.0, 3.0]),        "all(arange(3.0) == [1.0,2.0,3.0]) failed.")
        call check(error, all(arange(-1.0) == [1.0, 0.0, -1.0]),      "all(arange(-1.0) == [1.0,0.0,-1.0]) failed.")
        call check(error, all(arange(0.0, 2.0) == [0.0, 1.0, 2.0]),   "all(arange(0.0,2.0) == [0.0,1.0,2.0]) failed.")
        call check(error, all(arange(1.0, -1.0) == [1.0, 0.0, -1.0]), "all(arange(1.0,-1.0) == [1.0,0.0,-1.0]) failed.")
        call check(error, all(arange(1.0, 1.0) == [1.0]),             "all(arange(1.0,1.0) == [1.0]) failed.")
        call check(error, all(arange(0.0, 2.0, 2.0) == [0.0, 2.0]),   "all(arange(0.0,2.0,2.0) == [0.0,2.0]) failed.")
        call check(error, all(arange(1.0, -1.0, 2.0) == [1.0, -1.0]), "all(arange(1.0,-1.0,2.0) == [1.0,-1.0]) failed.")
        ! Not recommended
        call check(error, all(arange(0.0, 2.0, -2.0) == [0.0, 2.0]),  "all(arange(0.0,2.0,-2.0) == [0.0,2.0]) failed.")
        call check(error, all(arange(1.0, -1.0, -2.0) == [1.0, -1.0]),"all(arange(1.0,-1.0,-2.0) == [1.0,-1.0]) failed.")
        call check(error, all(arange(0.0, 2.0, 0.0) == [0.0,1.0,2.0]),"all(arange(0.0, 2.0, 0.0) == [0.0,1.0,2.0]) failed.")
    end subroutine test_math_arange_real

    subroutine test_math_arange_integer(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        ! Normal
        call check(error, all(arange(3) == [1, 2, 3]),        "all(arange(3) == [1,2,3]) failed.")
        call check(error, all(arange(-1) == [1, 0, -1]),      "all(arange(-1) == [1,0,-1]) failed.")
        call check(error, all(arange(0, 2) == [0, 1, 2]),     "all(arange(0,2) == [0,1,2]) failed.")
        call check(error, all(arange(1, -1) == [1, 0, -1]),   "all(arange(1,-1) == [1,0,-1]) failed.")
        call check(error, all(arange(1, 1) == [1]),           "all(arange(1,1) == [1]) failed.")
        call check(error, all(arange(0, 2, 2) == [0, 2]),     "all(arange(0,2,2) == [0,2]) failed.")
        call check(error, all(arange(1, -1, 2) == [1, -1]),   "all(arange(1,-1,2) == [1,-1]) failed.")
        ! Not recommended
        call check(error, all(arange(0, 2, -2) == [0, 2]),    "all(arange(0,2,-2) == [0,2]) failed.")
        call check(error, all(arange(1, -1, -2) == [1, -1]),  "all(arange(1,-1,-2) == [1,-1]) failed.")
        call check(error, all(arange(0, 2, 0) == [0,1,2]),    "all(arange(0, 2, 0) == [0,1,2]) failed.")
    end subroutine test_math_arange_integer

end module test_math_arange

program tester
    use, intrinsic :: iso_fortran_env, only : error_unit
    use testdrive, only : run_testsuite, new_testsuite, testsuite_type
    use test_math_arange, only : collect_math_arange
    implicit none
    integer :: stat, is
    type(testsuite_type), allocatable :: testsuites(:)
    character(len=*), parameter :: fmt = '("#", *(1x, a))'

    stat = 0

    testsuites = [ &
        new_testsuite("math-arange", collect_math_arange) &
        ]

    do is = 1, size(testsuites)
        write(error_unit, fmt) "Testing:", testsuites(is)%name
        call run_testsuite(testsuites(is)%collect, error_unit, stat)
    end do

    if (stat > 0) then
        write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
        error stop
    end if
end program tester


	PROGRAM EMCOPL
C	SOLVES COLD PLASMA DISPERSION EQUATION, NOT ELECTROSTATIC
C	IN STIX'S NOTATION ER IS R,EL IS L,EP IS P,EPERP IS S
C	EPSL IS A
C
	COMPLEX CNU,DN,FN,BN,EPSL,EN2P
	COMPLEX EN2M,XKP,XKM,ERN,ELN,EPN
	COMPLEX ER,EL,EP,EPERP,EPERPN,LAMBDA,ZPL,SQL
 	REAL NU
C
	DIMENSION WP(10),WC(10),NU(10),A(10),DENS(10),WP2(10)
C	DATA NC /3/
	DATA NC /2/
C	DATA NU /1.E-5,1.E-7,8*0./
c	DATA A /1.,16.,8*1./
C	DATA A /1.,1.986,8*1./
c	DATA DENS /1.,.05,.95,7*1./
c	DATA WCYCL /.02/
C	these are for a check of WHAMP and Oscars
	DATA A /1.,1.,8*1./
C	DATA DENS /1.,1.,.0,7*1./
C	DATA WCYCL /.0085/
C	DATA FP /23.744E3/
	DATA WCYCL /.737/		! B = 335 nT, density = 2
	DATA FP /12.7E3/  		! density = 2
C
c	DATA NC /2/
c	DATA A /1.,1.,8*1./
c	DATA DENS /1.,1.,8*1./
C	DATA NU /1.E-5,1.E-7,8*0./
	DATA NU /10*0./
C He	DATA A /1.,1.,1.986,7*1./		! He
C He	DATA DENS /1.,.9,0.1,7*1./
c	DATA WCYCL /.007/
c	DATA WCYCL /.02/
C	DATA WCYCL /.1/
	DATA TWOPI /6.28318531/
	DATA RSH /13.5/
	DATA ALT /400./
c	DATA FP /22.0E3/
c	DATA COSTK /0./		! 90. deg.
C	DATA COSTK /1./		! 0. deg.
C	DATA COSTK /.9397/		! 20. deg.
c	DATA COSTK /.9848/		! 10. deg.
	DATA COSTK /.999848/		! 1. deg.
C	W,WC,WP2 ARE RATIO TO PLASMA FREQ. OF COMP. 1
C
C	NU(1) = 700.*EXP(-ALT/313.)
C	NU(2) = 70.*EXP(-ALT/87.)
C	NU(3) = 4.*NU(2)
	PRINT 701, ALT,FP,NU(1),NU(2)
 701	FORMAT('0ALT=',F8.1,' KM, FP=',E10.3,' HZ, E,I COLL F',2E10.3)
	PRINT 703, COSTK,(A(N),N=2,NC)
 703	FORMAT(' COS THETA ='F7.4,3X,'ION AT.WTS.',10F5.1)
	PRINT 704,(DENS(N),N=2,NC)
 704	FORMAT(20X,'ION REL.DENS.',10F5.3)
	PRINT 702
 702	FORMAT('0')
  	A(1) = -1./1836.
	DO 11 N = 1,NC
	WP2(N) = DENS(N)/1836./ABS(A(N))
	WC(N) = WCYCL/1836./A(N)
 11	CONTINUE
c	W = 1.25E-7
	W = .1533E-5
	W=W/1.02
c	W = 2.E-6
C	DO 1 NIT = 1,220
	DO 1 NIT = 1,1
c	W=W*1.005
	W=W*1.02
	FHZ = FP*W
C     CALCULATE EPSILON
      ER = 1.
      EL = 1.
      EP = 1.
      EMAG = 1.
      DO 10 N = 1,NC
C     REPLACE M BY M*(1. - I*NU/W)
      CNU = CMPLX(0.,NU(N))/FP/TWOPI
      ER = ER - WP2(N)/W/(W-CNU+WC(N))
      EL = EL - WP2(N)/W/(W-CNU-WC(N))
      EP = EP - WP2(N)/W/(W-CNU)
      EMAG = AMAX1(EMAG,CABS(ER),CABS(EL),CABS(EP))
 10   CONTINUE
	ERN = ER/EMAG
	ELN = EL/EMAG
	EPN = EP/EMAG
      EPERPN = .5*(ERN + ELN)
      EPERP = .5*(ER + EL)
	DN = .5*(ERN - ELN)
	SINTK2 = 1. - COSTK**2
	FN = CSQRT(((ERN*ELN-EPN*EPERPN)*SINTK2)**2
     1    + 4.*(EPN*DN*COSTK)**2)
	BN = ERN*ELN*SINTK2 + EPN*EPERPN*(1. + COSTK**2)
	EPSL = EPERP*SINTK2 + EP*COSTK**2
	EN2P = .5*EMAG**2*(BN + FN)/EPSL
	XKP = W*CSQRT(EN2P)
	EN2M = .5*EMAG*(BN - FN)/(EPSL/EMAG)
	XKM = W*CSQRT(EN2M)
	PRINT 700,FHZ,EP,EPERP,ER,EL,EMAG
	PRINT 700,FHZ,EPN,EPERPN,ERN,ELN
	PRINT 700,FHZ,EN2P,XKP,EN2M,XKM
	write(71,700)FHZ,EN2P,EN2M
	write(69,700)FHZ,XKP,XKM
 1	CONTINUE
C     PRINT 100,W,X(1),EPSR,EPS0,EP
  100 FORMAT(' COPLAS' 8E12.4)
  700 FORMAT(' 'F12.4,4(E13.4,E12.4),E12.4)
C      RETURN
	STOP
      END


! =====================================================
subroutine qcor(ixy,i,m,aux,q,maxm,num_eqn,num_ghost,qc)
! =====================================================

    ! Compute the correction term to add to the solution for maintaining
    ! the conservation on sphere.

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

    dimension aux(16, 1-num_ghost:maxm+num_ghost)
    dimension q(num_eqn, 1-num_ghost:maxm+num_ghost)
    dimension qc(4)

    common /comxyt/ dtcom,dxcom,dycom,tcom,icom,jcom
    common /sw/  g

    if(ixy == 1) then
        in = 2
        dy = dycom
    else
        in = 8
        dy = dxcom
    endif

    ! left interface
    etxl = aux(in+3,i)
    etyl = aux(in+4,i)
    etzl = aux(in+5,i)
    gammal = dsqrt(etxl**2.d0 + etyl**2.d0 + etzl**2.d0) / dy
    enxl = aux(in,i) * gammal
    enyl = aux(in+1,i) * gammal
    enzl = aux(in+2,i) * gammal

    ! right interface
    etxr = aux(in+3,i+1)
    etyr = aux(in+4,i+1)
    etzr = aux(in+5,i+1)
    gammar = dsqrt(etxr**2.d0 + etyr**2.d0 + etzr**2.d0) / dy
    enxr = aux(in,i+1) * gammar
    enyr = aux(in+1,i+1) * gammar
    enzr = aux(in+2,i+1)  * gammar

    qc(1) = (enxr-enxl)*q(2,i) + (enyr-enyl)*q(3,i) +(enzr-enzl)*q(4,i)

    qc(2) = (enxr-enxl)*(q(2,i)**2.d0/q(1,i)+0.5d0*g*q(1,i)**2.d0) &
        +(enyr-enyl)*(q(2,i)*q(3,i)/q(1,i)) &
        +(enzr-enzl)*(q(2,i)*q(4,i)/q(1,i))

    qc(3) = (enxr-enxl)*(q(2,i)*q(3,i)/q(1,i)) &
        +(enyr-enyl)*(q(3,i)**2.d0/q(1,i)+0.5d0*g*q(1,i)**2.d0) &
        +(enzr-enzl)*(q(3,i)*q(4,i)/q(1,i))

    qc(4) = (enxr-enxl)*(q(2,i)*q(4,i)/q(1,i)) &
        +(enyr-enyl)*(q(3,i)*q(4,i)/q(1,i)) &
        +(enzr-enzl)*(q(4,i)**2.d0/q(1,i)+0.5d0*g*q(1,i)**2.d0)

    ! project qc to tangent plane:
    erx = aux(14,i)
    ery = aux(15,i)
    erz = aux(16,i)

    qcn = erx*qc(2) + ery*qc(3) + erz*qc(4)

    qc(2) = qc(2) - qcn*erx
    qc(3) = qc(3) - qcn*ery
    qc(4) = qc(4) - qcn*erz

    return
end subroutine qcor


      subroutine frsoil(sscunf,nowcrp)
c
c     +++PURPOSE+++
c
c     The purpose of this program is to estimate saturated hydraulic conductivity
c     when frost exists.
c     We treat ice as air for saturated hydralic conductivity calculation.
c     Then the saturated K with ice would be as if the unsaturated K with
c     liqiud water content = porosity - ice water content
c
c     Author(s):  Shuhui Dun, WSU
c     Date: 02/28/2008
c     Verified by: Joan Wu, WSU
c
c     +++PARAMETERS+++
      include 'pmxtil.inc'
      include 'pmxtls.inc'
      include 'pmxpln.inc'
      include 'pmxhil.inc'
      include 'pmxnsl.inc'
c
c     +++ARGUMENT DECLARATIONS+++
      real  sscunf(mxnsl,mxplan)
      integer nowcrp
c
c     +++ARGUMENT DEFINITIONS+++
c
c     sscunf - unfrozen saturated hydraulic conductivity (SSC)
c
c     +++COMMON BLOCKS+++
c
      include  'cstruc.inc'
c       read:  iplane
      include 'cupdate.inc'
c       read:  sdate
      include  'cwint.inc'
c       read:  snodpt(iplane),tfrdp(mxplan),tthawd(mxplan),frdp(mxplan),
c              thdp(mxplan),densg(mxplan)
c
      include 'cflgfs.inc'
c     fine layer for frost simulation
c
      include 'cpfrst.inc'
c
      include 'csaxp.inc'
c     Saxton and Ralwls model coefficients
c
      include 'cwater.inc'
c     read: dg(i,iplane)

      real getFreezeCond

c
c
c     +++LOCAL VARIABLES+++
c
      integer  frstn,i,j,jend
      real     slks(10,mxnsl,mxplan),kf
      real     varsm,varwtp,varkus,vardp,tmpvr1,tmpvr2
c
c     +++LOCAL DEFINITIONS+++
c
c     frstn - frost existing fine layer number in a soil layer
c     slks -  satuareated hydraulic conductivity of a fine layer m/s.
c
c     varsm  - soil moisture variable
c     varwtp - water potential variable
c     varkus - unsaturated K varible
c
c     tmpvr1 - variable for mathmatic mean
c     tmpvr2 - variable for harmonic mean
c
c     +++DATA INITIALIZATIONS+++
c
c     +++END SPECIFICATIONS+++
c
      Do 10 i = 1, nsl(iplane)
c
      if (i.gt.LNfrst) then
c     deeper than the frost bottom
         ssc(i,iplane) = sscunf(i, iplane)
         sscv(i,iplane) = sscunf(i, iplane)
      else
c     in frost zone
         tmpvr1 = 0.
         tmpvr2 = 0.
         vardp = dg(i,iplane)/nfine(i)
         jend = nfine(i)
c
         do 20 j = 1, jend
c
c             Estimate unsaturated hydraulic conductivity of a soil
c             using Saxton and Rawls, 2006
c
             if( slsic(j,i,iplane) .gt. 0.001) then
c            frost exists
c
c                as if soil water content at
                 varsm = saxpor(i,iplane)
     1                 - slsic(j,i,iplane)/vardp

c                Get the approiate frozen soil conductivity value to use
c                base on the land use - 3/30/2012 - jrf
                 kf = getFreezeCond(nowcrp,iplane)

                 if (varsm .le. 0.01) then
c                frost heave
                      slks(j,i,iplane) = kf*sscunf(i,iplane)
                 else
                      call saxfun(i,varsm,varwtp, varkus)
                      if ((varkus/sscunf(i,iplane)).lt.kf) then
                         slks(j,i,iplane) = kf*sscunf(i,iplane)
                      else
                         slks(j,i,iplane) = varkus
                      endif
                 endif
c
              else
c             no frost
                 slks(j,i,iplane) = sscunf(i,iplane)
              endif
c
              tmpvr1 = tmpvr1 + vardp*slks(j,i,iplane)
              tmpvr2 = tmpvr2 + vardp/slks(j,i,iplane)
20       continue
c
         ssc(i,iplane) = tmpvr1/dg(i,iplane)
         sscv(i,iplane) = dg(i,iplane)/tmpvr2
c
      endif
10    continue
c
      return
      end


subroutine CalcIndVel(NT,ntTerm,NBE,NB,NE,Px,Py,Pz,Vx,Vy,Vz)

    use wallsoln
    use blade

    ! Calculate wall and wake induced velocity (including bound vorticity component)

    real :: Px, Py, Pz, Vx, Vy, Vz, dUdX
    integer :: nt, ntTerm, nbe, nb, ne

    real :: Point(3), dVel(3), Vel(3)

    ! Calc wake induced velocity at wake locations
    CALL BladeIndVel(NT,ntTerm,NBE,NB,NE,Px,Py,Pz,Vx,Vy,Vz,dUdX,0,0)

    ! Calculate wall induced velocities at wake locations
    Point=[Px,Py,Pz]
    Call WallIndVel(Point,dVel)
    Vx=Vx+dVel(1)
    Vy=Vy+dVel(2)
    Vz=Vz+dVel(3)

    return
end subroutine CalcIndVel