! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

module model_mod

use types_mod,             only : r8, i8, i4

use location_mod,          only : location_type, set_location, get_location, &
                                  get_close_obs, get_close_state, &
                                  convert_vertical_obs, convert_vertical_state

use utilities_mod,         only : register_module, error_handler, E_ERR, E_MSG, do_output, &
                                  nmlfileunit, find_namelist_in_file, check_namelist_read, &
                                  do_nml_file, do_nml_term

use netcdf_utilities_mod,  only : nc_add_global_attribute, &
                                  nc_add_global_creation_time, &
                                  nc_begin_define_mode, nc_end_define_mode

use location_io_mod,       only : nc_write_location_atts, nc_get_location_varids, &
                                  nc_write_location

use obs_kind_mod,          only : QTY_STATE_VARIABLE

use ensemble_manager_mod,  only : ensemble_type

use distributed_state_mod, only : get_state

use state_structure_mod,   only : add_domain

use dart_time_io_mod,      only : read_model_time, write_model_time

use default_model_mod,     only : end_model, pert_model_copies, nc_write_model_vars, &
                                  init_time

use random_seq_mod,        only : random_seq_type, random_gaussian, &
                                  init_random_seq, several_random_gaussians

use time_manager_mod,      only : time_type, set_time

implicit none
private

!> required routines with code in this module
public :: get_model_size, &
          get_state_meta_data,  &
          model_interpolate, &
          shortest_time_between_assimilations, &
          static_init_model, &
          init_conditions,    &
          adv_1step, &
          nc_write_model_atts

!> required routines where code is in other modules
public :: pert_model_copies, &
          nc_write_model_vars, &
          get_close_obs, &
          get_close_state, &
          init_time, &
          end_model, &
          convert_vertical_obs, &
          convert_vertical_state, &
          read_model_time, &
          write_model_time

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

integer(i8), parameter :: model_size = 9

!  define model parameters
! c is sqrt(0.75)

real(r8), private, parameter :: a(3) = (/  1.0_r8,  1.0_r8, 3.0_r8 /), &
                                b(3) = (/ -1.5_r8, -1.5_r8, 0.5_r8 /), &
                                f(3) = (/ 0.10_r8,  0.0_r8, 0.0_r8 /), &
                                h(3) = (/ -1.0_r8,  0.0_r8, 0.0_r8 /), &
                                nu = 1.0_r8 / 48.0_r8, kappa = nu, c = 0.8660254_r8

! Define the location of the state variables in module storage
! This is used for distance dependence stuff in more general models but is
! currently just set to give 0 separation distance for all 9 vars here.

type(location_type) :: state_loc(model_size)
type(time_type)     :: time_step

! Need reproducible sequence of noise added so that different runs
! can be cleanly compared

logical :: first_ran_call = .true.
type(random_seq_type) :: ran_seq

! Namelist with default values

real(r8) :: g = 8.0_r8  ! lorenz default; 9.90_r8 is a higher dimension attractor

real(r8) :: deltat = 1.0_r8 / 12.0_r8     ! model time step
integer :: time_step_days = 0
integer :: time_step_seconds = 3600

logical :: add_noise = .false.

namelist /model_nml/ g, deltat, time_step_days, time_step_seconds, add_noise

contains

!----------------------------------------------------------------------
!> Initializes class data for this model. For now, simply outputs the
!> identity info, sets the location of the state variables, and initializes
!> the time type for the time stepping (is this general enough for time???)

subroutine static_init_model()

real(r8) :: x_loc
integer :: i, iunit, io, dom_id

! Register the module into the logfile
call register_module(source, revision, revdate)

! Read the namelist entry
call find_namelist_in_file("input.nml", "model_nml", iunit)
read(iunit, nml = model_nml, iostat = io)
call check_namelist_read(iunit, io, "model_nml")

! Record the namelist values used for the run ...
if (do_nml_file()) write(nmlfileunit, nml=model_nml)
if (do_nml_term()) write(     *     , nml=model_nml)

! Define the locations of the model state variables
do i = 1, model_size
   x_loc = (i - 1.0_r8) / model_size
   state_loc(i) =  set_location(x_loc)
end do

! The time_step in terms of a time type must also be initialized. Need
! to determine appropriate non-dimensionalization conversion for L96 from
! Shree Khare.
time_step = set_time(time_step_seconds, time_step_days)

! Tell the DART I/O routines how large the model data is so they
! can read/write it.
dom_id = add_domain(model_size)

end subroutine static_init_model

!----------------------------------------------------------------------
!> computes time tendency for the 9 variable lorenz model given the
!> current values of the 9 variables (x, y, z each with three elements)
!> and the values of a number of parameters.

subroutine comp_dt(xxx, dxxx)

real(r8), intent(in)  :: xxx(:)
real(r8), intent(out) :: dxxx(:)

real(r8) :: x(3), y(3), z(3), dx(3), dy(3), dz(3)
real(r8) :: rnum(9)
integer  :: i, j, k

!  unpack the 9-vectors into the x, y and z 3-vectors

call unpack9var(xxx, x, y, z)

!  equations 33-35 from lorenz, 1980, jas, p.1688
!  equations are defined with cyclic indices

do i = 1, 3
   J = MOD(I, 3) + 1
   K = MOD(I + 1, 3) + 1

   !  BEGIN WITH THE FIRST EQUATION (33)

   dx(i) = (a(i)*b(i)*x(j)*x(k) - c*(a(i) - a(k))*x(j)*y(k) + &
           c*(a(i) - a(j))*y(j)*x(k) - 2*c**2*y(j)*y(k) - &
           nu*a(i)**2*x(i) + a(i)*y(i) - a(i)*z(i)) / a(i)

   !  equation (34)

   dy(i) = (-1.*a(k)*b(k)*x(j)*y(k) - a(j)*b(j)*y(j)*x(k) + &
           c*(a(k) - a(j))*y(j)*y(k) - a(i)*x(i) - nu*a(i)**2*y(i)) / a(i)

   !  equation (35)

   dz(i) = -1.*b(k)*x(j)*(z(k) - h(k)) - &
           b(j)*(z(j) - h(j))*x(k) + c*y(j)*(z(k) -h(k)) - &
           c*(z(j) - h(j))*y(k) + g*a(i)*x(i) - kappa*a(i)*z(i) + f(i)
end do

call pack9var(dx, dy, dz, dxxx)     !  pack the results into 9 vector

! We need to initialize the random gen for experiments to be repeatable
if(first_ran_call) then
   first_ran_call = .false.
   call init_random_seq(ran_seq)
end if

! ADDITION OF SOME NOISE AT 1/10 the amplitude of DT
if (add_noise) then
   call several_random_gaussians(ran_seq, 0.0_r8, dxxx(i) / 10.0_r8, 9, rnum)
   do i = 1, 9
      dxxx(i) = dxxx(i) + rnum(i)
   end do
endif

end subroutine comp_dt

!---------------------------------------------------------------------------
!> set of routines used to switch between 3 3-variable sets and 9-variable
!> set for lorenz 9 variable pe model

subroutine pack9var(x, y, z, pert)

real(r8), intent(in)  :: x(3), y(3), z(3)
real(r8), intent(out) :: pert(9)

pert(1:3) = x
pert(4:6) = y
pert(7:9) = z

end subroutine pack9var

!---------------------------------------------------------------------------
!> inverse of pack9var above

subroutine unpack9var(pert, x, y, z)

real(r8), intent(in)  :: pert(9)
real(r8), intent(out) :: x(3), y(3), z(3)

x = pert(1:3)
y = pert(4:6)
z = pert(7:9)

end subroutine unpack9var

!-------------------------------------------------------------------------
!> does one time step advance for 9 variable model using two-step rk.

subroutine adv_1step(x, time)

implicit none

real(r8),        intent(inout) :: x(:)
type(time_type), intent(in)    :: time

real(r8) :: fract = 1.0_r8

call adv_single(x, fract)

end subroutine adv_1step

!-------------------------------------------------------------------------
!> does one time step advance for 9 variable model using two-step rk

subroutine adv_single(x, fract)

real(r8), intent(inout) :: x(:)
real(r8), intent(in)    :: fract

real(r8) :: x1(9), x2(9), dx(9)

!  compute the first intermediate step

call comp_dt(x, dx)
x1 = x + fract * deltat * dx

!  compute the second intermediate step

call comp_dt(x1, dx)
x2 = x1 + fract * deltat * dx

!  new value for x is average of original value and second intermediate

x = (x + x2) / 2.0_r8

end subroutine adv_single

!----------------------------------------------------------------------
!> generates set of random off-attractor initial conditions for 9 variable

subroutine init_conditions(x)

real(r8), intent(out) ::  x(:)

x = 0.10_r8

end subroutine init_conditions

!---------------------------------------------------------------------------
!> unused?
! application of balance eqtn as initialization method
! to the 9 variable lorenz model given the
! current values of the 9 variables (x, y, z each with three elements)
! and the values of a number of parameters.

subroutine balance_init(xxx, init_xxx)

real(r8), intent(in)  :: xxx(9)
real(r8), intent(out) :: init_xxx(9)

real(r8) :: x(3), y(3), z(3)
!!!real(r8) :: wkspce(3)
real(r8) :: lhs(3,3),rhs(3)
integer  :: i, j, k
!!!integer  :: ifail

!  unpack the 9-vectors into the x, y and z 3-vectors

call unpack9var(xxx, x, y, z)

