submodule (reconstruction) weno5
implicit none
! fifth order weno coefficients
double precision,parameter :: a300 = 1.d0/3.d0
double precision,parameter :: a301 =-7.d0/6.d0
double precision,parameter :: a302 = 11.d0/6.d0
double precision,parameter :: a310 =-1.d0/6.d0
double precision,parameter :: a311 = 5.d0/6.d0
double precision,parameter :: a312 = 1.d0/3.d0
double precision,parameter :: a320 = 1.d0/3.d0
double precision,parameter :: a321 = 5.d0/6.d0
double precision,parameter :: a322 =-1.d0/6.d0
double precision,parameter :: c30  = 0.1d0
double precision,parameter :: c31  = 0.6d0
double precision,parameter :: c32  = 0.3d0

double precision,parameter :: ss   = 1.0e-20

contains
module subroutine reconst_component_scalar_wenojs5(h,f,lo,hi,padding,bias,axis)
  implicit none
  type(rscalarfield_t),intent(inout) :: h
  type(rscalarfield_t),target,intent(in) :: f
  type(fscalarshape_t),intent(in) :: lo,hi,padding
  integer,intent(in) :: bias,axis

  double precision,dimension(:,:),pointer :: f0
  double precision,dimension(:,:),pointer :: f1
  double precision,dimension(:,:),pointer :: f2
  double precision,dimension(:,:),pointer :: f3
  double precision,dimension(:,:),pointer :: f4
  integer :: filo,fihi, &
             fjlo,fjhi

  double precision :: is0,is1,is2
  double precision :: aa0,aa1,aa2,aa_sum
  double precision :: w0,w1,w2
  double precision :: q30,q31,q32
  integer :: i,j
  integer,dimension(5) :: shift

  if(bias.eq.bias_upwind) then
    shift = (/-2,-1,0,1,2/)
  else
    shift = (/3,2,1,0,-1/)
  endif
  filo = lo%d(1) + padding%d(1)
  fihi = hi%d(1) + padding%d(1)
  fjlo = lo%d(2) + padding%d(2)
  fjhi = hi%d(2) + padding%d(2)
  select case(axis)
  case(axis_xi)
    f0 => f%p(filo+shift(1):fihi+shift(1),fjlo:fjhi)
    f1 => f%p(filo+shift(2):fihi+shift(2),fjlo:fjhi)
    f2 => f%p(filo+shift(3):fihi+shift(3),fjlo:fjhi)
    f3 => f%p(filo+shift(4):fihi+shift(4),fjlo:fjhi)
    f4 => f%p(filo+shift(5):fihi+shift(5),fjlo:fjhi)
  case(axis_eta)
    f0 => f%p(filo:fihi,fjlo+shift(1):fjhi+shift(1))
    f1 => f%p(filo:fihi,fjlo+shift(2):fjhi+shift(2))
    f2 => f%p(filo:fihi,fjlo+shift(3):fjhi+shift(3))
    f3 => f%p(filo:fihi,fjlo+shift(4):fjhi+shift(4))
    f4 => f%p(filo:fihi,fjlo+shift(5):fjhi+shift(5))
  case default
    print*,"Error: reconst_component_scalar_wenojs5()"
    print*,"No such ireconst: ",axis
    stop
  end select

  do j=lo%d(2), hi%d(2)
    do i=lo%d(1), hi%d(1)
      is0 = (f0(i,j) - 2.d0*f1(i,j) + f2(i,j))**2*13.d0/12.d0 &
           +(f1(i,j) - 4.d0*f2(i,j) + 3.d0*f3(i,j))**2/4.d0

      is1 = (f1(i,j) - 2.d0*f2(i,j)+f3(i,j))**2*13.d0/12.d0 &
           +(f1(i,j) - f3(i,j))**2/4.d0

      is2 = (f2(i,j) - 2.d0*f3(i,j) + f4(i,j))**2*13.d0/12.d0 &
           +(3.d0*f2(i,j) - 4.d0*f3(i,j) + f4(i,j))**2/4.d0

      aa0 = c30/(ss+is0)**2
      aa1 = c31/(ss+is1)**2
      aa2 = c32/(ss+is2)**2
      aa_sum = 1.d0/(aa0+aa1+aa2)

      w0 = aa0*aa_sum
      w1 = aa1*aa_sum
      w2 = aa2*aa_sum

      q30 = a300*f0(i,j) + a301*f1(i,j) + a302*f2(i,j)
      q31 = a310*f1(i,j) + a311*f3(i,j) + a312*f3(i,j)
      q32 = a320*f2(i,j) + a321*f3(i,j) + a322*f4(i,j)

      h%p(i,j) = w0*q30 + w1*q31 + w2*q32
    enddo
  enddo
end subroutine reconst_component_scalar_wenojs5

module subroutine reconst_component_vector_wenojs5(h,f,lo,hi,padding,bias,axis)
  implicit none
  type(rvectorfield_t),intent(inout) :: h
  type(rvectorfield_t),target,intent(in) :: f
  type(fvectorshape_t),intent(in) :: lo,hi,padding
  integer,intent(in) :: bias,axis

  double precision,dimension(:,:,:),pointer :: f0
  double precision,dimension(:,:,:),pointer :: f1
  double precision,dimension(:,:,:),pointer :: f2
  double precision,dimension(:,:,:),pointer :: f3
  double precision,dimension(:,:,:),pointer :: f4
  integer :: fnlo,fnhi, &
             filo,fihi, &
             fjlo,fjhi

  double precision,dimension(lo%d(1):hi%d(1)) :: is0,is1,is2
  double precision,dimension(lo%d(1):hi%d(1)):: aa0,aa1,aa2,aa_sum
  double precision,dimension(lo%d(1):hi%d(1)) :: w0,w1,w2
  double precision,dimension(lo%d(1):hi%d(1)) :: q30,q31,q32
  integer :: i,j
  integer,dimension(5) :: shift
  if(bias.eq.bias_upwind) then
    shift = (/-2,-1,0,1,2/)
  else
    shift = (/3,2,1,0,-1/)
  endif
  fnlo = lo%d(1) + padding%d(1)
  fnhi = hi%d(1) + padding%d(1)
  filo = lo%d(2) + padding%d(2)
  fihi = hi%d(2) + padding%d(2)
  fjlo = lo%d(3) + padding%d(3)
  fjhi = hi%d(3) + padding%d(3)
  select case(axis)
  case(axis_xi)
    f0 => f%p(fnlo:fnhi,filo+shift(1):fihi+shift(1),fjlo:fjhi)
    f1 => f%p(fnlo:fnhi,filo+shift(2):fihi+shift(2),fjlo:fjhi)
    f2 => f%p(fnlo:fnhi,filo+shift(3):fihi+shift(3),fjlo:fjhi)
    f3 => f%p(fnlo:fnhi,filo+shift(4):fihi+shift(4),fjlo:fjhi)
    f4 => f%p(fnlo:fnhi,filo+shift(5):fihi+shift(5),fjlo:fjhi)
  case(axis_eta)
    f0 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(1):fjhi+shift(1))
    f1 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(2):fjhi+shift(2))
    f2 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(3):fjhi+shift(3))
    f3 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(4):fjhi+shift(4))
    f4 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(5):fjhi+shift(5))
  case default
    print*,"Error: reconst_component_vector_wenojs5()"
    print*,"No such ireconst: ",axis
    stop
  end select

  do j=lo%d(3), hi%d(3)
    do i=lo%d(2), hi%d(2)
      is0(:) = (f0(:,i,j)-2.d0*f1(:,i,j)+f2(:,i,j))**2*13.d0/12.d0 &
              +(f0(:,i,j)-4.d0*f1(:,i,j)+3.d0*f2(:,i,j))**2/4.d0

      is1(:) = (f1(:,i,j)-2.d0*f2(:,i,j)+f3(:,i,j))**2*13.d0/12.d0 &
              +(f1(:,i,j)-f3(:,i,j))**2/4.d0

      is2(:) = (f2(:,i,j)-2.d0*f3(:,i,j)+f4(:,i,j))**2*13.d0/12.d0 &
              +(3.d0*f2(:,i,j)-4.d0*f3(:,i,j)+f4(:,i,j))**2/4.d0

      aa0(:)    = c30/(ss+is0(:))**2
      aa1(:)    = c31/(ss+is1(:))**2
      aa2(:)    = c32/(ss+is2(:))**2
      aa_sum(:) = 1.d0/(aa0(:)+aa1(:)+aa2(:))

      w0(:) = aa0(:)*aa_sum(:)
      w1(:) = aa1(:)*aa_sum(:)
      w2(:) = aa2(:)*aa_sum(:)

      q30(:) = a300*f0(:,i,j) + a301*f1(:,i,j) + a302*f2(:,i,j)
      q31(:) = a310*f1(:,i,j) + a311*f2(:,i,j) + a312*f3(:,i,j)
      q32(:) = a320*f2(:,i,j) + a321*f3(:,i,j) + a322*f4(:,i,j)

      h%p(lo%d(1):hi%d(1),i,j) = w0(:)*q30(:) + w1(:)*q31(:) + w2(:)*q32(:)
    enddo
  enddo
end subroutine reconst_component_vector_wenojs5

module subroutine reconst_component_matrix_wenojs5(h,f,lo,hi,padding,bias,axis)
  implicit none
  type(rmatrixfield_t),intent(inout) :: h
  type(rmatrixfield_t),target,intent(in) :: f
  type(fmatrixshape_t),intent(in) :: lo,hi,padding
  integer,intent(in) :: bias,axis

  double precision,dimension(:,:,:,:),pointer :: f0
  double precision,dimension(:,:,:,:),pointer :: f1
  double precision,dimension(:,:,:,:),pointer :: f2
  double precision,dimension(:,:,:,:),pointer :: f3
  double precision,dimension(:,:,:,:),pointer :: f4
  integer :: fmlo,fmhi, &
             fnlo,fnhi, &
             filo,fihi, &
             fjlo,fjhi

  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2)) :: is0,is1,is2
  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2)) :: aa0,aa1,aa2,aa_sum
  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2)) :: w0,w1,w2
  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2)) :: q30,q31,q32
  integer :: i,j
  integer,dimension(5) :: shift
  if(bias.eq.bias_upwind) then
    shift = (/-2,-1,0,1,2/)
  else
    shift = (/3,2,1,0,-1/)
  endif
  fmlo = lo%d(1) + padding%d(1)
  fmhi = hi%d(1) + padding%d(1)
  fnlo = lo%d(2) + padding%d(2)
  fnhi = hi%d(2) + padding%d(2)
  filo = lo%d(3) + padding%d(3)
  fihi = hi%d(3) + padding%d(3)
  fjlo = lo%d(4) + padding%d(4)
  fjhi = hi%d(4) + padding%d(4)
  select case(axis)
  case(axis_xi)
    f0 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(1):fihi+shift(1),fjlo:fjhi)
    f1 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(2):fihi+shift(2),fjlo:fjhi)
    f2 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(3):fihi+shift(3),fjlo:fjhi)
    f3 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(4):fihi+shift(4),fjlo:fjhi)
    f4 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(5):fihi+shift(5),fjlo:fjhi)
  case(axis_eta)
    f0 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(1):fjhi+shift(1))
    f1 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(2):fjhi+shift(2))
    f2 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(3):fjhi+shift(3))
    f3 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(4):fjhi+shift(4))
    f4 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(5):fjhi+shift(5))
  case default
    print*,"Error: reconst_component_matrix_wenojs5()"
    print*,"No such ireconst: ",axis
    stop
  end select
  do j = lo%d(4), hi%d(4)
    do i = lo%d(3), hi%d(3)
      is0(:,:) = (f0(:,:,i,j)-2.d0*f2(:,:,i,j)+f3(:,:,i,j))**2*13.d0/12.d0 &
                +(f0(:,:,i,j)-4.d0*f1(:,:,i,j)+3.d0*f2(:,:,i,j))**2/4.d0

      is1(:,:) = (f1(:,:,i,j)-2.d0*f2(:,:,i,j)+f3(:,:,i,j))**2*13.d0/12.d0 &
                +(f1(:,:,i,j)-f3(:,:,i,j))**2/4.d0

      is2(:,:) = (f2(:,:,i,j)-2.d0*f3(:,:,i,j)+f4(:,:,i,j))**2*13.d0/12.d0 &
                +(3.d0*f2(:,:,i,j)-4.d0*f3(:,:,i,j)+f4(:,:,i,j))**2/4.d0

      aa0(:,:)    = c30/(ss+is0(:,:))**2
      aa1(:,:)    = c31/(ss+is1(:,:))**2
      aa2(:,:)    = c32/(ss+is2(:,:))**2
      aa_sum(:,:) = 1.d0/(aa0(:,:)+aa1(:,:)+aa2(:,:))

      w0(:,:) = aa0(:,:)*aa_sum(:,:)
      w1(:,:) = aa1(:,:)*aa_sum(:,:)
      w2(:,:) = aa2(:,:)*aa_sum(:,:)

      q30(:,:) = a300*f0(:,:,i,j) + a301*f1(:,:,i,j) + a302*f2(:,:,i,j)
      q31(:,:) = a310*f1(:,:,i,j) + a311*f2(:,:,i,j) + a312*f3(:,:,i,j)
      q32(:,:) = a320*f2(:,:,i,j) + a321*f3(:,:,i,j) + a322*f4(:,:,i,j)

      h%p(lo%d(1):hi%d(1),lo%d(2):hi%d(2),i,j) = w0(:,:)*q30(:,:) &
                                                +w1(:,:)*q31(:,:) &
                                                +w2(:,:)*q32(:,:)
    enddo
  enddo
end subroutine reconst_component_matrix_wenojs5

