c subroutine regres.f
c
c source
c   Bevington, pages 172-175.
c
c purpose
c   make a mulitple linear regression fit to data with a specified
c      function which is linear in coefficients
c
c usage
c   call regres (x, y, sigmay, npts, nterms, m, mode, yfit,
c      a0, a, sigma0, sigmaa, r, rmul, chisqr, ftest)
c
c description of parameters
c   x	   - array of points for independent variable
c   y	   - array of points for dependent variable
c   sigmay - array of standard deviations for y data points
c   npts   - number of pairs of data points
c   nterms - number of coefficients
c   m	   - array of inclusion/rejection criteria for fctn
c   mode   - determines method of weighting least-squares fit
c	     +1 (instrumental) weight(i) = 1./sigmay(i)**2
c	      0 (no weighting) weight(i) = 1.
c	     -1 (statistical)  weight(i) = 1./y(i)
c   yfit   - array of calculated values of y
c   a0	   - constant term
c   a	   - array of coefficients
c   sigma0 - standard deviation of a0
c   sigmaa - array of standard deviations for coefficients
c   r	   - array of linear correlation coefficients
c   rmul   - multiple linear correlation coefficient
c   chisqr - reduced chi square for fit
c   ftest  - value of f for test of fit
c
c subroutines and function subprograms required
c   fctn (x, i, j, m)
c      evaluates the function for the jth term and the ith data point
c      using the array m to specify terms in the function
c   matinv (array, nterms, det)
c      inverts a symmetric two-dimensional matrix of degree nterms
c      and calculates its determinant
c
c comments
c (dim npts changed 100->1000 21-may-84 dct)
c   dimension statement valid for npts up to 100 and nterms up to 10
c   sigmaag changed to sigmaa in statement following statement 132
c
      subroutine regres (x,y,sigmay,npts,nterms,m,mode,yfit,
     *a0,a,sigma0,sigmaa,r,rmul,chisqr,ftest)
      double precision array,sum,ymean,sigma,chisq,xmean,sigmax
      dimension x(1),y(1),sigmay(1),m(1),yfit(1),a(1),sigmaa(1),
     *r(1)
      dimension weight(1000),xmean(10),sigmax(10),array(10,10)
      REAL FCTN
      EXTERNAL FCTN

c
c initialize sums and arrays
c
11    sum=0.
      ymean=0.
      sigma=0.
      chisq=0.
      rmul=0.
      do 17 i=1,npts
17    yfit(i)=0.
21    do 28 j=1,nterms
      xmean(j)=0.
      sigmax(j)=0.
      r(j)=0.
      a(j)=0.
      sigmaa(j)=0.
      do 28 k=1,nterms
28    array(j,k)=0.
c
c accumulate weighted sums
c
30    do 50 i=1,npts
31    if (mode) 32,37,39
32    if (y(i)) 35,37,33
33    weight(i)=1./y(i)
      goto 41
35    weight(i)=1./(-y(i))
      goto 41
37    weight(i)=1.
      goto 41
39    weight(i)=1./sigmay(i)**2
41    sum=sum+weight(i)
      ymean=ymean+weight(i)*y(i)
      do 44 j=1,nterms
44    xmean(j)=xmean(j)+weight(i)*fctn(x,i,j,m)
50    continue
51    ymean=ymean/sum
      do 53 j=1,nterms
53    xmean(j)=xmean(j)/sum
      fnpts=npts
      wmean=sum/fnpts
      do 57 i=1,npts
57    weight(i)=weight(i)/wmean
c
c accumulate matrices r and array
c
61    do 67 i=1,npts
      sigma=sigma+weight(i)*(y(i)-ymean)**2
      do 67 j=1,nterms
      sigmax(j)=sigmax(j)+weight(i)*(fctn(x,i,j,m)-xmean(j))**2
      r(j)=r(j)+weight(i)*(fctn(x,i,j,m)-xmean(j))*(y(i)-ymean)
      do 67 k=1,j
67    array(j,k)=array(j,k)+weight(i)*(fctn(x,i,j,m)-xmean(j))*
     *(fctn(x,i,k,m)-xmean(k))
71    free1=npts-1
72    sigma=dsqrt(sigma/free1)
      do 78 j=1,nterms
74    sigmax(j)=dsqrt(sigmax(j)/free1)
      r(j)=r(j)/(free1*sigmax(j)*sigma)
      do 78 k=1,j
      array(j,k)=array(j,k)/(free1*sigmax(j)*sigmax(k))
78    array(k,j)=array(j,k)
c
c invert symmetric matrix
c
81    call matinv (array,nterms,det)
      if (det) 101,91,101
91    a0=0.
      sigma0=0.
      rmul=0.
      chisqr=0.
      ftest=0.
      goto 150
c
c calculate coefficients, fit, and chi square
c
101   a0=ymean
102   do 108 j=1,nterms
      do 104 k=1,nterms
104   a(j)=a(j)+r(k)*array(j,k)
105   a(j)=a(j)*sigma/sigmax(j)
106   a0=a0-a(j)*xmean(j)
107   do 108 i=1,npts
108   yfit(i)=yfit(i)+a(j)*fctn(x,i,j,m)
111   do 113 i=1,npts
      yfit(i)=yfit(i)+a0
113   chisq=chisq+weight(i)*(y(i)-yfit(i))**2
      freen=npts-nterms-1
115   chisqr=chisq*wmean/freen
c
c calculate uncertainties
c
121   if (mode) 122,124,122
122   varnce=1./wmean
      goto 131
124   varnce=chisqr
131   do 133 j=1,nterms
132   sigmaa(j)=array(j,j)*varnce/(free1*sigmax(j)**2)
      sigmaa(j)=sqrt(sigmaa(j))
133   rmul=rmul+a(j)*r(j)*sigmax(j)/sigma
      freej=nterms
c +noao: When rmul = 1, the following division (stmt 135) would blow up.
c        It has been changed so ftest is set to -99999. in this case.
      if (1. - rmul) 135, 935, 135
135   ftest=(rmul/freej)/((1.-rmul)/freen)
      goto 136
935   ftest = -99999.
c -noao
136   rmul=sqrt(rmul)
141   sigma0=varnce/fnpts
      do 145 j=1,nterms
      do 145 k=1,nterms
145   sigma0=sigma0+varnce*xmean(j)*xmean(k)*array(j,k)/
     *(free1*sigmax(j)*sigmax(k))
146   sigma0=sqrt(sigma0)
150   return
      end