! application of balance eqtn as initialization method, curry ET.AL, tellus,
!    1995, p. 153-154, section 3.3
! equation 11 from gent & mcwilliams, 1982, jas, p.4

DO i = 1, 3
   j    = mod(i, 3) + 1
   k    = mod(i + 1, 3) + 1
   z(i) = (a(i)*y(i)-2*c**2*y(j)*y(k))/a(i)
end do

!  equation 29/30 from gent & mcwilliams, 1982, jas, p.6

do i = 1, 3
   j = mod(i, 3) + 1
   k = mod(i + 1, 3) + 1
   lhs(i,i) = ( a(i)*a(j)*a(k)*(1+g*a(i))-2*c**2*(a(j)**2* &
      b(j)*y(j)**2+a(k)**2*b(k)*y(k)**2) )
   lhs(j,i) = -( a(j)*a(k)*( y(k)*(2*c**2-a(k)*b(k))+a(i)* &
      b(k)*(z(k)-h(k)) )+2*c**2*a(i)*a(j)*b(i)*y(i) *y(j)  )
   lhs(k,i) = -( a(j)*a(k)*( y(j)*(2*c**2-a(j)*b(j))+a(i)* &
      b(j)*(z(j)-h(j)) )+2*c**2*a(i)*a(k)*b(i)*y(i) *y(k)  )
   rhs(i) = a(j)*a(k)*(  c*(a(k)-a(j))*y(j)*y(k)+c*a(i)*( &
      (z(j)-h(j))*y(k)-y(j)*(z(k)-h(k)) )+a(i)*( nu* &
      a(i)*(z(i)-y(i))-f(i) )  )-2*c**2*(  c*a(j)* &
      (a(j)-a(i))*y(i)*y(j)**2+c*a(k)*(a(i)-a(k))*y(i) &
      *y(k)**2-nu*a(j)*a(k)*(a(j)+a(k))*y(j)*y(k)  )
end do

!!!ifail=0
!  n.a.g. ROUTINE TO CALCULATE APPROXIMATE SOLUTION X TO aX=B (I.E. lhs*X=rhs)
!!!call f04arf_wrap(lhs,3,rhs,3,x,wkspce,ifail)
!        print *,'XINIT=',X

!  pack the results into 9 vector

call pack9var(x, y, z, init_xxx)

end subroutine balance_init

!-------------------------------------------------------------------------
! Returns number of items in state vector

function get_model_size()

integer(i8) :: get_model_size

get_model_size = model_size

end function get_model_size

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

function shortest_time_between_assimilations()

type(time_type) :: shortest_time_between_assimilations

shortest_time_between_assimilations = time_step

end function shortest_time_between_assimilations

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

subroutine model_interpolate(state_handle, ens_size, location, itype, expected_obs, istatus)

type(ensemble_type),  intent(in) :: state_handle
integer,              intent(in) :: ens_size
type(location_type),  intent(in) :: location
integer,              intent(in) :: itype
real(r8),            intent(out) :: expected_obs(ens_size)
integer,             intent(out) :: istatus(ens_size)

integer(i8)  :: lower_index, upper_index
real(r8) :: lctn, lctnfrac

! All obs okay for now
istatus(:) = 0

! Convert location to real
lctn = get_location(location)
! Multiply by model size assuming domain is [0, 1] cyclic
lctn = model_size * lctn

lower_index = int(lctn) + 1
upper_index = lower_index + 1
if(lower_index > model_size) lower_index = lower_index - model_size
if(upper_index > model_size) upper_index = upper_index - model_size

lctnfrac = lctn - int(lctn)
expected_obs = (1.0_r8 - lctnfrac) * get_state(lower_index, state_handle) + &
                         lctnfrac  * get_state(upper_index, state_handle)

end subroutine model_interpolate

!---------------------------------------------------------------------
!> Given an integer index into the state vector structure, returns the
!> associated location.

subroutine get_state_meta_data(index_in, location, var_type)

integer(i8),         intent(in)  :: index_in
type(location_type), intent(out) :: location
integer,             intent(out), optional :: var_type

location = state_loc(index_in)
if (present(var_type)) var_type = QTY_STATE_VARIABLE    ! default variable quantity

end subroutine get_state_meta_data

!------------------------------------------------------------------
!> Writes the model-specific attributes to a netCDF file

subroutine nc_write_model_atts(ncid, domain_id)

integer, intent(in) :: ncid      ! netCDF file identifier
integer, intent(in) :: domain_id

integer :: msize

! other parts of the dart system will write the state into the file
! so this routine just needs to write any model-specific
! attributes it wants to record.

msize = int(model_size, i4)

! Write Global Attributes

call nc_begin_define_mode(ncid)

call nc_add_global_creation_time(ncid)

call nc_add_global_attribute(ncid, "model_source", source )
call nc_add_global_attribute(ncid, "model_revision", revision )
call nc_add_global_attribute(ncid, "model_revdate", revdate )

call nc_add_global_attribute(ncid, "model", "9var")

call nc_add_global_attribute(ncid, "model_g", g )
call nc_add_global_attribute(ncid, "model_deltat", deltat )
call nc_add_global_attribute(ncid, "model_a", a )
call nc_add_global_attribute(ncid, "model_b", b )
call nc_add_global_attribute(ncid, "model_f", f )
call nc_add_global_attribute(ncid, "model_h", h )
call nc_add_global_attribute(ncid, "model_nu", nu )
call nc_add_global_attribute(ncid, "model_kappa", kappa )
call nc_add_global_attribute(ncid, "model_c", c )

call nc_write_location_atts(ncid, msize)
call nc_end_define_mode(ncid)
call nc_write_location(ncid, state_loc, msize)

end subroutine nc_write_model_atts

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

!===================================================================
! End of 9var model_mod
!===================================================================
end module model_mod

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


      SUBROUTINE FAILRS (FTHR,ULTSTN,STRESL,FINDEX)
C
C     THIS ROUTINE COMPUTES THE FAILURE INDEX OF A LAYER IN A LAMINATED
C     COMPOSITE ELEMENT USING ONE OF THE FOLLOWING FIVE FAILURE THEORIES
C     CURRENTLY AVAILABLE
C        1.   HILL
C        2.   HOFFMAN
C        3.   TSAI-WU
C        4.   MAX STRESS
C        5.   MAX STRAIN
C
C
C     DEFINITIONS
C
C     XT = ULTIMATE UNIAXIAL TENSILE STRENGTH IN THE FIBER DIRECTION
C     XC = ULTIMATE UNIAXIAL COMPRESSIVE STRENGTH IN THE FIBER DIRECTION
C     YT = ULTIMATE UNIAXIAL TENSILE STRENGTH PERPENDICULAR TO THE FIBER
C          DIRECTION
C     YC = ULTIMATE UNIAXIAL COMPRESSIVE STRENGTH PERPENDICULAR TO THE
C          FIBER DIRECTION
C     S  = ULTIMATE PLANAR SHEAR STRENGTH UNDER PURE SHEAR LOADING
C
C     SIMILARILY FOR THE ULTIMATE STRAINS
C
C
      INTEGER FTHR
      REAL    ULTSTN(6),STRESL(3)
C
C
C     CHECK FOR ZERO STRENGTH VALUES
C
      DO 50 I = 1,5
   50 IF (ULTSTN(I) .EQ. 0.0) GO TO 700
C
C     ULTIMATE STRENGTH VALUES
C
      XT   = ULTSTN(1)
      XC   = ULTSTN(2)
      YT   = ULTSTN(3)
      YC   = ULTSTN(4)
      S    = ULTSTN(5)
      F12  = ULTSTN(6)
C
C     LAYER STRESSES
C
      SIG1 = STRESL(1)
      SIG2 = STRESL(2)
      TAU12= STRESL(3)
C
C     LAYER STRAINS
C
      EPS1 = STRESL(1)
      EPS2 = STRESL(2)
      GAMA = STRESL(3)
C
      GO TO (100,200,300,400,500), FTHR
C
C     HILL FAILURE THEORY
C     -------------------
C
  100 X = XT
      IF (SIG1 .LT. 0.0) X = XC
C
      Y = YT
      IF (SIG2 .LT. 0.0) Y = YC
C
      XX = XT
      IF (SIG1*SIG2 .LT. 0.0) XX = XC
C
      FINDEX = (SIG1*SIG1)/(X*X)
      FINDEX = FINDEX + (SIG2 * SIG2)/(Y * Y)
      FINDEX = FINDEX - (SIG1 * SIG2)/(XX*XX)
      FINDEX = FINDEX + (TAU12*TAU12)/(S * S)
      GO TO 600
C
C
C     HOFFMAN FAILURE THEORY
C     ----------------------
C
  200 FINDEX = (1.0/XT-1.0/XC)*SIG1
      FINDEX = FINDEX + (1.0/YT-1.0/YC)*SIG2
      FINDEX = FINDEX + (SIG1 * SIG1)/(XT*XC)
      FINDEX = FINDEX + (SIG2 * SIG2)/(YT*YC)
      FINDEX = FINDEX + (TAU12*TAU12)/(S * S)
      FINDEX = FINDEX + (SIG1 * SIG2)/(XT*XC)
      GO TO 600
C
C
C     TSAI-WU FAILURE THEORY
C     ----------------------
C
C     CHECK STABILITY CRITERIA FOR THE INTERACTION TERM F12
C
  300 IF (F12 .EQ. 0.0) GO TO 350
C
      CRIT = (1.0/(XT*XC))*(1.0/(YT*YC)) - F12*F12
      IF (CRIT .GT. 0.0) GO TO 350