module subroutine reconst_component_tensor_wenojs5(h,f,lo,hi,padding,bias,axis)
  implicit none
  type(rtensorfield_t),intent(inout) :: h
  type(rtensorfield_t),target,intent(in) :: f
  type(ftensorshape_t),intent(in) :: lo,hi,padding
  integer,intent(in) :: bias,axis

  double precision,dimension(:,:,:,:,:),pointer :: f0
  double precision,dimension(:,:,:,:,:),pointer :: f1
  double precision,dimension(:,:,:,:,:),pointer :: f2
  double precision,dimension(:,:,:,:,:),pointer :: f3
  double precision,dimension(:,:,:,:,:),pointer :: f4
  integer :: fllo,flhi, &
             fmlo,fmhi, &
             fnlo,fnhi, &
             filo,fihi, &
             fjlo,fjhi

  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3)) :: is0,is1,is2
  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3)) :: aa0,aa1,aa2,aa_sum
  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3)) :: w0,w1,w2
  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3)) :: q30,q31,q32
  integer :: i,j
  integer,dimension(5) :: shift
  if(bias.eq.bias_upwind) then
    shift = (/-2,-1,0,1,2/)
  else
    shift = (/3,2,1,0,-1/)
  endif
  fllo = lo%d(1) + padding%d(1)
  flhi = hi%d(1) + padding%d(1)
  fmlo = lo%d(2) + padding%d(2)
  fmhi = hi%d(2) + padding%d(2)
  fnlo = lo%d(3) + padding%d(3)
  fnhi = hi%d(3) + padding%d(3)
  filo = lo%d(4) + padding%d(4)
  fihi = hi%d(4) + padding%d(4)
  fjlo = lo%d(5) + padding%d(5)
  fjhi = hi%d(5) + padding%d(5)
  select case(axis)
  case(axis_xi)
    f0 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(1):fihi+shift(1),fjlo:fjhi)
    f1 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(2):fihi+shift(2),fjlo:fjhi)
    f2 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(3):fihi+shift(3),fjlo:fjhi)
    f3 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(4):fihi+shift(4),fjlo:fjhi)
    f4 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(5):fihi+shift(5),fjlo:fjhi)
  case(axis_eta)
    f0 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(1):fjhi+shift(1))
    f1 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(2):fjhi+shift(2))
    f2 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(3):fjhi+shift(3))
    f3 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(4):fjhi+shift(4))
    f4 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(5):fjhi+shift(5))
  case default
    print*,"Error: reconst_component_tensor_wenojs5()"
    print*,"No such ireconst: ",axis
    stop
  end select
  do j = lo%d(5), hi%d(5)
    do i = lo%d(4), hi%d(4)
      is0(:,:,:) = (f0(:,:,:,i,j)-2.d0*f1(:,:,:,i,j)+f2(:,:,:,i,j))**2*13.d0/12.d0 &
                  +(f0(:,:,:,i,j)-4.d0*f1(:,:,:,i,j)+3.d0*f2(:,:,:,i,j))**2/4.d0

      is1(:,:,:) = (f1(:,:,:,i,j)-2.d0*f2(:,:,:,i,j)+f3(:,:,:,i,j))**2*13.d0/12.d0 &
                  +(f1(:,:,:,i,j)-f3(:,:,:,i,j))**2/4.d0

      is2(:,:,:) = (f2(:,:,:,i,j)-2.d0*f3(:,:,:,i,j)+f4(:,:,:,i,j))**2*13.d0/12.d0 &
                  +(3.d0*f2(:,:,:,i,j)-4.d0*f3(:,:,:,i,j)+f4(:,:,:,i,j))**2/4.d0

      aa0(:,:,:)    = c30/(ss+is0(:,:,:))**2
      aa1(:,:,:)    = c31/(ss+is1(:,:,:))**2
      aa2(:,:,:)    = c32/(ss+is2(:,:,:))**2
      aa_sum(:,:,:) = 1.d0/(aa0(:,:,:)+aa1(:,:,:)+aa2(:,:,:))

      w0(:,:,:) = aa0(:,:,:)*aa_sum(:,:,:)
      w1(:,:,:) = aa1(:,:,:)*aa_sum(:,:,:)
      w2(:,:,:) = aa2(:,:,:)*aa_sum(:,:,:)

      q30(:,:,:) = a300*f0(:,:,:,i,j) + a301*f1(:,:,:,i,j) + a302*f2(:,:,:,i,j)
      q31(:,:,:) = a310*f1(:,:,:,i,j) + a311*f2(:,:,:,i,j) + a312*f3(:,:,:,i,j)
      q32(:,:,:) = a320*f2(:,:,:,i,j) + a321*f3(:,:,:,i,j) + a322*f4(:,:,:,i,j)

      h%p(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3),i,j) = w0(:,:,:)*q30(:,:,:) &
                                                                +w1(:,:,:)*q31(:,:,:) &
                                                                +w2(:,:,:)*q32(:,:,:)
    enddo
  enddo
end subroutine reconst_component_tensor_wenojs5

module subroutine reconst_component_scalar_wenoz5(h,f,lo,hi,padding,bias,axis)
  implicit none
  type(rscalarfield_t),intent(inout) :: h
  type(rscalarfield_t),target,intent(in) :: f
  type(fscalarshape_t),intent(in) :: lo,hi,padding
  integer,intent(in) :: bias,axis

  double precision,dimension(:,:),pointer :: f0
  double precision,dimension(:,:),pointer :: f1
  double precision,dimension(:,:),pointer :: f2
  double precision,dimension(:,:),pointer :: f3
  double precision,dimension(:,:),pointer :: f4
  integer :: filo,fihi, &
             fjlo,fjhi

  double precision :: is0,is1,is2
  double precision :: tau5
  double precision :: aa0,aa1,aa2,aa_sum
  double precision :: w0,w1,w2
  double precision :: q30,q31,q32
  integer :: i,j
  integer,dimension(5) :: shift

  if(bias.eq.bias_upwind) then
    shift = (/-2,-1,0,1,2/)
  else
    shift = (/3,2,1,0,-1/)
  endif
  filo = lo%d(1) + padding%d(1)
  fihi = hi%d(1) + padding%d(1)
  fjlo = lo%d(2) + padding%d(2)
  fjhi = hi%d(2) + padding%d(2)
  select case(axis)
  case(axis_xi)
    f0 => f%p(filo+shift(1):fihi+shift(1),fjlo:fjhi)
    f1 => f%p(filo+shift(2):fihi+shift(2),fjlo:fjhi)
    f2 => f%p(filo+shift(3):fihi+shift(3),fjlo:fjhi)
    f3 => f%p(filo+shift(4):fihi+shift(4),fjlo:fjhi)
    f4 => f%p(filo+shift(5):fihi+shift(5),fjlo:fjhi)
  case(axis_eta)
    f0 => f%p(filo:fihi,fjlo+shift(1):fjhi+shift(1))
    f1 => f%p(filo:fihi,fjlo+shift(2):fjhi+shift(2))
    f2 => f%p(filo:fihi,fjlo+shift(3):fjhi+shift(3))
    f3 => f%p(filo:fihi,fjlo+shift(4):fjhi+shift(4))
    f4 => f%p(filo:fihi,fjlo+shift(5):fjhi+shift(5))
  case default
    print*,"Error: reconst_component_scalar_wenoz5()"
    print*,"No such ireconst: ",axis
    stop
  end select

  do j=lo%d(2), hi%d(2)
    do i=lo%d(1), hi%d(1)
      is0 = (f0(i,j) - 2.d0*f1(i,j) + f2(i,j))**2*13.d0/12.d0 &
           +(f1(i,j) - 4.d0*f2(i,j) + 3.d0*f3(i,j))**2/4.d0

      is1 = (f1(i,j) - 2.d0*f2(i,j)+f3(i,j))**2*13.d0/12.d0 &
           +(f1(i,j) - f3(i,j))**2/4.d0

      is2 = (f2(i,j) - 2.d0*f3(i,j) + f4(i,j))**2*13.d0/12.d0 &
           +(3.d0*f2(i,j) - 4.d0*f3(i,j) + f4(i,j))**2/4.d0

      tau5 = abs(is2-is0)
      aa0  = c30*(1.d0 + (tau5/(ss+is0))**2)
      aa1  = c31*(1.d0 + (tau5/(ss+is1))**2)
      aa2  = c32*(1.d0 + (tau5/(ss+is2))**2)
      aa_sum = 1.d0/(aa0+aa1+aa2)

      w0 = aa0*aa_sum
      w1 = aa1*aa_sum
      w2 = aa2*aa_sum

      q30 = a300*f0(i,j) + a301*f1(i,j) + a302*f2(i,j)
      q31 = a310*f1(i,j) + a311*f3(i,j) + a312*f3(i,j)
      q32 = a320*f2(i,j) + a321*f3(i,j) + a322*f4(i,j)

      h%p(i,j) = w0*q30 + w1*q31 + w2*q32
    enddo
  enddo
end subroutine reconst_component_scalar_wenoz5

module subroutine reconst_component_vector_wenoz5(h,f,lo,hi,padding,bias,axis)
  implicit none
  type(rvectorfield_t),intent(inout) :: h
  type(rvectorfield_t),target,intent(in) :: f
  type(fvectorshape_t),intent(in) :: lo,hi,padding
  integer,intent(in) :: bias,axis

  double precision,dimension(:,:,:),pointer :: f0
  double precision,dimension(:,:,:),pointer :: f1
  double precision,dimension(:,:,:),pointer :: f2
  double precision,dimension(:,:,:),pointer :: f3
  double precision,dimension(:,:,:),pointer :: f4
  integer :: fnlo,fnhi, &
             filo,fihi, &
             fjlo,fjhi

  double precision,dimension(lo%d(1):hi%d(1)) :: is0,is1,is2
  double precision,dimension(lo%d(1):hi%d(1)):: aa0,aa1,aa2,aa_sum
  double precision,dimension(lo%d(1):hi%d(1)):: tau5
  double precision,dimension(lo%d(1):hi%d(1)) :: w0,w1,w2
  double precision,dimension(lo%d(1):hi%d(1)) :: q30,q31,q32
  integer :: i,j
  integer,dimension(5) :: shift
  if(bias.eq.bias_upwind) then
    shift = (/-2,-1,0,1,2/)
  else
    shift = (/3,2,1,0,-1/)
  endif
  fnlo = lo%d(1) + padding%d(1)
  fnhi = hi%d(1) + padding%d(1)
  filo = lo%d(2) + padding%d(2)
  fihi = hi%d(2) + padding%d(2)
  fjlo = lo%d(3) + padding%d(3)
  fjhi = hi%d(3) + padding%d(3)
  select case(axis)
  case(axis_xi)
    f0 => f%p(fnlo:fnhi,filo+shift(1):fihi+shift(1),fjlo:fjhi)
    f1 => f%p(fnlo:fnhi,filo+shift(2):fihi+shift(2),fjlo:fjhi)
    f2 => f%p(fnlo:fnhi,filo+shift(3):fihi+shift(3),fjlo:fjhi)
    f3 => f%p(fnlo:fnhi,filo+shift(4):fihi+shift(4),fjlo:fjhi)
    f4 => f%p(fnlo:fnhi,filo+shift(5):fihi+shift(5),fjlo:fjhi)
  case(axis_eta)
    f0 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(1):fjhi+shift(1))
    f1 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(2):fjhi+shift(2))
    f2 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(3):fjhi+shift(3))
    f3 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(4):fjhi+shift(4))
    f4 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(5):fjhi+shift(5))
  case default
    print*,"Error: reconst_component_vector_wenoz5()"
    print*,"No such ireconst: ",axis
    stop
  end select

  do j=lo%d(3), hi%d(3)
    do i=lo%d(2), hi%d(2)
      is0(:) = (f0(:,i,j)-2.d0*f1(:,i,j)+f2(:,i,j))**2*13.d0/12.d0 &
              +(f0(:,i,j)-4.d0*f1(:,i,j)+3.d0*f2(:,i,j))**2/4.d0

      is1(:) = (f1(:,i,j)-2.d0*f2(:,i,j)+f3(:,i,j))**2*13.d0/12.d0 &
              +(f1(:,i,j)-f3(:,i,j))**2/4.d0

      is2(:) = (f2(:,i,j)-2.d0*f3(:,i,j)+f4(:,i,j))**2*13.d0/12.d0 &
              +(3.d0*f2(:,i,j)-4.d0*f3(:,i,j)+f4(:,i,j))**2/4.d0

      tau5(:) = abs(is2(:)-is0(:))
      aa0(:)  = c30*(1.d0 + (tau5(:)/(ss+is0(:)))**2)
      aa1(:)  = c31*(1.d0 + (tau5(:)/(ss+is1(:)))**2)
      aa2(:)  = c32*(1.d0 + (tau5(:)/(ss+is2(:)))**2)
      aa_sum(:) = 1.d0/(aa0(:)+aa1(:)+aa2(:))

      w0(:) = aa0(:)*aa_sum(:)
      w1(:) = aa1(:)*aa_sum(:)
      w2(:) = aa2(:)*aa_sum(:)

      q30(:) = a300*f0(:,i,j) + a301*f1(:,i,j) + a302*f2(:,i,j)
      q31(:) = a310*f1(:,i,j) + a311*f2(:,i,j) + a312*f3(:,i,j)
      q32(:) = a320*f2(:,i,j) + a321*f3(:,i,j) + a322*f4(:,i,j)

      h%p(lo%d(1):hi%d(1),i,j) = w0(:)*q30(:) + w1(:)*q31(:) + w2(:)*q32(:)
    enddo
  enddo
end subroutine reconst_component_vector_wenoz5