!
!     -------------------------------------------------------------
!      N I N E 1 1
!     -------------------------------------------------------------
!
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF 9j COEFFICIENT         *
!                                                                  *
!     |  J1/2  J2/2  J3/2 |                                        *
!     |  L1/2  L2/2  J3/2 |                                        *
!     |  K1/2  K1/2    1  |                                        *
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Vanderbilt University,  Nashville             October 1996   *
!
      SUBROUTINE NINE11(J1, J2, J3, L1, L2, K1, A)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE CONSTS_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:09:06  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE sixj_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: J1
      INTEGER  :: J2
      INTEGER  :: J3
      INTEGER  :: L1
      INTEGER  :: L2
      INTEGER  :: K1
      REAL(DOUBLE) , INTENT(OUT) :: A
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: ISKAI
      REAL(DOUBLE) :: S, VARD
!-----------------------------------------------
      A = ZERO
      ISKAI = DBLE((J1 - L1)*(J1 + L1 + 2) - (J2 - L2)*(J2 + L2 + 2))
      IF (ISKAI == 0) RETURN
      CALL SIXJ (J1, L1, K1, L2, J2, J3, 0, S)
      VARD = DSQRT(DBLE(4*K1)*DBLE(K1 + 2)*DBLE(K1 + 1)*DBLE(J3)*DBLE(J3 + 2)*&
         DBLE(J3 + 1))
      A = S*DBLE(ISKAI)/VARD
      IF (MOD(L1 + J2 + K1 + J3,4) /= 0) A = -A
      RETURN
      END SUBROUTINE NINE11


      function pot(s,z)
      parameter (pi=3.1415926535)
      common /potconstants/ apot(20,0:20000), frad(20,0:20000),
     +     dr, nr, lmax, potcor
      common /legendre/ plcon(0:40)
      common /flags/ idiskflag, ibulgeflag, ihaloflag
c     Returns the potential, being the sum of the spherical harmonics
c     with coefficients in apot, and the potential appdiskpot which
c     approximates the high-frequency components of the disk.
c     + external potentials
      p=0

      r=sqrt(s*s+z*z)
      ihi=int(r/dr)+1
      if (ihi.lt.1) ihi=1
      if (ihi.gt.nr) ihi=nr
      r1=dr*(ihi-1)
      r2=dr*ihi
      t=(r-r1)/(r2-r1)
      tm1 = 1.0 - t
      if (r.eq.0.) then
         lmaxx=0
         costheta=0
      else
         costheta=z/r
         lmaxx=lmax
      endif

      do l=lmaxx,0,-2
         p=p+plgndr1(l,costheta)*plcon(l)*
     +        (t*apot(l/2+1,ihi)+ tm1*apot(l/2+1,ihi-1))
      enddo
      if( idiskflag .eq. 1 .or. idiskflag .eq. 3)
     & p = p + appdiskpot(s,z)

      if( idiskflag .eq. 2 .or. idiskflag .eq. 3)
     & p= p + thickdiskpot(s,z)

      if(ihaloflag.eq.2)
     & p= p + fixedpot(r)

      pot=p
      return
      end

      function extpot(s,z)
      parameter (pi=3.1415926535)
      common /flags/ idiskflag, ibulgeflag, ihaloflag
c     external potentials
      p=0
      r=sqrt(s*s+z*z)

      if( idiskflag .eq. 1 .or. idiskflag .eq. 3)
     & p = p + appdiskpot(s,z)

      if( idiskflag .eq. 2 .or. idiskflag .eq. 3)
     & p= p + thickdiskpot(s,z)

      if(ihaloflag.eq.2)
     & p= p + fixedpot(r)

      extpot=p
      return
      end

      function cfharm(s,z,ff)
      parameter (pi=3.1415926535)
      common /potconstants/ apot(20,0:20000), frad(20,0:20000),
     +     dr, nr, lmax, potcor
      common /legendre/ plcon(0:40)
      common /flags/ idiskflag, ibulgeflag, ihaloflag
c     Returns the potential, being the sum of the spherical harmonics
c     with coefficients in apot, and the potential appdiskpot which
c     approximates the high-frequency components of the disk.
c     + external potentials
      real ff(20,0:20000)
      p=0
      r=sqrt(s*s+z*z)
      ihi=int(r/dr)+1
      if (ihi.lt.1) ihi=1
      if (ihi.gt.nr) ihi=nr
      r1=dr*(ihi-1)
      r2=dr*ihi
      t=(r-r1)/(r2-r1)
      tm1 = 1.0 - t
      if (r.eq.0.) then
         lmaxx=0
         costheta=0
      else
         costheta=z/r
         lmaxx=lmax
      endif

      do l=lmaxx,0,-2
         p=p+plgndr1(l,costheta)*plcon(l)*
     +        (t*ff(l/2+1,ihi)+ tm1*ff(l/2+1,ihi-1))
      enddo

      cfharm=p
      return
      end


double precision function cubicfilter(x, c0, c1, c2, c3)
    ! filter 4 values using cubic splines
    double precision x, c0, c1, c2, c3
    double precision w0, w1, w2, w3
    w0 = x*(x*(-x + 3d0) - 3d0) + 1d0
    w1 = x*x*(3d0*x - 6d0) + 4d0;
    w2 =  x*(x*(-3d0*x + 3d0) + 3d0) + 1d0
    w3 =  x*x*x
    cubicfilter = (c0 * w0 + c1 * w1 + c2 * w2 + c3 * w3) * 0.16666666666666666d0
end

double precision function tex2d(ftl_map, x, y, nx, ny)
    ! nx : second dimension of array
    ! ny : first dimension of array
    implicit none
    double precision, intent(in) :: ftl_map(0:ny-1, 0:nx-1)
    integer, intent(in) :: nx, ny
    integer x, y

    if (y < 0)  y = mod(ny + y, ny)
    if (x < 0)  x = mod(nx + x, nx)
    if (y >= ny) y = mod(y, ny)
    if (x >= nx) x = mod(x, nx)
    tex2d = ftl_map(y, x)
end