C
C     IF STABILITY CRITERIA IS VIOLATED THEN SET THE F12 THE INTERACTION
C     TERM TO ZERO
C
      F12 = 0.0
C
C
  350 FINDEX = (1.0/XT-1.0/XC)*SIG1
      FINDEX = FINDEX + (1.0/YT-1.0/YC)*SIG2
      FINDEX = FINDEX + (SIG1 * SIG1)/(XT*XC)
      FINDEX = FINDEX + (SIG2 * SIG2)/(YT*YC)
      FINDEX = FINDEX + (TAU12*TAU12)/(S * S)
      IF (F12 .EQ. 0.0) GO TO 600
      FINDEX = FINDEX + 2.0*F12*SIG1*SIG2
      GO TO 600
C
C
C     MAX STRESS FAILURE THEORY
C     -------------------------
C
  400 FI1 = SIG1/XT
      IF (SIG1 .LT. 0.0) FI1 = ABS(SIG1/XC)
C
      FI2 = SIG2/YT
      IF (SIG2 .LT. 0.0) FI2 = ABS(SIG2/YC)
C
      FI12 = ABS(TAU12)/S
C
      FINDEX = FI1
      IF (FI2  .GT. FINDEX) FINDEX = FI2
      IF (FI12 .GT. FINDEX) FINDEX = FI12
      GO TO 600
C
C
C     MAX STRAIN FAILURE THEORY
C     -------------------------
C
  500 FI1 = EPS1/XT
      IF (EPS1 .LT. 0.0) FI1 = ABS(EPS1/XC)
C
      FI2 = EPS2/YT
      IF (EPS2 .LT. 0.0) FI2 = ABS(EPS2/YC)
C
      FI12 = ABS(GAMA)/S
C
      FINDEX = FI1
      IF (FI2  .GT. FINDEX) FINDEX = FI2
      IF (FI12 .GT. FINDEX) FINDEX = FI12
C
  600 CONTINUE
C
      RETURN
C
C
C     NON-FATAL ERROR
C
  700 FINDEX = 0.0
      RETURN
      END


program test_fermi_dirac
use types, only: dp
use utils, only: assert, loadtxt
use efermi, only: fermi_dirac_smearing
implicit none
real(dp), parameter :: Z = 32 ! total charge
real(dp), parameter :: E_fermi_ref = 0.1708_dp ! eV
real(dp), parameter :: sigma = 2.69_dp ! eV
real(dp), allocatable :: D(:,:), eigs(:), occ_ref(:), occ(:)
real(dp) :: E_fermi
integer :: nband, i
call loadtxt("data/occ1.dat", D)
nband = size(D,1)
allocate(eigs(nband), occ_ref(nband), occ(nband))
eigs = D(:, 2) ! eV
occ_ref = D(:, 3)
call fermi_dirac_smearing(eigs, sigma, Z, E_fermi, occ)
do i = nband, 1, -1
    print "(i4,f10.4,f10.5,f10.5)", i, eigs(i), occ_ref(i), occ(i)
end do
print *, "Charges (occ and occ_ref):"
print *, sum(occ), sum(occ_ref)
print *, "Error:", abs(sum(occ)-Z)
call assert(abs(sum(occ)-Z) < 1e-12_dp)
print *
print *, "Fermi energy (E_fermi and E_fermi_ref):", E_fermi, E_fermi_ref
print *, "Error:", abs(E_fermi - E_fermi_ref)
call assert(abs(E_fermi - E_fermi_ref) < 1e-4_dp)
end program


! { dg-do run }

! real reductions

program reduction_2
  implicit none

  integer, parameter    :: n = 10, ng = 8, nw = 4, vl = 32
  integer               :: i
  real                  :: vresult, rg, rw, rv, rc
  real, parameter       :: e = 0.001
  logical               :: lrg, lrw, lrv, lrc, lvresult
  real, dimension (n)   :: array

  do i = 1, n
     array(i) = i
  end do

  !
  ! '+' reductions
  !

  rg = 0
  rw = 0
  rv = 0
  rc = 0
  vresult = 0

  !$acc parallel num_gangs(ng) copy(rg)
  !$acc loop reduction(+:rg) gang
  do i = 1, n
     rg = rg + array(i)
  end do
  !$acc end parallel

  !$acc parallel num_workers(nw) copy(rw)
  !$acc loop reduction(+:rw) worker
  do i = 1, n
     rw = rw + array(i)
  end do
  !$acc end parallel

  !$acc parallel vector_length(vl) copy(rv)
  !$acc loop reduction(+:rv) vector
  do i = 1, n
     rv = rv + array(i)
  end do
  !$acc end parallel

  !$acc parallel num_gangs(ng) num_workers(nw) vector_length(vl) copy(rc)
  !$acc loop reduction(+:rc) gang worker vector
  do i = 1, n
     rc = rc + array(i)
  end do
  !$acc end parallel

  ! Verify the results
  do i = 1, n
     vresult = vresult + array(i)
  end do

  if (rg .ne. vresult) call abort
  if (rw .ne. vresult) call abort
  if (rv .ne. vresult) call abort
  if (rc .ne. vresult) call abort

  !
  ! '*' reductions
  !

  rg = 1
  rw = 1
  rv = 1
  rc = 1
  vresult = 1

  !$acc parallel num_gangs(ng) copy(rg)
  !$acc loop reduction(*:rg) gang
  do i = 1, n
     rg = rg * array(i)
  end do
  !$acc end parallel

  !$acc parallel num_workers(nw) copy(rw)
  !$acc loop reduction(*:rw) worker
  do i = 1, n
     rw = rw * array(i)
  end do
  !$acc end parallel

  !$acc parallel vector_length(vl) copy(rv)
  !$acc loop reduction(*:rv) vector
  do i = 1, n
     rv = rv * array(i)
  end do
  !$acc end parallel

  !$acc parallel num_gangs(ng) num_workers(nw) vector_length(vl) copy(rc)
  !$acc loop reduction(*:rc) gang worker vector
  do i = 1, n
     rc = rc * array(i)
  end do
  !$acc end parallel

  ! Verify the results
  do i = 1, n
     vresult = vresult * array(i)
  end do

  if (abs (rg - vresult) .ge. e) call abort
  if (abs (rw - vresult) .ge. e) call abort
  if (abs (rv - vresult) .ge. e) call abort
  if (abs (rc - vresult) .ge. e) call abort

  !
  ! 'max' reductions
  !

  rg = 0
  rw = 0
  rg = 0
  rc = 0
  vresult = 0

  !$acc parallel num_gangs(ng) copy(rg)
  !$acc loop reduction(max:rg) gang
  do i = 1, n
     rg = max (rg, array(i))
  end do
  !$acc end parallel

  !$acc parallel num_workers(nw) copy(rw)
  !$acc loop reduction(max:rw) worker
  do i = 1, n
     rw = max (rw, array(i))
  end do
  !$acc end parallel

  !$acc parallel vector_length(vl) copy(rv)
  !$acc loop reduction(max:rv) vector
  do i = 1, n
     rv = max (rv, array(i))
  end do
  !$acc end parallel

  !$acc parallel num_gangs(ng) num_workers(nw) vector_length(vl) copy(rc)
  !$acc loop reduction(max:rc) gang worker vector
  do i = 1, n
     rc = max (rc, array(i))
  end do
  !$acc end parallel

  ! Verify the results
  do i = 1, n
     vresult = max (vresult, array(i))
  end do

  if (abs (rg - vresult) .ge. e) call abort
  if (abs (rw - vresult) .ge. e) call abort
  if (abs (rg - vresult) .ge. e) call abort
  if (abs (rc - vresult) .ge. e) call abort

  !
  ! 'min' reductions
  !

  rg = 0
  rw = 0
  rv = 0
  rc = 0
  vresult = 0

  !$acc parallel num_gangs(ng) copy(rg)
  !$acc loop reduction(min:rg) gang
  do i = 1, n
     rg = min (rg, array(i))
  end do
  !$acc end parallel

  !$acc parallel num_workers(nw) copy(rw)
  !$acc loop reduction(min:rw) worker
  do i = 1, n
     rw = min (rw, array(i))
  end do
  !$acc end parallel

  !$acc parallel vector_length(vl) copy(rv)
  !$acc loop reduction(min:rv) vector
  do i = 1, n
     rv = min (rv, array(i))
  end do
  !$acc end parallel

  !$acc parallel num_gangs(ng) num_workers(nw) vector_length(vl) copy(rc)
  !$acc loop reduction(min:rc) gang worker vector
  do i = 1, n
     rc = min (rc, array(i))
  end do
  !$acc end parallel

  ! Verify the results
  do i = 1, n
     vresult = min (vresult, array(i))
  end do

  if (rg .ne. vresult) call abort
  if (rv .ne. vresult) call abort
  if (rw .ne. vresult) call abort
  if (rc .ne. vresult) call abort

  !
  ! '.and.' reductions
  !

  lrg = .true.
  lrw = .true.
  lrv = .true.
  lrc = .true.
  lvresult = .true.

  !$acc parallel num_gangs(ng) copy(lrg)
  !$acc loop reduction(.and.:lrg) gang
  do i = 1, n
     lrg = lrg .and. (array(i) .ge. 5)
  end do
  !$acc end parallel

  !$acc parallel num_workers(nw) copy(lrw)
  !$acc loop reduction(.and.:lrw) worker
  do i = 1, n
     lrw = lrw .and. (array(i) .ge. 5)
  end do
  !$acc end parallel

  !$acc parallel vector_length(vl) copy(lrv)
  !$acc loop reduction(.and.:lrv) vector
  do i = 1, n
     lrv = lrv .and. (array(i) .ge. 5)
  end do
  !$acc end parallel

  !$acc parallel num_gangs(ng) num_workers(nw) vector_length(vl) copy(lrc)
  !$acc loop reduction(.and.:lrc) gang worker vector
  do i = 1, n
     lrc = lrc .and. (array(i) .ge. 5)
  end do
  !$acc end parallel

  ! Verify the results
  do i = 1, n
     lvresult = lvresult .and. (array(i) .ge. 5)
  end do

  if (lrg .neqv. lvresult) call abort
  if (lrw .neqv. lvresult) call abort
  if (lrv .neqv. lvresult) call abort
  if (lrc .neqv. lvresult) call abort

  !
  ! '.or.' reductions
  !

  lrg = .false.
  lrw = .false.
  lrv = .false.
  lrc = .false.
  lvresult = .false.

  !$acc parallel num_gangs(ng) copy(lrg)
  !$acc loop reduction(.or.:lrg) gang
  do i = 1, n
     lrg = lrg .or. (array(i) .ge. 5)
  end do
  !$acc end parallel

  !$acc parallel num_workers(nw) copy(lrw)
  !$acc loop reduction(.or.:lrw) worker
  do i = 1, n
     lrw = lrw .or. (array(i) .ge. 5)
  end do
  !$acc end parallel

  !$acc parallel vector_length(vl) copy(lrv)
  !$acc loop reduction(.or.:lrv) vector
  do i = 1, n
     lrv = lrv .or. (array(i) .ge. 5)
  end do
  !$acc end parallel

  !$acc parallel num_gangs(ng) num_workers(nw) vector_length(vl) copy(lrc)
  !$acc loop reduction(.or.:lrc) gang worker vector
  do i = 1, n
     lrc = lrc .or. (array(i) .ge. 5)
  end do
  !$acc end parallel

  ! Verify the results
  do i = 1, n
     lvresult = lvresult .or. (array(i) .ge. 5)
  end do

  if (lrg .neqv. lvresult) call abort
  if (lrw .neqv. lvresult) call abort
  if (lrv .neqv. lvresult) call abort
  if (lrc .neqv. lvresult) call abort

  !
  ! '.eqv.' reductions
  !

  lrg = .true.
  lrw = .true.
  lrv = .true.
  lrc = .true.
  lvresult = .true.

  !$acc parallel num_gangs(ng) copy(lrg)
  !$acc loop reduction(.eqv.:lrg) gang
  do i = 1, n
     lrg = lrg .eqv. (array(i) .ge. 5)
  end do
  !$acc end parallel

  !$acc parallel num_workers(nw) copy(lrw)
  !$acc loop reduction(.eqv.:lrw) worker
  do i = 1, n
     lrw = lrw .eqv. (array(i) .ge. 5)
  end do
  !$acc end parallel

  !$acc parallel vector_length(vl) copy(lrv)
  !$acc loop reduction(.eqv.:lrv) vector
  do i = 1, n
     lrv = lrv .eqv. (array(i) .ge. 5)
  end do
  !$acc end parallel

  !$acc parallel num_gangs(ng) num_workers(nw) vector_length(vl) copy(lrc)
  !$acc loop reduction(.eqv.:lrc) gang worker vector
  do i = 1, n
     lrc = lrc .eqv. (array(i) .ge. 5)
  end do
  !$acc end parallel

  ! Verify the results
  do i = 1, n
     lvresult = lvresult .eqv. (array(i) .ge. 5)
  end do

  if (lrg .neqv. lvresult) call abort
  if (lrw .neqv. lvresult) call abort
  if (lrv .neqv. lvresult) call abort
  if (lrc .neqv. lvresult) call abort

  !
  ! '.neqv.' reductions
  !

  lrg = .true.
  lrw = .true.
  lrv = .true.
  lrc = .true.
  lvresult = .true.

  !$acc parallel num_gangs(ng) copy(lrg)
  !$acc loop reduction(.neqv.:lrg) gang
  do i = 1, n
     lrg = lrg .neqv. (array(i) .ge. 5)
  end do
  !$acc end parallel

  !$acc parallel num_workers(nw) copy(lrw)
  !$acc loop reduction(.neqv.:lrw) worker
  do i = 1, n
     lrw = lrw .neqv. (array(i) .ge. 5)
  end do
  !$acc end parallel

  !$acc parallel vector_length(vl) copy(lrv)
  !$acc loop reduction(.neqv.:lrv) vector
  do i = 1, n
     lrv = lrv .neqv. (array(i) .ge. 5)
  end do
  !$acc end parallel

  !$acc parallel num_gangs(ng) num_workers(nw) vector_length(vl) copy(lrc)
  !$acc loop reduction(.neqv.:lrc) gang worker vector
  do i = 1, n
     lrc = lrc .neqv. (array(i) .ge. 5)
  end do
  !$acc end parallel

  ! Verify the results
  do i = 1, n
     lvresult = lvresult .neqv. (array(i) .ge. 5)
  end do

  if (lrg .neqv. lvresult) call abort
  if (lrw .neqv. lvresult) call abort
  if (lrv .neqv. lvresult) call abort
  if (lrc .neqv. lvresult) call abort