module subroutine reconst_component_matrix_wenoz5(h,f,lo,hi,padding,bias,axis)
  implicit none
  type(rmatrixfield_t),intent(inout) :: h
  type(rmatrixfield_t),target,intent(in) :: f
  type(fmatrixshape_t),intent(in) :: lo,hi,padding
  integer,intent(in) :: bias,axis

  double precision,dimension(:,:,:,:),pointer :: f0
  double precision,dimension(:,:,:,:),pointer :: f1
  double precision,dimension(:,:,:,:),pointer :: f2
  double precision,dimension(:,:,:,:),pointer :: f3
  double precision,dimension(:,:,:,:),pointer :: f4
  integer :: fmlo,fmhi, &
             fnlo,fnhi, &
             filo,fihi, &
             fjlo,fjhi

  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2)) :: is0,is1,is2
  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2)) :: aa0,aa1,aa2,aa_sum
  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2)) :: tau5
  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2)) :: w0,w1,w2
  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2)) :: q30,q31,q32
  integer :: i,j
  integer,dimension(5) :: shift
  if(bias.eq.bias_upwind) then
    shift = (/-2,-1,0,1,2/)
  else
    shift = (/3,2,1,0,-1/)
  endif
  fmlo = lo%d(1) + padding%d(1)
  fmhi = hi%d(1) + padding%d(1)
  fnlo = lo%d(2) + padding%d(2)
  fnhi = hi%d(2) + padding%d(2)
  filo = lo%d(3) + padding%d(3)
  fihi = hi%d(3) + padding%d(3)
  fjlo = lo%d(4) + padding%d(4)
  fjhi = hi%d(4) + padding%d(4)
  select case(axis)
  case(axis_xi)
    f0 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(1):fihi+shift(1),fjlo:fjhi)
    f1 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(2):fihi+shift(2),fjlo:fjhi)
    f2 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(3):fihi+shift(3),fjlo:fjhi)
    f3 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(4):fihi+shift(4),fjlo:fjhi)
    f4 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(5):fihi+shift(5),fjlo:fjhi)
  case(axis_eta)
    f0 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(1):fjhi+shift(1))
    f1 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(2):fjhi+shift(2))
    f2 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(3):fjhi+shift(3))
    f3 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(4):fjhi+shift(4))
    f4 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(5):fjhi+shift(5))
  case default
    print*,"Error: reconst_component_matrix_wenoz5()"
    print*,"No such ireconst: ",axis
    stop
  end select
  do j = lo%d(4), hi%d(4)
    do i = lo%d(3), hi%d(3)
      is0(:,:) = (f0(:,:,i,j)-2.d0*f2(:,:,i,j)+f3(:,:,i,j))**2*13.d0/12.d0 &
                +(f0(:,:,i,j)-4.d0*f1(:,:,i,j)+3.d0*f2(:,:,i,j))**2/4.d0

      is1(:,:) = (f1(:,:,i,j)-2.d0*f2(:,:,i,j)+f3(:,:,i,j))**2*13.d0/12.d0 &
                +(f1(:,:,i,j)-f3(:,:,i,j))**2/4.d0

      is2(:,:) = (f2(:,:,i,j)-2.d0*f3(:,:,i,j)+f4(:,:,i,j))**2*13.d0/12.d0 &
                +(3.d0*f2(:,:,i,j)-4.d0*f3(:,:,i,j)+f4(:,:,i,j))**2/4.d0

      tau5(:,:) = abs(is2(:,:)-is0(:,:))
      aa0(:,:)  = c30*(1.d0 + (tau5(:,:)/(ss+is0(:,:)))**2)
      aa1(:,:)  = c31*(1.d0 + (tau5(:,:)/(ss+is1(:,:)))**2)
      aa2(:,:)  = c32*(1.d0 + (tau5(:,:)/(ss+is2(:,:)))**2)
      aa_sum(:,:) = 1.d0/(aa0(:,:)+aa1(:,:)+aa2(:,:))

      w0(:,:) = aa0(:,:)*aa_sum(:,:)
      w1(:,:) = aa1(:,:)*aa_sum(:,:)
      w2(:,:) = aa2(:,:)*aa_sum(:,:)

      q30(:,:) = a300*f0(:,:,i,j) + a301*f1(:,:,i,j) + a302*f2(:,:,i,j)
      q31(:,:) = a310*f1(:,:,i,j) + a311*f2(:,:,i,j) + a312*f3(:,:,i,j)
      q32(:,:) = a320*f2(:,:,i,j) + a321*f3(:,:,i,j) + a322*f4(:,:,i,j)

      h%p(lo%d(1):hi%d(1),lo%d(2):hi%d(2),i,j) = w0(:,:)*q30(:,:) &
                                                +w1(:,:)*q31(:,:) &
                                                +w2(:,:)*q32(:,:)
    enddo
  enddo
end subroutine reconst_component_matrix_wenoz5

module subroutine reconst_component_tensor_wenoz5(h,f,lo,hi,padding,bias,axis)
  implicit none
  type(rtensorfield_t),intent(inout) :: h
  type(rtensorfield_t),target,intent(in) :: f
  type(ftensorshape_t),intent(in) :: lo,hi,padding
  integer,intent(in) :: bias,axis

  double precision,dimension(:,:,:,:,:),pointer :: f0
  double precision,dimension(:,:,:,:,:),pointer :: f1
  double precision,dimension(:,:,:,:,:),pointer :: f2
  double precision,dimension(:,:,:,:,:),pointer :: f3
  double precision,dimension(:,:,:,:,:),pointer :: f4
  integer :: fllo,flhi, &
             fmlo,fmhi, &
             fnlo,fnhi, &
             filo,fihi, &
             fjlo,fjhi

  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3)) :: is0,is1,is2
  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3)) :: aa0,aa1,aa2,aa_sum
  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3)) :: tau5
  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3)) :: w0,w1,w2
  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3)) :: q30,q31,q32
  integer :: i,j
  integer,dimension(5) :: shift
  if(bias.eq.bias_upwind) then
    shift = (/-2,-1,0,1,2/)
  else
    shift = (/3,2,1,0,-1/)
  endif
  fllo = lo%d(1) + padding%d(1)
  flhi = hi%d(1) + padding%d(1)
  fmlo = lo%d(2) + padding%d(2)
  fmhi = hi%d(2) + padding%d(2)
  fnlo = lo%d(3) + padding%d(3)
  fnhi = hi%d(3) + padding%d(3)
  filo = lo%d(4) + padding%d(4)
  fihi = hi%d(4) + padding%d(4)
  fjlo = lo%d(5) + padding%d(5)
  fjhi = hi%d(5) + padding%d(5)
  select case(axis)
  case(axis_xi)
    f0 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(1):fihi+shift(1),fjlo:fjhi)
    f1 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(2):fihi+shift(2),fjlo:fjhi)
    f2 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(3):fihi+shift(3),fjlo:fjhi)
    f3 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(4):fihi+shift(4),fjlo:fjhi)
    f4 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(5):fihi+shift(5),fjlo:fjhi)
  case(axis_eta)
    f0 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(1):fjhi+shift(1))
    f1 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(2):fjhi+shift(2))
    f2 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(3):fjhi+shift(3))
    f3 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(4):fjhi+shift(4))
    f4 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(5):fjhi+shift(5))
  case default
    print*,"Error: reconst_component_tensor_wenoz5()"
    print*,"No such ireconst: ",axis
    stop
  end select
  do j = lo%d(5), hi%d(5)
    do i = lo%d(4), hi%d(4)
      is0(:,:,:) = (f0(:,:,:,i,j)-2.d0*f1(:,:,:,i,j)+f2(:,:,:,i,j))**2*13.d0/12.d0 &
                  +(f0(:,:,:,i,j)-4.d0*f1(:,:,:,i,j)+3.d0*f2(:,:,:,i,j))**2/4.d0

      is1(:,:,:) = (f1(:,:,:,i,j)-2.d0*f2(:,:,:,i,j)+f3(:,:,:,i,j))**2*13.d0/12.d0 &
                  +(f1(:,:,:,i,j)-f3(:,:,:,i,j))**2/4.d0

      is2(:,:,:) = (f2(:,:,:,i,j)-2.d0*f3(:,:,:,i,j)+f4(:,:,:,i,j))**2*13.d0/12.d0 &
                  +(3.d0*f2(:,:,:,i,j)-4.d0*f3(:,:,:,i,j)+f4(:,:,:,i,j))**2/4.d0

      tau5(:,:,:) = abs(is2(:,:,:)-is0(:,:,:))
      aa0(:,:,:)  = c30*(1.d0 + (tau5(:,:,:)/(ss+is0(:,:,:)))**2)
      aa1(:,:,:)  = c31*(1.d0 + (tau5(:,:,:)/(ss+is1(:,:,:)))**2)
      aa2(:,:,:)  = c32*(1.d0 + (tau5(:,:,:)/(ss+is2(:,:,:)))**2)
      aa_sum(:,:,:) = 1.d0/(aa0(:,:,:)+aa1(:,:,:)+aa2(:,:,:))

      w0(:,:,:) = aa0(:,:,:)*aa_sum(:,:,:)
      w1(:,:,:) = aa1(:,:,:)*aa_sum(:,:,:)
      w2(:,:,:) = aa2(:,:,:)*aa_sum(:,:,:)

      q30(:,:,:) = a300*f0(:,:,:,i,j) + a301*f1(:,:,:,i,j) + a302*f2(:,:,:,i,j)
      q31(:,:,:) = a310*f1(:,:,:,i,j) + a311*f2(:,:,:,i,j) + a312*f3(:,:,:,i,j)
      q32(:,:,:) = a320*f2(:,:,:,i,j) + a321*f3(:,:,:,i,j) + a322*f4(:,:,:,i,j)

      h%p(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3),i,j) = w0(:,:,:)*q30(:,:,:) &
                                                                +w1(:,:,:)*q31(:,:,:) &
                                                                +w2(:,:,:)*q32(:,:,:)
    enddo
  enddo
end subroutine reconst_component_tensor_wenoz5