double precision function eval(ftl_map, fx, fy, nx, ny)
    ! nx : second dimension of array
    ! ny : first dimension of array
    implicit none
    double precision, intent(in) :: ftl_map(0:ny-1, 0:nx-1), fx, fy
    integer, intent(in) :: nx, ny
    double precision, external :: cubicfilter, tex2d
    double precision gx, gy
    integer px, py

    px = floor(fx)
    py = floor(fy)
    gx = fx - px
    gy = fy - py
    eval = cubicfilter(gy, &
              cubicfilter(gx, tex2d(ftl_map, px-1, py-1,nx, ny), tex2d(ftl_map, px, py-1,nx, ny), &
                        tex2d(ftl_map, px+1, py-1,nx, ny), tex2d(ftl_map, px+2,py-1,nx, ny)), &
              cubicfilter(gx, tex2D(ftl_map, px-1, py, nx, ny),   tex2d(ftl_map, px, py,nx, ny),   &
                        tex2d(ftl_map, px+1, py, nx, ny),   tex2d(ftl_map, px+2, py,nx, ny)),&
              cubicfilter(gx, tex2D(ftl_map, px-1, py+1,nx, ny), tex2d(ftl_map, px, py+1,nx, ny), &
                        tex2d(ftl_map, px+1, py+1, nx, ny), tex2d(ftl_map, px+2, py+1,nx, ny)), &
              cubicfilter(gx, tex2D(ftl_map, px-1, py+2,nx, ny), tex2d(ftl_map, px, py+2,nx, ny), &
                        tex2d(ftl_map, px+1, py+2,nx, ny), tex2d(ftl_map, px+2, py+2,nx, ny)) )
end

subroutine deflect(output, ftl_map, fx, fy, nx, ny, npts)
    ! input ftl_map should be bicubic prefiltered map
    ! fx, fy new coordinate in grid units.
    ! x and y are the 2nd and 1st ftl_map array dimension respectively.
    ! fx new x-coordinate, fy new y-coordinate

    implicit none
    double precision, intent(in) :: ftl_map(0:ny-1,0:nx-1)
    double precision, intent(in) :: fx(0:npts-1), fy(0:npts-1)
    double precision, intent(out) :: output(0:npts-1)
    double precision, external :: eval
    integer, intent(in) :: nx, ny, npts
    integer i
    do i = 0, npts - 1
        output(i) = eval(ftl_map, fx(i), fy(i), nx, ny)
    end do
end subroutine deflect

subroutine deflect_inverse(exo, eyo, ex, ey, dx, dy, minv_xx, minv_yy, minv_xy, minv_yx, nx, ny)
    ! iterate deflection inversion estimate
    ! ex, ey are current estimates in grid units, dx, dy the deflection in grid units
    ! minv_XX are the magnification matrix inverse components
    ! exo, eyo are the improved estimates.

    implicit none
    double precision, intent(in) :: dx(0:ny-1, 0:nx-1), dy(0:ny-1, 0:nx-1)
    double precision, intent(in) :: minv_xx(0:ny-1, 0:nx-1), minv_yy(0:ny-1, 0:nx-1)
    double precision, intent(in) :: minv_xy(0:ny-1, 0:nx-1), minv_yx(0:ny-1, 0:nx-1)
    double precision, intent(in) :: ex(0:ny-1, 0:nx-1), ey(0:ny-1, 0:nx-1)
    double precision, intent(out) :: exo(0:ny-1, 0:nx-1), eyo(0:ny-1, 0:nx-1)

    double precision fx, fy
    double precision len_mxx, len_myy, len_mxy, len_myx
    double precision ex_len_dx, ey_len_dy
    double precision, external :: eval
    integer x, y, nx, ny

    do x = 0, nx -1
        do y = 0, ny -1
            fx = ex(y, x) + x
            fy = ey(y, x) + y
            ex_len_dx = ex(y, x) + eval(dx, fx, fy, nx, ny)
            ey_len_dy = ey(y, x) + eval(dy, fx, fy, nx, ny)
            len_mxx = eval(minv_xx, fx, fy, nx, ny)
            len_myy = eval(minv_yy, fx, fy, nx, ny)
            len_mxy = eval(minv_xy, fx, fy, nx, ny)
            len_myx = eval(minv_yx, fx, fy, nx, ny)
            exo(y, x) = ex(y, x) + len_mxx * ex_len_dx + len_mxy * ey_len_dy
            eyo(y, x) = ey(y, x) + len_myx * ex_len_dx + len_myy * ey_len_dy
        end do
    end do

end subroutine deflect_inverse


C --- -----------------  KAPPA ---------------------------------------

      REAL*4 FUNCTION AHMIN(wlam)

C-----This function determines the photo-detachment cross-section for
C-----HMINUS according to T.L John: Astron. Astrophys. 193,189 (1988)

      REAL*8 WLAM
      REAL*4 XMICLAM,XMICLAM3,CROSEC(6)

      DATA CROSEC/152.519,49.534,-118.858,92.536,-34.194,4.982/

      XMICLAM = wlam * 10000.           ! cm -> microns
      DIVLAM  = 1. / XMICLAM
      DIVLAM0 = 1. / 1.6419
      DIFFLAM = ( DIVLAM - DIVLAM0 ) ** .5
      XLAM    = 1.E-06 * XMICLAM
      XMICLAM3= XLAM * XLAM * XLAM

C-----Cross-section for 1250 A <= LAM <= 16419 A (=threshold wavelength)

      AHMIN = 0.
      DO  I = 6,1,-1
         AHMIN = CROSEC(I) + AHMIN * DIFFLAM
      ENDDO
      AHMIN = AHMIN * XMICLAM3 * (DIVLAM - DIVLAM0) ** 1.5

      RETURN
      END


! A Gaussian process of full rank.  See [1, section 2], which gives an
! introduction to Gaussian processes.
!
! [1] J. Quinonero and C. Rasmussen. Analysis of Some Methods for
! Reduced Rank Gaussian Process Regression, in Switching and Learning
! in Feedback Systems: European Summer School on Multi-Agent Control,
! Maynooth, Ireland, September 8-10, 2003, Revised Lectures and
! Selected Papers, Springer, 2005

module m_gp_dense
  use m_gp
  use m_util
  use m_cov_all
  use m_noise_all
  implicit none

  private
  public DenseGP, read_DenseGP

  type, extends(BaseGP) :: DenseGP
     ! covariance matrix and inverse (C is represented by Q in the
     ! notation of ref [1])
     real(dp), dimension(:,:), allocatable :: C, invC
     ! precomuted product, used in the prediction
     real(dp), dimension(:), allocatable :: invCt
   contains
     procedure log_lik
     procedure update_matrices
     procedure predict
     procedure write_out
  end type DenseGP

  interface DenseGP
     module procedure make_DenseGP
     module procedure read_DenseGP
  end interface DenseGP

