module nodal_stencil_module

  use bl_types
  use multifab_module
  use bc_functions_module
  use impose_neumann_bcs_module
  use stencil_types_module

  implicit none

  real (kind = dp_t), private, parameter :: ZERO  = 0.0_dp_t
  real (kind = dp_t), private, parameter :: ONE   = 1.0_dp_t
  real (kind = dp_t), private, parameter :: TWO   = 2.0_dp_t
  real (kind = dp_t), private, parameter :: THREE = 3.0_dp_t
  real (kind = dp_t), private, parameter :: FOUR  = 4.0_dp_t
  real (kind = dp_t), private, parameter :: FIVE  = 5.0_dp_t
  real (kind = dp_t), private, parameter :: SIX   = 6.0_dp_t
  real (kind = dp_t), private, parameter :: SEVEN = 7.0_dp_t
  real (kind = dp_t), private, parameter :: EIGHT = 8.0_dp_t
  real (kind = dp_t), private, parameter :: TEN   = 10.0_dp_t
  real (kind = dp_t), private, parameter :: HALF  = 0.5_dp_t
  real (kind = dp_t), private, parameter :: FOURTH= 0.25_dp_t
  real (kind = dp_t), private, parameter :: THIRD = 1.0_dp_t/3.0_dp_t
  real (kind = dp_t), private, parameter :: SIXTH = 1.0_dp_t/6.0_dp_t
  real (kind = dp_t), private, parameter :: FOUR_THIRD = 4.0_dp_t/3.0_dp_t

  private :: set_faces_edges_corners_2d,set_faces_edges_corners_3d