end program reduction_2


      subroutine r8evbicub(xget,yget,x,nx,y,ny,ilinx,iliny,
     >                   f,inf2,ict,fval,ier)
C
C  evaluate a 2d cubic Spline interpolant on a rectilinear
C  grid -- this is C2 in both directions.
C
C  this subroutine calls two subroutines:
C     herm2xy  -- find cell containing (xget,yget)
C     fvbicub  -- evaluate interpolant function and (optionally) derivatives
C
C  input arguments:
C  ================
C
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER inf2
!============
      integer nx,ny                     ! grid sizes
      REAL*8 xget,yget                    ! target of this interpolation
      REAL*8 x(nx)                        ! ordered x grid
      REAL*8 y(ny)                        ! ordered y grid
      integer ilinx                     ! ilinx=1 => assume x evenly spaced
      integer iliny                     ! iliny=1 => assume y evenly spaced
C
      REAL*8 f(0:3,inf2,ny)               ! function data
C
C       f 2nd dimension inf2 must be .ge. nx
C       contents of f:
C
C  f(0,i,j) = f @ x(i),y(j)
C  f(1,i,j) = d2f/dx2 @ x(i),y(j)
C  f(2,i,j) = d2f/dy2 @ x(i),y(j)
C  f(3,i,j) = d4f/dx2dy2 @ x(i),y(j)
C
C      (these are spline coefficients selected for continuous 2-
C      diffentiability, see mkbicub[w].for)
C
      integer ict(6)                    ! code specifying output desired