module subroutine reconst_component_scalar_wenoe5(h,f,lo,hi,padding,bias,axis)
    implicit none
    type(rscalarfield_t),intent(inout) :: h
    type(rscalarfield_t),target,intent(in) :: f
    type(fscalarshape_t),intent(in) :: lo,hi,padding
    integer,intent(in) :: bias,axis

    double precision,dimension(:,:),pointer :: f0
    double precision,dimension(:,:),pointer :: f1
    double precision,dimension(:,:),pointer :: f2
    double precision,dimension(:,:),pointer :: f3
    double precision,dimension(:,:),pointer :: f4
    integer :: filo,fihi, &
               fjlo,fjhi

    double precision :: is0,is1,is2
    double precision :: fpp,fppp
    double precision :: tau5
    double precision :: aa0,aa1,aa2,aa_sum
    double precision :: w0,w1,w2
    double precision :: q30,q31,q32
    integer :: i,j
    integer,dimension(5) :: shift

    if(bias.eq.bias_upwind) then
      shift = (/-2,-1,0,1,2/)
    else
      shift = (/3,2,1,0,-1/)
    endif
    filo = lo%d(1) + padding%d(1)
    fihi = hi%d(1) + padding%d(1)
    fjlo = lo%d(2) + padding%d(2)
    fjhi = hi%d(2) + padding%d(2)
    select case(axis)
    case(axis_xi)
      f0 => f%p(filo+shift(1):fihi+shift(1),fjlo:fjhi)
      f1 => f%p(filo+shift(2):fihi+shift(2),fjlo:fjhi)
      f2 => f%p(filo+shift(3):fihi+shift(3),fjlo:fjhi)
      f3 => f%p(filo+shift(4):fihi+shift(4),fjlo:fjhi)
      f4 => f%p(filo+shift(5):fihi+shift(5),fjlo:fjhi)
    case(axis_eta)
      f0 => f%p(filo:fihi,fjlo+shift(1):fjhi+shift(1))
      f1 => f%p(filo:fihi,fjlo+shift(2):fjhi+shift(2))
      f2 => f%p(filo:fihi,fjlo+shift(3):fjhi+shift(3))
      f3 => f%p(filo:fihi,fjlo+shift(4):fjhi+shift(4))
      f4 => f%p(filo:fihi,fjlo+shift(5):fjhi+shift(5))
    case default
      print*,"Error: reconst_component_scalar_wenoe5()"
      print*,"No such ireconst: ",axis
      stop
    end select

    do j=lo%d(2), hi%d(2)
      do i=lo%d(1), hi%d(1)
        is0 = (f0(i,j) - 2.d0*f1(i,j) + f2(i,j))**2*13.d0/12.d0 &
             +(f1(i,j) - 4.d0*f2(i,j) + 3.d0*f3(i,j))**2/4.d0

        is1 = (f1(i,j) - 2.d0*f2(i,j)+f3(i,j))**2*13.d0/12.d0 &
             +(f1(i,j) - f3(i,j))**2/4.d0

        is2 = (f2(i,j) - 2.d0*f3(i,j) + f4(i,j))**2*13.d0/12.d0 &
             +(3.d0*f2(i,j) - 4.d0*f3(i,j) + f4(i,j))**2/4.d0

        fpp  = (f0(i,j)-4.0d0*f1(i,j)+6.0d0*f2(i,j) -4.0d0*f3(i,j)+f4(i,j))*0.6988d0 &
              +(f1(i,j)-2.0d0*f2(i,j)+f3(i,j))

        fppp = 0.5*(-f0(i,j) + 2.0*f1(i,j) - 2.0*f3(i,j) + f4(i,j))

        tau5 = abs(is0 - is2 + 13.0/3.0*fpp*fppp)

        aa0  = c30*(1.d0 + (tau5/(ss+is0))**2)
        aa1  = c31*(1.d0 + (tau5/(ss+is1))**2)
        aa2  = c32*(1.d0 + (tau5/(ss+is2))**2)
        aa_sum = 1.d0/(aa0+aa1+aa2)

        w0 = aa0*aa_sum
        w1 = aa1*aa_sum
        w2 = aa2*aa_sum

        q30 = a300*f0(i,j) + a301*f1(i,j) + a302*f2(i,j)
        q31 = a310*f1(i,j) + a311*f3(i,j) + a312*f3(i,j)
        q32 = a320*f2(i,j) + a321*f3(i,j) + a322*f4(i,j)

        h%p(i,j) = w0*q30 + w1*q31 + w2*q32
      enddo
    enddo
  end subroutine reconst_component_scalar_wenoe5

  module subroutine reconst_component_vector_wenoe5(h,f,lo,hi,padding,bias,axis)
    implicit none
    type(rvectorfield_t),intent(inout) :: h
    type(rvectorfield_t),target,intent(in) :: f
    type(fvectorshape_t),intent(in) :: lo,hi,padding
    integer,intent(in) :: bias,axis

    double precision,dimension(:,:,:),pointer :: f0
    double precision,dimension(:,:,:),pointer :: f1
    double precision,dimension(:,:,:),pointer :: f2
    double precision,dimension(:,:,:),pointer :: f3
    double precision,dimension(:,:,:),pointer :: f4
    integer :: fnlo,fnhi, &
               filo,fihi, &
               fjlo,fjhi

    double precision,dimension(lo%d(1):hi%d(1)) :: is0,is1,is2
    double precision,dimension(lo%d(1):hi%d(1)) :: fpp,fppp
    double precision,dimension(lo%d(1):hi%d(1)) :: aa0,aa1,aa2,aa_sum
    double precision,dimension(lo%d(1):hi%d(1)) :: tau5
    double precision,dimension(lo%d(1):hi%d(1)) :: w0,w1,w2
    double precision,dimension(lo%d(1):hi%d(1)) :: q30,q31,q32
    integer :: i,j
    integer,dimension(5) :: shift
    if(bias.eq.bias_upwind) then
      shift = (/-2,-1,0,1,2/)
    else
      shift = (/3,2,1,0,-1/)
    endif
    fnlo = lo%d(1) + padding%d(1)
    fnhi = hi%d(1) + padding%d(1)
    filo = lo%d(2) + padding%d(2)
    fihi = hi%d(2) + padding%d(2)
    fjlo = lo%d(3) + padding%d(3)
    fjhi = hi%d(3) + padding%d(3)
    select case(axis)
    case(axis_xi)
      f0 => f%p(fnlo:fnhi,filo+shift(1):fihi+shift(1),fjlo:fjhi)
      f1 => f%p(fnlo:fnhi,filo+shift(2):fihi+shift(2),fjlo:fjhi)
      f2 => f%p(fnlo:fnhi,filo+shift(3):fihi+shift(3),fjlo:fjhi)
      f3 => f%p(fnlo:fnhi,filo+shift(4):fihi+shift(4),fjlo:fjhi)
      f4 => f%p(fnlo:fnhi,filo+shift(5):fihi+shift(5),fjlo:fjhi)
    case(axis_eta)
      f0 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(1):fjhi+shift(1))
      f1 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(2):fjhi+shift(2))
      f2 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(3):fjhi+shift(3))
      f3 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(4):fjhi+shift(4))
      f4 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(5):fjhi+shift(5))
    case default
      print*,"Error: reconst_component_vector_wenoe5()"
      print*,"No such ireconst: ",axis
      stop
    end select

    do j=lo%d(3), hi%d(3)
      do i=lo%d(2), hi%d(2)
        is0(:) = (f0(:,i,j)-2.d0*f1(:,i,j)+f2(:,i,j))**2*13.d0/12.d0 &
                +(f0(:,i,j)-4.d0*f1(:,i,j)+3.d0*f2(:,i,j))**2/4.d0

        is1(:) = (f1(:,i,j)-2.d0*f2(:,i,j)+f3(:,i,j))**2*13.d0/12.d0 &
                +(f1(:,i,j)-f3(:,i,j))**2/4.d0

        is2(:) = (f2(:,i,j)-2.d0*f3(:,i,j)+f4(:,i,j))**2*13.d0/12.d0 &
                +(3.d0*f2(:,i,j)-4.d0*f3(:,i,j)+f4(:,i,j))**2/4.d0

        fpp(:) = (f0(:,i,j) - 4.0d0*f1(:,i,j) + 6.0d0*f2(:,i,j) - 4.0d0*f3(:,i,j)+f4(:,i,j))*0.6988d0 &
                +(f1(:,i,j) - 2.0d0*f2(:,i,j) + f3(:,i,j))

        fppp(:) = 0.5*(-f0(:,i,j) + 2.0*f1(:,i,j) - 2.0*f3(:,i,j) + f4(:,i,j))

        tau5(:) = abs(is0(:) - is2(:) + 13.0/3.0*fpp(:)*fppp(:))
        aa0(:)  = c30*(1.d0 + (tau5(:)/(ss+is0(:)))**2)
        aa1(:)  = c31*(1.d0 + (tau5(:)/(ss+is1(:)))**2)
        aa2(:)  = c32*(1.d0 + (tau5(:)/(ss+is2(:)))**2)
        aa_sum(:) = 1.d0/(aa0(:)+aa1(:)+aa2(:))

        w0(:) = aa0(:)*aa_sum(:)
        w1(:) = aa1(:)*aa_sum(:)
        w2(:) = aa2(:)*aa_sum(:)

        q30(:) = a300*f0(:,i,j) + a301*f1(:,i,j) + a302*f2(:,i,j)
        q31(:) = a310*f1(:,i,j) + a311*f2(:,i,j) + a312*f3(:,i,j)
        q32(:) = a320*f2(:,i,j) + a321*f3(:,i,j) + a322*f4(:,i,j)

        h%p(lo%d(1):hi%d(1),i,j) = w0(:)*q30(:) + w1(:)*q31(:) + w2(:)*q32(:)
      enddo
    enddo
  end subroutine reconst_component_vector_wenoe5

  module subroutine reconst_component_matrix_wenoe5(h,f,lo,hi,padding,bias,axis)
    implicit none
    type(rmatrixfield_t),intent(inout) :: h
    type(rmatrixfield_t),target,intent(in) :: f
    type(fmatrixshape_t),intent(in) :: lo,hi,padding
    integer,intent(in) :: bias,axis

    double precision,dimension(:,:,:,:),pointer :: f0
    double precision,dimension(:,:,:,:),pointer :: f1
    double precision,dimension(:,:,:,:),pointer :: f2
    double precision,dimension(:,:,:,:),pointer :: f3
    double precision,dimension(:,:,:,:),pointer :: f4
    integer :: fmlo,fmhi, &
               fnlo,fnhi, &
               filo,fihi, &
               fjlo,fjhi

    double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2)) :: is0,is1,is2
    double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2)) :: fpp,fppp
    double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2)) :: aa0,aa1,aa2,aa_sum
    double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2)) :: tau5
    double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2)) :: w0,w1,w2
    double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2)) :: q30,q31,q32
    integer :: i,j
    integer,dimension(5) :: shift
    if(bias.eq.bias_upwind) then
      shift = (/-2,-1,0,1,2/)
    else
      shift = (/3,2,1,0,-1/)
    endif
    fmlo = lo%d(1) + padding%d(1)
    fmhi = hi%d(1) + padding%d(1)
    fnlo = lo%d(2) + padding%d(2)
    fnhi = hi%d(2) + padding%d(2)
    filo = lo%d(3) + padding%d(3)
    fihi = hi%d(3) + padding%d(3)
    fjlo = lo%d(4) + padding%d(4)
    fjhi = hi%d(4) + padding%d(4)
    select case(axis)
    case(axis_xi)
      f0 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(1):fihi+shift(1),fjlo:fjhi)
      f1 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(2):fihi+shift(2),fjlo:fjhi)
      f2 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(3):fihi+shift(3),fjlo:fjhi)
      f3 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(4):fihi+shift(4),fjlo:fjhi)
      f4 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(5):fihi+shift(5),fjlo:fjhi)
    case(axis_eta)
      f0 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(1):fjhi+shift(1))
      f1 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(2):fjhi+shift(2))
      f2 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(3):fjhi+shift(3))
      f3 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(4):fjhi+shift(4))
      f4 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(5):fjhi+shift(5))
    case default
      print*,"Error: reconst_component_matrix_wenoe5()"
      print*,"No such ireconst: ",axis
      stop
    end select
    do j = lo%d(4), hi%d(4)
      do i = lo%d(3), hi%d(3)
        is0(:,:) = (f0(:,:,i,j)-2.d0*f2(:,:,i,j)+f3(:,:,i,j))**2*13.d0/12.d0 &
                  +(f0(:,:,i,j)-4.d0*f1(:,:,i,j)+3.d0*f2(:,:,i,j))**2/4.d0

        is1(:,:) = (f1(:,:,i,j)-2.d0*f2(:,:,i,j)+f3(:,:,i,j))**2*13.d0/12.d0 &
                  +(f1(:,:,i,j)-f3(:,:,i,j))**2/4.d0

        is2(:,:) = (f2(:,:,i,j)-2.d0*f3(:,:,i,j)+f4(:,:,i,j))**2*13.d0/12.d0 &
                  +(3.d0*f2(:,:,i,j)-4.d0*f3(:,:,i,j)+f4(:,:,i,j))**2/4.d0

        fpp(:,:) = (f0(:,:,i,j)-4.0d0*f1(:,:,i,j)+6.0d0*f2(:,:,i,j) -4.0d0*f3(:,:,i,j)+f4(:,:,i,j))*0.6988d0 &
                  +(f1(:,:,i,j)-2.0d0*f2(:,:,i,j)+f3(:,:,i,j))

        fppp(:,:) = 0.5*(-f0(:,:,i,j) + 2.0*f1(:,:,i,j) - 2.0*f3(:,:,i,j) + f4(:,:,i,j))

        tau5(:,:) = abs(is0(:,:) - is2(:,:) + 13.0/3.0*fpp(:,:)*fppp(:,:))

        aa0(:,:)  = c30*(1.d0 + (tau5(:,:)/(ss+is0(:,:)))**2)
        aa1(:,:)  = c31*(1.d0 + (tau5(:,:)/(ss+is1(:,:)))**2)
        aa2(:,:)  = c32*(1.d0 + (tau5(:,:)/(ss+is2(:,:)))**2)
        aa_sum(:,:) = 1.d0/(aa0(:,:)+aa1(:,:)+aa2(:,:))

        w0(:,:) = aa0(:,:)*aa_sum(:,:)
        w1(:,:) = aa1(:,:)*aa_sum(:,:)
        w2(:,:) = aa2(:,:)*aa_sum(:,:)

        q30(:,:) = a300*f0(:,:,i,j) + a301*f1(:,:,i,j) + a302*f2(:,:,i,j)
        q31(:,:) = a310*f1(:,:,i,j) + a311*f2(:,:,i,j) + a312*f3(:,:,i,j)
        q32(:,:) = a320*f2(:,:,i,j) + a321*f3(:,:,i,j) + a322*f4(:,:,i,j)

        h%p(lo%d(1):hi%d(1),lo%d(2):hi%d(2),i,j) = w0(:,:)*q30(:,:) &
                                                  +w1(:,:)*q31(:,:) &
                                                  +w2(:,:)*q32(:,:)
      enddo
    enddo
  end subroutine reconst_component_matrix_wenoe5

  module subroutine reconst_component_tensor_wenoe5(h,f,lo,hi,padding,bias,axis)
    implicit none
    type(rtensorfield_t),intent(inout) :: h
    type(rtensorfield_t),target,intent(in) :: f
    type(ftensorshape_t),intent(in) :: lo,hi,padding
    integer,intent(in) :: bias,axis

    double precision,dimension(:,:,:,:,:),pointer :: f0
    double precision,dimension(:,:,:,:,:),pointer :: f1
    double precision,dimension(:,:,:,:,:),pointer :: f2
    double precision,dimension(:,:,:,:,:),pointer :: f3
    double precision,dimension(:,:,:,:,:),pointer :: f4
    integer :: fllo,flhi, &
               fmlo,fmhi, &
               fnlo,fnhi, &
               filo,fihi, &
               fjlo,fjhi

    double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3)) :: is0,is1,is2
    double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3)) :: fpp,fppp
    double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3)) :: aa0,aa1,aa2,aa_sum
    double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3)) :: tau5
    double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3)) :: w0,w1,w2
    double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3)) :: q30,q31,q32
    integer :: i,j
    integer,dimension(5) :: shift
    if(bias.eq.bias_upwind) then
      shift = (/-2,-1,0,1,2/)
    else
      shift = (/3,2,1,0,-1/)
    endif
    fllo = lo%d(1) + padding%d(1)
    flhi = hi%d(1) + padding%d(1)
    fmlo = lo%d(2) + padding%d(2)
    fmhi = hi%d(2) + padding%d(2)
    fnlo = lo%d(3) + padding%d(3)
    fnhi = hi%d(3) + padding%d(3)
    filo = lo%d(4) + padding%d(4)
    fihi = hi%d(4) + padding%d(4)
    fjlo = lo%d(5) + padding%d(5)
    fjhi = hi%d(5) + padding%d(5)
    select case(axis)
    case(axis_xi)
      f0 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(1):fihi+shift(1),fjlo:fjhi)
      f1 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(2):fihi+shift(2),fjlo:fjhi)
      f2 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(3):fihi+shift(3),fjlo:fjhi)
      f3 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(4):fihi+shift(4),fjlo:fjhi)
      f4 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(5):fihi+shift(5),fjlo:fjhi)
    case(axis_eta)
      f0 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(1):fjhi+shift(1))
      f1 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(2):fjhi+shift(2))
      f2 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(3):fjhi+shift(3))
      f3 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(4):fjhi+shift(4))
      f4 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(5):fjhi+shift(5))
    case default
      print*,"Error: reconst_component_tensor_wenoe5()"
      print*,"No such ireconst: ",axis
      stop
    end select
    do j = lo%d(5), hi%d(5)
      do i = lo%d(4), hi%d(4)
        is0(:,:,:) = (f0(:,:,:,i,j)-2.d0*f1(:,:,:,i,j)+f2(:,:,:,i,j))**2*13.d0/12.d0 &
                    +(f0(:,:,:,i,j)-4.d0*f1(:,:,:,i,j)+3.d0*f2(:,:,:,i,j))**2/4.d0

        is1(:,:,:) = (f1(:,:,:,i,j)-2.d0*f2(:,:,:,i,j)+f3(:,:,:,i,j))**2*13.d0/12.d0 &
                    +(f1(:,:,:,i,j)-f3(:,:,:,i,j))**2/4.d0

        is2(:,:,:) = (f2(:,:,:,i,j)-2.d0*f3(:,:,:,i,j)+f4(:,:,:,i,j))**2*13.d0/12.d0 &
                    +(3.d0*f2(:,:,:,i,j)-4.d0*f3(:,:,:,i,j)+f4(:,:,:,i,j))**2/4.d0

        fpp(:,:,:) = (f0(:,:,:,i,j)-4.0d0*f1(:,:,:,i,j)+6.0d0*f2(:,:,:,i,j) -4.0d0*f3(:,:,:,i,j)+f4(:,:,:,i,j))*0.6988d0 &
                    +(f1(:,:,:,i,j)-2.0d0*f2(:,:,:,i,j)+f3(:,:,:,i,j))

        fppp(:,:,:) = 0.5*(-f0(:,:,:,i,j) + 2.0*f1(:,:,:,i,j) - 2.0*f3(:,:,:,i,j) + f4(:,:,:,i,j))

        tau5(:,:,:) = abs(is0(:,:,:) - is2(:,:,:) + 13.0/3.0*fpp(:,:,:)*fppp(:,:,:))
        aa0(:,:,:)  = c30*(1.d0 + (tau5(:,:,:)/(ss+is0(:,:,:)))**2)
        aa1(:,:,:)  = c31*(1.d0 + (tau5(:,:,:)/(ss+is1(:,:,:)))**2)
        aa2(:,:,:)  = c32*(1.d0 + (tau5(:,:,:)/(ss+is2(:,:,:)))**2)
        aa_sum(:,:,:) = 1.d0/(aa0(:,:,:)+aa1(:,:,:)+aa2(:,:,:))

        w0(:,:,:) = aa0(:,:,:)*aa_sum(:,:,:)
        w1(:,:,:) = aa1(:,:,:)*aa_sum(:,:,:)
        w2(:,:,:) = aa2(:,:,:)*aa_sum(:,:,:)

        q30(:,:,:) = a300*f0(:,:,:,i,j) + a301*f1(:,:,:,i,j) + a302*f2(:,:,:,i,j)
        q31(:,:,:) = a310*f1(:,:,:,i,j) + a311*f2(:,:,:,i,j) + a312*f3(:,:,:,i,j)
        q32(:,:,:) = a320*f2(:,:,:,i,j) + a321*f3(:,:,:,i,j) + a322*f4(:,:,:,i,j)

        h%p(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3),i,j) = w0(:,:,:)*q30(:,:,:) &
                                                                  +w1(:,:,:)*q31(:,:,:) &
                                                                  +w2(:,:,:)*q32(:,:,:)
      enddo
    enddo
  end subroutine reconst_component_tensor_wenoe5

  module subroutine cmpt_commweight_wenojs5(omega,f,lo,hi,padding,bias,axis)
    implicit none
    type(rvectorfield_t),intent(inout)     :: omega
    type(rscalarfield_t),target,intent(in) :: f
    type(fscalarshape_t),intent(in)        :: lo,hi,padding
    integer,intent(in)                     :: bias,axis

    double precision,dimension(:,:),pointer :: f0
    double precision,dimension(:,:),pointer :: f1
    double precision,dimension(:,:),pointer :: f2
    double precision,dimension(:,:),pointer :: f3
    double precision,dimension(:,:),pointer :: f4
    integer :: filo,fihi, &
               fjlo,fjhi

    double precision :: is0,is1,is2
    double precision :: aa0,aa1,aa2,aa_sum
    double precision :: w0,w1,w2
    integer :: i,j
    integer,dimension(5) :: shift

    if(bias.eq.bias_upwind) then
      shift = (/-2,-1,0,1,2/)
    else
      shift = (/3,2,1,0,-1/)
    endif
    filo = lo%d(1) + padding%d(1)
    fihi = hi%d(1) + padding%d(1)
    fjlo = lo%d(2) + padding%d(2)
    fjhi = hi%d(2) + padding%d(2)
    select case(axis)
    case(axis_xi)
      f0 => f%p(filo+shift(1):fihi+shift(1),fjlo:fjhi)
      f1 => f%p(filo+shift(2):fihi+shift(2),fjlo:fjhi)
      f2 => f%p(filo+shift(3):fihi+shift(3),fjlo:fjhi)
      f3 => f%p(filo+shift(4):fihi+shift(4),fjlo:fjhi)
      f4 => f%p(filo+shift(5):fihi+shift(5),fjlo:fjhi)
    case(axis_eta)
      f0 => f%p(filo:fihi,fjlo+shift(1):fjhi+shift(1))
      f1 => f%p(filo:fihi,fjlo+shift(2):fjhi+shift(2))
      f2 => f%p(filo:fihi,fjlo+shift(3):fjhi+shift(3))
      f3 => f%p(filo:fihi,fjlo+shift(4):fjhi+shift(4))
      f4 => f%p(filo:fihi,fjlo+shift(5):fjhi+shift(5))
    case default
      print*,"Error: cmpt_commweight_wenojs5()"
      print*,"No such ireconst: ",axis
      stop
    end select

    do j=lo%d(2), hi%d(2)
      do i=lo%d(1), hi%d(1)
        is0 = (f0(i,j) - 2.d0*f1(i,j) + f2(i,j))**2*13.d0/12.d0 &
             +(f1(i,j) - 4.d0*f2(i,j) + 3.d0*f3(i,j))**2/4.d0

        is1 = (f1(i,j) - 2.d0*f2(i,j)+f3(i,j))**2*13.d0/12.d0 &
             +(f1(i,j) - f3(i,j))**2/4.d0

        is2 = (f2(i,j) - 2.d0*f3(i,j) + f4(i,j))**2*13.d0/12.d0 &
             +(3.d0*f2(i,j) - 4.d0*f3(i,j) + f4(i,j))**2/4.d0

        aa0 = c30/(ss+is0)**2
        aa1 = c31/(ss+is1)**2
        aa2 = c32/(ss+is2)**2
        aa_sum = 1.d0/(aa0+aa1+aa2)

        w0 = aa0*aa_sum
        w1 = aa1*aa_sum
        w2 = aa2*aa_sum

        omega%p(:,i,j) = (/w0,w1,w2/)
      enddo
    enddo
  end subroutine cmpt_commweight_wenojs5

  module subroutine cmpt_commweight_wenoz5(omega,f,lo,hi,padding,bias,axis)
    implicit none
    type(rvectorfield_t),intent(inout)     :: omega
    type(rscalarfield_t),target,intent(in) :: f
    type(fscalarshape_t),intent(in)        :: lo,hi,padding
    integer,intent(in)                     :: bias,axis

    double precision,dimension(:,:),pointer :: f0
    double precision,dimension(:,:),pointer :: f1
    double precision,dimension(:,:),pointer :: f2
    double precision,dimension(:,:),pointer :: f3
    double precision,dimension(:,:),pointer :: f4
    integer :: filo,fihi, &
               fjlo,fjhi

    double precision :: is0,is1,is2
    double precision :: tau5
    double precision :: aa0,aa1,aa2,aa_sum
    double precision :: w0,w1,w2
    integer :: i,j
    integer,dimension(5) :: shift

    if(bias.eq.bias_upwind) then
      shift = (/-2,-1,0,1,2/)
    else
      shift = (/3,2,1,0,-1/)
    endif
    filo = lo%d(1) + padding%d(1)
    fihi = hi%d(1) + padding%d(1)
    fjlo = lo%d(2) + padding%d(2)
    fjhi = hi%d(2) + padding%d(2)
    select case(axis)
    case(axis_xi)
      f0 => f%p(filo+shift(1):fihi+shift(1),fjlo:fjhi)
      f1 => f%p(filo+shift(2):fihi+shift(2),fjlo:fjhi)
      f2 => f%p(filo+shift(3):fihi+shift(3),fjlo:fjhi)
      f3 => f%p(filo+shift(4):fihi+shift(4),fjlo:fjhi)
      f4 => f%p(filo+shift(5):fihi+shift(5),fjlo:fjhi)
    case(axis_eta)
      f0 => f%p(filo:fihi,fjlo+shift(1):fjhi+shift(1))
      f1 => f%p(filo:fihi,fjlo+shift(2):fjhi+shift(2))
      f2 => f%p(filo:fihi,fjlo+shift(3):fjhi+shift(3))
      f3 => f%p(filo:fihi,fjlo+shift(4):fjhi+shift(4))
      f4 => f%p(filo:fihi,fjlo+shift(5):fjhi+shift(5))
    case default
      print*,"Error: cmpt_commweight_wenoz5()"
      print*,"No such ireconst: ",axis
      stop
    end select

    do j=lo%d(2), hi%d(2)
      do i=lo%d(1), hi%d(1)
        is0 = (f0(i,j) - 2.d0*f1(i,j) + f2(i,j))**2*13.d0/12.d0 &
             +(f1(i,j) - 4.d0*f2(i,j) + 3.d0*f3(i,j))**2/4.d0

        is1 = (f1(i,j) - 2.d0*f2(i,j)+f3(i,j))**2*13.d0/12.d0 &
             +(f1(i,j) - f3(i,j))**2/4.d0

        is2 = (f2(i,j) - 2.d0*f3(i,j) + f4(i,j))**2*13.d0/12.d0 &
             +(3.d0*f2(i,j) - 4.d0*f3(i,j) + f4(i,j))**2/4.d0

        tau5 = abs(is2-is0)
        aa0  = c30*(1.d0 + (tau5/(ss+is0))**2)
        aa1  = c31*(1.d0 + (tau5/(ss+is1))**2)
        aa2  = c32*(1.d0 + (tau5/(ss+is2))**2)
        aa_sum = 1.d0/(aa0+aa1+aa2)

        w0 = aa0*aa_sum
        w1 = aa1*aa_sum
        w2 = aa2*aa_sum

        omega%p(:,i,j) = (/w0,w1,w2/)
      enddo
    enddo
  end subroutine cmpt_commweight_wenoz5

  module subroutine cmpt_commweight_wenoe5(omega,f,lo,hi,padding,bias,axis)
    implicit none
    type(rvectorfield_t),intent(inout)     :: omega
    type(rscalarfield_t),target,intent(in) :: f
    type(fscalarshape_t),intent(in)        :: lo,hi,padding
    integer,intent(in)                     :: bias,axis

    double precision,dimension(:,:),pointer :: f0
    double precision,dimension(:,:),pointer :: f1
    double precision,dimension(:,:),pointer :: f2
    double precision,dimension(:,:),pointer :: f3
    double precision,dimension(:,:),pointer :: f4
    integer :: filo,fihi, &
               fjlo,fjhi

    double precision :: is0,is1,is2
    double precision :: fpp,fppp
    double precision :: tau5
    double precision :: aa0,aa1,aa2,aa_sum
    double precision :: w0,w1,w2
    integer :: i,j
    integer,dimension(5) :: shift

    if(bias.eq.bias_upwind) then
      shift = (/-2,-1,0,1,2/)
    else
      shift = (/3,2,1,0,-1/)
    endif
    filo = lo%d(1) + padding%d(1)
    fihi = hi%d(1) + padding%d(1)
    fjlo = lo%d(2) + padding%d(2)
    fjhi = hi%d(2) + padding%d(2)
    select case(axis)
    case(axis_xi)
      f0 => f%p(filo+shift(1):fihi+shift(1),fjlo:fjhi)
      f1 => f%p(filo+shift(2):fihi+shift(2),fjlo:fjhi)
      f2 => f%p(filo+shift(3):fihi+shift(3),fjlo:fjhi)
      f3 => f%p(filo+shift(4):fihi+shift(4),fjlo:fjhi)
      f4 => f%p(filo+shift(5):fihi+shift(5),fjlo:fjhi)
    case(axis_eta)
      f0 => f%p(filo:fihi,fjlo+shift(1):fjhi+shift(1))
      f1 => f%p(filo:fihi,fjlo+shift(2):fjhi+shift(2))
      f2 => f%p(filo:fihi,fjlo+shift(3):fjhi+shift(3))
      f3 => f%p(filo:fihi,fjlo+shift(4):fjhi+shift(4))
      f4 => f%p(filo:fihi,fjlo+shift(5):fjhi+shift(5))
    case default
      print*,"Error: cmpt_commweight_wenoe5()"
      print*,"No such ireconst: ",axis
      stop
    end select

    do j=lo%d(2), hi%d(2)
      do i=lo%d(1), hi%d(1)
        is0 = (f0(i,j) - 2.d0*f1(i,j) + f2(i,j))**2*13.d0/12.d0 &
             +(f1(i,j) - 4.d0*f2(i,j) + 3.d0*f3(i,j))**2/4.d0

        is1 = (f1(i,j) - 2.d0*f2(i,j)+f3(i,j))**2*13.d0/12.d0 &
             +(f1(i,j) - f3(i,j))**2/4.d0

        is2 = (f2(i,j) - 2.d0*f3(i,j) + f4(i,j))**2*13.d0/12.d0 &
             +(3.d0*f2(i,j) - 4.d0*f3(i,j) + f4(i,j))**2/4.d0

        fpp  = (f0(i,j)-4.0d0*f1(i,j)+6.0d0*f2(i,j) -4.0d0*f3(i,j)+f4(i,j))*0.6988d0 &
              +(f1(i,j)-2.0d0*f2(i,j)+f3(i,j))

        fppp = 0.5*(-f0(i,j) + 2.0*f1(i,j) - 2.0*f3(i,j) + f4(i,j))

        tau5 = abs(is0 - is2 + 13.0/3.0*fpp*fppp)

        aa0    = c30*(1.d0 + (tau5/(ss+is0))**2)
        aa1    = c31*(1.d0 + (tau5/(ss+is1))**2)
        aa2    = c32*(1.d0 + (tau5/(ss+is2))**2)
        aa_sum = 1.d0/(aa0+aa1+aa2)

        w0 = aa0*aa_sum
        w1 = aa1*aa_sum
        w2 = aa2*aa_sum

        omega%p(:,i,j) = (/w0,w1,w2/)
      enddo
    enddo
  end subroutine cmpt_commweight_wenoe5