contains

  subroutine stencil_set_bc_nodal(sdim, bx, nbx, idx, mask, face_type, pd_periodic, la_periodic)
    integer,         intent(in   ) :: sdim
    type(box),       intent(in   ) :: bx, nbx
    type(imultifab), intent(inout) :: mask
    integer,         intent(in   ) :: idx
    integer,         intent(in   ) :: face_type(:,:,:)
    type(box),       intent(in   ) :: pd_periodic
    type(layout),    intent(inout) :: la_periodic

    integer, pointer :: mp(:,:,:,:)
    type(box)        :: bx1
    type(boxarray)   :: ba
    integer          :: ii, dm, ib, jb, kb, jb_lo, kb_lo
    logical          :: nodal(sdim)

    nodal = .true.
    !
    ! Set the mask to BC_DIR or BC_NEU based on face_type at a physical boundary.
    !
    do dm = 1, sdim
       !
       ! Lo side
       !
       bx1 = nbx
       bx1%hi(dm) = bx1%lo(dm)
       mp => dataptr(mask, idx, bx1)
       if (face_type(idx,dm,1) == BC_NEU) then
          mp = ibset(mp, BC_BIT(BC_NEU, dm, -1))
       else if (face_type(idx,dm,1) == BC_DIR) then
          mp = ibset(mp, BC_BIT(BC_DIR, 1, 0))
       end if
       !
       ! Hi side
       !
       bx1 = nbx
       bx1%lo(dm) = bx1%hi(dm)
       mp => dataptr(mask, idx, bx1)
       if (face_type(idx,dm,2) == BC_NEU) then
          mp = ibset(mp, BC_BIT(BC_NEU, dm, +1))
       else if (face_type(idx,dm,2) == BC_DIR) then
          mp = ibset(mp, BC_BIT(BC_DIR, 1, 0))
       end if
    end do
    !
    ! Set the mask to BC_DIR at coarse-fine boundaries.
    !
    jb_lo = -1; if (sdim .lt. 2) jb_lo = 1
    kb_lo = -1; if (sdim .lt. 3) kb_lo = 1

    do kb = kb_lo, 1
       do jb = jb_lo, 1
          do ib = -1, 1
             bx1 = shift(bx,ib,1)
             if (sdim > 1) bx1 = shift(bx1,jb,2)
             if (sdim > 2) bx1 = shift(bx1,kb,3)
             bx1 = intersection(bx1, pd_periodic)
             if ( empty(bx1) ) cycle
             call layout_boxarray_diff(ba, bx1, la_periodic)
             do ii = 1, nboxes(ba)
                bx1 = intersection(box_nodalize(get_box(ba,ii),nodal), nbx)
                if ( empty(bx1) ) cycle
                mp => dataptr(mask, idx, bx1)
                mp = ibset(mp, BC_BIT(BC_DIR,1,0))
             end do
             call destroy(ba)
          end do
       end do
    end do

  end subroutine stencil_set_bc_nodal

  subroutine s_simple_1d_nodal(ss, sg, mm, dh)
    real (kind = dp_t), intent(inout) :: ss(0:,:)
    real (kind = dp_t), intent(inout) :: sg(0:)
    integer           , intent(in   ) :: mm(:)
    real (kind = dp_t), intent(in   ) :: dh(:)

    integer            :: i,nx
    real (kind = dp_t) :: f1

    f1 = ONE/dh(1)**2

    nx = size(ss,dim=2)

    if (bc_neumann(mm( 1),1,-1)) sg( 0) = sg(   1)
    if (bc_neumann(mm(nx),1,+1)) sg(nx) = sg(nx-1)

    do i = 1,nx
       ss(1,i) = sg(i  )*f1
       ss(2,i) = sg(i-1)*f1
       ss(0,i) = -(sg(i)+sg(i-1))*f1
    end do

  end subroutine s_simple_1d_nodal

  subroutine s_cross_2d_nodal(ss, sg, mm, face_type, dh)
    real (kind = dp_t), intent(inout) :: ss(0:,:,:)
    real (kind = dp_t), intent(inout) :: sg(0:,0:)
    integer           , intent(in   ) :: mm(:,:)
    integer           , intent(in   ) :: face_type(:,:)
    real (kind = dp_t), intent(in   ) :: dh(:)

    integer            :: i, j, nx, ny
    real (kind = dp_t) :: fac

    nx = size(ss,dim=2)
    ny = size(ss,dim=3)

    call set_faces_edges_corners_2d(nx, ny, sg, mm, face_type)

    fac = (HALF / (dh(1))**2)

    do j = 1,ny
      do i = 1,nx
          ss(1,i,j) = fac*(sg(i  ,j-1) + sg(i  ,j  ))
          ss(2,i,j) = fac*(sg(i-1,j-1) + sg(i-1,j  ))
          ss(3,i,j) = fac*(sg(i-1,j  ) + sg(i  ,j  ))
          ss(4,i,j) = fac*(sg(i-1,j-1) + sg(i  ,j-1))
          ss(0,i,j) = -(ss(1,i,j) + ss(2,i,j) + ss(3,i,j) + ss(4,i,j))
      end do
    end do

  end subroutine s_cross_2d_nodal

  subroutine s_simple_2d_one_sided(ss, sg, mm, face_type, dh)
    real (kind = dp_t), intent(inout) :: ss(0:,:,:)
    real (kind = dp_t), intent(inout) :: sg(0:,0:)
    integer           , intent(in   ) :: mm(:,:)
    integer           , intent(in   ) :: face_type(:,:)
    real (kind = dp_t), intent(in   ) :: dh(:)

    integer            :: i, j, nx, ny
    real (kind = dp_t) :: fac
    real (kind = dp_t) :: sg_int(0:size(sg,dim=1)-1,0:size(sg,dim=2)-1)

    nx = size(ss,dim=2)
    ny = size(ss,dim=3)

    sg_int = ZERO

    do j = 1, ny-1
      do i = 1, nx-1
         sg_int(i,j) = sg(i,j)
      end do
    end do

    call set_faces_edges_corners_2d(nx, ny, sg_int, mm, face_type)

    fac = (HALF / (dh(1))**2)

    do j = 1,ny
      do i = 1,nx
          ss(1,i,j) = fac*(sg_int(i  ,j-1) + sg_int(i  ,j  ))
          ss(2,i,j) = fac*(sg_int(i-1,j-1) + sg_int(i-1,j  ))
          ss(3,i,j) = fac*(sg_int(i-1,j  ) + sg_int(i  ,j  ))
          ss(4,i,j) = fac*(sg_int(i-1,j-1) + sg_int(i  ,j-1))
          ss(0,i,j) = -(ss(1,i,j) + ss(2,i,j) + ss(3,i,j) + ss(4,i,j))
      end do
    end do

  end subroutine s_simple_2d_one_sided

  subroutine s_dense_2d_nodal(ss, sg, ng_s, mm, face_type, dh, lo, hi)

    integer           , intent(in   ) :: lo(:),hi(:),ng_s
    real (kind = dp_t), intent(inout) :: ss(0:,lo(1):,lo(2):)
    real (kind = dp_t), intent(inout) :: sg(lo(1)-ng_s:,lo(2)-ng_s:,:)
    integer           , intent(in   ) :: mm(lo(1):,lo(2):)
    integer           , intent(in   ) :: face_type(:,:)
    real (kind = dp_t), intent(in   ) :: dh(:)

    integer            :: i, j
    real (kind = dp_t) :: fac

    ! Set sg on edges at a Neumann boundary.
    do i = lo(1),hi(1)
       if (bc_neumann(mm(i,lo(2)  ),2,-1)) sg(i,lo(2)-1,:) = sg(i,lo(2),:)
       if (bc_neumann(mm(i,hi(2)+1),2,+1)) sg(i,hi(2)+1,:) = sg(i,hi(2),:)
    end do

    do j = lo(2),hi(2)
       if (bc_neumann(mm(lo(1)  ,j),1,-1)) sg(lo(1)-1,j,:) = sg(lo(1),j,:)
       if (bc_neumann(mm(hi(1)+1,j),1,+1)) sg(hi(1)+1,j,:) = sg(hi(1),j,:)
    end do

    ! Note: we do the corners *after* each of the edge has been done.
    ! Lo i
    if (face_type(1,1) == BC_NEU) then
       sg(lo(1)-1,lo(2)-1,:) = sg(lo(1),lo(2)-1,:)
       sg(lo(1)-1,hi(2)+1,:) = sg(lo(1),hi(2)+1,:)
    end if

    ! Hi i
    if (face_type(1,2) == BC_NEU) then
       sg(hi(1)+1,lo(2)-1,:) = sg(hi(1),lo(2)-1,:)
       sg(hi(1)+1,hi(2)+1,:) = sg(hi(1),hi(2)+1,:)
    end if

    ! Lo j
    if (face_type(2,1) == BC_NEU) then
       sg(lo(1)-1,lo(2)-1,:) = sg(lo(1)-1,lo(2),:)
       sg(hi(1)+1,lo(2)-1,:) = sg(hi(1)+1,lo(2),:)
    end if

    ! Hi j
    if (face_type(2,2) == BC_NEU) then
       sg(lo(1)-1,hi(2)+1,:) = sg(lo(1)-1,hi(2),:)
       sg(hi(1)+1,hi(2)+1,:) = sg(hi(1)+1,hi(2),:)
    end if

    fac = (THIRD / (dh(1))**2)

    do j = lo(2),hi(2)+1
      do i = lo(1),hi(1)+1

          ! Faces
          ss(2,i,j) = fac*(HALF * (sg(i  ,j-1,1) + sg(i-1,j-1,1)))
          ss(4,i,j) = fac*(HALF * (sg(i-1,j  ,1) + sg(i-1,j-1,1)))
          ss(5,i,j) = fac*(HALF * (sg(i  ,j  ,1) + sg(i  ,j-1,1)))
          ss(7,i,j) = fac*(HALF * (sg(i  ,j  ,1) + sg(i-1,j  ,1)))

          ! Corners
          ss(1,i,j) = fac*sg(i-1,j-1,1)
          ss(3,i,j) = fac*sg(i  ,j-1,1)
          ss(6,i,j) = fac*sg(i-1,j  ,1)
          ss(8,i,j) = fac*sg(i,  j  ,1)

          ss(0,i,j) = -(ss(1,i,j) + ss(2,i,j) + ss(3,i,j) + ss(4,i,j) &
                      + ss(5,i,j) + ss(6,i,j) + ss(7,i,j) + ss(8,i,j) )
      end do
    end do

  end subroutine s_dense_2d_nodal

  subroutine set_faces_edges_corners_2d(nx, ny, sg, mm, face_type)
    integer           , intent(in   ) :: nx, ny
    real (kind = dp_t), intent(inout) :: sg(0:,0:)
    integer           , intent(in   ) :: mm(:,:)
    integer           , intent(in   ) :: face_type(:,:)

    integer :: i, j
    !
    ! Set sg on edges at a Neumann boundary.
    !
    do i = 1,nx-1
       if (bc_neumann(mm(i, 1),2,-1)) sg(i, 0) = sg(i,1)
       if (bc_neumann(mm(i,ny),2,+1)) sg(i,ny) = sg(i,ny-1)
    end do

    do j = 1,ny-1
       if (bc_neumann(mm( 1,j),1,-1)) sg( 0,j) = sg(   1,j)
       if (bc_neumann(mm(nx,j),1,+1)) sg(nx,j) = sg(nx-1,j)
    end do
    !
    ! Note: we do the corners *after* each of the edges has been done.
    !
    if (face_type(1,1) == BC_NEU) then
       sg(0, 0) = sg(1, 0)
       sg(0,ny) = sg(1,ny)
    end if
    if (face_type(1,2) == BC_NEU) then
       sg(nx, 0) = sg(nx-1,0)
       sg(nx,ny) = sg(nx-1,ny)
    end if
    if (face_type(2,1) == BC_NEU) then
       sg( 0,0) = sg( 0,1)
       sg(nx,0) = sg(nx,1)
    end if
    if (face_type(2,2) == BC_NEU) then
       sg( 0,ny) = sg( 0,ny-1)
       sg(nx,ny) = sg(nx,ny-1)
    end if

  end subroutine set_faces_edges_corners_2d

  subroutine set_faces_edges_corners_3d(nx, ny, nz, sg, mm)
    integer           , intent(in   ) :: nx, ny, nz
    real (kind = dp_t), intent(inout) :: sg(0:,0:,0:)
    integer           , intent(in   ) :: mm(:,:,:)

    integer :: i, j, k
    !
    ! Set sg on faces at a Neumann boundary.
    !
    do j = 1,ny-1
       do i = 1,nx-1
          if (bc_neumann(mm(i,j, 1),3,-1)) sg(i,j, 0) = sg(i,j,1)
          if (bc_neumann(mm(i,j,nz),3,+1)) sg(i,j,nz) = sg(i,j,nz-1)
       end do
    end do

    do k = 1,nz-1
       do i = 1,nx-1
          if (bc_neumann(mm(i, 1,k),2,-1)) sg(i, 0,k) = sg(i,1,k)
          if (bc_neumann(mm(i,ny,k),2,+1)) sg(i,ny,k) = sg(i,ny-1,k)
       end do
    end do

    do k = 1,nz-1
       do j = 1,ny-1
          if (bc_neumann(mm( 1,j,k),1,-1)) sg( 0,j,k) = sg(   1,j,k)
          if (bc_neumann(mm(nx,j,k),1,+1)) sg(nx,j,k) = sg(nx-1,j,k)
       end do
    end do
    !
    ! Set sg on edges at a Neumann boundary.
    !
    do i = 1,nx-1
       if (bc_neumann(mm(i, 1, 1),2,-1)) sg(i, 0, 0) = sg(i,1, 0)
       if (bc_neumann(mm(i, 1,nz),2,-1)) sg(i, 0,nz) = sg(i,1,nz)

       if (bc_neumann(mm(i,ny, 1),2,+1)) sg(i,ny, 0) = sg(i,ny-1, 0)
       if (bc_neumann(mm(i,ny,nz),2,+1)) sg(i,ny,nz) = sg(i,ny-1,nz)

       if (bc_neumann(mm(i, 1, 1),3,-1)) sg(i, 0, 0) = sg(i, 0,1)
       if (bc_neumann(mm(i,ny, 1),3,-1)) sg(i,ny, 0) = sg(i,ny,1)

       if (bc_neumann(mm(i, 1,nz),3,+1)) sg(i, 0,nz) = sg(i, 0,nz-1)
       if (bc_neumann(mm(i,ny,nz),3,+1)) sg(i,ny,nz) = sg(i,ny,nz-1)
    end do

    do j = 1,ny-1
       if (bc_neumann(mm( 1,j, 1),1,-1)) sg( 0,j, 0) = sg(1,j, 0)
       if (bc_neumann(mm( 1,j,nz),1,-1)) sg( 0,j,nz) = sg(1,j,nz)

       if (bc_neumann(mm(nx,j, 1),1,+1)) sg(nx,j, 0) = sg(nx-1,j, 0)
       if (bc_neumann(mm(nx,j,nz),1,+1)) sg(nx,j,nz) = sg(nx-1,j,nz)

       if (bc_neumann(mm( 1,j, 1),3,-1)) sg( 0,j, 0) = sg( 0,j,1)
       if (bc_neumann(mm(nx,j, 1),3,-1)) sg(nx,j, 0) = sg(nx,j,1)

       if (bc_neumann(mm( 1,j,nz),3,+1)) sg( 0,j,nz) = sg( 0,j,nz-1)
       if (bc_neumann(mm(nx,j,nz),3,+1)) sg(nx,j,nz) = sg(nx,j,nz-1)
    end do

    do k = 1,nz-1
       if (bc_neumann(mm( 1, 1,k),1,-1)) sg( 0, 0,k) = sg(1, 0,k)
       if (bc_neumann(mm( 1,ny,k),1,-1)) sg( 0,ny,k) = sg(1,ny,k)

       if (bc_neumann(mm(nx, 1,k),1,+1)) sg(nx, 0,k) = sg(nx-1, 0,k)
       if (bc_neumann(mm(nx,ny,k),1,+1)) sg(nx,ny,k) = sg(nx-1,ny,k)

       if (bc_neumann(mm( 1, 1,k),2,-1)) sg( 0, 0,k) = sg( 0,1,k)
       if (bc_neumann(mm(nx, 1,k),2,-1)) sg(nx, 0,k) = sg(nx,1,k)

       if (bc_neumann(mm( 1,ny,k),2,+1)) sg( 0,ny,k) = sg( 0,ny-1,k)
       if (bc_neumann(mm(nx,ny,k),2,+1)) sg(nx,ny,k) = sg(nx,ny-1,k)
    end do

    if (bc_neumann(mm( 1, 1, 1),1,-1)) sg( 0, 0, 0) = sg( 1, 0, 0)
    if (bc_neumann(mm( 1, 1, 1),2,-1)) sg( 0, 0, 0) = sg( 0, 1, 0)
    if (bc_neumann(mm( 1, 1, 1),3,-1)) sg( 0, 0, 0) = sg( 0, 0, 1)

    if (bc_neumann(mm(nx, 1, 1),1,+1)) sg(nx, 0, 0) = sg(nx-1, 0, 0)
    if (bc_neumann(mm(nx, 1, 1),2,-1)) sg(nx, 0, 0) = sg(nx  , 1, 0)
    if (bc_neumann(mm(nx, 1, 1),3,-1)) sg(nx, 0, 0) = sg(nx  , 0, 1)

    if (bc_neumann(mm( 1,ny, 1),1,-1)) sg( 0,ny, 0) = sg( 1,ny  , 0)
    if (bc_neumann(mm( 1,ny, 1),2,+1)) sg( 0,ny, 0) = sg( 0,ny-1, 0)
    if (bc_neumann(mm( 1,ny, 1),3,-1)) sg( 0,ny, 0) = sg( 0,ny  , 1)

    if (bc_neumann(mm( 1, 1,nz),1,-1)) sg( 0, 0,nz) = sg( 1, 0,nz  )
    if (bc_neumann(mm( 1, 1,nz),2,-1)) sg( 0, 0,nz) = sg( 0, 1,nz  )
    if (bc_neumann(mm( 1, 1,nz),3,+1)) sg( 0, 0,nz) = sg( 0, 0,nz-1)

    if (bc_neumann(mm(nx,ny, 1),1,+1)) sg(nx,ny, 0) = sg(nx-1,ny  , 0)
    if (bc_neumann(mm(nx,ny, 1),2,+1)) sg(nx,ny, 0) = sg(nx  ,ny-1, 0)
    if (bc_neumann(mm(nx,ny, 1),3,-1)) sg(nx,ny, 0) = sg(nx  ,ny  , 1)

    if (bc_neumann(mm(nx, 1,nz),1,+1)) sg(nx, 0,nz) = sg(nx-1, 0,nz  )
    if (bc_neumann(mm(nx, 1,nz),2,-1)) sg(nx, 0,nz) = sg(nx  , 1,nz  )
    if (bc_neumann(mm(nx, 1,nz),3,+1)) sg(nx, 0,nz) = sg(nx  , 0,nz-1)

    if (bc_neumann(mm( 1,ny,nz),1,-1)) sg( 0,ny,nz) = sg( 1,ny  ,nz  )
    if (bc_neumann(mm( 1,ny,nz),2,+1)) sg( 0,ny,nz) = sg( 0,ny-1,nz  )
    if (bc_neumann(mm( 1,ny,nz),3,+1)) sg( 0,ny,nz) = sg( 0,ny  ,nz-1)

    if (bc_neumann(mm(nx,ny,nz),1,+1)) sg(nx,ny,nz) = sg(nx-1,ny  ,nz  )
    if (bc_neumann(mm(nx,ny,nz),2,+1)) sg(nx,ny,nz) = sg(nx  ,ny-1,nz  )
    if (bc_neumann(mm(nx,ny,nz),3,+1)) sg(nx,ny,nz) = sg(nx  ,ny  ,nz-1)

  end subroutine set_faces_edges_corners_3d

  subroutine s_cross_3d_nodal(ss, sg, mm, dh)
    real (kind = dp_t), intent(inout) :: ss(0:,:,:,:)
    real (kind = dp_t), intent(inout) :: sg(0:,0:,0:)
    integer           , intent(inout) :: mm(:,:,:)
    real (kind = dp_t), intent(in   ) :: dh(:)

    integer            :: i, j, k, nx, ny, nz
    real (kind = dp_t) :: fac

    nx = size(ss,dim=2)
    ny = size(ss,dim=3)
    nz = size(ss,dim=4)
    !
    !   BEGIN STENCIL
    !
    !   Stencil applies as follows :  (i is left to right, j is down to up)
    !
    !        at k-1        at k         at k+1
    !
    !                        3
    !          6          2  0  1          5
    !                        4
    !
    !   END STENCIL
    !
    call set_faces_edges_corners_3d(nx, ny, nz, sg, mm)

    fac = (FOURTH / (dh(1))**2)

    !$OMP PARALLEL DO PRIVATE(i,j,k) IF(nz.ge.4)
    do k = 1, nz
       do j = 1, ny
          do i = 1, nx
             !
             ! Faces in x-direction
             !
             ss(2,i,j,k) = fac*((sg(i-1,j-1,k-1) + sg(i-1,j-1,k  ) &
                                +sg(i-1,j  ,k-1) + sg(i-1,j  ,k  )))
             ss(1,i,j,k) = fac*((sg(i  ,j-1,k-1) + sg(i  ,j-1,k  ) &
                                +sg(i  ,j  ,k-1) + sg(i  ,j  ,k  )))
             !
             ! Faces in y-direction
             !
             ss(4,i,j,k) = fac*((sg(i-1,j-1,k-1) + sg(i-1,j-1,k  ) &
                                +sg(i  ,j-1,k-1) + sg(i  ,j-1,k  )))
             ss(3,i,j,k) = fac*((sg(i-1,j  ,k-1) + sg(i-1,j  ,k  ) &
                                +sg(i  ,j  ,k-1) + sg(i  ,j  ,k  )))
             !
             ! Faces in z-direction
             !
             ss(6,i,j,k) = fac*((sg(i-1,j-1,k-1) + sg(i-1,j  ,k-1) &
                                +sg(i  ,j-1,k-1) + sg(i  ,j  ,k-1)))
             ss(5,i,j,k) = fac*((sg(i-1,j-1,k  ) + sg(i-1,j  ,k  ) &
                                +sg(i  ,j-1,k  ) + sg(i  ,j  ,k  )))

             ss(0,i,j,k) = -( ss(1,i,j,k) + ss(2,i,j,k) &
                  +ss(3,i,j,k) + ss(4,i,j,k) &
                  +ss(5,i,j,k) + ss(6,i,j,k) )
          end do
       end do
    end do
    !$OMP END PARALLEL DO

  end subroutine s_cross_3d_nodal

  subroutine s_simple_3d_one_sided(ss, sg, mm, dh)

    real (kind = dp_t), intent(inout) :: ss(0:,:,:,:)
    real (kind = dp_t), intent(inout) :: sg(0:,0:,0:)
    integer           , intent(inout) :: mm(:,:,:)
    real (kind = dp_t), intent(in   ) :: dh(:)

    integer :: i, j, k, nx, ny, nz
    real (kind = dp_t) :: fac
    real (kind = dp_t), allocatable :: sg_int(:,:,:)

    nx = size(ss,dim=2)
    ny = size(ss,dim=3)
    nz = size(ss,dim=4)
    !
    !   BEGIN STENCIL
    !
    !   Stencil applies as follows :  (i is left to right, j is down to up)
    !
    !        at k-1        at k         at k+1
    !
    !                        3
    !          6          2  0  1          5
    !                        4
    !
    !   END STENCIL
    !
    allocate(sg_int(0:size(sg,dim=1)-1,0:size(sg,dim=2)-1,0:size(sg,dim=3)-1))

    sg_int = ZERO

    do k = 1, nz-1
       do j = 1, ny-1
          do i = 1, nx-1
             sg_int(i,j,k) = sg(i,j,k)
          end do
       end do
    end do

    call set_faces_edges_corners_3d(nx, ny, nz, sg_int, mm)

    fac = (FOURTH / (dh(1))**2)

    !$OMP PARALLEL DO PRIVATE(i,j,k) IF(nz.ge.4)
    do k = 1, nz
       do j = 1, ny
          do i = 1, nx
             !
             ! Faces in x-direction
             !
             ss(2,i,j,k) = fac*((sg_int(i-1,j-1,k-1) + sg_int(i-1,j-1,k  ) &
                  +sg_int(i-1,j  ,k-1) + sg_int(i-1,j  ,k  )))
             ss(1,i,j,k) = fac*((sg_int(i  ,j-1,k-1) + sg_int(i  ,j-1,k  ) &
                  +sg_int(i  ,j  ,k-1) + sg_int(i  ,j  ,k  )))
             !
             ! Faces in y-direction
             !
             ss(4,i,j,k) = fac*((sg_int(i-1,j-1,k-1) + sg_int(i-1,j-1,k  ) &
                  +sg_int(i  ,j-1,k-1) + sg_int(i  ,j-1,k  )))
             ss(3,i,j,k) = fac*((sg_int(i-1,j  ,k-1) + sg_int(i-1,j  ,k  ) &
                  +sg_int(i  ,j  ,k-1) + sg_int(i  ,j  ,k  )))
             !
             ! Faces in z-direction
             !
             ss(6,i,j,k) = fac*((sg_int(i-1,j-1,k-1) + sg_int(i-1,j  ,k-1) &
                  +sg_int(i  ,j-1,k-1) + sg_int(i  ,j  ,k-1)))
             ss(5,i,j,k) = fac*((sg_int(i-1,j-1,k  ) + sg_int(i-1,j  ,k  ) &
                  +sg_int(i  ,j-1,k  ) + sg_int(i  ,j  ,k  )))

             ss(0,i,j,k) = -( ss(1,i,j,k) + ss(2,i,j,k) &
                  +ss(3,i,j,k) + ss(4,i,j,k) &
                  +ss(5,i,j,k) + ss(6,i,j,k) )
          end do
       end do
    end do
    !$OMP END PARALLEL DO

    deallocate(sg_int)

  end subroutine s_simple_3d_one_sided

  subroutine s_dense_3d_nodal(ss, sg, mm, dh)
    real (kind = dp_t), intent(inout) :: ss(0:,:,:,:)
    real (kind = dp_t), intent(inout) :: sg(0:,0:,0:)
    integer           , intent(inout) :: mm(:,:,:)
    real (kind = dp_t), intent(in   ) :: dh(:)

    integer            :: i, j, k, nx, ny, nz
    real (kind = dp_t) :: fx,fy,fz,f0,fac,fxyz,f2y2zx,f2x2zy,f2x2yz

    real (kind = dp_t), parameter :: ONETHIRTYSIXTH = ONE / (36.0_dp_t)

    nx = size(ss,dim=2)
    ny = size(ss,dim=3)
    nz = size(ss,dim=4)
    !
    !   BEGIN STENCIL
    !
    !   Stencil applies as follows :  (i is left to right, j is down to up)
    !
    !        at k-1        at k         at k+1
    !
    !       6  7  8      11 24  12     18 19 20
    !       4 25  5      21  0  22     16 26 17
    !       1  2  3       9 23  10     13 14 15
    !
    !   END STENCIL
    !
    call set_faces_edges_corners_3d(nx, ny, nz, sg, mm)

    fx     = ONETHIRTYSIXTH
    fy     = ONETHIRTYSIXTH
    fz     = ONETHIRTYSIXTH
    f0     = FOUR * (fx + fy + fz)
    fac    = (ONE / ((dh(1))**2))
    fxyz   = (fx+fy+fz)
    f2y2zx = (TWO*fy+TWO*fz-fx)
    f2x2zy = (TWO*fx+TWO*fz-fy)
    f2x2yz = (TWO*fx+TWO*fy-fz)

    !$OMP PARALLEL DO PRIVATE(i,j,k)
    do k = 1, nz
       do j = 1, ny
          do i = 1, nx
             !
             ! Corners
             !
             ss( 1,i,j,k) = fac*fxyz*sg(i-1,j-1,k-1)
             ss( 3,i,j,k) = fac*fxyz*sg(i  ,j-1,k-1)
             ss( 6,i,j,k) = fac*fxyz*sg(i-1,j  ,k-1)
             ss( 8,i,j,k) = fac*fxyz*sg(i  ,j  ,k-1)
             ss(13,i,j,k) = fac*fxyz*sg(i-1,j-1,k  )
             ss(15,i,j,k) = fac*fxyz*sg(i  ,j-1,k  )
             ss(18,i,j,k) = fac*fxyz*sg(i-1,j  ,k  )
             ss(20,i,j,k) = fac*fxyz*sg(i  ,j  ,k  )
             !
             ! Edges in x-direction
             !
             ss( 2,i,j,k) = fac*(f2y2zx*(sg(i  ,j-1,k-1) + sg(i-1,j-1,k-1)))
             ss( 7,i,j,k) = fac*(f2y2zx*(sg(i  ,j  ,k-1) + sg(i-1,j  ,k-1)))
             ss(14,i,j,k) = fac*(f2y2zx*(sg(i  ,j-1,k  ) + sg(i-1,j-1,k  )))
             ss(19,i,j,k) = fac*(f2y2zx*(sg(i  ,j  ,k  ) + sg(i-1,j  ,k  )))
             !
             ! Edges in y-direction
             !
             ss( 4,i,j,k) = fac*(f2x2zy*(sg(i-1,j-1,k-1) + sg(i-1,j  ,k-1)))
             ss( 5,i,j,k) = fac*(f2x2zy*(sg(i  ,j-1,k-1) + sg(i  ,j  ,k-1)))
             ss(16,i,j,k) = fac*(f2x2zy*(sg(i-1,j-1,k  ) + sg(i-1,j  ,k  )))
             ss(17,i,j,k) = fac*(f2x2zy*(sg(i  ,j-1,k  ) + sg(i  ,j  ,k  )))
             !
             ! Edges in z-direction
             !
             ss( 9,i,j,k) = fac*(f2x2yz*(sg(i-1,j-1,k-1) + sg(i-1,j-1,k  )))
             ss(10,i,j,k) = fac*(f2x2yz*(sg(i  ,j-1,k-1) + sg(i  ,j-1,k  )))
             ss(11,i,j,k) = fac*(f2x2yz*(sg(i-1,j  ,k-1) + sg(i-1,j  ,k  )))
             ss(12,i,j,k) = fac*(f2x2yz*(sg(i  ,j  ,k-1) + sg(i  ,j  ,k  )))

             if (size(ss,dim=1) .eq. 27) then
                !
                ! Faces in x-direction (only non-zero for non-uniform dx)
                !
                ss(21,i,j,k) = fac*((FOUR*fx-TWO*fy-TWO*fz)*(sg(i-1,j-1,k-1) + sg(i-1,j-1,k  ) &
                     +sg(i-1,j  ,k-1) + sg(i-1,j  ,k  )))
                ss(22,i,j,k) = fac*((FOUR*fx-TWO*fy-TWO*fz)*(sg(i  ,j-1,k-1) + sg(i  ,j-1,k  ) &
                     +sg(i  ,j  ,k-1) + sg(i  ,j  ,k  )))
                !
                ! Faces in y-direction (only non-zero for non-uniform dx)
                !
                ss(23,i,j,k) = fac*((FOUR*fy-TWO*fx-TWO*fz)*(sg(i-1,j-1,k-1) + sg(i-1,j-1,k  ) &
                     +sg(i  ,j-1,k-1) + sg(i  ,j-1,k  )))
                ss(24,i,j,k) = fac*((FOUR*fy-TWO*fx-TWO*fz)*(sg(i-1,j  ,k-1) + sg(i-1,j  ,k  ) &
                     +sg(i  ,j  ,k-1) + sg(i  ,j  ,k  )))
                !
                ! Faces in z-direction (only non-zero for non-uniform dx)
                !
                ss(25,i,j,k) = fac*((FOUR*fz-TWO*fx-TWO*fy)*(sg(i-1,j-1,k-1) + sg(i-1,j  ,k-1) &
                     +sg(i  ,j-1,k-1) + sg(i  ,j  ,k-1)))
                ss(26,i,j,k) = fac*((FOUR*fz-TWO*fx-TWO*fy)*(sg(i-1,j-1,k  ) + sg(i-1,j  ,k  ) &
                     +sg(i  ,j-1,k  ) + sg(i  ,j  ,k  )))
             end if

             ss(0,i,j,k) = -fac*f0*( sg(i-1,j-1,k-1) + sg(i,j-1,k-1) &
                                    +sg(i-1,j  ,k-1) + sg(i,j  ,k-1) &
                                    +sg(i-1,j-1,k  ) + sg(i,j-1,k  ) &
                                    +sg(i-1,j  ,k  ) + sg(i,j  ,k  ) )

          end do
       end do
    end do
    !$OMP END PARALLEL DO

  end subroutine s_dense_3d_nodal