C
C  ict(1)=1 -- return f  (0, don't)
C  ict(2)=1 -- return df/dx  (0, don't)
C  ict(3)=1 -- return df/dy  (0, don't)
C  ict(4)=1 -- return d2f/dx2  (0, don't)
C  ict(5)=1 -- return d2f/dy2  (0, don't)
C  ict(6)=1 -- return d2f/dxdy (0, don't)
c                   the number of non zero values ict(1:6)
c                   determines the number of outputs...
c
c  new dmc December 2005 -- access to higher derivatives (even if not
c  continuous-- but can only go up to 3rd derivatives on any one coordinate.
c     if ict(1)=3 -- want 3rd derivatives
c          ict(2)=1 for d3f/dx3
c          ict(3)=1 for d3f/dx2dy
c          ict(4)=1 for d3f/dxdy2
c          ict(5)=1 for d3f/dy3
c               number of non-zero values ict(2:5) gives no. of outputs
c     if ict(1)=4 -- want 4th derivatives
c          ict(2)=1 for d4f/dx3dy
c          ict(3)=1 for d4f/dx2dy2
c          ict(4)=1 for d4f/dxdy3
c               number of non-zero values ict(2:4) gives no. of outputs
c     if ict(1)=5 -- want 5th derivatives
c          ict(2)=1 for d5f/dx3dy2
c          ict(3)=1 for d5f/dx2dy3
c               number of non-zero values ict(2:3) gives no. of outputs
c     if ict(1)=6 -- want 6th derivatives
c          d6f/dx3dy3 -- one value is returned.
C
C output arguments:
C =================
C
      REAL*8 fval(*)                      ! output data
      integer ier                       ! error code =0 ==> no error
C
C  fval(1) receives the first output (depends on ict(...) spec)
C  fval(2) receives the second output (depends on ict(...) spec)
C  fval(3) receives the third output (depends on ict(...) spec)
C  fval(4) receives the fourth output (depends on ict(...) spec)
C  fval(5) receives the fourth output (depends on ict(...) spec)
C  fval(6) receives the fourth output (depends on ict(...) spec)
C
C  examples:
C    on input ict = [1,1,1,0,0,1]
C   on output fval= [f,df/dx,df/dy,d2f/dxdy], elements 5 & 6 not referenced.
C
C    on input ict = [1,0,0,0,0,0]
C   on output fval= [f] ... elements 2 -- 6 never referenced.
C
C    on input ict = [0,0,0,1,1,0]
C   on output fval= [d2f/dx2,d2f/dy2] ... elements 3 -- 6 never referenced.
C
C    on input ict = [0,0,1,0,0,0]
C   on output fval= [df/dy] ... elements 2 -- 6 never referenced.
C
C  ier -- completion code:  0 means OK
C-------------------
C  local:
C
      integer i(1),j(1)                       ! cell indices
C
C  normalized displacement from (x(i),y(j)) corner of cell.
C    xparam=0 @x(i)  xparam=1 @x(i+1)
C    yparam=0 @y(j)  yparam=1 @y(j+1)
C
      REAL*8 xparam(1),yparam(1)
C
C  cell dimensions and
C  inverse cell dimensions hxi = 1/(x(i+1)-x(i)), hyi = 1/(y(j+1)-y(j))
C
      REAL*8 hx(1),hy(1)
      REAL*8 hxi(1),hyi(1)
C
C  0 .le. xparam .le. 1
C  0 .le. yparam .le. 1
C
C  ** the interface is very similar to herm2ev.for; can use herm2xy **
C---------------------------------------------------------------------
C
      i(1)=0
      j(1)=0
      call r8herm2xy(xget,yget,x,nx,y,ny,ilinx,iliny,
     >   i(1),j(1),xparam(1),yparam(1),hx(1),hxi(1),hy(1),hyi(1),ier)
      if(ier.ne.0) return
c
      call r8fvbicub(ict,1,1,
     >   fval,i,j,xparam,yparam,hx,hxi,hy,hyi,f,inf2,ny)
C
      return
      end
C---------------------------------------------------------------------
C  evaluate C1 cubic Hermite function interpolation -- 2d fcn
C   --vectorized-- dmc 10 Feb 1999
C
      subroutine r8fvbicub(ict,ivec,ivecd,
     >   fval,ii,jj,xparam,yparam,hx,hxi,hy,hyi,
     >   fin,inf2,ny)
C
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER ny,inf2,iadr,i,j
!============
! idecl:  explicitize implicit REAL declarations:
      REAL*8 z36th,xp,xpi,xp2,xpi2,cx,cxi,hx2,yp,ypi,yp2,ypi2,cy
      REAL*8 cyi,hy2,cxd,cxdi,cyd,cydi
!============
      integer ict(6)                    ! requested output control
      integer ivec                      ! vector length
      integer ivecd                     ! vector dimension (1st dim of fval)
C
      integer ii(ivec),jj(ivec)         ! target cells (i,j)
      REAL*8 xparam(ivec),yparam(ivec)
                          ! normalized displacements from (i,j) corners
C
      REAL*8 hx(ivec),hy(ivec)            ! grid spacing, and
      REAL*8 hxi(ivec),hyi(ivec)          ! inverse grid spacing 1/(x(i+1)-x(i))
                                        ! & 1/(y(j+1)-y(j))
C
      REAL*8 fin(0:3,inf2,ny)             ! interpolant data (cf "evbicub")
C
      REAL*8 fval(ivecd,*)                ! output returned
C
C  for detailed description of fin, ict and fval see subroutine
C  evbicub comments.  Note ict is not vectorized; the same output
C  is expected to be returned for all input vector data points.
C
C  note that the index inputs ii,jj and parameter inputs
C     xparam,yparam,hx,hxi,hy,hyi are vectorized, and the
C     output array fval has a vector ** 1st dimension ** whose
C     size must be given as a separate argument
C
C  to use this routine in scalar mode, pass in ivec=ivecd=1
C
C---------------
C  Spline evaluation consists of a "mixing" of the interpolant
C  data using the linear functionals xparam, xpi = 1-xparam,
C  yparam, ypi = 1-yparam, and the cubic functionals
C  xparam**3-xparam, xpi**3-xpi, yparam**3-yparam, ypi**3-ypi ...
C  and their derivatives as needed.
C
      integer v
      REAL*8 sum
C
      REAL*8, parameter :: sixth = 0.166666666666666667_r8
C
C---------------
C   ...in x direction
C
      z36th=sixth*sixth
      iadr=0
C
      if(ict(1).le.2) then
C
C  get desired values:
C
         if(ict(1).eq.1) then
C
C  function value:
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               j=jj(v)
C
C  in x direction...
C
               xp=xparam(v)
               xpi=1.0_r8-xp
               xp2=xp*xp
               xpi2=xpi*xpi
C
               cx=xp*(xp2-1.0_r8)
               cxi=xpi*(xpi2-1.0_r8)
               hx2=hx(v)*hx(v)
C
C   ...and in y direction
C
               yp=yparam(v)
               ypi=1.0_r8-yp
               yp2=yp*yp
               ypi2=ypi*ypi
C
               cy=yp*(yp2-1.0_r8)
               cyi=ypi*(ypi2-1.0_r8)
               hy2=hy(v)*hy(v)
C
               sum=xpi*(ypi*fin(0,i,j)  +yp*fin(0,i,j+1))+
     >              xp*(ypi*fin(0,i+1,j)+yp*fin(0,i+1,j+1))
C
               sum=sum+sixth*hx2*(
     >              cxi*(ypi*fin(1,i,j)  +yp*fin(1,i,j+1))+
     >              cx*(ypi*fin(1,i+1,j)+yp*fin(1,i+1,j+1)))
C
               sum=sum+sixth*hy2*(
     >              xpi*(cyi*fin(2,i,j)  +cy*fin(2,i,j+1))+
     >              xp*(cyi*fin(2,i+1,j)+cy*fin(2,i+1,j+1)))
C
               sum=sum+z36th*hx2*hy2*(
     >              cxi*(cyi*fin(3,i,j)  +cy*fin(3,i,j+1))+
     >              cx*(cyi*fin(3,i+1,j)+cy*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
C
         if(ict(2).eq.1) then
C
C  df/dx:
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               j=jj(v)
C
C  in x direction...
C
               xp=xparam(v)
               xpi=1.0_r8-xp
               xp2=xp*xp
               xpi2=xpi*xpi

               cxd=3.0_r8*xp2-1.0_r8
               cxdi=-3.0_r8*xpi2+1.0_r8
C
C   ...and in y direction
C
               yp=yparam(v)
               ypi=1.0_r8-yp
               yp2=yp*yp
               ypi2=ypi*ypi
C
               cy=yp*(yp2-1.0_r8)
               cyi=ypi*(ypi2-1.0_r8)
               hy2=hy(v)*hy(v)
C
               sum=hxi(v)*(
     >              -(ypi*fin(0,i,j)  +yp*fin(0,i,j+1))
     >              +(ypi*fin(0,i+1,j)+yp*fin(0,i+1,j+1)))
C
               sum=sum+sixth*hx(v)*(
     >              cxdi*(ypi*fin(1,i,j)  +yp*fin(1,i,j+1))+
     >              cxd*(ypi*fin(1,i+1,j)+yp*fin(1,i+1,j+1)))
C
               sum=sum+sixth*hxi(v)*hy2*(
     >              -(cyi*fin(2,i,j)  +cy*fin(2,i,j+1))
     >              +(cyi*fin(2,i+1,j)+cy*fin(2,i+1,j+1)))
C
               sum=sum+z36th*hx(v)*hy2*(
     >              cxdi*(cyi*fin(3,i,j)  +cy*fin(3,i,j+1))+
     >              cxd*(cyi*fin(3,i+1,j)+cy*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
C
         if(ict(3).eq.1) then
C
C  df/dy:
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               j=jj(v)
C
C  in x direction...
C
               xp=xparam(v)
               xpi=1.0_r8-xp
               xp2=xp*xp
               xpi2=xpi*xpi
C
               cx=xp*(xp2-1.0_r8)
               cxi=xpi*(xpi2-1.0_r8)
               hx2=hx(v)*hx(v)
C
C   ...and in y direction
C
               yp=yparam(v)
               ypi=1.0_r8-yp
               yp2=yp*yp
               ypi2=ypi*ypi

               cyd=3.0_r8*yp2-1.0_r8
               cydi=-3.0_r8*ypi2+1.0_r8
C
               sum=hyi(v)*(
     >              xpi*(-fin(0,i,j)  +fin(0,i,j+1))+
     >              xp*(-fin(0,i+1,j)+fin(0,i+1,j+1)))
C
               sum=sum+sixth*hx2*hyi(v)*(
     >              cxi*(-fin(1,i,j)  +fin(1,i,j+1))+
     >              cx*(-fin(1,i+1,j)+fin(1,i+1,j+1)))
C
               sum=sum+sixth*hy(v)*(
     >              xpi*(cydi*fin(2,i,j)  +cyd*fin(2,i,j+1))+
     >              xp*(cydi*fin(2,i+1,j)+cyd*fin(2,i+1,j+1)))
C
               sum=sum+z36th*hx2*hy(v)*(
     >              cxi*(cydi*fin(3,i,j)  +cyd*fin(3,i,j+1))+
     >              cx*(cydi*fin(3,i+1,j)+cyd*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
C
         if(ict(4).eq.1) then
C
C  d2f/dx2:
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               j=jj(v)
C
C  in x direction...
C
               xp=xparam(v)
               xpi=1.0_r8-xp
C
C   ...and in y direction
C
               yp=yparam(v)
               ypi=1.0_r8-yp
               yp2=yp*yp
               ypi2=ypi*ypi
C
               cy=yp*(yp2-1.0_r8)
               cyi=ypi*(ypi2-1.0_r8)
               hy2=hy(v)*hy(v)
C
               sum=(
     >              xpi*(ypi*fin(1,i,j)  +yp*fin(1,i,j+1))+
     >              xp*(ypi*fin(1,i+1,j)+yp*fin(1,i+1,j+1)))
C
               sum=sum+sixth*hy2*(
     >              xpi*(cyi*fin(3,i,j)  +cy*fin(3,i,j+1))+
     >              xp*(cyi*fin(3,i+1,j)+cy*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
C
         if(ict(5).eq.1) then
C
C  d2f/dy2:
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               j=jj(v)
C
C  in x direction...
C
               xp=xparam(v)
               xpi=1.0_r8-xp
               xp2=xp*xp
               xpi2=xpi*xpi
C
               cx=xp*(xp2-1.0_r8)
               cxi=xpi*(xpi2-1.0_r8)
               hx2=hx(v)*hx(v)
C
C   ...and in y direction
C
               yp=yparam(v)
               ypi=1.0_r8-yp
C
               sum=(
     >              xpi*(ypi*fin(2,i,j)  +yp*fin(2,i,j+1))+
     >              xp*(ypi*fin(2,i+1,j)+yp*fin(2,i+1,j+1)))
C
               sum=sum+sixth*hx2*(
     >              cxi*(ypi*fin(3,i,j)  +yp*fin(3,i,j+1))+
     >              cx*(ypi*fin(3,i+1,j)+yp*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
C
         if(ict(6).eq.1) then
C
C  d2f/dxdy:
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               j=jj(v)
C
C  in x direction...
C
               xp=xparam(v)
               xpi=1.0_r8-xp
               xp2=xp*xp
               xpi2=xpi*xpi

               cxd=3.0_r8*xp2-1.0_r8
               cxdi=-3.0_r8*xpi2+1.0_r8
C
C   ...and in y direction
C
               yp=yparam(v)
               ypi=1.0_r8-yp
               yp2=yp*yp
               ypi2=ypi*ypi

               cyd=3.0_r8*yp2-1.0_r8
               cydi=-3.0_r8*ypi2+1.0_r8
C
               sum=hxi(v)*hyi(v)*(
     >              fin(0,i,j)  -fin(0,i,j+1)
     >              -fin(0,i+1,j)+fin(0,i+1,j+1))
C
               sum=sum+sixth*hx(v)*hyi(v)*(
     >              cxdi*(-fin(1,i,j)  +fin(1,i,j+1))+
     >              cxd*(-fin(1,i+1,j)+fin(1,i+1,j+1)))
C
               sum=sum+sixth*hxi(v)*hy(v)*(
     >              -(cydi*fin(2,i,j)  +cyd*fin(2,i,j+1))
     >              +(cydi*fin(2,i+1,j)+cyd*fin(2,i+1,j+1)))
C
               sum=sum+z36th*hx(v)*hy(v)*(
     >              cxdi*(cydi*fin(3,i,j)  +cyd*fin(3,i,j+1))+
     >              cxd*(cydi*fin(3,i+1,j)+cyd*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
C
C-------------------------------------------------
C
      else if(ict(1).eq.3) then
         if(ict(2).eq.1) then
c  evaluate d3f/dx3 (not continuous)
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               j=jj(v)
               yp=yparam(v)
               ypi=1.0_r8-yp
               yp2=yp*yp
               ypi2=ypi*ypi
               cy=yp*(yp2-1.0_r8)
               cyi=ypi*(ypi2-1.0_r8)
               hy2=hy(v)*hy(v)
               sum=hxi(v)*(
     >              -(ypi*fin(1,i,j)  +yp*fin(1,i,j+1))
     >              +(ypi*fin(1,i+1,j)+yp*fin(1,i+1,j+1)))
C
               sum=sum+sixth*hy2*hxi(v)*(
     >              -(cyi*fin(3,i,j)  +cy*fin(3,i,j+1))
     >              +(cyi*fin(3,i+1,j)+cy*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
c
         if(ict(3).eq.1) then
c  evaluate d3f/dx2dy
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               j=jj(v)
               xp=xparam(v)
               xpi=1.0_r8-xp
               yp=yparam(v)
               ypi=1.0_r8-yp
               yp2=yp*yp
               ypi2=ypi*ypi
               cyd=3.0_r8*yp2-1.0_r8
               cydi=-3.0_r8*ypi2+1.0_r8
C
               sum=hyi(v)*(
     >              xpi*(-fin(1,i,j)  +fin(1,i,j+1))+
     >              xp*(-fin(1,i+1,j) +fin(1,i+1,j+1)))
C
               sum=sum+sixth*hy(v)*(
     >              xpi*(cydi*fin(3,i,j) +cyd*fin(3,i,j+1))+
     >              xp*(cydi*fin(3,i+1,j)+cyd*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
c
         if(ict(4).eq.1) then
c  evaluate d3f/dxdy2
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               j=jj(v)
               xp=xparam(v)
               xpi=1.0_r8-xp
               xp2=xp*xp
               xpi2=xpi*xpi
               cxd=3.0_r8*xp2-1.0_r8
               cxdi=-3.0_r8*xpi2+1.0_r8
               yp=yparam(v)
               ypi=1.0_r8-yp
C
               sum=hxi(v)*(
     >              -(ypi*fin(2,i,j)  +yp*fin(2,i,j+1))
     >              +(ypi*fin(2,i+1,j)+yp*fin(2,i+1,j+1)))
C
               sum=sum+sixth*hx(v)*(
     >              cxdi*(ypi*fin(3,i,j)  +yp*fin(3,i,j+1))+
     >              cxd*(ypi*fin(3,i+1,j)+yp*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif

         if(ict(5).eq.1) then
c  evaluate d3f/dy3 (not continuous)
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               j=jj(v)
C
               xp=xparam(v)
               xpi=1.0_r8-xp
               xp2=xp*xp
               xpi2=xpi*xpi
C
               cx=xp*(xp2-1.0_r8)
               cxi=xpi*(xpi2-1.0_r8)
               hx2=hx(v)*hx(v)
C
               sum=hyi(v)*(
     >              xpi*(-fin(2,i,j)  +fin(2,i,j+1))+
     >              xp*(-fin(2,i+1,j) +fin(2,i+1,j+1)))
C
               sum=sum+sixth*hx2*hyi(v)*(
     >              cxi*(-fin(3,i,j)  +fin(3,i,j+1))+
     >              cx*(-fin(3,i+1,j) +fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
c
c-----------------------------------
c  access to 4th derivatives
c
      else if(ict(1).eq.4) then
         if(ict(2).eq.1) then
c  evaluate d4f/dx3dy (not continuous)
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               j=jj(v)
               yp=yparam(v)
               ypi=1.0_r8-yp
               yp2=yp*yp
               ypi2=ypi*ypi
               cyd=3.0_r8*yp2-1.0_r8
               cydi=-3.0_r8*ypi2+1.0_r8
C
               sum=hxi(v)*hyi(v)*(
     >              +( fin(1,i,j)  -fin(1,i,j+1))
     >              +(-fin(1,i+1,j)+fin(1,i+1,j+1)))
C
               sum=sum+sixth*hy(v)*hxi(v)*(
     >              -(cydi*fin(3,i,j)  +cyd*fin(3,i,j+1))
     >              +(cydi*fin(3,i+1,j)+cyd*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
c
         if(ict(3).eq.1) then
c  evaluate d4f/dx2dy2
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               j=jj(v)
C
               xp=xparam(v)
               xpi=1.0_r8-xp
               yp=yparam(v)
               ypi=1.0_r8-yp
C
               sum=xpi*(ypi*fin(3,i,j)  +yp*fin(3,i,j+1))+
     >              xp*(ypi*fin(3,i+1,j)+yp*fin(3,i+1,j+1))
C
               fval(v,iadr)=sum
            enddo
         endif
c
         if(ict(4).eq.1) then
c  evaluate d4f/dxdy3 (not continuous)
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               j=jj(v)
C
               xp=xparam(v)
               xpi=1.0_r8-xp
               xp2=xp*xp
               xpi2=xpi*xpi
C
               cxd=3.0_r8*xp2-1.0_r8
               cxdi=-3.0_r8*xpi2+1.0_r8
C
               sum=hyi(v)*hxi(v)*(
     >              +( fin(2,i,j)  -fin(2,i,j+1))
     >              +(-fin(2,i+1,j)+fin(2,i+1,j+1)))
C
               sum=sum+sixth*hx(v)*hyi(v)*(
     >              cxdi*(-fin(3,i,j)  +fin(3,i,j+1))+
     >              cxd*(-fin(3,i+1,j) +fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
c
c-----------------------------------
c  access to 5th derivatives
c
      else if(ict(1).eq.5) then
         if(ict(2).eq.1) then
c  evaluate d5f/dx3dy2 (not continuous)
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               j=jj(v)
C
               yp=yparam(v)
               ypi=1.0_r8-yp
C
               sum=hxi(v)*(
     >              -(ypi*fin(3,i,j)  +yp*fin(3,i,j+1))
     >              +(ypi*fin(3,i+1,j)+yp*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
c
         if(ict(3).eq.1) then
c  evaluate d5f/dx2dy3 (not continuous)
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               j=jj(v)
C
               xp=xparam(v)
               xpi=1.0_r8-xp
C
               sum=hyi(v)*(
     >              xpi*(-fin(3,i,j)  +fin(3,i,j+1))+
     >              xp*(-fin(3,i+1,j)+fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
c
c-----------------------------------
c  access to 6th derivatives
c
      else if(ict(1).eq.6) then
c  evaluate d6f/dx3dy3 (not continuous)
         iadr=iadr+1
         do v=1,ivec
            i=ii(v)
            j=jj(v)
            sum=hxi(v)*hyi(v)*(
     >              +( fin(3,i,j)  -fin(3,i,j+1))
     >              +(-fin(3,i+1,j)+fin(3,i+1,j+1)))
            fval(v,iadr)=sum
         enddo
      endif
c
      return
      end
C---------------------------------------------------------------------
C  evaluate C1 cubic Hermite function interpolation -- 2d fcn
C   --vectorized-- dmc 10 Feb 1999
C    --optimized for VARIATION along x axis ONLY--
C
      subroutine r8fvbicubx(ict,ivec,ivecd,
     >   fval,ii,jj,xparam,yparam,hx,hxi,hy,hyi,
     >   fin,inf2,ny)
C
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER ny,inf2,iadr,j,i
!============
! idecl:  explicitize implicit REAL declarations:
      REAL*8 z36th,yp,ypi,yp2,ypi2,cy,cyi,hy2,xp,xpi,xp2,xpi2,cx
      REAL*8 cxi,hx2,cxd,cxdi,cyd,cydi
!============
      integer ict(6)                    ! requested output control
      integer ivec                      ! vector length
      integer ivecd                     ! vector dimension (1st dim of fval)
C
      integer ii(ivec),jj               ! target cells (i,j)
      REAL*8 xparam(ivec),yparam
                          ! normalized displacements from (i,j) corners
C
      REAL*8 hx(ivec),hy                  ! grid spacing, and
      REAL*8 hxi(ivec),hyi                ! inverse grid spacing 1/(x(i+1)-x(i))
                                        ! & 1/(y(j+1)-y(j))
C
      REAL*8 fin(0:3,inf2,ny)             ! interpolant data (cf "evbicub")
C
      REAL*8 fval(ivecd,*)                ! output returned
C
C  for detailed description of fin, ict and fval see subroutine
C  evbicub comments.  Note ict is not vectorized; the same output
C  is expected to be returned for all input vector data points.
C
C  note that the index inputs ii,jj and parameter inputs
C     xparam,yparam,hx,hxi,hy,hyi are vectorized, and the
C     output array fval has a vector ** 1st dimension ** whose
C     size must be given as a separate argument
C
C  to use this routine in scalar mode, pass in ivec=ivecd=1
C
C---------------
C  Spline evaluation consists of a "mixing" of the interpolant
C  data using the linear functionals xparam, xpi = 1-xparam,
C  yparam, ypi = 1-yparam, and the cubic functionals
C  xparam**3-xparam, xpi**3-xpi, yparam**3-yparam, ypi**3-ypi ...
C  and their derivatives as needed.
C
      integer v
      REAL*8 sum
C
      REAL*8, parameter :: sixth = 0.166666666666666667_r8
C
C---------------
C   ...in x direction
C
      z36th=sixth*sixth
      iadr=0
C
      if(ict(1).le.2) then
C
C  get desired values:
C
         if(ict(1).eq.1) then
C
C  function value:
C
            j=jj
C
C   ...and in y direction
C
            yp=yparam
            ypi=1.0_r8-yp
            yp2=yp*yp
            ypi2=ypi*ypi
C
            cy=yp*(yp2-1.0_r8)
            cyi=ypi*(ypi2-1.0_r8)
            hy2=hy*hy
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
C
C  in x direction...
C
               xp=xparam(v)
               xpi=1.0_r8-xp
               xp2=xp*xp
               xpi2=xpi*xpi
C
               cx=xp*(xp2-1.0_r8)
               cxi=xpi*(xpi2-1.0_r8)
               hx2=hx(v)*hx(v)
C
               sum=xpi*(ypi*fin(0,i,j)  +yp*fin(0,i,j+1))+
     >              xp*(ypi*fin(0,i+1,j)+yp*fin(0,i+1,j+1))
C
               sum=sum+sixth*hx2*(
     >              cxi*(ypi*fin(1,i,j)  +yp*fin(1,i,j+1))+
     >              cx*(ypi*fin(1,i+1,j)+yp*fin(1,i+1,j+1)))
C
               sum=sum+sixth*hy2*(
     >              xpi*(cyi*fin(2,i,j)  +cy*fin(2,i,j+1))+
     >              xp*(cyi*fin(2,i+1,j)+cy*fin(2,i+1,j+1)))
C
               sum=sum+z36th*hx2*hy2*(
     >              cxi*(cyi*fin(3,i,j)  +cy*fin(3,i,j+1))+
     >              cx*(cyi*fin(3,i+1,j)+cy*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
C
         if(ict(2).eq.1) then
C
C  df/dx:
C
            j=jj
C
C   ...and in y direction
C
            yp=yparam
            ypi=1.0_r8-yp
            yp2=yp*yp
            ypi2=ypi*ypi
C
            cy=yp*(yp2-1.0_r8)
            cyi=ypi*(ypi2-1.0_r8)
            hy2=hy*hy
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
C
C  in x direction...
C
               xp=xparam(v)
               xpi=1.0_r8-xp
               xp2=xp*xp
               xpi2=xpi*xpi

               cxd=3.0_r8*xp2-1.0_r8
               cxdi=-3.0_r8*xpi2+1.0_r8
C
               sum=hxi(v)*(
     >              -(ypi*fin(0,i,j)  +yp*fin(0,i,j+1))
     >              +(ypi*fin(0,i+1,j)+yp*fin(0,i+1,j+1)))
C
               sum=sum+sixth*hx(v)*(
     >              cxdi*(ypi*fin(1,i,j)  +yp*fin(1,i,j+1))+
     >              cxd*(ypi*fin(1,i+1,j)+yp*fin(1,i+1,j+1)))
C
               sum=sum+sixth*hxi(v)*hy2*(
     >              -(cyi*fin(2,i,j)  +cy*fin(2,i,j+1))
     >              +(cyi*fin(2,i+1,j)+cy*fin(2,i+1,j+1)))
C
               sum=sum+z36th*hx(v)*hy2*(
     >              cxdi*(cyi*fin(3,i,j)  +cy*fin(3,i,j+1))+
     >              cxd*(cyi*fin(3,i+1,j)+cy*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
C
         if(ict(3).eq.1) then
C
C  df/dy:
C
            j=jj
C
C   ...and in y direction
C
            yp=yparam
            ypi=1.0_r8-yp
            yp2=yp*yp
            ypi2=ypi*ypi

            cyd=3.0_r8*yp2-1.0_r8
            cydi=-3.0_r8*ypi2+1.0_r8
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
C
C  in x direction...
C
               xp=xparam(v)
               xpi=1.0_r8-xp
               xp2=xp*xp
               xpi2=xpi*xpi
C
               cx=xp*(xp2-1.0_r8)
               cxi=xpi*(xpi2-1.0_r8)
               hx2=hx(v)*hx(v)
C
               sum=hyi*(
     >              xpi*(-fin(0,i,j)  +fin(0,i,j+1))+
     >              xp*(-fin(0,i+1,j)+fin(0,i+1,j+1)))
C
               sum=sum+sixth*hx2*hyi*(
     >              cxi*(-fin(1,i,j)  +fin(1,i,j+1))+
     >              cx*(-fin(1,i+1,j)+fin(1,i+1,j+1)))
C
               sum=sum+sixth*hy*(
     >              xpi*(cydi*fin(2,i,j)  +cyd*fin(2,i,j+1))+
     >              xp*(cydi*fin(2,i+1,j)+cyd*fin(2,i+1,j+1)))
C
               sum=sum+z36th*hx2*hy*(
     >              cxi*(cydi*fin(3,i,j)  +cyd*fin(3,i,j+1))+
     >              cx*(cydi*fin(3,i+1,j)+cyd*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
C
         if(ict(4).eq.1) then
C
C  d2f/dx2:
C
            j=jj
C
C   ...and in y direction
C
            yp=yparam
            ypi=1.0_r8-yp
            yp2=yp*yp
            ypi2=ypi*ypi
C
            cy=yp*(yp2-1.0_r8)
            cyi=ypi*(ypi2-1.0_r8)
            hy2=hy*hy
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
C
C  in x direction...
C
               xp=xparam(v)
               xpi=1.0_r8-xp
C
               sum=(
     >              xpi*(ypi*fin(1,i,j)  +yp*fin(1,i,j+1))+
     >              xp*(ypi*fin(1,i+1,j)+yp*fin(1,i+1,j+1)))
C
               sum=sum+sixth*hy2*(
     >              xpi*(cyi*fin(3,i,j)  +cy*fin(3,i,j+1))+
     >              xp*(cyi*fin(3,i+1,j)+cy*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
C
         if(ict(5).eq.1) then
C
C  d2f/dy2:
C
            j=jj
C
C   ...and in y direction
C
            yp=yparam
            ypi=1.0_r8-yp
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
C
C  in x direction...
C
               xp=xparam(v)
               xpi=1.0_r8-xp
               xp2=xp*xp
               xpi2=xpi*xpi
C
               cx=xp*(xp2-1.0_r8)
               cxi=xpi*(xpi2-1.0_r8)
               hx2=hx(v)*hx(v)
C
               sum=(
     >              xpi*(ypi*fin(2,i,j)  +yp*fin(2,i,j+1))+
     >              xp*(ypi*fin(2,i+1,j)+yp*fin(2,i+1,j+1)))
C
               sum=sum+sixth*hx2*(
     >              cxi*(ypi*fin(3,i,j)  +yp*fin(3,i,j+1))+
     >              cx*(ypi*fin(3,i+1,j)+yp*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
C
         if(ict(6).eq.1) then
C
C  d2f/dxdy:
C
            j=jj
C
C   ...and in y direction
C
            yp=yparam
            ypi=1.0_r8-yp
            yp2=yp*yp
            ypi2=ypi*ypi

            cyd=3.0_r8*yp2-1.0_r8
            cydi=-3.0_r8*ypi2+1.0_r8
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
C
C  in x direction...
C
               xp=xparam(v)
               xpi=1.0_r8-xp
               xp2=xp*xp
               xpi2=xpi*xpi

               cxd=3.0_r8*xp2-1.0_r8
               cxdi=-3.0_r8*xpi2+1.0_r8
C
               sum=hxi(v)*hyi*(
     >              fin(0,i,j)  -fin(0,i,j+1)
     >              -fin(0,i+1,j)+fin(0,i+1,j+1))
C
               sum=sum+sixth*hx(v)*hyi*(
     >              cxdi*(-fin(1,i,j)  +fin(1,i,j+1))+
     >              cxd*(-fin(1,i+1,j)+fin(1,i+1,j+1)))
C
               sum=sum+sixth*hxi(v)*hy*(
     >              -(cydi*fin(2,i,j)  +cyd*fin(2,i,j+1))
     >              +(cydi*fin(2,i+1,j)+cyd*fin(2,i+1,j+1)))
C
               sum=sum+z36th*hx(v)*hy*(
     >              cxdi*(cydi*fin(3,i,j)  +cyd*fin(3,i,j+1))+
     >              cxd*(cydi*fin(3,i+1,j)+cyd*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
C
C-------------------------------------------------
C
      else if(ict(1).eq.3) then
         if(ict(2).eq.1) then
c  evaluate d3f/dx3 (not continuous)
            j=jj
            yp=yparam
            ypi=1.0_r8-yp
            yp2=yp*yp
            ypi2=ypi*ypi
            cy=yp*(yp2-1.0_r8)
            cyi=ypi*(ypi2-1.0_r8)
            hy2=hy*hy
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               sum=hxi(v)*(
     >              -(ypi*fin(1,i,j)  +yp*fin(1,i,j+1))
     >              +(ypi*fin(1,i+1,j)+yp*fin(1,i+1,j+1)))
C
               sum=sum+sixth*hy2*hxi(v)*(
     >              -(cyi*fin(3,i,j)  +cy*fin(3,i,j+1))
     >              +(cyi*fin(3,i+1,j)+cy*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
c
         if(ict(3).eq.1) then
c  evaluate d3f/dx2dy
            j=jj
C
            yp=yparam
            ypi=1.0_r8-yp
            yp2=yp*yp
            ypi2=ypi*ypi
            cyd=3.0_r8*yp2-1.0_r8
            cydi=-3.0_r8*ypi2+1.0_r8
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               xp=xparam(v)
               xpi=1.0_r8-xp
C
               sum=hyi*(
     >              xpi*(-fin(1,i,j)  +fin(1,i,j+1))+
     >              xp*(-fin(1,i+1,j) +fin(1,i+1,j+1)))
C
               sum=sum+sixth*hy*(
     >              xpi*(cydi*fin(3,i,j) +cyd*fin(3,i,j+1))+
     >              xp*(cydi*fin(3,i+1,j)+cyd*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
c
         if(ict(4).eq.1) then
c  evaluate d3f/dxdy2
            j=jj
            yp=yparam
            ypi=1.0_r8-yp
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               xp=xparam(v)
               xpi=1.0_r8-xp
               xp2=xp*xp
               xpi2=xpi*xpi
               cxd=3.0_r8*xp2-1.0_r8
               cxdi=-3.0_r8*xpi2+1.0_r8
C
               sum=hxi(v)*(
     >              -(ypi*fin(2,i,j)  +yp*fin(2,i,j+1))
     >              +(ypi*fin(2,i+1,j)+yp*fin(2,i+1,j+1)))
C
               sum=sum+sixth*hx(v)*(
     >              cxdi*(ypi*fin(3,i,j)  +yp*fin(3,i,j+1))+
     >              cxd*(ypi*fin(3,i+1,j)+yp*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif

         if(ict(5).eq.1) then
c  evaluate d3f/dy3 (not continuous)
            iadr=iadr+1
            j=jj
            do v=1,ivec
               i=ii(v)
C
               xp=xparam(v)
               xpi=1.0_r8-xp
               xp2=xp*xp
               xpi2=xpi*xpi
C
               cx=xp*(xp2-1.0_r8)
               cxi=xpi*(xpi2-1.0_r8)
               hx2=hx(v)*hx(v)
C
               sum=hyi*(
     >              xpi*(-fin(2,i,j)  +fin(2,i,j+1))+
     >              xp*(-fin(2,i+1,j) +fin(2,i+1,j+1)))
C
               sum=sum+sixth*hx2*hyi*(
     >              cxi*(-fin(3,i,j)  +fin(3,i,j+1))+
     >              cx*(-fin(3,i+1,j) +fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
c
c-----------------------------------
c  access to 4th derivatives
c
      else if(ict(1).eq.4) then
         if(ict(2).eq.1) then
c  evaluate d4f/dx3dy (not continuous)
            iadr=iadr+1
            j=jj
C
            yp=yparam
            ypi=1.0_r8-yp
            yp2=yp*yp
            ypi2=ypi*ypi
            cyd=3.0_r8*yp2-1.0_r8
            cydi=-3.0_r8*ypi2+1.0_r8
C
            do v=1,ivec
               i=ii(v)
C
               sum=hxi(v)*hyi*(
     >              +( fin(1,i,j)  -fin(1,i,j+1))
     >              +(-fin(1,i+1,j)+fin(1,i+1,j+1)))
C
               sum=sum+sixth*hy*hxi(v)*(
     >              -(cydi*fin(3,i,j)  +cyd*fin(3,i,j+1))
     >              +(cydi*fin(3,i+1,j)+cyd*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
c
         if(ict(3).eq.1) then
c  evaluate d4f/dx2dy2
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
               j=jj
C
               xp=xparam(v)
               xpi=1.0_r8-xp
               yp=yparam
               ypi=1.0_r8-yp
C
               sum=xpi*(ypi*fin(3,i,j)  +yp*fin(3,i,j+1))+
     >              xp*(ypi*fin(3,i+1,j)+yp*fin(3,i+1,j+1))
C
               fval(v,iadr)=sum
            enddo
         endif
c
         if(ict(4).eq.1) then
c  evaluate d4f/dxdy3 (not continuous)
            j=jj
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
C
               xp=xparam(v)
               xpi=1.0_r8-xp
               xp2=xp*xp
               xpi2=xpi*xpi
C
               cxd=3.0_r8*xp2-1.0_r8
               cxdi=-3.0_r8*xpi2+1.0_r8
C
               sum=hyi*hxi(v)*(
     >              +( fin(2,i,j)  -fin(2,i,j+1))
     >              +(-fin(2,i+1,j)+fin(2,i+1,j+1)))
C
               sum=sum+sixth*hx(v)*hyi*(
     >              cxdi*(-fin(3,i,j)  +fin(3,i,j+1))+
     >              cxd*(-fin(3,i+1,j) +fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
c
c-----------------------------------
c  access to 5th derivatives
c
      else if(ict(1).eq.5) then
         if(ict(2).eq.1) then
c  evaluate d5f/dx3dy2 (not continuous)
            j=jj
C
            yp=yparam
            ypi=1.0_r8-yp
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
C
               sum=hxi(v)*(
     >              -(ypi*fin(3,i,j)  +yp*fin(3,i,j+1))
     >              +(ypi*fin(3,i+1,j)+yp*fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
c
         if(ict(3).eq.1) then
c  evaluate d5f/dx2dy3 (not continuous)
            j=jj
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
C
               xp=xparam(v)
               xpi=1.0_r8-xp
C
               sum=hyi*(
     >              xpi*(-fin(3,i,j)  +fin(3,i,j+1))+
     >              xp*(-fin(3,i+1,j)+fin(3,i+1,j+1)))
C
               fval(v,iadr)=sum
            enddo
         endif
c
c-----------------------------------
c  access to 6th derivatives
c
      else if(ict(1).eq.6) then
c  evaluate d6f/dx3dy3 (not continuous)
         iadr=iadr+1
         j=jj
         do v=1,ivec
            i=ii(v)
            sum=hxi(v)*hyi*(
     >              +( fin(3,i,j)  -fin(3,i,j+1))
     >              +(-fin(3,i+1,j)+fin(3,i+1,j+1)))
            fval(v,iadr)=sum
         enddo
      endif
c
      return
      end


module sym_vector_sub

  use sym_sub, only: Amat, Ainv, SymMatB, use_symmetry

  implicit none

  private
  public :: sym_vector_xyz

contains

  subroutine sym_vector_xyz( vxyz )
    implicit none
    real(8),intent(inout) :: vxyz(3)
    real(8) :: vtmp(3), Rvtmp(3)
    integer :: isym, nsym
    if ( .not.use_symmetry ) return
    nsym = size(SymMatB,3)
    vtmp = matmul( Ainv, vxyz )
    vxyz = 0.0d0
    do isym=1,nsym
       Rvtmp = matmul( SymMatB(:,1:3,isym), vtmp )
       vxyz = vxyz + Rvtmp
    end do
    vtmp = vxyz/nsym
    vxyz = matmul( Amat, vtmp )
  end subroutine sym_vector_xyz

end module sym_vector_sub