module subroutine reconst_commweight_scalar_weno5(h,f,omega,lo,hi,padding,bias,axis)
  implicit none
  type(rscalarfield_t),intent(inout)     :: h
  type(rscalarfield_t),target,intent(in) :: f
  type(rvectorfield_t),intent(in)        :: omega
  type(fscalarshape_t),intent(in)        :: lo,hi,padding
  integer,intent(in)                     :: bias,axis

  double precision,dimension(:,:),pointer :: f0
  double precision,dimension(:,:),pointer :: f1
  double precision,dimension(:,:),pointer :: f2
  double precision,dimension(:,:),pointer :: f3
  double precision,dimension(:,:),pointer :: f4
  integer :: filo,fihi, &
             fjlo,fjhi

  double precision :: q30,q31,q32
  integer :: i,j
  integer,dimension(5) :: shift

  if(bias.eq.bias_upwind) then
    shift = (/-2,-1,0,1,2/)
  else
    shift = (/3,2,1,0,-1/)
  endif
  filo = lo%d(1) + padding%d(1)
  fihi = hi%d(1) + padding%d(1)
  fjlo = lo%d(2) + padding%d(2)
  fjhi = hi%d(2) + padding%d(2)
  select case(axis)
  case(axis_xi)
    f0 => f%p(filo+shift(1):fihi+shift(1),fjlo:fjhi)
    f1 => f%p(filo+shift(2):fihi+shift(2),fjlo:fjhi)
    f2 => f%p(filo+shift(3):fihi+shift(3),fjlo:fjhi)
    f3 => f%p(filo+shift(4):fihi+shift(4),fjlo:fjhi)
    f4 => f%p(filo+shift(5):fihi+shift(5),fjlo:fjhi)
  case(axis_eta)
    f0 => f%p(filo:fihi,fjlo+shift(1):fjhi+shift(1))
    f1 => f%p(filo:fihi,fjlo+shift(2):fjhi+shift(2))
    f2 => f%p(filo:fihi,fjlo+shift(3):fjhi+shift(3))
    f3 => f%p(filo:fihi,fjlo+shift(4):fjhi+shift(4))
    f4 => f%p(filo:fihi,fjlo+shift(5):fjhi+shift(5))
  case default
    print*,"Error: reconst_commweight_scalar_weno5()"
    print*,"No such ireconst: ",axis
    stop
  end select

  do j=lo%d(2), hi%d(2)
    do i=lo%d(1), hi%d(1)

      q30 = a300*f0(i,j) + a301*f1(i,j) + a302*f2(i,j)
      q31 = a310*f1(i,j) + a311*f3(i,j) + a312*f3(i,j)
      q32 = a320*f2(i,j) + a321*f3(i,j) + a322*f4(i,j)

      h%p(i,j) = omega%p(1,i,j)*q30 + omega%p(2,i,j)*q31 + omega%p(3,i,j)*q32
    enddo
  enddo
end subroutine reconst_commweight_scalar_weno5