end module nodal_stencil_module


c  Part of R package KernSmooth
c  Copyright (C) 1995  M. P. Wand
c
c  Unlimited use and distribution (see LICENCE).

cccccccccc FORTRAN subroutine linbin.f cccccccccc

c Obtains bin counts for univariate data
c via the linear binning strategy. If "trun=0" then
c weight from end observations is given to corresponding
c end grid points. If "trun=1" then end observations
c are truncated.

c Last changed: 20 MAR 2009

      subroutine linbin(X,n,a,b,M,trun,gcnts)
      double precision X(*),a,b,gcnts(*),lxi,delta,rem
      integer n,M,i,li,trun

c     Initialize grid counts to zero

      do 10 i=1,M
         gcnts(i) = dble(0)
10    continue

      delta = (b-a)/(M-1)
      do 20 i=1,n
         lxi = ((X(i)-a)/delta) + 1

c        Find integer part of "lxi"

         li = int(lxi)

         rem = lxi - li
         if (li.ge.1.and.li.lt.M) then
            gcnts(li) = gcnts(li) + (1-rem)
            gcnts(li+1) = gcnts(li+1) + rem
         endif

         if (li.lt.1.and.trun.eq.0) then
            gcnts(1) = gcnts(1) + 1
         endif

         if (li.ge.M.and.trun.eq.0) then
            gcnts(M) = gcnts(M) + 1
         endif

20    continue

      return
      end

cccccccccc End of linbin.f cccccccccc


      SUBROUTINE SAMPL(A,NA,B,NB,Q,NQ,R,NR,W,NW,T,IOP,DUMMY)
C
C   REFERENCES:
C      Kwakernaak, Huibert; and Sivan, Raphael: Linear Optimal Control
C        Systems. John Wiley & Sons, Inc., c. 1972.
C      Dorato, Peter; and Levis, Alexander H.: Optimal Linear Regula-
C        tors:  The Discrete-Time Case. IEEE Trans. Autom. Control,
C        vol. AC-16, no. 6, Dec. 1971, pp. 613-620.
C      Levis, Alexander H.; Schlueter, Robert A.; and Athans, Michael:
C        On the Behaviour of Optimal Linear Sampled-Data Regulators.
C        Int. J. Control, vol. 13, no. 2, Feb. 1971, pp. 343-361.
C      Armstrong, Ernest S.; and Caglayan, Alper K.: An Algorithm for
C        the Weighting Matrices in the Sampled-Data Optimal Linear
C        Regulator Problem. NASA TN D-8372, 1976.
C
C   Subroutines employed by SAMPL: ADD, EQUATE, EXPINT, EXPSER, LNCNT,
C      MAXEL, MULT, NORMS, PRNT, SCALE, TRANP
C   Subroutines employing SAMPL: None
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1),B(1),Q(1),R(1),W(1),DUMMY(1)
      DIMENSION NA(2),NB(2),NQ(2),NR(2),NW(2),IOP(2),NDUM(2)
      COMMON/CONV/SUMCV,MAXSUM,RICTCV,SERCV
C
      IF(  IOP(1) .EQ. 0 ) GO TO 100
C
      IF(  IOP(2) .EQ. 0 ) GO TO 50