contains

  subroutine alloc_DenseGP(gp, n, ntheta, dims, CovFunction, NoiseModel)
    type(DenseGP), intent(inout) :: gp
    ! n: number of observations
    ! ntheta: number of covariance hyperparameters
    ! dims: dimension of the inputs
    integer, intent(in) :: n, ntheta, dims
    class(cov_fn) :: CovFunction
    class(noise_model) :: NoiseModel

    allocate(real(dp) :: gp%nu(NoiseModel%nparams_required(dims)))
    allocate(real(dp) :: gp%theta(ntheta))
    allocate(real(dp) :: gp%x(n, dims))
    allocate(integer :: gp%obs_type(n))
    allocate(real(dp) :: gp%t(n))
    allocate(real(dp) :: gp%C(n,n))
    allocate(real(dp) :: gp%invC(n,n))
    allocate(real(dp) :: gp%invCt(n))
    allocate(gp%covariance, mold=CovFunction)
    allocate(gp%noise_model, mold=NoiseModel)
  end subroutine alloc_DenseGP

  function make_DenseGP(nu, theta, x, obs_type, t, CovFunction, NoiseModel) result(gp)
    type(DenseGP) :: gp
    ! noise hyperparameters
    real(dp), dimension(:), intent(in) :: nu
    ! covariance hyperparameters
    real(dp), dimension(:), intent(in) :: theta
    ! training input coordinates
    real(dp), dimension(:,:), intent(in) :: x
    ! training input observation types
    integer,  dimension(:), intent(in) :: obs_type
    ! training outputs
    real(dp), dimension(:), intent(in) :: t

    class(cov_fn) :: CovFunction
    class(noise_model) :: NoiseModel

    integer :: n, d
    n = size(t)
    d = size(x,2)

    if (size(theta) /= CovFunction%ntheta_required(d)) then
       print *, "size of theta does not match number of hyperparameters required by the covariance function"
       stop 1
    end if

    if (size(nu) /= NoiseModel%nparams_required(d)) then
       print *, "size of nu (noise params) does not match number required by the noise model"
       stop 1
    end if

    call alloc_DenseGP(gp, n, size(theta), d, CovFunction, NoiseModel)

    gp%nu = nu
    gp%theta = theta
    gp%obs_type = obs_type
    gp%t = t
    gp%x = x
    call update_matrices(gp)
  end function make_DenseGP

  subroutine write_out(this, filename)
    class(DenseGP), intent(in) :: this
    character(len=*), intent(in) :: filename
    character(len=max_name_len) :: cov_fn_name
    character(len=max_name_len) :: noise_model_name
    integer :: u ! unit number for output

    cov_fn_name = cov_fn_to_string(this%covariance)
    noise_model_name = noise_model_to_string(this%noise_model)

    open(newunit=u, file=filename)

    write (u,'(A)') "DenseGP"
    write (u,'(I10)') size(this%t), size(this%theta), size(this%nu), size(this%x,2)
    write (u,'(A)') trim(cov_fn_name)
    write (u,'(A)') trim(noise_model_name)
    write (u,'(es24.15)') this%nu, this%theta, this%x
    write (u,'(I4)') this%obs_type
    write (u,'(es24.15)') this%C, this%invC, this%invCt

    close(u)
  end subroutine write_out

  function read_DenseGP(filename) result(gp)
    character(len=*), intent(in) :: filename
    type(DenseGP) :: gp
    integer n, ntheta, nnu, d, u
    character(len=max_name_len) :: label
    character(len=max_name_len) :: cov_fn_name
    character(len=max_name_len) :: noise_model_name
    class(cov_fn), allocatable :: CovFunction
    class(noise_model), allocatable :: NoiseModel
    open(newunit=u, file=filename)
    read (u,'(A)') label

    if (trim(label) /= "DenseGP") then
       print *, "Incompatible data file"
       stop 1
    end if

    read (u,'(I10)') n, ntheta, nnu, d

    read (u,'(A)') cov_fn_name
    call string_to_cov_fn(cov_fn_name, CovFunction)
    if (ntheta /= CovFunction%ntheta_required(d)) then
       print *, "ntheta does not match number required by the covariance function"
       stop 1
    end if

    read (u,'(A)') noise_model_name
    call string_to_noise_model(noise_model_name, NoiseModel)
    if (nnu /= NoiseModel%nparams_required(d)) then
       print *, "size of nu (noise params) does not match number required by the noise model"
       stop 1
    end if

    call alloc_DenseGP(gp, n, ntheta, d, CovFunction, NoiseModel)

    read (u,'(es24.15)') gp%nu, gp%theta, &
         gp%x
    read (u,'(I4)') gp%obs_type
    read (u,'(es24.15)') gp%C, gp%invC, gp%invCt
    close(u)
  end function read_DenseGP

  subroutine update_matrices(this)
    class(DenseGP), intent(inout) :: this
    integer :: i,j,n
    real(dp) noise
    ! always a small amount of noise to stabilize the inversion
    real(dp), parameter :: noise_stab = 1e-9_dp

    n = size(this%t)

    do i=1,n
       do j=1,n
          if (i.ne.j) then
             noise = 0.0_dp
          else
             noise = this%noise_model%noise(this%obs_type(i), this%nu) + noise_stab
          end if
          ! Q in ref [1] (just below eq. (7) therein)
          this%C(i,j) = this%covariance%cov(this%obs_type(i), this%obs_type(j), &
               this%x(i,:), this%x(j,:), this%theta) + noise
       end do
    end do

    this%invC = this%C
    call ninv(this%invC)
    this%invCt = solve(this%C, this%t)
  end subroutine update_matrices

  function predict(this, xnew, obs_type_new)
    real(dp) predict
    class(DenseGP), intent(in) :: this
    real(dp), dimension(:), intent(in) :: xnew
    integer, optional, intent(in) :: obs_type_new

    integer :: obs_type_new1, i

    real(dp), dimension(size(this%t)) :: k
    if (present(obs_type_new)) then
       obs_type_new1 = obs_type_new
    else
       obs_type_new1 = 0
    endif

    do i=1,size(this%t)
       k(i) = this%covariance%cov(obs_type_new1,this%obs_type(i),xnew,this%x(i,:),this%theta)
    end do
    ! Predictive mean from eq. (6) in ref [1]. Here, k corresponds to
    ! k^{*} in the reference, and t to y
    predict = dot_product(k, this%invCt)
  end function predict

  function log_lik(this)
    class(DenseGP), intent(in) :: this
    real(dp) log_lik
    ! First line of eq. (8) in ref. [1]
    log_lik = -0.5_dp * (logdet(this%C) + dot_product(this%t, this%invCt))
  end function log_lik