module subroutine reconst_commweight_vector_weno5(h,f,omega,lo,hi,padding,bias,axis)
  implicit none
  type(rvectorfield_t),intent(inout)     :: h
  type(rvectorfield_t),target,intent(in) :: f
  type(rvectorfield_t),intent(in)        :: omega
  type(fvectorshape_t),intent(in)        :: lo,hi,padding
  integer,intent(in)                     :: bias,axis

  double precision,dimension(:,:,:),pointer :: f0
  double precision,dimension(:,:,:),pointer :: f1
  double precision,dimension(:,:,:),pointer :: f2
  double precision,dimension(:,:,:),pointer :: f3
  double precision,dimension(:,:,:),pointer :: f4
  integer :: fnlo,fnhi, &
             filo,fihi, &
             fjlo,fjhi

  double precision,dimension(lo%d(1):hi%d(1)) :: q30,q31,q32
  integer :: i,j
  integer,dimension(5) :: shift
  if(bias.eq.bias_upwind) then
    shift = (/-2,-1,0,1,2/)
  else
    shift = (/3,2,1,0,-1/)
  endif
  fnlo = lo%d(1) + padding%d(1)
  fnhi = hi%d(1) + padding%d(1)
  filo = lo%d(2) + padding%d(2)
  fihi = hi%d(2) + padding%d(2)
  fjlo = lo%d(3) + padding%d(3)
  fjhi = hi%d(3) + padding%d(3)
  select case(axis)
  case(axis_xi)
    f0 => f%p(fnlo:fnhi,filo+shift(1):fihi+shift(1),fjlo:fjhi)
    f1 => f%p(fnlo:fnhi,filo+shift(2):fihi+shift(2),fjlo:fjhi)
    f2 => f%p(fnlo:fnhi,filo+shift(3):fihi+shift(3),fjlo:fjhi)
    f3 => f%p(fnlo:fnhi,filo+shift(4):fihi+shift(4),fjlo:fjhi)
    f4 => f%p(fnlo:fnhi,filo+shift(5):fihi+shift(5),fjlo:fjhi)
  case(axis_eta)
    f0 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(1):fjhi+shift(1))
    f1 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(2):fjhi+shift(2))
    f2 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(3):fjhi+shift(3))
    f3 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(4):fjhi+shift(4))
    f4 => f%p(fnlo:fnhi,filo:fihi,fjlo+shift(5):fjhi+shift(5))
  case default
    print*,"Error: reconst_commweight_vector_weno5()"
    print*,"No such ireconst: ",axis
    stop
  end select

  do j=lo%d(3), hi%d(3)
    do i=lo%d(2), hi%d(2)

      q30(:) = a300*f0(:,i,j) + a301*f1(:,i,j) + a302*f2(:,i,j)
      q31(:) = a310*f1(:,i,j) + a311*f2(:,i,j) + a312*f3(:,i,j)
      q32(:) = a320*f2(:,i,j) + a321*f3(:,i,j) + a322*f4(:,i,j)

      h%p(lo%d(1):hi%d(1),i,j) =  omega%p(1,i,j)*q30(:) &
                                + omega%p(2,i,j)*q31(:) &
                                + omega%p(3,i,j)*q32(:)
    enddo
  enddo
end subroutine reconst_commweight_vector_weno5

module subroutine reconst_commweight_matrix_weno5(h,f,omega,lo,hi,padding,bias,axis)
  implicit none
  type(rmatrixfield_t),intent(inout)     :: h
  type(rmatrixfield_t),target,intent(in) :: f
  type(rvectorfield_t),intent(in)        :: omega
  type(fmatrixshape_t),intent(in)        :: lo,hi,padding
  integer,intent(in)                     :: bias,axis

  double precision,dimension(:,:,:,:),pointer :: f0
  double precision,dimension(:,:,:,:),pointer :: f1
  double precision,dimension(:,:,:,:),pointer :: f2
  double precision,dimension(:,:,:,:),pointer :: f3
  double precision,dimension(:,:,:,:),pointer :: f4
  integer :: fmlo,fmhi, &
             fnlo,fnhi, &
             filo,fihi, &
             fjlo,fjhi

  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2)) :: q30,q31,q32
  integer :: i,j
  integer,dimension(5) :: shift
  if(bias.eq.bias_upwind) then
    shift = (/-2,-1,0,1,2/)
  else
    shift = (/3,2,1,0,-1/)
  endif
  fmlo = lo%d(1) + padding%d(1)
  fmhi = hi%d(1) + padding%d(1)
  fnlo = lo%d(2) + padding%d(2)
  fnhi = hi%d(2) + padding%d(2)
  filo = lo%d(3) + padding%d(3)
  fihi = hi%d(3) + padding%d(3)
  fjlo = lo%d(4) + padding%d(4)
  fjhi = hi%d(4) + padding%d(4)
  select case(axis)
  case(axis_xi)
    f0 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(1):fihi+shift(1),fjlo:fjhi)
    f1 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(2):fihi+shift(2),fjlo:fjhi)
    f2 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(3):fihi+shift(3),fjlo:fjhi)
    f3 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(4):fihi+shift(4),fjlo:fjhi)
    f4 => f%p(fmlo:fmhi,fnlo:fnhi,filo+shift(5):fihi+shift(5),fjlo:fjhi)
  case(axis_eta)
    f0 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(1):fjhi+shift(1))
    f1 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(2):fjhi+shift(2))
    f2 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(3):fjhi+shift(3))
    f3 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(4):fjhi+shift(4))
    f4 => f%p(fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(5):fjhi+shift(5))
  case default
    print*,"Error: reconst_commweight_matrix_weno5()"
    print*,"No such ireconst: ",axis
    stop
  end select
  do j = lo%d(4), hi%d(4)
    do i = lo%d(3), hi%d(3)
      q30(:,:) = a300*f0(:,:,i,j) + a301*f1(:,:,i,j) + a302*f2(:,:,i,j)
      q31(:,:) = a310*f1(:,:,i,j) + a311*f2(:,:,i,j) + a312*f3(:,:,i,j)
      q32(:,:) = a320*f2(:,:,i,j) + a321*f3(:,:,i,j) + a322*f4(:,:,i,j)

      h%p(lo%d(1):hi%d(1),lo%d(2):hi%d(2),i,j) =  omega%p(1,i,j)*q30(:,:) &
                                                + omega%p(2,i,j)*q31(:,:) &
                                                + omega%p(3,i,j)*q32(:,:)
    enddo
  enddo
end subroutine reconst_commweight_matrix_weno5

module subroutine reconst_commweight_tensor_weno5(h,f,omega,lo,hi,padding,bias,axis)
  implicit none
  type(rtensorfield_t),intent(inout)     :: h
  type(rtensorfield_t),target,intent(in) :: f
  type(rvectorfield_t),intent(in)        :: omega
  type(ftensorshape_t),intent(in)        :: lo,hi,padding
  integer,intent(in)                     :: bias,axis

  double precision,dimension(:,:,:,:,:),pointer :: f0
  double precision,dimension(:,:,:,:,:),pointer :: f1
  double precision,dimension(:,:,:,:,:),pointer :: f2
  double precision,dimension(:,:,:,:,:),pointer :: f3
  double precision,dimension(:,:,:,:,:),pointer :: f4
  integer :: fllo,flhi, &
             fmlo,fmhi, &
             fnlo,fnhi, &
             filo,fihi, &
             fjlo,fjhi

  double precision,dimension(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3)) :: q30,q31,q32
  integer :: i,j
  integer,dimension(5) :: shift
  if(bias.eq.bias_upwind) then
    shift = (/-2,-1,0,1,2/)
  else
    shift = (/3,2,1,0,-1/)
  endif
  fllo = lo%d(1) + padding%d(1)
  flhi = hi%d(1) + padding%d(1)
  fmlo = lo%d(2) + padding%d(2)
  fmhi = hi%d(2) + padding%d(2)
  fnlo = lo%d(3) + padding%d(3)
  fnhi = hi%d(3) + padding%d(3)
  filo = lo%d(4) + padding%d(4)
  fihi = hi%d(4) + padding%d(4)
  fjlo = lo%d(5) + padding%d(5)
  fjhi = hi%d(5) + padding%d(5)
  select case(axis)
  case(axis_xi)
    f0 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(1):fihi+shift(1),fjlo:fjhi)
    f1 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(2):fihi+shift(2),fjlo:fjhi)
    f2 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(3):fihi+shift(3),fjlo:fjhi)
    f3 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(4):fihi+shift(4),fjlo:fjhi)
    f4 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo+shift(5):fihi+shift(5),fjlo:fjhi)
  case(axis_eta)
    f0 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(1):fjhi+shift(1))
    f1 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(2):fjhi+shift(2))
    f2 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(3):fjhi+shift(3))
    f3 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(4):fjhi+shift(4))
    f4 => f%p(fllo:flhi,fmlo:fmhi,fnlo:fnhi,filo:fihi,fjlo+shift(5):fjhi+shift(5))
  case default
    print*,"Error: reconst_commweight_tensor_weno5()"
    print*,"No such ireconst: ",axis
    stop
  end select
  do j = lo%d(5), hi%d(5)
    do i = lo%d(4), hi%d(4)
      q30(:,:,:) = a300*f0(:,:,:,i,j) + a301*f1(:,:,:,i,j) + a302*f2(:,:,:,i,j)
      q31(:,:,:) = a310*f1(:,:,:,i,j) + a311*f2(:,:,:,i,j) + a312*f3(:,:,:,i,j)
      q32(:,:,:) = a320*f2(:,:,:,i,j) + a321*f3(:,:,:,i,j) + a322*f4(:,:,:,i,j)

      h%p(lo%d(1):hi%d(1),lo%d(2):hi%d(2),lo%d(3):hi%d(3),i,j) =  omega%p(1,i,j)*q30(:,:,:) &
                                                                + omega%p(2,i,j)*q31(:,:,:) &
                                                                + omega%p(3,i,j)*q32(:,:,:)
    enddo
  enddo
end subroutine reconst_commweight_tensor_weno5
end submodule


       subroutine pmlp(l,p1,p2)
C.............to ka (p1), c mmetp  ha  to ke (p2)othoc te  ho  p mo  l
      real l(3),p1(2),p2(2)
      d=l(1)*l(1)+l(2)*l(2)
      p2(1)=(-2.*l(3)*l(1)-(l(1)*l(1)-l(2)*l(2))*p1(1)-
     12.*l(1)*l(2)*p1(2))/d
      p2(2)=(-2.*l(2)*l(3)-2.*l(1)*l(2)*p1(1)+(l(1)*l(1)-l(2)*l(2))*
     1p1(2))/d
      return
      end


      module MOD_INV

      contains

      SUBROUTINE INV(N, A)

C******************************************************************************
C***  MATRIX INVERSION (CRAY FORTRAN)
C***  MATRIX A
C***  N = RANK OF SUBMATRIX (LEFT UPPER BLOCK) TO BE INVERTED
C******************************************************************************

      USE MOD_ERROR

      implicit real*8(a - h, o - z)

      integer, intent(in) :: N

      real*8, intent(inout) :: A(N, N)

      integer :: IK(N), JK(N)

      DO 100 K = 1, N
C
C     SUCHE MAXIMALES MATRIXELEMENT
!      AMAX=0.
!      ABSAMAX=0.