C
      CALL LNCNT(5)
      WRITE(6,25)
   25 FORMAT(//' COMPUTATION OF WEIGHTING MATRICES FOR THE OPTIMAL SAMPL
     1ED-DATA REGULATOR PROBLEM'//)
      CALL PRNT(A,NA,' A  ',1)
      CALL PRNT(B,NB,' B  ',1)
      CALL LNCNT(3)
      WRITE(6,35)
   35 FORMAT(/' CONTINUOUS PERFORMANCE INDEX WEIGHTING MATRICES'/)
      CALL PRNT(Q,NQ,' Q  ',1)
      CALL PRNT(R,NR,' R  ',1)
      CALL LNCNT(3)
      WRITE(6,45) T
   45 FORMAT(/' SAMPLE TIME = ',D16.8/)
C
      GO TO 100
C
   50 CONTINUE
      CALL LNCNT(8)
      WRITE(6,75)
   75 FORMAT(//' COMPUTATION OF THE RECONSTRUCTIBILITY GRAMIAN'/' FOR TH
     1E (A,H) SYSTEM OVER THE INTERVAL (0,T) '/' THE MATRIX Q IS  ( H TR
     2ANSPOSE ) X H'//)
      CALL PRNT(A,NA,' A  ',1)
      CALL PRNT(Q,NQ,' Q  ',1)
      CALL LNCNT(3)
      WRITE(6,85) T
   85 FORMAT(/' T = ',D16.8/)
C
  100 CONTINUE
C
      N = NA(1)
      L = ( N**2)
      N1 = L + 1
      N2 = N1 + L
      TT  = T
C
      IOPT = 1
      CALL NORMS(N,N,N,A,IOPT,ANORM)
      IOPT = 3
      CALL NORMS(N,N,N,A,IOPT,ROWA)
      IF( ANORM .GT. ROWA ) ANORM = ROWA
C
      IF( ANORM .LE. 1.E-15 ) GO TO 900
C
      TMAX = 1.0/ANORM
      K = 0
C
  125 CONTINUE
      IF( TMAX - TT ) 150,150,200
  150 CONTINUE
      K = K + 1
      TT = T/( 2**K)
      IF( K - 1000 ) 125,800,800
C
  200 CONTINUE
C
      I = 0
      SC = TT
      CALL SCALE(A,NA,A,NA,TT)
      CALL SCALE(Q,NQ,Q,NQ,TT)
      CALL EQUATE(Q,NQ,DUMMY,NQ)
C
      IF( IOP(2) .NE. 0 ) GO TO 500
C
  225 CONTINUE
      II = I + 2
      I = I + 1
      F = 1.0/II
      CALL SCALE(A,NA,DUMMY(N1),NA,F)
      CALL MULT(DUMMY,NA,DUMMY(N1),NA,DUMMY(N2),NA)
      CALL TRANP(DUMMY(N2),NA,DUMMY(N1),NA)
      CALL ADD(DUMMY(N1),NA,DUMMY(N2),NA,DUMMY,NA)
C
      CALL MAXEL(Q,NQ,TOT)
      CALL MAXEL(DUMMY,NA,DELT)
      IF( TOT .GT. 1.0 ) GO TO 250
      IF( DELT/TOT .LT. SERCV )  GO TO 300
      GO TO 275
  250 CONTINUE
      IF( DELT .LT. SERCV )  GO TO 300
  275 CONTINUE
      CALL ADD(Q,NQ,DUMMY,NA,Q,NQ)
      GO TO 225
C
  300 CONTINUE
C
      IF( K .EQ. 0 ) GO TO 400
      N3 = N2 + L
      G = 1.0
      IOPT = 0
      CALL EXPSER(A,NA,DUMMY,NA,G,IOPT,DUMMY(N1))
C
  350 CONTINUE
      IF( K .EQ. 0 ) GO TO 400
      K = K-1
C
      CALL TRANP(DUMMY,NA,DUMMY(N1),NA)
      CALL MULT(Q,NQ,DUMMY,NA,DUMMY(N2),NA)
      CALL MULT(DUMMY(N1),NA,DUMMY(N2),NA,DUMMY(N3),NA)
      CALL ADD(Q,NQ,DUMMY(N3),NA,Q,NQ)
      CALL MULT(DUMMY,NA,DUMMY,NA,DUMMY(N1),NA)
      CALL EQUATE(DUMMY(N1),NA,DUMMY,NA)
C
      GO TO 350
C
  400 CONTINUE
      S =  1.0/SC
      CALL SCALE(A,NA,A,NA,S)
C
      IF( IOP(1) .EQ. 0 ) RETURN
      CALL PRNT(Q,NQ,'GRAM',1)
      RETURN
C
  500 CONTINUE
      CALL SCALE(B,NB,B,NB,TT)
      N3 = N2 + L
      N4 = N3 + L
      N5 = N4 + L
      N6 = N5 + L
C
  525 CONTINUE
      II = I + 2
      I = I + 1
      F = 1.0/II
      CALL SCALE(A,NA,DUMMY(N1),NA,F)
      CALL TRANP(DUMMY(N1),NA,DUMMY(N2),NA)
      CALL MULT(DUMMY,NA,DUMMY(N1),NA,DUMMY(N3),NA)
      CALL TRANP(DUMMY(N3),NA,DUMMY(N1),NA)
      CALL MULT(DUMMY,NA,B,NB,DUMMY(N5),NW)
      CALL ADD(DUMMY(N1),NA,DUMMY(N3),NA,DUMMY,NA)
      CALL SCALE(DUMMY(N5),NW,DUMMY(N1),NW,F)
      IF( I .NE. 1 ) GO TO 550
      CALL EQUATE(DUMMY(N1),NW,W,NW)
      CALL EQUATE(DUMMY(N1),NW,DUMMY(N6),NW)
      CALL ADD(Q,NQ,DUMMY,NQ,Q,NQ)
      GO TO 525
C
  550 CONTINUE
      CALL MULT(DUMMY(N2),NA,DUMMY(N6),NW,DUMMY(N5),NW)
      CALL ADD(DUMMY(N5),NW,DUMMY(N1),NW,DUMMY(N1),NW)
      CALL TRANP(B,NB,DUMMY(N2),NDUM)
      CALL SCALE(DUMMY(N2),NDUM,DUMMY(N2),NDUM,F)
      CALL MULT(DUMMY(N2),NDUM,DUMMY(N6),NW,DUMMY(N3),NR)
      CALL TRANP(DUMMY(N3),NR,DUMMY(N5),NR)
      CALL ADD(DUMMY(N3),NR,DUMMY(N5),NR,DUMMY(N3),NR)
      CALL EQUATE(DUMMY(N1),NW,DUMMY(N6),NW)
      IF(  I .NE. 2 ) GO TO 575
      CALL ADD(Q,NQ,DUMMY,NQ,Q,NQ)
      CALL ADD(W,NW,DUMMY(N1),NW,W,NW)
      CALL EQUATE(DUMMY(N3),NR,DUMMY(N4),NR)
      GO TO 525
C
  575 CONTINUE
      CALL MAXEL(Q,NQ,TOT)
      CALL MAXEL(DUMMY,NQ,DELT)
      IF( TOT .GT. 1.0 )  GO TO 580
      IF( DELT/TOT .LT. SERCV )  GO TO 585
      GO TO 595
C
  580 CONTINUE
      IF( DELT .LT. SERCV )  GO TO 585
      GO TO 595
C
  585 CONTINUE
      CALL MAXEL(DUMMY(N4),NR,TOT)
      CALL MAXEL(DUMMY(N3),NR,DELT)
      IF( TOT .GT. 1.0 )  GO TO 590
      IF( DELT/TOT .LT. SERCV )  GO TO 600
      GO TO 595
C
  590 CONTINUE
      IF( DELT .LT. SERCV )  GO TO 600
C
  595 CONTINUE
      CALL ADD (Q,NQ,DUMMY,NQ,Q,NQ)
      CALL ADD(W,NW,DUMMY(N1),NW,W,NW)
      CALL ADD(DUMMY(N4),NR,DUMMY(N3),NR,DUMMY(N4),NR)
      GO TO 525
C
  600 CONTINUE
      IF( K .EQ. 0 ) GO TO 700
      G = 1.0
      IOPT = 0
      CALL EXPINT(A,NA,DUMMY,NA,DUMMY(N1),NA,G,IOPT,DUMMY(N2))
      CALL MULT(DUMMY(N1),NA,B,NB,DUMMY(N2),NB)
      CALL EQUATE(DUMMY(N2),NB,DUMMY(N1),NB)
C
  650 CONTINUE
      IF( K .EQ. 0 ) GO TO 700
      K = K - 1
      CALL MULT(Q,NQ,DUMMY,NA,DUMMY(N2),NA)
      CALL TRANP(DUMMY,NA,DUMMY(N3),NA)
      CALL MULT(DUMMY(N3),NA,DUMMY(N2),NA,DUMMY(N5),NA)
      CALL MULT(Q,NQ,DUMMY(N1),NB,DUMMY(N2),NB)
      CALL ADD(Q,NQ,DUMMY(N5),NA,Q,NQ)
      CALL MULT(DUMMY(N3),NA,DUMMY(N2),NB,DUMMY(N5),NB)
      CALL MULT(DUMMY(N3),NA,W,NW,DUMMY(N6),NW)
      CALL ADD(DUMMY(N5),NW,DUMMY(N6),NW,DUMMY(N5),NW)
      CALL TRANP(DUMMY(N1),NB,DUMMY(N6),NDUM)
      CALL MULT(DUMMY(N6),NDUM,W,NW,DUMMY(N3),NR)
      CALL ADD(W,NW,DUMMY(N5),NW,W,NW)
      CALL MULT(DUMMY(N6),NDUM,DUMMY(N2),NB,DUMMY(N5),NR)
      CALL ADD(DUMMY(N5),NR,DUMMY(N3),NR,DUMMY(N5),NR)
      CALL TRANP(DUMMY(N3),NR,DUMMY(N6),NR)
      CALL ADD(DUMMY(N5),NR,DUMMY(N6),NR,DUMMY(N6),NR)
      CALL SCALE(DUMMY(N4),NR,DUMMY(N4),NR,2.0D0)
      CALL ADD(DUMMY(N6),NR,DUMMY(N4),NR,DUMMY(N4),NR)
      CALL MULT(DUMMY,NA,DUMMY(N1),NB,DUMMY(N3),NB)
      CALL ADD(DUMMY(N3),NB,DUMMY(N1),NB,DUMMY(N1),NB)
      CALL MULT(DUMMY,NA,DUMMY,NA,DUMMY(N3),NA)
      CALL EQUATE(DUMMY(N3),NA,DUMMY,NA)
      GO TO 650
C
  700 CONTINUE
      CALL SCALE(R,NR,R,NR,T)
      CALL ADD(R,NR,DUMMY(N4),NR,R,NR)
      CALL SCALE(W,NW,W,NW,2.0D0)
      S = 1.0/SC
      CALL SCALE(A,NA,A,NA,S)
      CALL SCALE(B,NB,B,NB,S)
      IF( IOP(1) .EQ. 0 ) RETURN
C
      CALL LNCNT(3)
      WRITE(6,750)
  750 FORMAT(/' DISCRETE PERFORMANCE INDEX WEIGHTING MATRICES'/)
      CALL PRNT(Q,NQ,' Q  ',1)
      CALL PRNT(W,NW,' W  ',1)
      CALL PRNT(R,NR,' R  ',1)
      RETURN
C
  800 CONTINUE
      CALL LNCNT(1)
      WRITE(6,850)
  850 FORMAT(' ERROR IN SAMPL , K = 1000')
      RETURN
C
  900 CONTINUE
      CALL SCALE(Q,NQ,Q,NQ,T)
      IF( IOP(2) .NE. 0 ) GO TO 925
      IF( IOP(1) .NE. 0 ) CALL PRNT(Q,NQ,'GRAM',1)
      RETURN
C
  925 CONTINUE
      CALL MULT(Q,NQ,B,NB,W,NW)
      CALL SCALE(W,NW,W,NW,T)
      CALL TRANP(B,NB,DUMMY,NDUM)
      CALL MULT(DUMMY,NDUM,W,NW,DUMMY(N1),NR)
      TT = T/3.
      CALL SCALE(DUMMY(N1),NR,DUMMY,NR,TT)
      CALL SCALE(R,NR,R,NR,T)
      CALL ADD(R,NR,DUMMY,NR,R,NR)
      IF( IOP(1) .EQ. 0 ) RETURN
      CALL LNCNT(3)
      WRITE(6,750)
      CALL PRNT(Q,NQ,' Q  ',1)
      CALL PRNT(W,NW,' W  ',1)
      CALL PRNT(R,NR,' R  ',1)
      RETURN
C
      END


!Function
program Functions
    implicit none

    INTEGER :: number_one, number_two
    INTEGER :: total

    write (*, *) "Enter a number?"
    read (*, *) number_one
    write (*, *) "Enter another number?"
    read (*, *) number_two

    print *, ""

    print *, "Sum of a and b is ", total(number_one, number_two)

end program Functions

!Function
INTEGER function total(a, b)
    implicit none
    !Declaration of a, b data type that is passed
    INTEGER :: a, b

    !TO return the value just put the return value in function name like below
    total = a + b

end function


      SUBROUTINE INVERS (NDIM,A,N,B,M,DETERM,ISING,INDEX)
C
C     INVERSE, OR LINEAR EQUATIONS SOLVER
C
C     NDIM IS THE ACTUAL SIZE OF A IN CALLING PROGRAM. E.G. A(NDIM,NDIM)
C     A IS SQUARE MATRIX TO BE INVERTED.
C     N IS SIZE OF UPPER LEFT PORTION BEING INVERTED.
C     B IS COLUMN OF CONSTANTS (OPTIONAL INPUT). SUPPLY SPACE B(NDIM,1)
C     M IS THE NUMBER OF COLUMNS OF CONSTANTS
C     DETERM RETURNS THE VALUE OF DETERMINANT IF NON-SINGULAR
C     ISING RETURNS 2, IF MATRIX A(N,N) IS SINGULAR
C                   1, IF MATRIX A(N,N) IS NON-SINGULAR
C     (IF ISING IS SET TO .LT. 0 UPON INPUT, DETERM IS NOT CALCULATED)
C     INVERSE RETURNS  IN A
C     SOLUTION VECTORS RETURN IN B
C     INDEX IS WORKING STORAGE (N,3)
C
      DIMENSION       A(NDIM,1),   B(NDIM,1), INDEX(N,3)
      COMMON /MACHIN/ MACH
      EQUIVALENCE     (IROW,JROW), (ICOLUM,JCOLUM), (AMAX, T, SWAP)
      DATA    EPSI  / 1.0E-30 /
C
C     INITIALIZE
C
      IF (MACH  .EQ. 5) EPSI = 1.E-18
      DETERM = 1.0
      IF (ISING .LT. 0) DETERM = 0.0
      DO 10 J = 1,N
   10 INDEX(J,3) = 0
      DO 130 I = 1,N
C
C     SEARCH FOR PIVOT
C
      AMAX = 0.0
      DO 40 J = 1,N
      IF (INDEX(J,3) .EQ. 1) GO TO 40
      DO 30 K = 1,N
      IF (INDEX(K,3) - 1) 20,30,190
   20 IF (ABS(A(J,K)) .LE. AMAX) GO TO 30
      IROW   = J
      ICOLUM = K
      AMAX   = ABS(A(J,K))
   30 CONTINUE
   40 CONTINUE
      INDEX(ICOLUM,3) = INDEX(ICOLUM,3) + 1
      INDEX(I,1) = IROW
      INDEX(I,2) = ICOLUM
C
C     INTERCHANGE ROWS TO PUT PIVOT ELEMENT ON DIAGONAL
C
      IF (IROW .EQ. ICOLUM) GO TO 70
      DETERM = -DETERM
      DO 50 L = 1,N
      SWAP = A(IROW,L)
      A(IROW,L  ) = A(ICOLUM,L)
   50 A(ICOLUM,L) = SWAP
      IF (M .LE. 0) GO TO 70
      DO 60 L = 1,M
      SWAP = B(IROW,L)
      B(IROW,L  ) = B(ICOLUM,L)
   60 B(ICOLUM,L) = SWAP
C
C     DIVIDE PIVOT ROW BY PIVOT ELEMENT
C
   70 PIVOT  = A(ICOLUM,ICOLUM)
      DETERM = DETERM*PIVOT
      IF (ABS(PIVOT) .LT. EPSI) GO TO 190
      A(ICOLUM,ICOLUM) = 1.0
      DO 80 L = 1,N
   80 A(ICOLUM,L) = A(ICOLUM,L)/PIVOT
      IF (M .LE. 0) GO TO 100
      DO 90 L=1,M
   90 B(ICOLUM,L) = B(ICOLUM,L)/PIVOT
C
C     REDUCE NON PIVOT ROWS
C
  100 DO 130 L1 = 1,N
      IF (L1 .EQ. ICOLUM) GO TO 130
      T = A(L1,ICOLUM)
      A(L1,ICOLUM) = 0.0
      IF (ABS(T) .LT. EPSI) GO TO 130
      DO 110 L = 1,N
  110 A(L1,L) = A(L1,L) - A(ICOLUM,L)*T
      IF (M .LE. 0) GO TO 130
      DO 120 L = 1,M
  120 B(L1,L) = B(L1,L) - B(ICOLUM,L)*T
  130 CONTINUE
C
C     INTERCHANGE COLUMNS
C
      DO 150 I = 1,N
      L = N + 1 - I
      IF (INDEX(L,1) .EQ. INDEX(L,2)) GO TO 150
      JROW   = INDEX(L,1)
      JCOLUM = INDEX(L,2)
      DO 140 K = 1,N
      SWAP = A(K,JROW)
      A(K,JROW  ) = A(K,JCOLUM)
      A(K,JCOLUM) = SWAP
  140 CONTINUE
  150 CONTINUE
      DO 170 K = 1,N
      IF (INDEX(K,3) .EQ. 1) GO TO 160
      ISING = 2
      GO TO 180
  160 CONTINUE
  170 CONTINUE
      ISING = 1
  180 RETURN
  190 ISING = 2
      RETURN
      END


! test_pot_dd.f90
! dipole-dipole potential
MODULE test_pot_module

  !------------------------------------------------------------------------------------------------!
  ! This software was written in 2016/17                                                           !
  ! by Michael P. Allen <m.p.allen@warwick.ac.uk>/<m.p.allen@bristol.ac.uk>                        !
  ! and Dominic J. Tildesley <d.tildesley7@gmail.com> ("the authors"),                             !
  ! to accompany the book "Computer Simulation of Liquids", second edition, 2017 ("the text"),     !
  ! published by Oxford University Press ("the publishers").                                       !
  !                                                                                !
  ! LICENCE                                                                                !
  ! Creative Commons CC0 Public Domain Dedication.                                                 !
  ! To the extent possible under law, the authors have dedicated all copyright and related         !
  ! and neighboring rights to this software to the PUBLIC domain worldwide.                        !
  ! This software is distributed without any warranty.                                             !
  ! You should have received a copy of the CC0 Public Domain Dedication along with this software.  !
  ! If not, see <http://creativecommons.org/publicdomain/zero/1.0/>.                               !
  !                                                                                !
  ! DISCLAIMER                                                                                !
  ! The authors and publishers make no warranties about the software, and disclaim liability       !
  ! for all uses of the software, to the fullest extent permitted by applicable law.               !
  ! The authors and publishers do not recommend use of this software for any purpose.              !
  ! It is made freely available, solely to clarify points made in the text. When using or citing   !
  ! the software, you should not imply endorsement by the authors or publishers.                   !
  !------------------------------------------------------------------------------------------------!

  USE, INTRINSIC :: iso_fortran_env, ONLY : error_unit

  IMPLICIT NONE
  PRIVATE

  ! Public routine
  PUBLIC :: force

  ! Public data
  INTEGER, PARAMETER, PUBLIC :: n = 2 ! Pair potential

CONTAINS

  SUBROUTINE force  ( r, e, pot, f, t )
    USE maths_module, ONLY : cross_product
    IMPLICIT NONE

    REAL, DIMENSION(:,:),           INTENT(in)  :: r, e
    REAL,                           INTENT(out) :: pot
    REAL, DIMENSION(:,:), OPTIONAL, INTENT(out) :: f, t

    REAL, DIMENSION(3) :: rij, sij, fij, gi, gj
    REAL               :: rij_mag, ci, cj, cij
    REAL, PARAMETER    :: tol = 1.e-6
    INTEGER, PARAMETER :: i = 1, j = 2 ! notation to match appendix

    ! Routine to demonstrate the calculation of forces and torques from the
    ! dipole-dipole potential
    ! Written for ease of comparison with the text, rather than efficiency!

    ! Check dimensions to be sure
    IF ( ANY ( SHAPE(r) /= [3,n] ) ) THEN
       WRITE ( unit=error_unit, fmt='(a,4i15)' ) 'r shape error', SHAPE(r), 3, n
       STOP 'Error in test_pot_dd'
    END IF
    IF ( ANY ( SHAPE(e) /= [3,n] ) ) THEN
       WRITE ( unit=error_unit, fmt='(a,4i15)' ) 'e shape error', SHAPE(e), 3, n
       STOP 'Error in test_pot_dd'
    END IF

    ! Check unit vectors
    IF ( ABS(SUM(e(:,i)**2)-1.0) > tol .OR. ABS(SUM(e(:,j)**2)-1.0) > tol ) THEN
       WRITE ( unit=error_unit, fmt='(a)'      ) 'Warning, non-unit vectors'
       WRITE ( unit=error_unit, fmt='(4f10.5)' ) e(:,i), SUM(e(:,i)**2)
       WRITE ( unit=error_unit, fmt='(4f10.5)' ) e(:,j), SUM(e(:,j)**2)
    END IF

    rij = r(:,i) - r(:,j)
    rij_mag = SQRT ( SUM(rij**2) ) ! Magnitude of separation vector
    sij = rij / rij_mag            ! Unit vector
    ci  = DOT_PRODUCT ( e(:,i), sij )
    cj  = DOT_PRODUCT ( e(:,j), sij )
    cij = DOT_PRODUCT ( e(:,i), e(:,j) )

    ! The dipole-dipole potential with mu_i = mu_j = 1
    pot = (cij-3.0*ci*cj)/rij_mag**3

    IF ( .NOT. PRESENT(f) ) RETURN

    IF ( .NOT. PRESENT(t) ) THEN
       WRITE ( unit=error_unit, fmt='(a)' ) 'Both f and t expected'
       STOP 'Error in test_pot_dd'
    END IF
    IF ( ANY ( SHAPE(f) /= [3,n] ) ) THEN
       WRITE ( unit=error_unit, fmt='(a,4i15)' ) 'f shape error', SHAPE(f), 3, n
       STOP 'Error in test_pot_dd'
    END IF
    IF ( ANY ( SHAPE(t) /= [3,n] ) ) THEN
       WRITE ( unit=error_unit, fmt='(a,4i15)' ) 't shape error', SHAPE(t), 3, n
       STOP 'Error in test_pot_dd'
    END IF

    ! Forces
    fij = 3.0 * ( (cij-5.0*ci*cj)*sij + cj*e(:,i) + ci*e(:,j) ) / rij_mag**4

    ! Torque gradients
    gi = ( e(:,j) - 3.0*cj*sij ) / rij_mag**3
    gj = ( e(:,i) - 3.0*ci*sij ) / rij_mag**3

    ! Final forces and torques
    f(:,i) = fij
    f(:,j) = -fij
    t(:,i) = -cross_product(e(:,i),gi)
    t(:,j) = -cross_product(e(:,j),gj)

  END SUBROUTINE force

END MODULE test_pot_module


Submodule ( statistical_data_mod ) statistical_mean_smod
!
  Implicit None
!
Contains
!
  Module Procedure Statistical_Mean
!
    If ( Size(this%data) .ne. 0 ) Then
       mean = Sum ( this%data ) / Size ( this%data )
    Else
       mean = Huge ( mean )
    End If
    this%mean = mean
    this%Dmean = .true.
!
  End Procedure Statistical_Mean
!
End Submodule statistical_mean_smod


Real Function akpsgm(pkaon)
  Save
  If (pkaon<0.2 .Or. pkaon>=1.5) sigma1 = 0.
  If (pkaon>=0.2 .And. pkaon<1.5) sigma1 = 0.6*pkaon**(-1.8)
  akpsgm = sigma1
  Return
End Function akpsgm


      SUBROUTINE UNIBARF( ZS,N,LAG,ZMEAN,SUM,SD,AIC,DIC,IMIN,AICM,SDMIN,
     *                    B1,C,D,B2,AICB,SDB,PN,A,SXX )
C
      INCLUDE 'timsac_f.h'
C
cc      PROGRAM  UNIBAR
C.......................................................................
C.....PLANNED BY H.AKAIKE...............................................
C.....DESIGNED BY H.AKAIKE AND G.KITAGAWA...............................
C.....PROGRAMMED BY G.KITAGAWA AND F.TADA...............................
C.....ADDRESS: THE INSTITUTE OF STATISTICAL MATHEMATICS, 4-6-7 MINAMI-AZ
C..............MINATO-KU, TOKYO 106, JAPAN..............................
C.....DATE OF THE LATEST REVISION:  MAR. 6,1979.........................
C.......................................................................
C.....THIS PROGRAM WAS ORIGINALLY PUBLISHED IN "TIMSAC-78", BY H.AKAIKE,
C.....G.KITAGAWA, E.ARAHATA AND F.TADA, COMPUTER SCIENCE MONOGRAPHS, NO.
C.....THE INSTITUTE OF STATISTICAL MATHEMATICS, TOKYO, 1979.............
C.......................................................................
C     TIMSAC 78.1.2.
C     ___        _                  __
C     UNIVARIATE BAYESIAN METHOD OF AR MODEL FITTING
C
C     THIS PROGRAM FITS AN AUTOREGRESSIVE MODEL BY A BAYESIAN PROCEDURE.
C     THE LEAST SQUARES ESTIMATES OF THE PARAMETERS ARE OBTAINED BY THE
C     HOUSEHOLDER TRANSFORMATION.
C     -----------------------------------------------------------------
C     THE BASIC STATISTIC AIC IS DEFINED BY
C
C               AIC = N * LOG( SD )  +  2 * M  ,
C     WHERE
C       N:     DATA LENGTH,
C       SD:    ESTIMATE OF INNOVATION VARIANCE, THE AVERAGE OF THE
C              SQUARED RESIDUALS
C       M:     ORDER OF THE MODEL
C     -----------------------------------------------------------------
C     BAYESIAN WEIGHT OF THE M-TH ORDER MODEL IS DEFINED BY
C            W(M)  =  CONST  *  C(M)  /  ( M + 1 ),
C     WHERE
C            CONST =  NORMALIZING CONSTANT
C            C(M)  =  EXP( -0.5*AIC(M) ).
C     -----------------------------------------------------------------
C     THE EQUIVALENT NUMBER OF FREE PARAMETERS FOR THE BAYESIAN MODEL IS
C     DEFINED BY
C            EK    =  D(1)**2 + ... + D(K)**2 + 1
C     WHERE D(J) IS DEFINED BY
C            D(J) = W(J) + ... + W(K).
C
C     M IN THE DEFINITION OF AIC IS REPLACED BY EK TO DEFINE AN EQUIVALE
C     FOR A BAYESIAN MODEL.
C     -----------------------------------------------------------------
C       REFERENCES:
C          H.AKAIKE(1978), "A BAYESIAN EXTENSION OF THE MINIMUM AIC
C          PROCEDURE OF AUTOREGRESSIVE MODEL FITTING.",  RESEARCH MEMO.
C          NO. 126, THE INSTITUTE OF STATISTICAL MATHEMATICS; TOKYO.
C          G.KITAGAWA AND H.AKAIKE(1978), "A PROCEDURE FOR THE MODELING
C          OF NON-STATIONARY TIME SERIES.",  ANN. INST. STATIST. MATH.,
C          30,B,351-363.
C       ---------------------------------------------------------------
C       THE FOLLOWING SUBROUTINES ARE DIRECTLY CALLED BY THIS PROGRAM:
C             REDATA
C             REDUCT
C             ARBAYS
C             NRASPE
C       ---------------------------------------------------------------
C       INPUTS REQUIRED:
C             LAG         :  ORDER OF THE AR-MODEL, MUST BE LESS THAN 10
C             MT          :  INPUT DEVICE FOR ORIGINAL DATA (MT=5 : CARD
C
C               -- THE FOLLOWING INPUTS ARE REQUESTED BY SUBROUTINE REDA
C
C             TITLE:    SPECIFICATION OF DATA
C             N:        DATA LENGTH, MUST BE LESS THAN OR EQUAL TO 10000
C             DFORM:    INPUT DATA FORMAT SPECIFICATION STATEMENT.
C                       -- FOR EXAMPLE --     (8F10.5)
C             (Z(I),I=1,N):  ORIGINAL DATA
C               --------------------------------------------------------
C
cc      !DEC$ ATTRIBUTES DLLEXPORT :: UNIBARF
C
cxx      IMPLICIT  REAL * 8  ( A-H , O-Z )
CC      REAL * 4   Z(10000) , TITLE(20)
cc      REAL * 4   TITLE(20)
cc      DIMENSION  Z(10000)
cc      DIMENSION  X(200,101) , D(200) , A(100) , B(100)
cxx      DIMENSION  ZS(N), Z(N)
cxx      DIMENSION  X(N-LAG,LAG+1), D(LAG), A(LAG), B1(LAG), B2(LAG)
cxx      DIMENSION  SD(LAG+1), AIC(LAG+1), DIC(LAG+1), C(LAG+1)
cxx      DIMENSION  SXX(121)
      INTEGER :: N, LAG, IMIN
      REAL(8) :: ZS(N), ZMEAN, SUM, SD(LAG+1), AIC(LAG+1), DIC(LAG+1),
     1           AICM, SDMIN, B1(LAG), C(LAG+1), D(LAG), B2(LAG),
     2           AICB, SDB, PN, A(LAG), SXX(121)
      REAL(8) :: Z(N), X(N-LAG,LAG+1), B
C
C        EXTERNAL SUBROUTINE DECLARATION:
C
      EXTERNAL  SETX1
C
cc      CHARACTER(100)  IFLNAM,OFLNAM
cc      CALL FLNAM2( IFLNAM,OFLNAM,NFL )
cc      IF ( NFL.EQ.0 ) GO TO 999
cc      IF ( NFL.EQ.2 ) THEN
cc         OPEN( 6,FILE=OFLNAM,ERR=900,IOSTAT=IVAR )
cc      ELSE
cc         CALL SETWND
cc      END IF
C
C        PARAMETERS:
C             MJ1:  ABSOLUTE DIMENSION FOR SUBROUTINE CALL
C             ISW:  =0   OUTPUTS ARE SUPPRESSED
C                   >0   OUTPUTS ARE PRINTED OUT
cc      MJ1 = 200
      MJ1 = N-LAG
      ISW = 1
C
cc      WRITE( 6,3 )
cc      WRITE( 6,4 )
C
cc      MT = 5
cc      OPEN( MT,FILE=IFLNAM,ERR=910,IOSTAT=IVAR,STATUS='OLD' )
CC      READ( 5,1 )     MT
cc      READ( 5,1 )     LAG
cc      WRITE( 6,2 )    LAG , MT
C
C
C          +---------------------------------------+                  +-
C          ! ORIGINAL DATA INPUT AND MEAN DELETION !                  !
C          +---------------------------------------+                  +-
C
cc      CALL  REDATA( Z,N,MT,TITLE )
cc      CLOSE( MT )
      CALL REDATA( ZS,Z,N,ZMEAN,SUM )
      K = LAG
      NMK = N-LAG
C
C          +-----------------------+                                  +-
C          ! HOUSEHOLDER REDUCTION !                                  !
C          +-----------------------+                                  +-
C
      N1 = N+1
cc      CALL  REDUCT( SETX1,Z,D,NMK,0,K,MJ1,LAG,X )
      CALL  REDUCT( SETX1,Z,NMK,0,K,MJ1,LAG,X )
C
C         +-----------------------------------------------+           +-
C         ! AUTOREGRESSIVE MODEL FITTING (BAYESIAN MODEL) !           !
C         +-----------------------------------------------+           +-
C
cc      CALL  ARBAYS( X,D,K,LAG,NMK,ISW,TITLE,MJ1,A,B,SDB,AICB )
cxx      CALL  ARBAYS( X,D,K,LAG,NMK,ISW,MJ1,SD,AIC,DIC,AICM,SDMIN,IMIN,
      CALL  ARBAYS( X,D,K,NMK,ISW,MJ1,SD,AIC,DIC,AICM,SDMIN,IMIN,
     *              A,B1,B2,C,SDB,PN,AICB )
C
C          +------------------------+                                 +-
C          ! POWER SPECTRUM DISPLAY !                                 !
C          +------------------------+                                 +-
C
cc      CALL  NRASPE( SDB,A,B,K,0,120,TITLE )
      CALL  NRASPE( SDB,A,B,K,0,120,SXX )
cc      GO TO 999
C
cc  900 CONTINUE
cc      WRITE(6,600) IVAR,OFLNAM
cc  600 FORMAT(/,' !!! Output_Data_File OPEN ERROR ',I8,//,5X,100A)
cc       GO TO 999
C
cc  910 CONTINUE
cc      IF ( NFL.EQ.2 ) CLOSE( 6 )
cc#ifdef __linux__
C      reopen #6 as stdout
cc      IF ( NFL.EQ.2 ) OPEN(6, FILE='/dev/fd/1')
cc#endif
C /* __linux__ */
cc      WRITE(6,610) IVAR,IFLNAM
cc  610 FORMAT(/,' !!! Input_Data_File OPEN ERROR ',I8,//,5X,100A)
C
cc  999 CONTINUE
      RETURN
cxx    1 FORMAT( 16I5 )
cxx    2 FORMAT( 1H ,I4,'-TH ORDER BAYESIAN MODEL IS FITTED',/,1H ,2X,
cxx     1'ORIGINAL DATA INPUT DEVICE  MT =',I4 )
cxx    3 FORMAT( ' PROGRAM TIMSAC 78.1.2',/'   EXPONENTIALLY WEIGHTED BAYES
cxx     1IAN AUTOREGRESSIVE MODEL FITTING;  SCALAR CASE')
cxx    4 FORMAT(  '   < AUTOREGRESSIVE MODEL >',/,1H ,10X,'Z(I) = A(1)*Z(I-
cxx     11) + A(2)*Z(I-2) +  ...  + A(M)*Z(I-M) + E(I)',/,'   WHERE',/,11X,
cxx     2'M:     ORDER OF THE MODEL',/,11X,'E(I):  GAUSSIAN WHITE NOISE WIT
cxx     3H MEAN 0  AND  VARIANCE SD(M).' )
      E N D


module rTE_Fortran

implicit none

complex(kind=8), parameter :: j = complex(0.d0, 1.d0)
real(kind=8), parameter :: pi = dacos(-1.d0)
real(kind=8), parameter :: pi2 = 2.d0*pi
real(kind=8), parameter :: mu0 = 4.d-7*pi ! H/m

private

public :: rTE_forward
public :: rTE_sensitivity

contains

!====================================================================!
subroutine rTE_forward(nLayers, nFrequencies, nFilter, frequencies, lambda, sig, chi, depth, halfSpace, rTE)
  !! Computes the TE portion for forward modelling. Callable from python.
!====================================================================!
  integer, intent(in) :: nLayers
  integer, intent(in) :: nFrequencies
  integer, intent(in) :: nFilter
  real(kind=8), intent(in) :: frequencies(nFrequencies, nFilter)
  !f2py intent(in) :: frequencies
  real(kind=8), intent(in) :: lambda(nFrequencies, nFilter)
  !f2py intent(in) :: lambda
  complex(kind=8), intent(in) :: sig(nLayers, nFrequencies, nFilter)
  !f2py intent(in) :: sig
  real(kind=8), intent(in) :: chi(nLayers)
  !f2py intent(in) :: chi
  real(kind=8), intent(in) :: depth(nLayers)
  !f2py intent(in) :: depth
  logical, intent(in) :: halfspace
  !f2py intent(in) :: halfSpace
  complex(kind=8), intent(inout) :: rTE(nFrequencies, nFilter)
  !f2py intent(in, out) :: rTE

  integer :: i, jj, k
  complex(kind=8) :: c, cm1, cp1
  complex(kind=8) :: m0, m1, m2, m3
  complex(kind=8) :: s0, s1, s2, s3
  complex(kind=8) :: ss0, ss1, ss2, ss3
  real(kind=8) :: h
  real(kind=8) :: lam2
  real(kind=8) :: omega
  real(kind=8) :: tmp0
  complex(kind=8) :: uTmp0, uTmp1, cTmp
  real(kind=8) :: thickness(nLayers - 1)
  complex(kind=8) :: c1(nLayers)

  if (halfSpace .or. nLayers == 1) then

    cTmp = mu0 * (1.d0 + chi(1))
    do jj = 1, nFilter
      do i = 1, nFrequencies
        omega = pi2 * frequencies(i, jj)
        uTmp0 = lambda(i, jj)
        uTmp1 = sqrt(uTmp0**2.d0 + j * omega * cTmp * sig(1, i, jj))
        c = mu0 * uTmp1 / (cTmp * uTmp0)

        cm1 = 0.5d0 * (1.d0 - c)
        cp1 = 0.5d0 * (1.d0 + c)

        rTE(i, jj) = cm1 / cp1
      enddo
    enddo

    return ! Early escape
  endif

  do k = 1, nLayers - 1
    thickness(k) = -(depth(k+1) - depth(k))
    c1(k) = 1.d0 + chi(k)
  enddo
  c1(nLayers) = 1.d0 + chi(nLayers)

  do jj = 1, nFilter
    do i = 1, nFrequencies
      omega = pi2 * frequencies(i, jj)
      tmp0 = omega * mu0
      lam2 = lambda(i, jj)**2.d0

      ! Set up first layer
      uTmp1 = sqrt(lam2 + j * tmp0 * c1(1) * sig(1, i, jj))
      c = uTmp1 / (c1(1) * lambda(i, jj))

      s0 = 0.5d0 * (1.d0 + c)
      s1 = 0.5d0 * (1.d0 - c)
      s2 = s1
      s3 = s0

      do k = 1, nLayers - 1
        cTmp = j * tmp0
        uTmp0 = sqrt(lam2 + cTmp * c1(k) * sig(k, i, jj))
        uTmp1 = sqrt(lam2 + cTmp * c1(k + 1) * sig(k+1, i, jj))
        c = (c1(k) * uTmp1) / (c1(k + 1) * uTmp0)

        h = thickness(k)

        cTmp = exp(-2.d0 * uTmp0 * h)
        cm1 = 0.5d0 * (1.d0 - c)
        cp1 = 0.5d0 * (1.d0 + c)

        m0 = cp1 * cTmp
        m1 = cm1
        m2 = cm1 * cTmp
        m3 = cp1

        ss0 = (s0 * m0) + (s2 * m1)
        ss1 = (s1 * m0) + (s3 * m1)
        ss2 = (s0 * m2) + (s2 * m3)
        ss3 = (s1 * m2) + (s3 * m3)

        s0 = ss0
        s1 = ss1
        s2 = ss2
        s3 = ss3
      enddo

      rTE(i, jj) = s2 / s3
    enddo
  enddo

  end subroutine
  !====================================================================!

  !====================================================================!
  subroutine rTE_sensitivity(nLayers, nFrequencies, nFilter, frequencies, lambda, sig, chi, depth, halfSpace, drTE)
  !! Computes the TE portion for forward modelling. Callable from python.
  !====================================================================!
  integer, intent(in) :: nLayers
  integer, intent(in) :: nFrequencies
  integer, intent(in) :: nFilter
  real(kind=8), intent(in) :: frequencies(nFrequencies, nFilter)
  !f2py intent(in) :: frequencies
  real(kind=8), intent(in) :: lambda(nFrequencies, nFilter)
  !f2py intent(in) :: lambda
  complex(kind=8), intent(in) :: sig(nLayers, nFrequencies, nFilter)
  !f2py intent(in) :: sig
  real(kind=8), intent(in) :: chi(nLayers)
  !f2py intent(in) :: chi
  real(kind=8), intent(in) :: depth(nLayers)
  !f2py intent(in) :: depth
  logical, intent(in) :: halfspace
  !f2py intent(in) :: halfSpace
  complex(kind=8), intent(inout) :: drTE(nLayers, nFrequencies, nFilter)
  !f2py intent(in, out) :: drTE

  real(kind=8) :: h0, h_1
  real(kind=8) :: lam, lam2
  real(kind=8) :: thickness(nLayers - 1)
  real(kind=8) :: c1(nLayers), c1t, c2t, c3t

  complex(kind=8) :: const, cTmp, cTmp2, cTmp3, cTmp4
  complex(kind=8) :: dJ_10mTemp00, dJ_10mTemp01, dJ_10mTemp10, dJ_10mTemp11
  real(kind=8)    :: dJ0mTemp00_
  complex(kind=8) :: dJ0mTemp00, dJ0mTemp11
  complex(kind=8) :: dJ01mTemp00, dJ01mTemp01, dJ01mTemp10, dJ01mTemp11
  complex(kind=8) :: dJ1mTemp00, dJ1mTemp01, dJ1mTemp10
  complex(kind=8) :: dJ0sum00, dJ0sum10, dJ0sum01, dJ0sum11
  complex(kind=8) :: dJ1sum00, dJ1sum10, dJ1sum01, dJ1sum11
  complex(kind=8) :: dudsig
  complex(kind=8) :: mTemp00, mTemp01, mTemp10, mTemp11
  complex(kind=8) :: m0Sum00, m0Sum01, m0Sum10, m0Sum11
  complex(kind=8) :: m1Sum00, m1Sum01, m1Sum10, m1Sum11
  complex(kind=8) :: w
  complex(kind=8) :: utemp0, utemp1
  complex(kind=8), dimension(nLayers) :: M00, M01, M10, M11
  complex(kind=8), dimension(nLayers) :: dJ00, dJ01, dJ10, dJ11

  integer :: i
  integer :: jj
  integer :: k, k1

  ! Half space model, provide early exit
  if (halfspace .or. nLayers == 1) then
    cTmp = 1.d0 + chi(1)
    do jj = 1, nFilter
      do i = 1, nFrequencies

        w = pi2 * frequencies(i, jj)
        lam = lambda(i, jj)
        cTmp2 = j * w * mu0 * cTmp
        cTmp3 = 1.d0 / (cTmp * lam)

        ! utemp0 = lambda
        utemp1 = sqrt(lam**2.d0 + cTmp2 * sig(1, i, jj))
        const = utemp1 * cTmp3

        ! Compute M1
        M0sum01 = 0.5d0 * (1.d0 - const)
        M0sum11 = 0.5d0 * (1.d0 + const)

        ! Compute dM1du1
        dJ1sum11 = 0.25d0 * (cTmp2 / utemp1) * cTmp3

        drTE(1, i, jj) = ((-dJ1sum11 * M0sum11) - dJ1sum11 * M0sum01) / M0sum11**2.d0

      enddo
    enddo
    return ! Early Exit
  endif

  do k = 1, nLayers - 1
    thickness(k) = -(depth(k+1) - depth(k))
    c1(k) = 1.d0 + chi(k)
  enddo
  c1(nLayers) = 1.d0 + chi(nLayers)

  do jj = 1, nFilter
    do i = 1, nFrequencies

      c1t = c1(1)
      c2t = c1(2)

      lam = lambda(i, jj)
      lam2 = lam**2.d0
      w = pi2 * frequencies(i, jj)
      c3t = 1.d0 / (c1t * lam)
      cTmp2 = j * w * mu0

      ! utemp0 = lambda
      utemp1 = sqrt(lam2 + cTmp2 * c1t * sig(1, i, jj))

      const = utemp1 * c3t

      ! Compute M1
      Mtemp00 = 0.5d0 * (1.d0 + const)
      Mtemp10 = 0.5d0 * (1.d0 - const)
      ! Mtemp01 = mTemp10
      ! Mtemp11 = mTemp00

      M00(1) = Mtemp00
      M01(1) = Mtemp10
      M10(1) = Mtemp10
      M11(1) = Mtemp00

      M0sum00 = Mtemp00
      M0sum10 = Mtemp10

      ! Compute dM1du1
      dj0Mtemp00_ =  0.5d0 * c3t

      !!!!!!!!
      ! j = 0
      !!!!!!!!

      utemp0  = utemp1
      utemp1  = sqrt(lam2 + cTmp2 * c2t * sig(2, i, jj))
      const =  (c1t * utemp1) / (c2t * utemp0)

      h0 = thickness(1)

      mTemp11 = 0.5d0 * (1.d0 + const)
      mTemp10 = 0.5d0 * (1.d0 - const)
      mTemp00 = exp(-2.d0 * utemp0 * h0)
      mTemp01 = mTemp10 * mTemp00
      mTemp00 = mTemp11 * mTemp00

      M00(2) = Mtemp00
      M01(2) = Mtemp01
      M10(2) = Mtemp10
      M11(2) = Mtemp11

      ! Inline the matmul
      M1sum10 = (M0sum10 * Mtemp00) + (M0sum00 * Mtemp10)
      M1sum00 = (M0sum00 * Mtemp00) + (M0sum10 * Mtemp10)
      M1sum01 = (M0sum00 * Mtemp01) + (M0sum10 * Mtemp11)
      M1sum11 = (M0sum10 * Mtemp01) + (M0sum00 * Mtemp11)

      M0sum00 = M1sum00
      M0sum10 = M1sum10
      M0sum01 = M1sum01
      M0sum11 = M1sum11

      ! TODO: for Computing Jacobian
      dudsig = 0.5d0 * cTmp2 * c1(1) / utemp0

      dJ01Mtemp00 = (c1t * utemp1) / (c2t * utemp0**2.d0)
      dJ01Mtemp11 = dJ01Mtemp00 * utemp0
      dJ01Mtemp01 = exp(-2.d0 * utemp0 * h0)

      ! Compute dM1dm1*M2
      dJ_10Mtemp00 = dj0Mtemp00_ * (Mtemp00 - Mtemp10)
      ! dJ_10Mtemp10 = -dJ_10Mtemp00
      dJ_10Mtemp01 = dj0Mtemp00_ * (Mtemp01 - Mtemp11)
      ! dJ_10Mtemp11 = -dJ_10Mtemp01

      dj1Mtemp10 =  0.5d0 * dJ01Mtemp00
      cTmp3 = h0 * dJ01Mtemp01
      dj1Mtemp01 =  dj1Mtemp10 * dJ01Mtemp01
      dj1Mtemp00 = -dj1Mtemp01 - (1.d0 + dJ01Mtemp11) * cTmp3
      dj1Mtemp01 =  dj1Mtemp01 - (1.d0 - dJ01Mtemp11) * cTmp3
      ! dj1Mtemp11 = -dj1Mtemp10

      ! Compute M1*dM2dm1  ! Re-coded given "symmetry"
      cTmp4 = M01(1) * dj1Mtemp10
      dJ01Mtemp00 = (M00(1) * dj1Mtemp00) + cTmp4
      dJ01Mtemp01 = (M00(1) * dj1Mtemp01) - cTmp4
      cTmp4 = M11(1) * dj1Mtemp10
      dJ01Mtemp10 = (M10(1) * dj1Mtemp00) + cTmp4
      dJ01Mtemp11 = (M10(1) * dj1Mtemp01) - cTmp4

      dJ00(1) = dudsig * (dJ_10Mtemp00 + dJ01Mtemp00)
      dJ10(1) = dudsig * (dJ01Mtemp10 - dJ_10Mtemp00)
      dJ01(1) = dudsig * (dJ_10Mtemp01 + dJ01Mtemp01)
      dJ11(1) = dudsig * (dJ01Mtemp11 - dJ_10Mtemp01)

      do k = 2, nLayers - 1
        c1t = c1(k - 1)
        c2t = c1(k)
        c3t = c1(k + 1)
        utemp0  = utemp1
        utemp1  = sqrt(lam2 + cTmp2 * c3t * sig(k + 1, i, jj))
        const =  (c2t * utemp1) / (c3t * utemp0)

        h0 = thickness(k)

        mTemp11 = 0.5d0 * (1.d0 + const)
        mTemp10 = 0.5d0 * (1.d0 - const)
        mTemp00 = exp(-2.d0 * utemp0 * h0)
        mTemp01 = mTemp10 * mTemp00
        mTemp00 = mTemp11 * mTemp00

        M00(k + 1) = Mtemp00
        M01(k + 1) = Mtemp01
        M10(k + 1) = Mtemp10
        M11(k + 1) = Mtemp11

        ! Inline the matmul
        M1sum00 = (M0sum00 * Mtemp00) + (M0sum01 * Mtemp10)
        M1sum10 = (M0sum10 * Mtemp00) + (M0sum11 * Mtemp10)
        M1sum01 = (M0sum00 * Mtemp01) + (M0sum01 * Mtemp11)
        M1sum11 = (M0sum10 * Mtemp01) + (M0sum11 * Mtemp11)

        M0sum00 = M1sum00
        M0sum10 = M1sum10
        M0sum01 = M1sum01
        M0sum11 = M1sum11

        ! TODO: for Computing Jacobian
        dudsig = 0.5d0 * cTmp2 * c2t / utemp0

        h_1 = thickness(k - 1)
        dJ_10Mtemp00 = sqrt(lam**2.0 + cTmp2 * c1t * sig(k - 1, i, jj))
        dJ_10Mtemp10 = c1t / (c2t * dJ_10Mtemp00)
        dJ_10Mtemp11 = exp(-2.d0 * dJ_10Mtemp00 * h_1)

        dj0Mtemp11 =  0.5 * dJ_10Mtemp10
        dj0Mtemp00 =  dj0Mtemp11 * dJ_10Mtemp11

        ! Compute dMjdmj*Mj+1  ! Re-coded given "symmetry"
        cTmp4 = Mtemp00 - Mtemp10
        dJ_10Mtemp00 = dj0Mtemp00 * cTmp4
        dJ_10Mtemp10 = -dj0Mtemp11 * cTmp4
        cTmp4 = Mtemp01 - Mtemp11
        dJ_10Mtemp01 = dj0Mtemp00 * cTmp4
        dJ_10Mtemp11 = -dj0Mtemp11 * cTmp4

        dJ01Mtemp00 = (c2t * utemp1) / (c3t * utemp0**2.d0)
        dJ01Mtemp11 = dJ01Mtemp00 * utemp0
        dJ01Mtemp10 = exp(-2.d0 * utemp0 * h0)

        dj1Mtemp10 =  0.5*dJ01Mtemp00
        cTmp3 = h0 * dJ01Mtemp10
        dj1Mtemp01 =  dj1Mtemp10 * dJ01Mtemp10
        dj1Mtemp00 = -dj1Mtemp01 - (1.d0 + dJ01Mtemp11) * cTmp3
        dj1Mtemp01 =  dj1Mtemp01 - (1.d0 - dJ01Mtemp11) * cTmp3
        ! dj1Mtemp11 = -dj1Mtemp10

        ! Compute Mj*dMj+1dmj
        cTmp4 = M01(k) * dj1Mtemp10
        dJ01Mtemp00 = (M00(k) * dj1Mtemp00) + cTmp4
        dJ01Mtemp01 = (M00(k) * dj1Mtemp01) - cTmp4
        cTmp4 = M11(k) * dj1Mtemp10
        dJ01Mtemp10 = (M10(k) * dj1Mtemp00) + cTmp4
        dJ01Mtemp11 = (M10(k) * dj1Mtemp01) - cTmp4

        dJ00(k) = dudsig * (dJ_10Mtemp00 + dJ01Mtemp00)
        dJ10(k) = dudsig * (dJ_10Mtemp10 + dJ01Mtemp10)
        dJ01(k) = dudsig * (dJ_10Mtemp01 + dJ01Mtemp01)
        dJ11(k) = dudsig * (dJ_10Mtemp11 + dJ01Mtemp11)
      enddo

      ! k = n_layer
      utemp0 = utemp1
      c1t = c1(nLayers - 1)
      c2t = c1(nLayers)
      dudsig = 0.5d0 * cTmp2 * c2t / utemp0

      h_1 = thickness(nLayers - 1)

      dJ_10Mtemp00 = sqrt(lam2 + cTmp2 * c1t * sig(nLayers - 1, i, jj))
      dJ_10Mtemp11 = c1t / (c2t * dJ_10Mtemp00)
      dJ_10Mtemp01 = exp(-2.d0 * dJ_10Mtemp00 * h_1)

      dj0Mtemp11 =  0.5d0 * dJ_10Mtemp11
      dj0Mtemp00 =  dj0Mtemp11 * dJ_10Mtemp01

      cTmp4 = dudsig * dj0Mtemp00
      dJ00(nLayers) = cTmp4
      dJ01(nLayers) = -cTmp4
      cTmp4 = dudsig * dj0Mtemp11
      dJ10(nLayers) = -cTmp4
      dJ11(nLayers) = cTmp4

      ! Second pass, Double loop
      ! k1 = 1
      dJ1sum00 = (0.d0, 0.d0) ; dJ1sum10 = (0.d0, 0.d0)
      dJ1sum01 = (0.d0, 0.d0) ; dJ1sum11 = (0.d0, 0.d0)

      dJ0sum00 = dJ1sum00 ; dJ0sum10 = dJ1sum10
      dJ0sum01 = dJ1sum01 ; dJ0sum11 = dJ1sum11

      ! k = 1
      if (nLayers > 2) then
        dJ1sum00 = (dJ00(1) * M00(3)) + (dJ01(1) * M10(3))
        dJ1sum10 = (dJ10(1) * M00(3)) + (dJ11(1) * M10(3))
        dJ1sum01 = (dJ00(1) * M01(3)) + (dJ01(1) * M11(3))
        dJ1sum11 = (dJ10(1) * M01(3)) + (dJ11(1) * M11(3))

        dJ0sum00 = dJ1sum00 ; dJ0sum10 = dJ1sum10
        dJ0sum01 = dJ1sum01 ; dJ0sum11 = dJ1sum11

        do k = 2, nLayers - 2
          dJ1sum00 = (dJ0sum00 * M00(k + 2)) + (dJ0sum01 * M10(k + 2))
          dJ1sum10 = (dJ0sum10 * M00(k + 2)) + (dJ0sum11 * M10(k + 2))
          dJ1sum01 = (dJ0sum00 * M01(k + 2)) + (dJ0sum01 * M11(k + 2))
          dJ1sum11 = (dJ0sum10 * M01(k + 2)) + (dJ0sum11 * M11(k + 2))

          dJ0sum00 = dJ1sum00 ; dJ0sum10 = dJ1sum10
          dJ0sum01 = dJ1sum01 ; dJ0sum11 = dJ1sum11
        enddo
      endif

      cTmp3 = 1.d0 / M1sum11**2.d0

      drTE(1, i, jj) = (dJ1sum01 * M1sum11 - dJ1sum11 * M1sum01) * cTmp3

      do k1 = 2, nLayers - 1
        dJ0sum00 = M00(1) ; dJ0sum10 = M10(1)
        dJ0sum01 = M01(1) ; dJ0sum11 = M11(1)

        do k = 1, k1 - 2
          dJ1sum00 = (dJ0sum00 * M00(k + 1)) + (dJ0sum01 * M10(k + 1))
          dJ1sum10 = (dJ0sum10 * M00(k + 1)) + (dJ0sum11 * M10(k + 1))
          dJ1sum01 = (dJ0sum00 * M01(k + 1)) + (dJ0sum01 * M11(k + 1))
          dJ1sum11 = (dJ0sum10 * M01(k + 1)) + (dJ0sum11 * M11(k + 1))

          dJ0sum00 = dJ1sum00 ; dJ0sum10 = dJ1sum10
          dJ0sum01 = dJ1sum01 ; dJ0sum11 = dJ1sum11
        enddo

        ! k = i - 1
        dJ1sum00 = (dJ0sum00 * dJ00(k1)) + (dJ0sum01 * dJ10(k1))
        dJ1sum10 = (dJ0sum10 * dJ00(k1)) + (dJ0sum11 * dJ10(k1))
        dJ1sum01 = (dJ0sum00 * dJ01(k1)) + (dJ0sum01 * dJ11(k1))
        dJ1sum11 = (dJ0sum10 * dJ01(k1)) + (dJ0sum11 * dJ11(k1))

        dJ0sum00 = dJ1sum00 ; dJ0sum10 = dJ1sum10
        dJ0sum01 = dJ1sum01 ; dJ0sum11 = dJ1sum11

        do k = k1, nLayers - 2
          dJ1sum00 = (dJ0sum00 * M00(k + 2)) + (dJ0sum01 * M10(k + 2))
          dJ1sum10 = (dJ0sum10 * M00(k + 2)) + (dJ0sum11 * M10(k + 2))
          dJ1sum01 = (dJ0sum00 * M01(k + 2)) + (dJ0sum01 * M11(k + 2))
          dJ1sum11 = (dJ0sum10 * M01(k + 2)) + (dJ0sum11 * M11(k + 2))

          dJ0sum00 = dJ1sum00 ; dJ0sum10 = dJ1sum10
          dJ0sum01 = dJ1sum01 ; dJ0sum11 = dJ1sum11
        enddo

        drTE(k1, i, jj) = (dJ1sum01 * M1sum11 - dJ1sum11 * M1sum01) * cTmp3
      enddo

      ! k1 = nLayers
      dJ0sum00 = M00(1) ; dJ0sum10 = M10(1)
      dJ0sum01 = M01(1) ; dJ0sum11 = M11(1)

      do k = 1, nLayers - 2
        dJ1sum00 = (dJ0sum00 * M00(k + 1)) + (dJ0sum01 * M10(k + 1))
        dJ1sum10 = (dJ0sum10 * M00(k + 1)) + (dJ0sum11 * M10(k + 1))
        dJ1sum01 = (dJ0sum00 * M01(k + 1)) + (dJ0sum01 * M11(k + 1))
        dJ1sum11 = (dJ0sum10 * M01(k + 1)) + (dJ0sum11 * M11(k + 1))

        dJ0sum00 = dJ1sum00 ; dJ0sum10 = dJ1sum10
        dJ0sum01 = dJ1sum01 ; dJ0sum11 = dJ1sum11
      enddo

      ! k = nLayers - 1
      dJ1sum00 = (dJ0sum00 * dJ00(nLayers)) + (dJ0sum01 * dJ10(nLayers))
      dJ1sum10 = (dJ0sum10 * dJ00(nLayers)) + (dJ0sum11 * dJ10(nLayers))
      dJ1sum01 = (dJ0sum00 * dJ01(nLayers)) + (dJ0sum01 * dJ11(nLayers))
      dJ1sum11 = (dJ0sum10 * dJ01(nLayers)) + (dJ0sum11 * dJ11(nLayers))

      drTE(nLayers, i, jj) = (dJ1sum01 * M1sum11 - dJ1sum11 * M1sum01) * cTmp3
    enddo ! i = 1, nFrequencies
  enddo !jj = 1, nFilter
  end subroutine
  !====================================================================!
end module


c............................................................corehff
      SUBROUTINE corehff(mrad,kap1,kap2,xmj,s,nsol,bhf,gck,fck,
     +                   rc,dx,jtop)
C   ********************************************************************
C   *                                                                  *
C   *   CALCULATE THE RELATIVISTIC HYPERFINE FIELDS FOR THE            *
C   *                  CURRENT  CORE STATE S                           *
C   *                                                                  *
C   *   THE WAVE FUNCTION  {G(K,S),F(K,S)}  IS NORMALIZED TO 1         *
C   *                                                                  *
C   ********************************************************************

      IMPLICIT NONE
C CONVERSION FACTOR FOR HYPERFINE FIELDS FROM A.U. TO GAUSS
C                                      ELECTRON CHARGE     IN ESU
C                                      BOHR-RADIUS         IN CM
c
c
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C   ANGULAR HYPERFINE MATRIX ELEMENTS   SEE E.G.  E.M.ROSE
C        THE FACTOR  I  HAS BEEN OMITTED
C
C     .. Parameters ..
      REAL e0
      PARAMETER (e0=1.6021892e-19*2.997930e+09)
      REAL a0
      PARAMETER (a0=0.52917706e-08)
      REAL cautog
      PARAMETER (cautog=e0/ (a0*a0))
C     ..
C     .. Scalar Arguments ..
      INTEGER, INTENT (IN) :: mrad
      REAL bhf,dx,xmj
      INTEGER jtop,kap1,kap2,nsol,s
C     ..
C     .. Array Arguments ..
      REAL fck(2,2,mrad),gck(2,2,mrad),rc(mrad)
C     ..
C     .. Local Scalars ..
      INTEGER n
C     ..
C     .. Local Arrays ..
      REAL ame(2,2),rint(mrad)
C     ..
C     .. External Functions ..
      REAL rsimp
      EXTERNAL rsimp
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC real,sqrt
C     ..
      ame(1,1) = 4.0*kap1*xmj/ (4.0*kap1*kap1-1.0)
      IF (nsol.EQ.2) THEN
         ame(2,2) = 4.0*kap2*xmj/ (4.0*kap2*kap2-1.0)
         ame(2,1) = sqrt(0.25- (xmj/real(kap1-kap2))**2)
         ame(1,2) = ame(2,1)
      END IF
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      IF (nsol.EQ.1) THEN
         DO n = 1,jtop
            rint(n) = (gck(1,s,n)*fck(1,s,n)+fck(1,s,n)*gck(1,s,n))*
     +                ame(1,1)
         END DO
      ELSE
         DO n = 1,jtop
            rint(n) = (gck(1,s,n)*fck(1,s,n)+fck(1,s,n)*gck(1,s,n))*
     +                ame(1,1) + (gck(2,s,n)*fck(2,s,n)+
     +                fck(2,s,n)*gck(2,s,n))*ame(2,2) +
     +                (gck(2,s,n)*fck(1,s,n)+fck(2,s,n)*gck(1,s,n))*
     +                ame(2,1) + (gck(1,s,n)*fck(2,s,n)+
     +                fck(1,s,n)*gck(2,s,n))*ame(1,2)
         END DO
      END IF
      bhf = -cautog*rsimp(mrad,rint,rc,jtop,dx)*0.001
c      write(oUnit,'(''hf='',e14.7)') BHF
      RETURN
      END


!! Module for Exponential-SDC  sweeper
! =====================================================================================
! MODULE: pf_mod_exp
! !> @author
! Tommaso Buvoli
!
! Last Modified: Dec 28, 2018
!
!> Module for Exponential-SDC sweeper.
!! ==================================
!!  This module extends pf_sweeper_t and is used for creating an exponential sweeper
!!  that solves equations of the form
!!         $$   y' = L y + N(t,y)  $$
!!  When extending this class, you must supply the functions phib, swpPhib, and resPhib
!!  that each compute matrix-vector products of the form
!!         $$ \sum_{i=0}^n t^i \varphi_i(tL)b_i $$
!!  in addition to the function f_eval for compluting the nonlinear term N(t,y).
!!  The complete description of these three functions is contained below.
module pf_mod_exp_sweeper

use pf_mod_dtype
use pf_mod_utils

implicit none

!> Exponential SDC sweeper type, extends abstract pf_sweeper_t
type, extends(pf_sweeper_t), abstract :: pf_exp_t

    real(pfdp),        allocatable :: w(:,:,:)   ! weights
    real(pfdp),        allocatable :: nodes(:)   ! nodes
    real(pfdp),        allocatable :: eta(:)     ! normalized substeps (on interval [0, 1])
    class(pf_encap_t), allocatable :: b(:)       ! scratch space for computing nonlinear derivatives
    class(pf_encap_t), allocatable :: f_old(:)   ! scratch space for storing nonlinear terms
    class(pf_encap_t), allocatable :: newF       ! scratch space for storing new function evaluations
    LOGICAL :: use_phib=.true.                  ! if TRUE calls phib otherwise calls swpPhib and resPhib (reset in derived sweeper)

    contains

        ! specialized procedures for exponential integrator
        procedure(pf_f_eval_p), deferred :: f_eval    ! computes nonlinear term in equation
        procedure(pf_phib),     deferred :: phib      ! computes x(t) = \sum_{i=0}^n t^i \varphi_i(tL)b_i
        procedure(pf_swpPhib),  deferred :: swpPhib   ! computes x(t) = \sum_{i=0}^n t^i \varphi_i(tL)b_i where t = t_{n,j+1} - t_{n,j} for j = 1, ... q - 1
        procedure(pf_resPhib),  deferred :: resPhib   ! computes x(t) = \sum_{i=0}^n t^i \varphi_i(tL)b_i where t = t_{n,j+1} - t_{n} for j = 1, ... q - 1
        procedure, private :: weights
        procedure, private :: LocalDerivsAtNode
        ! generic functions
        procedure :: initialize   => exp_initialize
        procedure :: sweep        => exp_sweep
        procedure :: evaluate     => exp_evaluate
        procedure :: integrate    => exp_integrate
        procedure :: residual     => exp_residual
        procedure :: spreadq0     => exp_spreadq0
        procedure :: compute_dt   => exp_compute_dt
        procedure :: evaluate_all => exp_evaluate_all
        procedure :: destroy      => exp_destroy
        ! functions that can be accessed directly by types that inherit pf_exp_t
        procedure :: exp_destroy
        procedure :: exp_initialize

    end type pf_exp_t

    interface ! DESCRIPTION OF REQUIRED FUNCTIONS

        ! =================================================================================             REMARK: ADDING ax operation would simplify dealing with h for b(2:end)
        ! PHIB: Computes the product of vectors and phi functions
        !
        !       y(t) = exp(t h L) b_1 + h \sum_{i=1}^n t^i \varphi_i(t h L)b_{i+1}
        !
        !       for a user specified t, and h.
        !
        !       NOTE: The operator L is not passed in as a parameter, and must be
        !       implemented appropriately within the function.
        !
        ! Arguments
        !
        !   t   (input) DOUBLE
        !       evaluation time for expression
        !
        !   h   (input) DOUBLE
        !       scaling factor for the linear opeartor AND the vectors b_i for i = 2 ... n
        !
        !   b   (input) pf_encap_t(:)
        !       array that stores the vectors b_i
        !
        !   y   (output) pf_encap_t
        !       once subroutine terminate this stores the result y(t)
        ! =================================================================================

        subroutine pf_phib(this, t, h, b, y)
            import pf_exp_t, pf_encap_t, pfdp
            class(pf_exp_t),    intent(inout) :: this
            real(pfdp),         intent(in)    :: t
            real(pfdp),         intent(in)    :: h
            class(pf_encap_t),  intent(in)    :: b(:)
            class(pf_encap_t),  intent(inout) :: y
        end subroutine pf_phib

        ! =================================================================================
        ! SWPPHIB: Computes the product of vectors and phi functions
        !
        !           y(t) = \varphi_0(h L) b_1 + h \sum_{i=1}^n t^i \varphi_i(t h L)b_{i+1}
        !
        !       where the time t is
        !
        !           t_{n,j+1} - t_{n,j}         j = 1, ... q - 1
        !
        !       and h is a user specified. This procedure is used when computing
        !       exponential correction sweeps.
        !
        !       NOTE: The operator L is not passed in as a parameter, and must be
        !       implemented appropriately within the function.
        !
        ! Arguments
        !
        !   j   (input) Integer
        !       substep index for determining t: t = t_{n,j+1} - t_{n,j}
        !
        !   h   (input) DOUBLE
        !       scaling factor for the linear opeartor AND the vectors b_i for i = 2 ... n
        !
        !   b   (input) pf_encap_t(:)
        !       array that stores the vectors b_i
        !
        !   y   (output) pf_encap_t
        !       once subroutine terminate this stores the result y(t)
        ! =================================================================================

        subroutine pf_swpPhib(this, j, h, b, y)
            import pf_exp_t, pf_encap_t, pfdp
            class(pf_exp_t),    intent(inout) :: this
            integer,            intent(in)    :: j
            real(pfdp),         intent(in)    :: h
            class(pf_encap_t),  intent(in)    :: b(:)
            class(pf_encap_t),  intent(inout) :: y
        end subroutine pf_swpPhib

        ! =================================================================================
        ! RESPHIB: Computes the product of vectors and phi functions
        !
        !           y(t) = \varphi_0(h L) b_1 + h \sum_{i=1}^n t^i \varphi_i(t h L)b_{i+1}
        !
        !       where the time t is
        !
        !           t_{n,j} - t_{n}
        !
        !       and h is a user specified. This procedure is used when computing
        !       exponential correction sweeps.
        !
        !       NOTE: The operator L is not passed in as a parameter, and must be
        !       implemented appropriately within the function.
        !
        ! Arguments
        !
        !   j   (input) Integer
        !       substep index for determining t: t = t_{n,j+1} - t_{n}
        !
        !   h   (input) DOUBLE
        !       scaling factor for the linear opeartor AND the vectors b_i for i = 2 ... n
        !
        !   b   (input) pf_encap_t(:)
        !       array that stores the vectors b_i
        !
        !   y   (output) pf_encap_t
        !       once subroutine terminate this stores the result y(t)
        ! =================================================================================

        subroutine pf_resPhib(this, j, h, b, y)
            import pf_exp_t, pf_encap_t, pfdp
            class(pf_exp_t),    intent(inout) :: this
            integer,            intent(in)    :: j
            real(pfdp),         intent(in)    :: h
            class(pf_encap_t),  intent(in)    :: b(:)
            class(pf_encap_t),  intent(inout) :: y
        end subroutine pf_resPhib

        ! =================================================================================
        ! f_eval: computes the equations nonlinear term N(t,y)
        !
        ! Arguments
        !
        !   y     (input) pf_encap_t
        !         solution y(t)
        !
        !   t     (input) DOUBLE
        !         time t
        !
        !   level_index (input) INTEGER
        !         current level index
        !
        !   f     (output) pf_encap_t
        !         N(t,y)
        ! =================================================================================

        subroutine pf_f_eval_p(this, y, t, level_index, n)
            import pf_exp_t, pf_encap_t, pfdp
            class(pf_exp_t),   intent(inout) :: this
            class(pf_encap_t), intent(in)    :: y
            real(pfdp),        intent(in)    :: t
            integer,           intent(in)    :: level_index
            class(pf_encap_t), intent(inout) :: n
        end subroutine pf_f_eval_p

    end interface

    contains

    ! =================================================================================
    ! INITIALIZE: initializes the following internal parameters
    !      w        DOUBLE(:,:,:)     contains FD weights for computing local derivatives at t_{n,j}
    !      nodes    DOUBLE(:)         sdc nodes
    !      eta      DOUBLE(:)         normalized substeps (t_{n,j+1} - t_{n,j})/h
    !      npieces  INTEGER           number of RHS peices (always will be one)
    !      newF     pf_encap_t        stores new function evaluations
    !      b        pf_encap_t(:)     stores vectors b for computing phi products
    ! =================================================================================

    subroutine exp_initialize(this, pf,level_index)

        ! arguments
        class(pf_exp_t),   intent(inout) :: this
        type(pf_pfasst_t), target, intent(inout) :: pf
        integer,              intent(in)    :: level_index

        ! local variables
        integer :: i, nnodes,ierr
        real(pfdp), allocatable :: q(:)

        type(pf_level_t), pointer :: lev
        lev => pf%levels(level_index)
        nnodes = lev%nnodes
        allocate(this%eta(nnodes - 1),stat=ierr)
        if (ierr /=0) call pf_stop(__FILE__,__LINE__,'allocate fail, error=',ierr)
        allocate(this%nodes(nnodes),stat=ierr)
        if (ierr /=0) call pf_stop(__FILE__,__LINE__,'allocate fail, error=',ierr)
        allocate(q(nnodes),stat=ierr)
        if (ierr /=0) call pf_stop(__FILE__,__LINE__,'allocate fail, error=',ierr)
        ! set nodes and substeps
        this%nodes = lev%sdcmats%qnodes
        this%eta = this%nodes(2 : nnodes) - this%nodes(1 : nnodes - 1) ! substeps
        ! compute weights
        allocate(this%w(nnodes - 1, nnodes, nnodes),stat=ierr)
        if (ierr /=0) call pf_stop(__FILE__,__LINE__,'allocate fail, error=',ierr)

        do i = 1, nnodes - 1
            q = this%nodes - this%nodes(i);
            call weights(this, REAL(0.0, pfdp), q, nnodes - 1, this%W(i,:,:))
        end do
        ! set number of rhs components
        this%npieces = 1
        ! initialize temporary storage objects
        call lev%ulevel%factory%create_single(this%newF, lev%index, lev%lev_shape)
        call lev%ulevel%factory%create_array(this%b, nnodes + 1, lev%index, lev%lev_shape)
        call lev%ulevel%factory%create_array(this%f_old, nnodes, lev%index, lev%lev_shape)

    end subroutine exp_initialize

    ! SWEEP: exponential sweep subroutine ===============================================
    subroutine exp_sweep(this, pf, level_index, t0, dt,nsweeps, flags)

        use pf_mod_timer
        use pf_mod_hooks

        ! arguments
        class(pf_exp_t),   intent(inout) :: this
        type(pf_pfasst_t), intent(inout), target :: pf   !!  PFASST structure
        integer,           intent(in)    :: level_index  !!  which level to sweep on
        real(pfdp),        intent(in)    :: t0           !!  Time at beginning of time step
        real(pfdp),        intent(in)    :: dt           !!  time step size
        integer,           intent(in)    :: nsweeps      !!  number of sweeps to do
        integer, optional, intent(in)    :: flags

        ! local variables
        type(pf_level_t), pointer :: lev
        integer                    :: m, nnodes, j, k
        real(pfdp)                 :: t

        lev => pf%levels(level_index)
        nnodes = lev%nnodes
        ! error sweeps
        do k = 1, nsweeps
           call call_hooks(pf, level_index, PF_PRE_SWEEP)
           if (pf%save_timings > 1) call pf_start_timer(pf, T_SWEEP,level_index)

           pf%state%sweep=k
           ! NOTE: ensure that lev%F has been properly initialized here
           do j = 1, nnodes
              call this%f_old(j)%copy(lev%F(j,1))  ! Save old f
           end do
           if (k .eq. 1) then
              call lev%Q(1)%copy(lev%q0)
              if (pf%save_timings > 1) call pf_start_timer(pf, T_FEVAL,level_index)
              call this%f_eval(lev%Q(1), t0, level_index, lev%F(1,1))      ! compute F_j^{[k+1]}
              if (pf%save_timings > 1) call pf_stop_timer(pf, T_FEVAL,level_index)
           end if
           t = t0
           do j = 1, nnodes - 1
              t = t0 + dt * this%eta(j)
              ! form b vectors
              call LocalDerivsAtNode(this, j, nnodes, this%f_old, this%b)  ! phi expansion for exponential picard integral
              call this%b(1)%copy(lev%Q(j))  ! add term \phi_0(tL) y_n

              call this%b(2)%axpy(REAL(-1.0, pfdp), this%f_old(j))         ! add -\phi_1(tL) F_j^{[k]}
              if (pf%save_timings > 1) call pf_start_timer(pf, T_FEVAL,level_index)
              call this%f_eval(lev%Q(j), t, level_index, lev%F(j,1))      ! compute F_j^{[k+1]}
              if (pf%save_timings > 1) call pf_stop_timer(pf, T_FEVAL,level_index)
              call this%b(2)%axpy(REAL(1.0, pfdp), lev%F(j,1))          ! add \phi_1(tL) F_j^{[k+1]}

              ! compute phi products
              if (this%use_phib) then
                 call this%phib(this%eta(j), dt, this%b, lev%Q(j+1))
              else
                 call this%swpPhib(j, dt, this%b, lev%Q(j+1))
              end if

              !  Now we have to add in the tauQ
              if (level_index < pf%state%finest_level) then

                 call lev%Q(j+1)%axpy(1.0_pfdp, lev%tauQ(j))
                 if (j > 1) then     ! The tau is not node to node, so subtract out
                    call lev%Q(j+1)%axpy(-1.0_pfdp, lev%tauQ(j-1))
                 end if
              end if

           end do  !  Substepping over nodes
           if (pf%save_timings > 1) call pf_start_timer(pf, T_FEVAL,level_index)
           call this%f_eval(lev%Q(nnodes), t0 + dt, level_index, lev%F(nnodes,1))   ! eval last nonlinear term
           if (pf%save_timings > 1) call pf_stop_timer(pf, T_FEVAL,level_index)

           call pf_residual(pf, level_index, dt)
           call lev%qend%copy(lev%Q(lev%nnodes))
           if (pf%save_timings > 1) call pf_stop_timer(pf, T_SWEEP,level_index)
           call call_hooks(pf, level_index, PF_POST_SWEEP)

        end do  !  Sweeps
    end subroutine exp_sweep

    ! =================================================================================
    ! INTEGRATE: computes the integrals for the exponential Picard residual
    !
    !         r_j = A_j - B_j
    !
    !     where
    !
    !         A_j = \left[ \exp(t h L) y(t_n) - \int_{t_n}^{t_{n,j}} \exp(L(t - t_n)) P(t) dt \right]
    !         B_j = y(t_{n,j})
    !
    !     NOTE: This procedure computes the expression \hat{r}_j = A_j - y(t_n). The
    !     term y(t_n) is subtracted from result since the generic calling function
    !     compute the residual as
    !
    !        r_j = y(t_n) + exp_integrate() - y(t_{n,j})
    !
    !     thus incorrectly adding the term y_n
    ! =================================================================================

    subroutine exp_integrate(this, pf,level_index, qSDC, fSDC, dt, fintsdc, flags)
      class(pf_exp_t),   intent(inout) :: this
      type(pf_pfasst_t), target, intent(inout) :: pf
      integer,              intent(in)    :: level_index
      class(pf_encap_t), intent(in   ) :: qSDC(:)      !!  Solution values
      class(pf_encap_t), intent(in   ) :: fSDC(:, :)   !!  RHS Function values
      real(pfdp),        intent(in   ) :: dt           !!  Time step
      class(pf_encap_t), intent(inout) :: fintsdc(:)   !!  Integral from t_n to t_m
      integer, optional, intent(in   ) :: flags

      ! local variables
      integer :: i, nnodes
      type(pf_level_t), pointer :: lev
      lev => pf%levels(level_index)   !  Assign level pointer

      nnodes = lev%nnodes

      do i = 1, nnodes
         call this%f_old(i)%copy(fSDC(i,1))  ! Save old f
      end do

      do i = 1, nnodes - 1 ! loop over integrals : compute \int_{t_{n,i}}^{t_{n, i + 1}}
         call LocalDerivsAtNode(this, i, nnodes, this%f_old, this%b) ! compute derivatives

         call this%b(1)%copy(qSDC(i))

         call fintsdc(i)%setval(0.0_pfdp)
         if (this%use_phib) then
            call this%phib(this%eta(i), dt, this%b, fintsdc(i))
         else
            call this%swpPhib(i, dt, this%b, fintsdc(i))
         end if

         call fintsdc(i)%axpy(-1.0_pfdp,qSDC(i))
         if (i > 1) then
            call fintsdc(i)%axpy(1.0_pfdp,fintsdc(i-1))
         end if
      end do

    end subroutine exp_integrate

    ! RESIDUAL: compute  residual (generic) ====================================
    subroutine exp_residual(this, pf, level_index, dt, flags)

      class(pf_exp_t),  intent(inout)  :: this
      type(pf_pfasst_t), target, intent(inout) :: pf
      integer,              intent(in)    :: level_index
      real(pfdp),             intent(in)    :: dt
      integer, intent(in), optional    :: flags

      integer :: m
      type(pf_level_t), pointer :: lev
      lev => pf%levels(level_index)   !  Assign level pointer

      !>  Compute the integral of F from t_n to t_m at each node
      call lev%ulevel%sweeper%integrate(pf,level_index, lev%Q, lev%F, dt, lev%I, flags)

      !> add tau if it exists
      if (level_index < pf%state%finest_level) then
         do m = 1, lev%nnodes-1
            call lev%I(m)%axpy(1.0_pfdp, lev%tauQ(m), flags)
         end do
      end if

      !> subtract out the solution value
      do m = 1, lev%nnodes-1
         call lev%R(m)%copy(lev%I(m))
         call lev%R(m)%axpy(-1.0_pfdp, lev%Q(m+1))
         call lev%R(m)%axpy(1.0_pfdp, lev%Q(1))
      end do

    end subroutine exp_residual

    ! SPREADQ: spread solution (generic) ======================================
    subroutine exp_spreadq0(this, pf,level_index, t0, flags, step)
      class(pf_exp_t),  intent(inout)  :: this
      type(pf_pfasst_t), target, intent(inout) :: pf
      integer,              intent(in)    :: level_index
      real(pfdp),        intent(in   ) :: t0
      integer, optional,   intent(in)  :: flags, step

      type(pf_level_t), pointer :: lev
      lev => pf%levels(level_index)   !  Assign level pointer

      call pf_generic_spreadq0(this, pf,level_index, t0)

    end subroutine exp_spreadq0

    ! EVALUATE: evaluate the nonlinear term at node m ========================
    subroutine exp_evaluate(this, pf,level_index, t, m, flags, step)
      ! arguments
      class(pf_exp_t),   intent(inout) :: this
      type(pf_pfasst_t), target, intent(inout) :: pf
      integer,              intent(in)    :: level_index
      real(pfdp),        intent(in   ) :: t    !!  Time at which to evaluate
      integer,           intent(in   ) :: m    !!  Node at which to evaluate
      integer, intent(in), optional    :: flags, step

      type(pf_level_t), pointer :: lev
      lev => pf%levels(level_index)   !  Assign level pointer
      if (pf%save_timings > 1) call pf_start_timer(pf, T_FEVAL,level_index)
      call this%f_eval(lev%Q(m), t, level_index, lev%F(m,1))
      if (pf%save_timings > 1) call pf_stop_timer(pf, T_FEVAL,level_index)
    end subroutine exp_evaluate

    ! EVALUATE_ALL: evaluate the nonlinear term at all nodes =================
    subroutine exp_evaluate_all(this, pf,level_index, t, flags, step)
      ! arguments
      class(pf_exp_t),  intent(inout)  :: this
      type(pf_pfasst_t), target, intent(inout) :: pf
      integer,              intent(in)    :: level_index
      real(pfdp),        intent(in   ) :: t(:)     !!  Array of times at each node
      integer, intent(in), optional    :: flags, step

      type(pf_level_t), pointer :: lev
      lev => pf%levels(level_index)   !  Assign level pointer

      call pf_generic_evaluate_all(this,pf, level_index, t)

    end subroutine exp_evaluate_all

    ! DEALLOCATE: deallocate sweeper variables
    subroutine exp_destroy(this, pf,level_index)
      ! arguments
      class(pf_exp_t),   intent(inout) :: this
      type(pf_pfasst_t), target, intent(inout) :: pf
      integer,              intent(in)    :: level_index

      type(pf_level_t), pointer :: lev
      lev => pf%levels(level_index)   !  Assign level pointer

        deallocate(this%w)
        deallocate(this%eta)
        deallocate(this%newF)
        call lev%ulevel%factory%destroy_array(this%b)
        call lev%ulevel%factory%destroy_array(this%f_old)
    end subroutine exp_destroy

    ! =======================================================================
    ! LocalDerivsAtNode: approximate the local derivative vector
    !           at the substep t_{n,i} for the nonlinear function N(y(t))
    !           using the terms N(y{n,i}). Local coordinates coorespond to
    !           s = h t.
    ! Arguments
    !
    !   i       (input) INTEGER
    !           index of the substep for which we want to approximate derivatives
    !
    !   nnodes  (input) INTEGER
    !           number of nodes
    !
    !   N_eval  (input) pf_encap_t(:)
    !           Nonlinear function evaluations; N_eval(i) contains N(y_{n,i})
    !
    !   N_deriv (output) pf_encap_t(:)
    !           N_deriv(i) approximates \frac{d^{i-1}}{dt^{i-1}} N(y(t))
    ! =======================================================================

    subroutine LocalDerivsAtNode(this, i, nnodes, N_eval, N_deriv)
        ! arguments
        class(pf_exp_t),   intent(inout) :: this
        integer,           intent(in)    :: i
        integer,           intent(in)    :: nnodes
        class(pf_encap_t), intent(in)    :: N_eval(:)
        class(pf_encap_t), intent(inout) :: N_deriv(:)
        ! local variables
        integer :: j, k

        ! form nonlinear derivative vectors b
        do j = 1, nnodes                                                ! loop over derivatives j = 1 ... n
            call N_deriv(j+1)%setval(REAL(0.0, pfdp))
            do k = 1, nnodes                                            ! look over nodes k = 1 ... n
                call N_deriv(j+1)%axpy(this%w(i, k, j), N_eval(k))
            end do
        end do
      end subroutine LocalDerivsAtNode

    ! =======================================================================
    ! WEIGHTS   Compute coefficients for finite difference approximation for
    !           the derivatives 1 to m at point z assuming data is known at
    !           points in array x. Based on the program "weights" in
    !           B. Fornberg, "Calculation of weights in finite difference
    !           formulas", SIAM Review 40 (1998), pp. 685-691.
    ! Arguments
    !
    !   z   (input) DOUBLE
    !       location where approximations are to be accurate
    !
    !   x   (input) DOUBLE Array
    !       array containing interpolation points
    !
    !   m   (input) INTEGER
    !       highest derivative for which weights are sought
    !
    !   W   (output) DOUBLE array, dimension(size(x),m+1)
    !       matrix that gives weights at grid locations x for
    !       derivative of order j<=m are found in c(:,j)
    ! =======================================================================

    subroutine weights(this, z, x, m, W)

        ! Arguments
        class(pf_exp_t),  intent(inout)  :: this
        real(pfdp), intent(in)    :: z
        real(pfdp), intent(inout)    :: x(:)
        integer,    intent(in)    :: m
        real(pfdp), intent(out)   :: W(m+1,m+1)

        ! Variable Declarations
        real(pfdp) :: c1, c2, c3, c4, c5
        integer  :: ii,i,j,k,n,mn

        !        do ii = 1, m
!        x = this%nodes - this%nodes(ii);

           c1 = 1.0_pfdp
           c4 = x(1) - z
           W  = 0.0_pfdp
           W(1,1) = 1.0_pfdp

           n = SIZE(x)
           do i=2,n
              mn = min(i,m+1)
              c2 = 1.0_pfdp
              c5 = c4
              c4 = x(i) - z
              do j=1,i-1
                 c3 = x(i) - x(j)
                 c2 = c2*c3;
                 if(j == i-1) then
                    do k=mn,2,-1
                       W(i,k) = c1*(REAL(k-1,pfdp)*W(i-1,k-1) - c5*W(i-1,k))/c2;
                    enddo

                    W(i,1) = -c1*c5*W(i-1,1)/c2;
                 endif
                 do k=mn,2,-1
                    W(j,k) = (c4*W(j,k) - REAL(k-1,pfdp)*W(j,k-1))/c3;
                 enddo
                 W(j,1) = c4*W(j,1)/c3;
              enddo
              c1 = c2;
           enddo
!        end do

end subroutine weights
        subroutine exp_compute_dt(this,pf,level_index,  t0, dt,flags)
          class(pf_exp_t),  intent(inout) :: this
          type(pf_pfasst_t), target, intent(inout) :: pf
          integer,              intent(in)    :: level_index
          real(pfdp),        intent(in   ) :: t0
          real(pfdp),        intent(inout) :: dt
          integer, optional,   intent(in)    :: flags

          type(pf_level_t),    pointer :: lev
          lev => pf%levels(level_index)   !!  Assign level pointer
          !  Do nothing now
          return
        end subroutine exp_compute_dt

end module pf_mod_exp_sweeper


!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the 'Software'), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!

module MBreadthFirstSearch

    use MArrayQueue
    use MGraph
    use MVertex

    implicit none
    private

    type, public :: TBreadthFirstSearch
    contains
        procedure, nopass :: search
    end type
contains
    function search(graph) result(sequence)
        class(TGraph), intent(in out) :: graph

        logical, dimension(:,:), pointer     :: adjacencyMatrix
        type(TVertex), dimension(:), pointer :: vertexList
        integer, dimension(:), pointer       :: sequence
        type(TArrayQueue) :: queue

        integer vertexNumber
        integer vertex
        integer index

        adjacencyMatrix => graph%getAdjacencyMatrix()
        vertexList      => graph%getVertexlist()
        vertexNumber    =  graph%getVertexNumber()

        allocate(sequence(size(vertexList)))

        call vertexList(1)%setVisited(.true.)
        call queue%init()

        index = 1
        sequence(index) = vertexList(index)%getValue()
        call queue%push(vertexList(index)%getValue())

        do while (queue%empty() == .false.)
            vertex = getAdjacencyUnvisitedVertex(adjacencyMatrix, vertexList, vertexNumber, queue%peek())

            if (vertex == 0) then
                vertex = queue%pop()
            else
                call vertexList(vertex).setVisited(.true.)
                call queue%push(vertex)

                index = index + 1
                sequence(index) = vertex
            end if
        end do

        do index = 1, vertexNumber
            call vertexList(index).setVisited(.false.)
        end do

        call queue%destroy()
    end function

    function getAdjacencyUnvisitedVertex(adjacencyMatrix, vertexList, vertexNumber, vertex) result(value)
        logical, dimension(:,:)     :: adjacencyMatrix
        type(TVertex), dimension(:) :: vertexList
        integer, intent(in)         :: vertexNumber
        integer, intent(in)         :: vertex
        integer :: value

        integer index

        do index = 1, vertexNumber
            if ((adjacencyMatrix(vertex, index) == .true.) &
                    .and. (vertexList(index)%isVisited() == .false.)) then
                value = index
                return
            end if
        end do

        value = 0
    end function
end module