end module m_gp_dense


      subroutine herm2ev(xget,yget,x,nx,y,ny,ilinx,iliny,
     >                   f,inf2,ict,fval,ier)
C
C  evaluate a 2d cubic Hermite interpolant on a rectilinear
C  grid -- this is C1 in both directions.
C
C  this subroutine calls two subroutines:
C     herm2xy  -- find cell containing (xget,yget)
C     herm2fcn -- evaluate interpolant function and (optionally) derivatives
C
C  input arguments:
C  ================
C
      real xget,yget                    ! target of this interpolation
      real x(nx)                        ! ordered x grid
      real y(ny)                        ! ordered y grid
      integer ilinx                     ! ilinx=1 => assume x evenly spaced
      integer iliny                     ! iliny=1 => assume y evenly spaced
C
      real 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) = df/dx @ x(i),y(j)
C  f(2,i,j) = df/dy @ x(i),y(j)
C  f(3,i,j) = d2f/dxdy @ x(i),y(j)
C
      integer ict(4)                    ! 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/dxdy (0, don't)
C
C output arguments:
C =================
C
      real 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
C  examples:
C    on input ict = [1,1,1,1]
C   on output fval= [f,df/dx,df/dy,d2f/dxdy]
C
C    on input ict = [1,0,0,0]
C   on output fval= [f] ... elements 2 & 3 & 4 never referenced
C
C    on input ict = [0,1,1,0]
C   on output fval= [df/dx,df/dy] ... element 3 & 4 never referenced
C
C    on input ict = [0,0,1,0]
C   on output fval= [df/dy] ... elements 2 & 3 & 4 never referenced.
C
C  ier -- completion code:  0 means OK
C-------------------
C  local:
C
      integer i,j                       ! 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 xparam,yparam
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 hx,hy
      real hxi,hyi
C
C  0 .le. xparam .le. 1
C  0 .le. yparam .le. 1
C
C---------------------------------------------------------------------
C
      call herm2xy(xget,yget,x,nx,y,ny,ilinx,iliny,
     >   i,j,xparam,yparam,hx,hxi,hy,hyi,ier)
      if(ier.ne.0) return
c
      call herm2fcn(ict,1,1,
     >   fval,i,j,xparam,yparam,hx,hxi,hy,hyi,f,inf2,ny)
C
      return
      end
C---------------------------------------------------------------------
c  herm2xy -- look up x-y zone
c
c  this is the "first part" of herm2ev, see comments, above.
c
      subroutine herm2xy(xget,yget,x,nx,y,ny,ilinx,iliny,
     >   i,j,xparam,yparam,hx,hxi,hy,hyi,ier)
c
c  input of herm2xy
c  ================
c
      integer nx,ny                     ! array dimensions
c
      real xget,yget                    ! target point
      real x(nx),y(ny)                  ! indep. coords., strict ascending
c
      integer ilinx                     ! =1:  x evenly spaced
      integer iliny                     ! =1:  y evenly spaced
c
c  output of herm2xy
c  =================
      integer i,j                       ! index to cell containing target pt
c          on exit:  1.le.i.le.nx-1   1.le.j.le.ny-1
c
c  normalized position w/in (i,j) cell (btw 0 and 1):
c
      real xparam                       ! (xget-x(i))/(x(i+1)-x(i))
      real yparam                       ! (yget-y(j))/(y(j+1)-y(j))
c
c  grid spacing
c
      real hx                           ! hx = x(i+1)-x(i)
      real hy                           ! hy = y(j+1)-y(j)
c
c  inverse grid spacing:
c
      real hxi                          ! 1/hx = 1/(x(i+1)-x(i))
      real hyi                          ! 1/hy = 1/(y(j+1)-y(j))
c
      integer ier                       ! return ier.ne.0 on error
c
c------------------------------------
c
      ier=0
c
c  range check
c
      zxget=xget
      zyget=yget
      if((xget.lt.x(1)).or.(xget.gt.x(nx))) then
         zxtol=4.0e-7*max(abs(x(1)),abs(x(nx)))
         if((xget.lt.x(1)-zxtol).or.(xget.gt.x(nx)+zxtol)) then
            ier=1
            write(6,1001) xget,x(1),x(nx)
 1001       format(' ?herm2ev:  xget=',1pe11.4,' out of range ',
     >         1pe11.4,' to ',1pe11.4)
         else
            if((xget.lt.x(1)-0.5*zxtol).or.
     >         (xget.gt.x(nx)+0.5*zxtol))
     >      write(6,1011) xget,x(1),x(nx)
 1011       format(' %herm2ev:  xget=',1pe15.8,' beyond range ',
     >         1pe15.8,' to ',1pe15.8,' (fixup applied)')
            if(xget.lt.x(1)) then
               zxget=x(1)
            else
               zxget=x(nx)
            endif
         endif
      endif
      if((yget.lt.y(1)).or.(yget.gt.y(ny))) then
         zytol=4.0e-7*max(abs(y(1)),abs(y(ny)))
         if((yget.lt.y(1)-zytol).or.(yget.gt.y(ny)+zytol)) then
            ier=1
            write(6,1002) yget,y(1),y(ny)
 1002       format(' ?herm2ev:  yget=',1pe11.4,' out of range ',
     >         1pe11.4,' to ',1pe11.4)
         else
            if((yget.lt.y(1)-0.5*zytol).or.
     >         (yget.gt.y(ny)+0.5*zytol))
     >      write(6,1012) yget,y(1),y(ny)
 1012       format(' %herm2ev:  yget=',1pe15.8,' beyond range ',
     >         1pe15.8,' to ',1pe15.8,' (fixup applied)')
            if(yget.lt.y(1)) then
               zyget=y(1)
            else
               zyget=y(ny)
            endif
         endif
      endif
      if(ier.ne.0) return
c
c  now find interval in which target point lies..
c
      nxm=nx-1
      nym=ny-1
c
      if(ilinx.eq.1) then
         ii=1+nxm*(zxget-x(1))/(x(nx)-x(1))
         i=min(nxm, ii)
         if(zxget.lt.x(i)) then
            i=i-1
         else if(zxget.gt.x(i+1)) then
            i=i+1
         endif
      else
         if((1.le.i).and.(i.lt.nxm)) then
            if((x(i).le.zxget).and.(zxget.le.x(i+1))) then
               continue  ! already have the zone
            else
               call zonfind(x,nx,zxget,i)
            endif
         else
            i=nx/2
            call zonfind(x,nx,zxget,i)
         endif
      endif
c
      if(iliny.eq.1) then
         jj=1+nym*(zyget-y(1))/(y(ny)-y(1))
         j=min(nym, jj)
         if(zyget.lt.y(j)) then
            j=j-1
         else if(zyget.gt.y(j+1)) then
            j=j+1
         endif
      else
         if((1.le.j).and.(j.lt.nym)) then
            if((y(j).le.zyget).and.(zyget.le.y(j+1))) then
               continue  ! already have the zone
            else
               call zonfind(y,ny,zyget,j)
            endif
         else
            j=ny/2
            call zonfind(y,ny,zyget,j)
         endif
      endif
c
      hx=(x(i+1)-x(i))
      hy=(y(j+1)-y(j))
c
      hxi=1.0/hx
      hyi=1.0/hy
c
      xparam=(zxget-x(i))*hxi
      yparam=(zyget-y(j))*hyi
c
      return
      end
C---------------------------------------------------------------------
C  evaluate C1 cubic Hermite function interpolation -- 2d fcn
C   --vectorized-- dmc 10 Feb 1999
C
      subroutine herm2fcn(ict,ivec,ivecd,
     >   fval,ii,jj,xparam,yparam,hx,hxi,hy,hyi,
     >   fin,inf2,ny)
C
      integer ict(4)                    ! 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 xparam(ivec),yparam(ivec)
                          ! normalized displacements from (i,j) corners
C
      real hx(ivec),hy(ivec)            ! grid spacing, and
      real hxi(ivec),hyi(ivec)          ! inverse grid spacing 1/(x(i+1)-x(i))
                                        ! & 1/(y(j+1)-y(j))
C
      real fin(0:3,inf2,ny)             ! interpolant data (cf "herm2ev")
C
      real fval(ivecd,*)                ! output returned
C
C  for detailed description of fin, ict and fval see subroutine
C  herm2ev 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  Hermite cubic basis functions
C  -->for function value matching
C     a(0)=0 a(1)=1        a'(0)=0 a'(1)=0
C   abar(0)=1 abar(1)=0  abar'(0)=0 abar'(1)=0
C
C   a(x)=-2*x**3 + 3*x**2    = x*x*(-2.0*x+3.0)
C   abar(x)=1-a(x)
C   a'(x)=-abar'(x)          = 6.0*x*(1.0-x)
C
C  -->for derivative matching
C     b(0)=0 b(1)=0          b'(0)=0 b'(1)=1
C   bbar(0)=0 bbar(1)=0  bbar'(0)=1 bbar'(1)=0
C
C     b(x)=x**3-x**2         b'(x)=3*x**2-2*x
C     bbar(x)=x**3-2*x**2+x  bbar'(x)=3*x**2-4*x+1
C
      real sum
      integer v
C
      do v=1,ivec
         i=ii(v)
         j=jj(v)
C
C   ...in x direction
C
         xp=xparam(v)
         xpi=1.0-xp
         xp2=xp*xp
         xpi2=xpi*xpi
         ax=xp2*(3.0-2.0*xp)
         axbar=1.0-ax
         bx=-xp2*xpi
         bxbar=xpi2*xp
C
C   ...in y direction
C
         yp=yparam(v)
         ypi=1.0-yp
         yp2=yp*yp
         ypi2=ypi*ypi
         ay=yp2*(3.0-2.0*yp)
         aybar=1.0-ay
         by=-yp2*ypi
         bybar=ypi2*yp
C
C   ...derivatives...
C
         axp=6.0*xp*xpi
         axbarp=-axp
         bxp=xp*(3.0*xp-2.0)
         bxbarp=xpi*(3.0*xpi-2.0)
C
         ayp=6.0*yp*ypi
         aybarp=-ayp
         byp=yp*(3.0*yp-2.0)
         bybarp=ypi*(3.0*ypi-2.0)
C
         iadr=0
C
C  get desired values:
C
         if(ict(1).eq.1) then
C
C  function value:
C
            iadr=iadr+1
            sum=axbar*(aybar*fin(0,i,j)  +ay*fin(0,i,j+1))+
     >             ax*(aybar*fin(0,i+1,j)+ay*fin(0,i+1,j+1))
C
            sum=sum+hx(v)*(
     >         bxbar*(aybar*fin(1,i,j)  +ay*fin(1,i,j+1))+
     >            bx*(aybar*fin(1,i+1,j)+ay*fin(1,i+1,j+1)))
C
            sum=sum+hy(v)*(
     >         axbar*(bybar*fin(2,i,j)  +by*fin(2,i,j+1))+
     >            ax*(bybar*fin(2,i+1,j)+by*fin(2,i+1,j+1)))
C
            sum=sum+hx(v)*hy(v)*(
     >         bxbar*(bybar*fin(3,i,j)  +by*fin(3,i,j+1))+
     >            bx*(bybar*fin(3,i+1,j)+by*fin(3,i+1,j+1)))
C
            fval(v,iadr)=sum
         endif
C
         if(ict(2).eq.1) then
C
C  df/dx:
C
            iadr=iadr+1
C
            sum=hxi(v)*(
     >         axbarp*(aybar*fin(0,i,j)  +ay*fin(0,i,j+1))+
     >            axp*(aybar*fin(0,i+1,j)+ay*fin(0,i+1,j+1)))
C
            sum=sum+
     >         bxbarp*(aybar*fin(1,i,j)  +ay*fin(1,i,j+1))+
     >            bxp*(aybar*fin(1,i+1,j)+ay*fin(1,i+1,j+1))
C
            sum=sum+hxi(v)*hy(v)*(
     >         axbarp*(bybar*fin(2,i,j)  +by*fin(2,i,j+1))+
     >            axp*(bybar*fin(2,i+1,j)+by*fin(2,i+1,j+1)))
C
            sum=sum+hy(v)*(
     >         bxbarp*(bybar*fin(3,i,j)  +by*fin(3,i,j+1))+
     >            bxp*(bybar*fin(3,i+1,j)+by*fin(3,i+1,j+1)))
C
            fval(v,iadr)=sum
         endif
C
         if(ict(3).eq.1) then
C
C  df/dy:
C
            iadr=iadr+1
C
            sum=hyi(v)*(
     >         axbar*(aybarp*fin(0,i,j)  +ayp*fin(0,i,j+1))+
     >            ax*(aybarp*fin(0,i+1,j)+ayp*fin(0,i+1,j+1)))
C
            sum=sum+hx(v)*hyi(v)*(
     >         bxbar*(aybarp*fin(1,i,j)  +ayp*fin(1,i,j+1))+
     >            bx*(aybarp*fin(1,i+1,j)+ayp*fin(1,i+1,j+1)))
C
            sum=sum+
     >         axbar*(bybarp*fin(2,i,j)  +byp*fin(2,i,j+1))+
     >            ax*(bybarp*fin(2,i+1,j)+byp*fin(2,i+1,j+1))
C
            sum=sum+hx(v)*(
     >         bxbar*(bybarp*fin(3,i,j)  +byp*fin(3,i,j+1))+
     >            bx*(bybarp*fin(3,i+1,j)+byp*fin(3,i+1,j+1)))
C
            fval(v,iadr)=sum
         endif
C
         if(ict(4).eq.1) then
C
C  d2f/dxdy:
C
            iadr=iadr+1
C
            sum=hxi(v)*hyi(v)*(
     >         axbarp*(aybarp*fin(0,i,j)  +ayp*fin(0,i,j+1))+
     >            axp*(aybarp*fin(0,i+1,j)+ayp*fin(0,i+1,j+1)))
C
            sum=sum+hyi(v)*(
     >         bxbarp*(aybarp*fin(1,i,j)  +ayp*fin(1,i,j+1))+
     >            bxp*(aybarp*fin(1,i+1,j)+ayp*fin(1,i+1,j+1)))
C
            sum=sum+hxi(v)*(
     >         axbarp*(bybarp*fin(2,i,j)  +byp*fin(2,i,j+1))+
     >            axp*(bybarp*fin(2,i+1,j)+byp*fin(2,i+1,j+1)))
C
            sum=sum+
     >         bxbarp*(bybarp*fin(3,i,j)  +byp*fin(3,i,j+1))+
     >            bxp*(bybarp*fin(3,i+1,j)+byp*fin(3,i+1,j+1))
C
            fval(v,iadr)=sum
         endif
C
      enddo                             ! vector loop
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 herm2fcnx(ict,ivec,ivecd,
     >   fval,ii,jj,xparam,yparam,hx,hxi,hy,hyi,
     >   fin,inf2,ny)
C
      integer ict(4)                    ! 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 xparam(ivec),yparam
                          ! normalized displacements from (i,j) corners
C
      real hx(ivec),hy                  ! grid spacing, and
      real hxi(ivec),hyi                ! inverse grid spacing 1/(x(i+1)-x(i))
                                        ! & 1/(y(j+1)-y(j))
C
      real fin(0:3,inf2,ny)             ! interpolant data (cf "herm2ev")
C
      real fval(ivecd,*)                ! output returned
C
C  for detailed description of fin, ict and fval see subroutine
C  herm2ev 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  Hermite cubic basis functions
C  -->for function value matching
C     a(0)=0 a(1)=1        a'(0)=0 a'(1)=0
C   abar(0)=1 abar(1)=0  abar'(0)=0 abar'(1)=0
C
C   a(x)=-2*x**3 + 3*x**2    = x*x*(-2.0*x+3.0)
C   abar(x)=1-a(x)
C   a'(x)=-abar'(x)          = 6.0*x*(1.0-x)
C
C  -->for derivative matching
C     b(0)=0 b(1)=0          b'(0)=0 b'(1)=1
C   bbar(0)=0 bbar(1)=0  bbar'(0)=1 bbar'(1)=0
C
C     b(x)=x**3-x**2         b'(x)=3*x**2-2*x
C     bbar(x)=x**3-2*x**2+x  bbar'(x)=3*x**2-4*x+1
C
      real sum
      integer v
C
      j=jj
C
C   ...in y direction
C
      yp=yparam
      ypi=1.0-yp
      yp2=yp*yp
      ypi2=ypi*ypi
      ay=yp2*(3.0-2.0*yp)
      aybar=1.0-ay
      by=-yp2*ypi
      bybar=ypi2*yp
C
C   ...derivatives...
C
      ayp=6.0*yp*ypi
      aybarp=-ayp
      byp=yp*(3.0*yp-2.0)
      bybarp=ypi*(3.0*ypi-2.0)
C
      do v=1,ivec
         i=ii(v)
C
C   ...in x direction
C
         xp=xparam(v)
         xpi=1.0-xp
         xp2=xp*xp
         xpi2=xpi*xpi
         ax=xp2*(3.0-2.0*xp)
         axbar=1.0-ax
         bx=-xp2*xpi
         bxbar=xpi2*xp
C
C   ...derivatives...
C
         axp=6.0*xp*xpi
         axbarp=-axp
         bxp=xp*(3.0*xp-2.0)
         bxbarp=xpi*(3.0*xpi-2.0)
C
         iadr=0
C
C  get desired values:
C
         if(ict(1).eq.1) then
C
C  function value:
C
            iadr=iadr+1
            sum=axbar*(aybar*fin(0,i,j)  +ay*fin(0,i,j+1))+
     >             ax*(aybar*fin(0,i+1,j)+ay*fin(0,i+1,j+1))
C
            sum=sum+hx(v)*(
     >         bxbar*(aybar*fin(1,i,j)  +ay*fin(1,i,j+1))+
     >            bx*(aybar*fin(1,i+1,j)+ay*fin(1,i+1,j+1)))
C
            sum=sum+hy*(
     >         axbar*(bybar*fin(2,i,j)  +by*fin(2,i,j+1))+
     >            ax*(bybar*fin(2,i+1,j)+by*fin(2,i+1,j+1)))
C
            sum=sum+hx(v)*hy*(
     >         bxbar*(bybar*fin(3,i,j)  +by*fin(3,i,j+1))+
     >            bx*(bybar*fin(3,i+1,j)+by*fin(3,i+1,j+1)))
C
            fval(v,iadr)=sum
         endif
C
         if(ict(2).eq.1) then
C
C  df/dx:
C
            iadr=iadr+1
C
            sum=hxi(v)*(
     >         axbarp*(aybar*fin(0,i,j)  +ay*fin(0,i,j+1))+
     >            axp*(aybar*fin(0,i+1,j)+ay*fin(0,i+1,j+1)))
C
            sum=sum+
     >         bxbarp*(aybar*fin(1,i,j)  +ay*fin(1,i,j+1))+
     >            bxp*(aybar*fin(1,i+1,j)+ay*fin(1,i+1,j+1))
C
            sum=sum+hxi(v)*hy*(
     >         axbarp*(bybar*fin(2,i,j)  +by*fin(2,i,j+1))+
     >            axp*(bybar*fin(2,i+1,j)+by*fin(2,i+1,j+1)))
C
            sum=sum+hy*(
     >         bxbarp*(bybar*fin(3,i,j)  +by*fin(3,i,j+1))+
     >            bxp*(bybar*fin(3,i+1,j)+by*fin(3,i+1,j+1)))
C
            fval(v,iadr)=sum
         endif
C
         if(ict(3).eq.1) then
C
C  df/dy:
C
            iadr=iadr+1
C
            sum=hyi*(
     >         axbar*(aybarp*fin(0,i,j)  +ayp*fin(0,i,j+1))+
     >            ax*(aybarp*fin(0,i+1,j)+ayp*fin(0,i+1,j+1)))
C
            sum=sum+hx(v)*hyi*(
     >         bxbar*(aybarp*fin(1,i,j)  +ayp*fin(1,i,j+1))+
     >            bx*(aybarp*fin(1,i+1,j)+ayp*fin(1,i+1,j+1)))
C
            sum=sum+
     >         axbar*(bybarp*fin(2,i,j)  +byp*fin(2,i,j+1))+
     >            ax*(bybarp*fin(2,i+1,j)+byp*fin(2,i+1,j+1))
C
            sum=sum+hx(v)*(
     >         bxbar*(bybarp*fin(3,i,j)  +byp*fin(3,i,j+1))+
     >            bx*(bybarp*fin(3,i+1,j)+byp*fin(3,i+1,j+1)))
C
            fval(v,iadr)=sum
         endif
C
         if(ict(4).eq.1) then
C
C  d2f/dxdy:
C
            iadr=iadr+1
C
            sum=hxi(v)*hyi*(
     >         axbarp*(aybarp*fin(0,i,j)  +ayp*fin(0,i,j+1))+
     >            axp*(aybarp*fin(0,i+1,j)+ayp*fin(0,i+1,j+1)))
C
            sum=sum+hyi*(
     >         bxbarp*(aybarp*fin(1,i,j)  +ayp*fin(1,i,j+1))+
     >            bxp*(aybarp*fin(1,i+1,j)+ayp*fin(1,i+1,j+1)))
C
            sum=sum+hxi(v)*(
     >         axbarp*(bybarp*fin(2,i,j)  +byp*fin(2,i,j+1))+
     >            axp*(bybarp*fin(2,i+1,j)+byp*fin(2,i+1,j+1)))
C
            sum=sum+
     >         bxbarp*(bybarp*fin(3,i,j)  +byp*fin(3,i,j+1))+
     >            bxp*(bybarp*fin(3,i+1,j)+byp*fin(3,i+1,j+1))
C
            fval(v,iadr)=sum
         endif
C
      enddo                             ! vector loop
C
      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C   Copyright (C) 1995-2004, Scientific Computing Division,
C   University Corporation for Atmospheric Research
C   Licensed under the GNU General Public License (GPL)
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id: mrfti1.f,v 1.2 2006-11-21 01:10:18 haley Exp $
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE DMRFTI1(N,WA,FAC)
      DOUBLE PRECISION FI
      DOUBLE PRECISION WA(N),FAC(15)
      INTEGER NTRYH(4)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION TPI,ARGH,ARGLD,ARG
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/
C
      NL = N
      NF = 0
      J = 0
  101 J = J + 1
      IF (J-4) 102,102,103
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRY + 2
  104 NQ = NL/NTRY
      NR = NL - NTRY*NQ
      IF (NR) 101,105,101
  105 NF = NF + 1
      FAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY.NE.2) GO TO 107
      IF (NF.EQ.1) GO TO 107
      DO 106 I = 2,NF
          IB = NF - I + 2
          FAC(IB+2) = FAC(IB+1)
  106 CONTINUE
      FAC(3) = 2
  107 IF (NL.NE.1) GO TO 104
      FAC(1) = N
      FAC(2) = NF