!         do J = K, N
!        L=N+1-K
!        ISAMAX=1
!        DO LL=1,L
c           PRINT *, 'N=',N, 'J=',J,'LL=',LL,'A(LL,J)=',A(LL,J)
!           IF (abs(A(K+LL-1,j)).gt.abs(A(K+isamax-1,j))) isamax=LL
!        ENDDO
!        imax=isamax+K-1
c*cray      IMAX=ISAMAX(L,A(K,J),1)+K-1
!      IF(ABSAMAX.GT.ABS(A(IMAX,J))) GOTO 30
!      AMAX=A(IMAX,J)
!      ABSAMAX=ABS(AMAX)

            imax = maxloc(abs(A(k, k : n))

            amax = a(imax, j)

            absamax = abs(amax)

            IK(K) = IMAX
            JK(K) = J

!         enddo
C
C***  STOP IN CASE OF SINGULARITY (PIVOT ELEMENT = 0 )
      IF (AMAX .EQ. .0) THEN
        print *,'INV: SINGULARITY DISCOVERED'
        print *,'INV: ',N, AMAX
        CALL ERROR('inv.for: ERROR SINGULARITY DISCOVERED')
      ENDIF
C
C     VERTAUSCHEN DER ZEILEN I UND K
      I=IK(K)
      IF(I.NE.K) THEN
        DO J=1,N
          SAVE =A(K,J)
          A(K,J)=A(I,J)
          A(I,J)=-SAVE
        ENDDO
      ENDIF
C
C     VERTAUSCHEN DER SPALTEN J UND K
      J=JK(K)
      IF(J.NE.K) THEN
        DO I=1,N
          SAVE = A(I,K)
          A(I,K)=A(I,J)
          A(I,J)=-SAVE
        ENDDO
      ENDIF
C
C     DIVISION DER SPALTE K DURCH AMAX
      A(1:N,K)=-A(1:N,K)/AMAX
      A(K,K)=0.
C
C     UMFORMEN DER ZEILEN UND SPALTEN
C***  ELEMENTARE UMFORMUNG:  ZEILE I = ZEILE I + A(I,K) * ZEILE K
      DO 81 I=1,N
      IF (I .EQ. K) GOTO 81
      AIK=A(I,K)
      A(I,1:N)=A(I,1:N)+AIK*A(K,1:N)
   81 CONTINUE
C
C***  SPALTE K: DIVISION DUCH AMAX
      DO 90 J=1,N
      A(K,J)=A(K,J)/AMAX
  90  CONTINUE
C
C***  DIAGONALELEMENT
      A(K,K)=1./AMAX
  100 CONTINUE
C
C
C     ZEILEN UND SPALTEN RUECKTAUSCHOPERATIONEN
      DO 130 L=1,N
      K=N-L+1
      J=IK(K)
      IF(J.LE.K) GOTO 111
C***  VERTAUSCHEN DER SPALTEN J UND K
      DO 110 I=1,N
       SAVE=A(I,K)
      A(I,K)=-A(I,J)
  110 A(I,J)=SAVE
  111 I=JK(K)
      IF(I .LE. K) GOTO 130
C***  VERTAUSCHEN DER ZEILEN I UND K
      DO 120 J=1,N
      SAVE=A(K,J)
      A(K,J)=-A(I,J)
  120 A(I,J)=SAVE
  130 CONTINUE
C
      RETURN
      END SUBROUTINE
      END MODULE


C    @(#)linflo.f	20.3 2/13/96
      subroutine linflo (i,ain,pin,qin,c1,dv1,c2,dv2)
C
C     This subroutine calculates the line flow AIN (in amps) and
C     PIN + jQIN (in MW and MVAR) for transfer sensitivity branch I.
C     The voltages are subjected to compensation-perturbation C1*DV1(,)
C     and transfer-perturbation C2*DV2().
C

      include 'ipfinc/parametr.inc'

      include 'ipfinc/blank.inc'
c	Global variables used:
c		bmva
      include 'ipfinc/bus.inc'
c	Global variables used:
c		e(r*8), f(r*8)
      include 'ipfinc/transf.inc'
c	Global variables used:
c		fdata, fymtrx
c
      double precision dv1(2,*)
      real  dv2(*)
      complex v(2), a(2), ax, vx

      if (abs (c1) .ge. 1.0e10 .or. abs (c2) .ge. 1.0e10) then
         pin = 1.0e10
         qin = 1.0e10
         ain = 1.0e10
      else
         k1 = kfdata(1,i)
         k2 = kfdata(2,i)

         vk = e(k1)
         ak = f(k1) + c1 * dv1(1,k1) + c2 * dv2(k1)
         ek = vk * cos (ak)
         fk = vk * sin (ak)
         v(1) = cmplx (ek,fk)

         vm = e(k2)
         am = f(k2) + c1 * dv1(1,k2) + c2 * dv2(k2)
         em = vm * cos (am)
         fm = vm * sin (am)
         v(2) = cmplx (em,fm)

         a(1) = fymtrx(1,i) * v(1) + fymtrx(2,i) * v(2)
C
C        Compute branch voltages and currents into section voltages and
C        currents.
C
         vx =  (cmplx (fdata(15,i),fdata(16,i)) * v(1)
     1        + cmplx (fdata(17,i),fdata(18,i)) * a(1))
         ax =  (cmplx (fdata(19,i),fdata(20,i)) * v(1)
     1        + cmplx (fdata(21,i),fdata(22,i)) * a(1))

         ain = cabs (ax) * fdata(10,i)
         pin = real (vx * conjg (ax)) * bmva
         qin = aimag (vx * conjg (ax)) * bmva
      endif

      return
      end


      subroutine limiter_srd(qp, qx, qy, mitot, mjtot, irr, nvar, hx,
     . hy, lwidth, lstgrd, xlow, ylow)
       implicit double precision(a-h,o-z)

       common /order2/ ssw, primitive, nolimiter
       dimension nlist(25,2)
       logical primitive
       include "./reconinfo.i"
       include "cirr.i"
       dimension qp(mitot,mjtot,4),qx(irrsize,4),
     &           qy(irrsize,4),irr(mitot,mjtot)

       dimension dumax(4),dumin(4),phimin(4)
       dimension graddot(4),alpha(4),recon(4)
       logical IS_GHOST, verbose/.true./
       IS_GHOST(i,j) = (i .le. lwidth .or. i .gt. mitot-lwidth .or.
     .                  j .le. lwidth .or. j .gt. mjtot-lwidth)

!        qx = 0.d0
!        qy = 0.d0
!        return

       if(primitive .eqv. .false.) then
        print *, "PROBLEM: THE CURRENT LIMITER IMPLEMENTATION ONLY WORKS
     .            WHEN RECONSTRUCTING IN PRIMITIVE VARIABLES."
       endif

      do 30 j = lwidth+1, mjtot-lwidth
      do 30 i = lwidth+1, mitot-lwidth

!          if( i .eq. 12 .and. j .eq. 14) then
!          print *, "here"
!          endif

          k = irr(i,j)
          if (k .eq. -1 .or. k .eq. lstgrd) goto 30 ! solid/full cells have no need for a gradient

          ! find max and min needed for BJ limiting
          dumax = 0.d0
          dumin = 0.d0
          do 31 joff = -mjoff(i,j), mjoff(i,j)
          do 31 ioff = -mioff(i,j), mioff(i,j)
            if (ioff .eq. 0 .and. joff .eq. 0) go to 31
            if (IS_GHOST(i+ioff,j+joff)) go to 31

            koff = irr(i+ioff,j+joff)
            if (koff .eq. -1) go to 31
            dumax = max(dumax,qp(i+ioff,j+joff,:)-qp(i,j,:))
            dumin = min(dumin,qp(i+ioff,j+joff,:)-qp(i,j,:))
  31      continue

          phimin = 1.d0
          do 32 joff = -mjoff(i,j), mjoff(i,j)
          do 32 ioff = -mioff(i,j), mioff(i,j)
             if (ioff .eq. 0 .and. joff .eq. 0) go to 32 ! no eqn to solve
             if (IS_GHOST(i+ioff,j+joff)) go to 32
             koff = irr(i+ioff,j+joff)
             if (koff .eq. -1) go to 32

             if(koff .eq. lstgrd) then
              call getCellCentroid(lstgrd,i+ioff,j+joff,xc,yc,xlow,
     .                       ylow,hx,hy,koff)
             else
                 xc = xcentMerge(koff)
                 yc = ycentMerge(koff)
             endif

              diffx = xc-xcentMerge(k)
              diffy = yc-ycentMerge(k)
              graddot  = qx(k,:)*diffx + qy(k,:)*diffy
              recon = qp(i,j,:) + graddot
                do m = 1,4
                   if (graddot(m) > 0.d0) then
                      alpha(m) = min(1.d0, dumax(m)/graddot(m))
                   else if (graddot(m) < 0.d0) then
                      alpha(m) = min(1.d0, dumin(m)/graddot(m))
                   else
                      alpha(m) = 1.d0
                   endif
                end do
                ! one last check for positivity
!                if (recon(1) .le. 0.d0) alpha = 0.d0
!                velsq = recon(2)**2+recon(3)**2
!                press = .4d0*(recon(4)-0.5d0*velsq/recon(1))
!                if (press .le. 0.d0) alpha = 0.d0
                phimin = min(phimin, alpha)
  32      continue
          qx(k,:) = qx(k,:)*phimin(:)
          qy(k,:) = qy(k,:)*phimin(:)

  30  continue

110   continue

      ! final check for positivity
      do 310 j = lwidth+1, mjtot-lwidth
      do 310 i = lwidth+1, mitot-lwidth
          k = irr(i,j)
          if (k .eq. -1 .or. k .eq. lstgrd) goto 310 ! solid/full cells have no need for a gradient

          alpha = 1.d0
          do 27 ic = 1, ncount(k)
             icurr = iidx(k,ic)
             jcurr = jidx(k,ic)
             koff = irr(icurr,jcurr)
             call getCellCentroid(lstgrd,icurr,jcurr,xc,yc,xlow,
     .                            ylow,hx,hy,koff)
             diffx = xc-xcentMerge(k)
             diffy = yc-ycentMerge(k)
             graddot  = qx(k,:)*diffx + qy(k,:)*diffy
             recon = qp(i,j,:) + graddot
             ! one last check for positivity
             if (recon(1) .le. 0.d0) alpha = 0.d0
             velsq = recon(2)**2+recon(3)**2
             press = .4d0*(recon(4)-0.5d0*velsq/recon(1))
             if (press .le. 0.d0) alpha = 0.d0
  27      continue
          qx(k,:) = qx(k,:)*alpha(:)
          qy(k,:) = qy(k,:)*alpha(:)
  310 continue

      ! final check for positivity
      do 111 j = lwidth+1, mjtot-lwidth
      do 111 i = lwidth+1, mitot-lwidth
          k = irr(i,j)
          if (k .eq. -1 .or. k .eq. lstgrd) goto 111 ! solid/full cells have no need for a gradient

          alpha = 1.d0
          do 17 ic = 1, ncount(k)
             icurr = iidx(k,ic)
             jcurr = jidx(k,ic)
             koff = irr(icurr,jcurr)
             call getCellCentroid(lstgrd,icurr,jcurr,xc,yc,xlow,
     .                            ylow,hx,hy,koff)
             diffx = xc-xcentMerge(k)
             diffy = yc-ycentMerge(k)
             recon = qp(i,j,:) + qx(k,:)*diffx + qy(k,:)*diffy
             ! one last check for positivity
             if (recon(1) .le. 0.d0) alpha = 0.d0
             velsq = recon(2)**2+recon(3)**2
             press = .4d0*(recon(4)-0.5d0*velsq/recon(1))
             if (press .le. 0.d0) alpha = 0.d0
  17      continue

          if(alpha(1) .eq. 0) then
          print *, "FINAL POSITIVITY CHECK FAILED."
          endif

  111 continue

      return
      end


      program genlat2
c
c***********************************************************************
c
c     program to generate a truncated octahedral cell from a perfect
c     lattice
c
c     copyright daresbury laboratory
c     author - w.smith oct. 1992
c
c***********************************************************************
c
      implicit real*8 (a-h,o-z)
      parameter (mxatom=10)
      dimension xb(mxatom),yb(mxatom),zb(mxatom)
      character*8 name(mxatom)
      character*80 title
      write(*,*)'enter suitable one-line title for lattice file'
      read(*,'(a80)')title
      write(*,*)'enter number of basis atoms (max 10)'
      read(*,*)natms
      write(*,*)'define cubic unit cell width'
      read(*,*)cell_param
      write(*,*)'define required spherical cutoff'
      read(*,*)radius
      write(*,*)'enter ion names (8 chars) and fractional coordinates'
      wdth=radius*4.d0/sqrt(3.d0)
      num=int(wdth/cell_param)
      if(dble(num)*cell_param.lt.wdth)num=num+1
      wdth=dble(num)*cell_param
      test=0.75d0*wdth
      density=dble(natms)/cell_param**3
      do i=1,natms
         read(*,*)name(i),xb(i),yb(i),zb(i)
      enddo
      open(10,file='LATTICE')
      write(10,'(a80)')title
      write(10,'(2i10)')0,4
      write(10,'(3f20.8)')wdth,0.d0,0.d0,0.d0,wdth,0.d0,0.d0,0.d0,wdth
c
c     set up lattice
      matms=0
      do  n=1,natms
         do  k=1,num
            do  j=1,num
               do  i=1,num
                  xs=dble(i-1)+xb(n)-0.5d0*dble(num)
                  xx=cell_param*xs
                  if(abs(xx).lt.0.5d0*wdth)then
                     yy=cell_param*ys
                     ys=dble(j-1)+yb(n)-0.5d0*dble(num)
                     if(abs(yy).lt.0.5d0*wdth)then
                        zs=dble(k-1)+zb(n)-0.5d0*dble(num)
                        zz=cell_param*zs
                        if(abs(zz).lt.0.5d0*wdth)then
                           if(abs(xx)+abs(yy)+abs(zz).lt.test)then
                              matms=matms+1
                              write(10,'(a8,/,3f20.6)')name(n),xx,yy,zz
                           endif
                        endif
                     endif
                  endif
               enddo
            enddo
         enddo
      enddo
      tdensty=dble(matms)/(0.5d0*wdth**3)
      actcut=wdth*sqrt(3.d0)/4.d0
      write(*,*)'width parameter of TO cell =',wdth
      write(*,*)'number of ions in system = ',matms
      write(*,*)'target density =',density
      write(*,*)'actual density =',tdensty
      write(*,*)'target cutoff  =',radius
      write(*,*)'maximum cutoff =',actcut
      stop
      end


C
C	Expression Tests:
C	A number of test cases for diagnosing
C	problems with order of operations and
C	constant folding.
C
C	For convinience, these always print out the
C	computed value followed by the expected value.
C

2	print -2+4,          2
3	print 1+2x3,         7
4	print (1+2)x3,       9
5	print -(1+2)x3,     -9
6	print mg(1+1,0),     0
7	print (1+mg(2,2))x2, 2


! Created by  on 13/03/2020.

submodule (AVD) AVD_sm
contains
    module function d0_over_i(obj, a) result(r)
        type(avd_b) :: r
        type(avd_b), intent(in) :: obj
        integer, intent(in)     :: a
        r%v = obj%v/a
    end function d0_over_i

    module function d0_over_r(obj, a) result(r)
        type(avd_b) :: r
        type(avd_b), intent(in) :: obj
        real(8), intent(in)     :: a
        r%v = obj%v/a
    end function d0_over_r

    module function i_over_d0(a, obj) result(r)
        type(avd_b) :: r
        type(avd_b), intent(in) :: obj
        integer, intent(in)     :: a
        r = a*obj**(-1)
    end function i_over_d0

    module function r_over_d0(a, obj) result(r)
        type(avd_b) :: r
        type(avd_b), intent(in) :: obj
        real(8), intent(in)     :: a
        r = a*obj**(-1)
    end function r_over_d0

    module function d1_over_i(obj, a) result(r)
        type(avd_d1) :: r
        type(avd_d1), intent(in) :: obj
        integer, intent(in)      :: a
        r%avd_b = obj%avd_b/a
        r%d1 = obj%d1/a
    end function d1_over_i

    module function d1_over_r(obj, a) result(r)
        type(avd_d1) :: r
        type(avd_d1), intent(in) :: obj
        real(8), intent(in)      :: a
        r%avd_b = obj%avd_b/a
        r%d1 = obj%d1/a
    end function d1_over_r

    module function i_over_d1(a, obj) result(r)
        type(avd_d1) :: r
        type(avd_d1), intent(in) :: obj
        integer, intent(in)      :: a
        r = a*obj**(-1)
    end function i_over_d1

    module function r_over_d1(a, obj) result(r)
        type(avd_d1) :: r
        type(avd_d1), intent(in) :: obj
        real(8), intent(in)      :: a
        r = a*obj**(-1)
    end function r_over_d1

    module function d2_over_i(obj, a) result(r)
        type(avd_d2) :: r
        type(avd_d2), intent(in) :: obj
        integer, intent(in)      :: a
        r%avd_d1 = obj%avd_d1/a
        r%d2 = obj%d2/a
    end function d2_over_i

    module function d2_over_r(obj, a) result(r)
        type(avd_d2) :: r
        type(avd_d2), intent(in) :: obj
        real(8), intent(in)      :: a
        r%avd_d1 = obj%avd_d1/a
        r%d2 = obj%d2/a
    end function d2_over_r

    module function i_over_d2(a, obj) result(r)
        type(avd_d2) :: r
        type(avd_d2), intent(in) :: obj
        integer, intent(in)      :: a
        r = a*obj**(-1)
    end function i_over_d2

    module function r_over_d2(a, obj) result(r)
        type(avd_d2) :: r
        type(avd_d2), intent(in) :: obj
        real(8), intent(in)      :: a
        r = a*obj**(-1)
    end function r_over_d2

    module function d3_over_i(obj, a) result(r)
        type(avd_d3) :: r
        type(avd_d3), intent(in) :: obj
        integer, intent(in)      :: a
        r%avd_d2 = obj%avd_d2/a
        r%d3 = obj%d3/a
    end function d3_over_i

    module function d3_over_r(obj, a) result(r)
        type(avd_d3) :: r
        type(avd_d3), intent(in) :: obj
        real(8), intent(in)      :: a
        r%avd_d2 = obj%avd_d2/a
        r%d3 = obj%d3/a
    end function d3_over_r

    module function i_over_d3(a, obj) result(r)
        type(avd_d3) :: r
        type(avd_d3), intent(in) :: obj
        integer, intent(in)      :: a
        r = a*obj**(-1)
    end function i_over_d3

    module function r_over_d3(a, obj) result(r)
        type(avd_d3) :: r
        type(avd_d3), intent(in) :: obj
        real(8), intent(in)      :: a
        r = a*obj**(-1)
    end function r_over_d3

    module function d4_over_i(obj, a) result(r)
        type(avd_d4) :: r
        type(avd_d4), intent(in) :: obj
        integer, intent(in)      :: a
        r%avd_d3 = obj%avd_d3/a
        r%d4 = obj%d4/a
    end function d4_over_i

    module function d4_over_r(obj, a) result(r)
        type(avd_d4) :: r
        type(avd_d4), intent(in) :: obj
        real(8), intent(in)      :: a
        r%avd_d3 = obj%avd_d3/a
        r%d4 = obj%d4/a
    end function d4_over_r

    module function i_over_d4(a, obj) result(r)
        type(avd_d4) :: r
        type(avd_d4), intent(in) :: obj
        integer, intent(in)      :: a
        r = a*obj**(-1)
    end function i_over_d4

    module function r_over_d4(a, obj) result(r)
        type(avd_d4) :: r
        type(avd_d4), intent(in) :: obj
        real(8), intent(in)      :: a
        r = a*obj**(-1)
    end function r_over_d4

    module function d4_over_d4(a, b) result(r)
        type(avd_d4) :: r
        type(avd_d4), intent(in) :: a, b
        r = a*b**(-1)
    end function d4_over_d4

end submodule AVD_sm


      subroutine recol(j,is,il,ia,x,y,d)
c     implicit double precision (a-h,o-z)                                    dp
c
c     reduce the components of a column or load vector
c
c     note- an assembly language version of this routine
c     is available for the cray-1 and for the cdc-7600.
c
      dimension ia(*),x(*),y(*),d(*)
c
      k=0
      i2=ia(is-1)
      do 20 ii=is,il
      i1=i2+1
      i2=ia(ii)
      n=i2-i1
      if(j.ge.0) n=min(n,k+j)
      k=k+1
      if(j.lt.0) d(ii)=x(i2)
      if(n.eq.0) go to 20
      s=0.
      do 10 i=1,n
      s=s+x(i+i2-n-1)*y(i+k-n-1)
   10 continue
      y(k)=y(k)-s
   20 continue
      return
      end


      PROGRAM test_fbspline
c23456789
      implicit none
      real*8 x0, x1
      integer*8 spline
      integer num, x0code, x1code, num_splines
      real x0val, x1val
      real a(11), b(11), val(2)
      real*8 x

      x0 = 0.0D0
      x1 = 1.0D0
      num = 11
      a(1) = 1.5
      a(2) = -1.3
      a(3) = 2.3
      a(4) = 3.1
      a(5) = 1.8
      a(6) = 0.9
      a(7) = -0.2
      a(8) = -1.0
      a(9) = -1.2
      a(10) = -0.8
      a(11) = 1.5

      b( 1) = 3.1
      b( 2) = -1.7
      b( 3) = 2.1
      b( 4) = 6.7
      b( 5) = 1.4
      b( 6) = 3.9
      b( 7) = -0.3
      b( 8) = -1.5
      b( 9) = -9.1
      b(10) = 5.1
      b(11) = 3.1
      x0code = 0
      x1code = 0
      num_splines = 2

      call fcreate_multi_ubspline_1d_s (x0, x1, num, x0code, x0val,
     +     x1code, x1val, num_splines, spline)
      call fset_multi_ubspline_1d_s (spline, 0, a);
      call fset_multi_ubspline_1d_s (spline, 1, b);
      x = 0.0D0
      do while (x .le. 1.00001D0)
        call feval_multi_ubspline_1d_s (spline, x, val)
        write (*,*) x, val(1), val(2)
        x = x + 0.001D0
      enddo

      stop
      end


! minimal Scalapack demo
implicit none

integer :: ictxt, myid, nprocs, mycol, myrow, npcol, nprow
real :: eps
real, external :: pslamch

! arbitrary test parameters
npcol = 2
nprow = 2

call blacs_pinfo(myid, nprocs)
call blacs_get(-1, 0, ictxt)
call blacs_gridinit(ictxt, "C", nprocs, 1)

call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)

eps = pslamch(ictxt, 'E')

if(myrow == mycol) print '(A, F10.6)', "OK: Scalapack Fortran  eps=", eps

call blacs_gridexit(ictxt)
call blacs_exit(0)

end program


      SUBROUTINE SB01MD( NCONT, N, A, LDA, B, WR, WI, Z, LDZ, G, DWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To determine the one-dimensional state feedback matrix G of the
C     linear time-invariant single-input system
C
C           dX/dt = A * X + B * U,
C
C     where A is an NCONT-by-NCONT matrix and B is an NCONT element
C     vector such that the closed-loop system
C
C           dX/dt = (A - B * G) * X
C
C     has desired poles. The system must be preliminarily reduced
C     to orthogonal canonical form using the SLICOT Library routine
C     AB01MD.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     NCONT   (input) INTEGER
C             The order of the matrix A as produced by SLICOT Library
C             routine AB01MD.  NCONT >= 0.
C
C     N       (input) INTEGER
C             The order of the matrix Z.  N >= NCONT.
C
C     A       (input/output) DOUBLE PRECISION array, dimension
C             (LDA,NCONT)
C             On entry, the leading NCONT-by-NCONT part of this array
C             must contain the canonical form of the state dynamics
C             matrix A as produced by SLICOT Library routine AB01MD.
C             On exit, the leading NCONT-by-NCONT part of this array
C             contains the upper quasi-triangular form S of the closed-
C             loop system matrix (A - B * G), that is triangular except
C             for possible 2-by-2 diagonal blocks.
C             (To reconstruct the closed-loop system matrix see
C             FURTHER COMMENTS below.)
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,NCONT).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (NCONT)
C             On entry, this array must contain the canonical form of
C             the input/state vector B as produced by SLICOT Library
C             routine AB01MD.
C             On exit, this array contains the transformed vector Z * B
C             of the closed-loop system.
C
C     WR      (input) DOUBLE PRECISION array, dimension (NCONT)
C     WI      (input) DOUBLE PRECISION array, dimension (NCONT)
C             These arrays must contain the real and imaginary parts,
C             respectively, of the desired poles of the closed-loop
C             system. The poles can be unordered, except that complex
C             conjugate pairs of poles must appear consecutively.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             On entry, the leading N-by-N part of this array must
C             contain the orthogonal transformation matrix as produced
C             by SLICOT Library routine AB01MD, which reduces the system
C             to canonical form.
C             On exit, the leading NCONT-by-NCONT part of this array
C             contains the orthogonal matrix Z which reduces the closed-
C             loop system matrix (A - B * G) to upper quasi-triangular
C             form.
C
C     LDZ     INTEGER
C             The leading dimension of array Z.  LDZ >= MAX(1,N).
C
C     G       (output) DOUBLE PRECISION array, dimension (NCONT)
C             This array contains the one-dimensional state feedback
C             matrix G of the original system.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (3*NCONT)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The method is based on the orthogonal reduction of the closed-loop
C     system matrix (A - B * G) to upper quasi-triangular form S whose
C     1-by-1 and 2-by-2 diagonal blocks correspond to the desired poles.
C     That is, S = Z'*(A - B * G)*Z, where Z is an orthogonal matrix.
C
C     REFERENCES
C
C     [1] Petkov, P. Hr.
C         A Computational Algorithm for Pole Assignment of Linear
C         Single Input Systems.
C         Internal Report 81/2, Control Systems Research Group, School
C         of Electronic Engineering and Computer Science, Kingston
C         Polytechnic, 1981.
C
C     NUMERICAL ASPECTS
C                                   3
C     The algorithm requires 0(NCONT ) operations and is backward
C     stable.
C
C     FURTHER COMMENTS
C
C     If required, the closed-loop system matrix (A - B * G) can be
C     formed from the matrix product Z * S * Z' (where S and Z are the
C     matrices output in arrays A and Z respectively).
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997.
C     Supersedes Release 2.0 routine SB01AD by Control Systems Research
C     Group, Kingston Polytechnic, United Kingdom, May 1981.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Closed loop spectrum, closed loop systems, eigenvalue assignment,
C     orthogonal canonical form, orthogonal transformation, pole
C     placement, Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDZ, N, NCONT
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(*), DWORK(*), G(*), WI(*), WR(*),
     $                  Z(LDZ,*)