C*PT*WARNING* Constant already double-precision
C*PT*WARNING* Constant already double-precision
      TPI = 8.D0*DATAN(1.D0)
      ARGH = TPI/DBLE(N)
      IS = 0
      NFM1 = NF - 1
      L1 = 1
      IF (NFM1.EQ.0) RETURN
      DO 110 K1 = 1,NFM1
          IP = FAC(K1+2)
          LD = 0
          L2 = L1*IP
          IDO = N/L2
          IPM = IP - 1
          DO 109 J = 1,IPM
              LD = LD + L1
              I = IS
              ARGLD = DBLE(LD)*ARGH
              FI = 0.D0
              DO 108 II = 3,IDO,2
                  I = I + 2
                  FI = FI + 1.D0
                  ARG = FI*ARGLD
                  WA(I-1) = DCOS(ARG)
                  WA(I) = DSIN(ARG)
  108         CONTINUE
              IS = IS + IDO
  109     CONTINUE
          L1 = L2
  110 CONTINUE
      RETURN
      END


      SUBROUTINE MA02ES( UPLO, N, A, LDA )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To store by skew-symmetry the upper or lower triangle of a
C     skew-symmetric matrix, given the other triangle. The diagonal
C     entries are set to zero.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1
C             Specifies which part of the matrix is given as follows:
C             = 'U':  Upper triangular part;
C             = 'L':  Lower triangular part.
C             For all other values, the array A is not referenced.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N upper triangular part
C             (if UPLO = 'U'), or lower triangular part (if UPLO = 'L'),
C             of this array must contain the corresponding upper or
C             lower triangle of the skew-symmetric matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the skew-symmetric matrix A with all elements stored.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Sep. 2012.
C
C     REVISIONS
C
C     -
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDA, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*)
C     .. Local Scalars ..
      INTEGER            J
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C
C     .. Executable Statements ..
C
C     For efficiency reasons, the parameters are not checked for errors.
C
      IF( LSAME( UPLO, 'L' ) ) THEN
C
C        Construct the upper triangle of A.
C
         DO 20 I = 1, N
            A(I,I) = ZERO
            DO 10 J = 2, N
               A(I,J) = -A(J,I)
   10       CONTINUE
   20    CONTINUE
C
      ELSE IF( LSAME( UPLO, 'U' ) ) THEN
C
C        Construct the lower triangle of A.
C
         DO 40 I = 1, N
            A(I,I) = ZERO
            DO 30 J = 2, N
               A(J,I) = -A(I,J)
   30       CONTINUE
   40    CONTINUE
C
      END IF
      RETURN
C *** Last line of MA02ES ***
      END