C     .. Local Scalars ..
      LOGICAL           COMPL
      INTEGER           I, IM1, K, L, LL, LP1, NCONT2, NI, NJ
      DOUBLE PRECISION  B1, P, Q, R, S, T
C     .. External Functions ..
      DOUBLE PRECISION  DDOT
      EXTERNAL          DDOT
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DGEMV, DLARTG, DLASET, DROT,
     $                  DSCAL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( NCONT.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.NCONT ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, NCONT ) ) THEN
         INFO = -4
      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -9
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return
C
         CALL XERBLA( 'SB01MD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( NCONT.EQ.0 .OR. N.EQ.0 )
     $   RETURN
C
C     Return if the system is not complete controllable.
C
      IF ( B(1).EQ.ZERO )
     $   RETURN
C
      IF ( NCONT.EQ.1 ) THEN
C
C        1-by-1 case.
C
         P = A(1,1) - WR(1)
         A(1,1) = WR(1)
         G(1) = P/B(1)
         Z(1,1) = ONE
         RETURN
      END IF
C
C     General case.  Save the contents of WI in DWORK.
C
      NCONT2 = 2*NCONT
      CALL DCOPY( NCONT, WI, 1, DWORK(NCONT2+1), 1 )
C
      B1 = B(1)
      B(1) = ONE
      L  = 0
      LL = 0
   20 CONTINUE
      L  = L + 1
      LL = LL + 1
      COMPL = DWORK(NCONT2+L).NE.ZERO
      IF ( L.NE.NCONT ) THEN
         LP1 = L + 1
         IF ( LL.NE.2 ) THEN
            IF ( COMPL ) THEN
C
C              Compute complex eigenvector.
C
               DWORK(NCONT) = ONE
               DWORK(NCONT2) = ONE
               P = WR(L)
               T = DWORK(NCONT2+L)
               Q = T*DWORK(NCONT2+LP1)
               DWORK(NCONT2+L) = ONE
               DWORK(NCONT2+LP1) = Q
C
               DO 40 I = NCONT, LP1, -1
                  IM1 = I - 1
                  DWORK(IM1) = ( P*DWORK(I) + Q*DWORK(NCONT+I) -
     $               DDOT( NCONT-IM1, A(I,I), LDA, DWORK(I), 1 ) )
     $               /A(I,IM1)
                  DWORK(NCONT+IM1) = ( P*DWORK(NCONT+I) + DWORK(I) -
     $               DDOT( NCONT-IM1, A(I,I), LDA, DWORK(NCONT+I), 1 ) )
     $               /A(I,IM1)
   40          CONTINUE
C
            ELSE
C
C              Compute real eigenvector.
C
               DWORK(NCONT) = ONE
               P = WR(L)
C
               DO 60 I = NCONT, LP1, -1
                  IM1 = I - 1
                  DWORK(IM1) = ( P*DWORK(I) -
     $               DDOT( NCONT-IM1, A(I,I), LDA, DWORK(I), 1 ) )
     $               /A(I,IM1)
   60          CONTINUE
C
            END IF
         END IF
C
C        Transform eigenvector.
C
         DO 80 K = NCONT - 1, L, -1
            IF ( LL.NE.2 ) THEN
               R = DWORK(K)
               S = DWORK(K+1)
            ELSE
               R = DWORK(NCONT+K)
               S = DWORK(NCONT+K+1)
            END IF
            CALL DLARTG( R, S, P, Q, T )
            DWORK(K) = T
            IF ( LL.NE.2 ) THEN
               NJ = MAX( K-1, L )
            ELSE
               DWORK(NCONT+K) = T
               NJ = L - 1
            END IF
C
C           Transform  A.
C
            CALL DROT( NCONT-NJ+1, A(K,NJ), LDA, A(K+1,NJ), LDA, P, Q )
C
            IF ( COMPL .AND. LL.EQ.1 ) THEN
               NI = NCONT
            ELSE
               NI = MIN( K+2, NCONT )
            END IF
            CALL DROT( NI, A(1,K), 1, A(1,K+1), 1, P, Q )
C
            IF ( K.EQ.L ) THEN
C
C              Transform  B.
C
               T = B(K)
               B(K) = P*T
               B(K+1) = -Q*T
            END IF
C
C           Accumulate transformations.
C
            CALL DROT( NCONT, Z(1,K), 1, Z(1,K+1), 1, P, Q )
C
            IF ( COMPL .AND. LL.NE.2 ) THEN
               T = DWORK(NCONT+K)
               DWORK(NCONT+K) = P*T + Q*DWORK(NCONT+K+1)
               DWORK(NCONT+K+1) = P*DWORK(NCONT+K+1) - Q*T
            END IF
   80    CONTINUE
C
      END IF
C
      IF ( .NOT.COMPL ) THEN
C
C        Find one element of  G.
C
         K = L
         R = B(L)
         IF ( L.NE.NCONT ) THEN
            IF ( ABS( B(LP1) ).GT.ABS( B(L) ) ) THEN
               K = LP1
               R = B(LP1)
            END IF
         END IF
         P = A(K,L)
         IF ( K.EQ.L ) P = P - WR(L)
         P = P/R
C
         CALL DAXPY( LP1, -P, B, 1, A(1,L), 1 )
C
         G(L) = P/B1
         IF ( L.NE.NCONT ) THEN
            LL = 0
            GO TO 20
         END IF
      ELSE IF ( LL.EQ.1 ) THEN
         GO TO 20
      ELSE
C
C        Find two elements of  G.
C
         K = L
         R = B(L)
         IF ( L.NE.NCONT ) THEN
            IF ( ABS( B(LP1)).GT.ABS( B(L) ) ) THEN
               K = LP1
               R = B(LP1)
            END IF
         END IF
         P = A(K,L-1)
         Q = A(K,L)
         IF ( K.EQ.L ) THEN
            P = P - ( DWORK(NCONT+L)/DWORK(L-1) )*DWORK(NCONT2+L)
            Q = Q - WR(L) +
     $            ( DWORK(NCONT+L-1)/DWORK(L-1) )*DWORK(NCONT2+L)
         END IF
         P = P/R
         Q = Q/R
C
         CALL DAXPY( LP1, -P, B, 1, A(1,L-1), 1 )
         CALL DAXPY( LP1, -Q, B, 1, A(1,L), 1 )
C
         G(L-1) = P/B1
         G(L) = Q/B1
         IF ( L.NE.NCONT ) THEN
            LL = 0
            GO TO 20
         END IF
      END IF
C
C     Transform  G.
C
      CALL DGEMV( 'No transpose', NCONT, NCONT, ONE, Z, LDZ, G, 1,
     $            ZERO, DWORK, 1 )
      CALL DCOPY( NCONT, DWORK, 1, G, 1 )
      CALL DSCAL( NCONT, B1, B, 1 )
C
C     Annihilate A after the first subdiagonal.
C
      IF ( NCONT.GT.2 )
     $   CALL DLASET( 'Lower', NCONT-2, NCONT-2, ZERO, ZERO, A(3,1),
     $                LDA )
C
      RETURN
C *** Last line of SB01MD ***
      END