      DOUBLE PRECISION FUNCTION FFWID3PI(QQ,S1,S3)
      IMPLICIT NONE
      DOUBLE PRECISION                   QQ,S1,S3
C **************************************************************
C     Input:  QQ S1 S3   ! mpi-pi-pi+**2   mpi-pi+**2  mpi-pi-**2
C     Calls: functions FORM1, FORM2, FORM4
C     Uses constants: tau mass, pi mass, normalization constant.
C     Load: Initialized tauola library,
C     Output:  d\Gamma(tau --> 3pi nu)/(dQQ dS1 dS3)
C     Remark: If QQ S1 S3 are outside of the phase space
C             function FFWID3PI returns zero.
C **************************************************************
      COMPLEX F1,F2,F4, FORM1,FORM2, FORM4
      DOUBLE PRECISION V11,V12,V22,GGF2,VUD2,ABS1,QQMIN,
     &                 QQMAX,S3MAX,S3MIN,S1MIN,S1MAX
      REAL XQQ,XS1,XS3, XS2,RQQ
      COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
      REAL*4            GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
      COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
      DOUBLE PRECISION  XLAM,X,Y,Z
      DOUBLE PRECISION  XAMPI2
      DOUBLE PRECISION  GETFPIRPT
      REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
      DOUBLE PRECISION        PI
      DATA                    PI /3.141592653589793238462643D0/
      INTEGER  IMODE,IDUM,IFRCHL
      REAL RRQ,RCHLWIDA1PI

      XLAM(X,Y,Z)= sqrt(abs((x-y-z)**2 - 4.*y*z))

      ABS1 = 1.d-5

      GGF2 = GFERMI**2
      VUD2 = CCABIB**2

C     TO CHANGE THE VARIABLES TO SINGLE PRECISION
C     INPUT FOR FORM1,FORM2,FORM4 IS SINGLE PRECISION

      XQQ = QQ
      XS1 = S1
      XS2 = QQ -S1-S3 + 3.*AMPI**2
      XS3 = S3
      XAMPI2 = AMPI**2
C     Limits for PHASE SPACE
C     Limits for QQ
      QQMIN = 9.D0*AMPI**2
      QQMAX  = (AMTAU-AMNUTA)**2

C     Limits for S1
      S1MAX=(DSQRT(QQ) - AMPI)**2 -ABS1
      S1MIN=4.D0*AMPI**2 +ABS1

C    LIMIT FOR XS3
      S3MAX = (QQ - AMPI**2)**2 -
     &    ( XLAM(QQ,S1,XAMPI2)
     &         - XLAM(S1,XAMPI2,XAMPI2) )**2
      S3MIN = (QQ - AMPI**2)**2 -
     &    (XLAM(QQ,S1,XAMPI2)
     &          + XLAM(S1,XAMPI2,XAMPI2) )**2

      S3MAX = S3MAX/4./S1
      S3MIN = S3MIN/4./S1

C     Check on PHASE SPACE
C
      IF((XS2.LE.0.) .OR.(S3MAX.LE.S3MIN)
     &   .OR.(XS1.LE.S1MIN).OR.(XS1.GE.S1MAX)
     &   .OR.(XS3.LE.S3MIN).OR.(XS3.GE.S3MAX)
     &   .OR.(QQ.LE.QQMIN).OR.(QQ.GE.QQMAX)
     &    )  THEN
        FFWID3PI = 0.D0
        RETURN
      ENDIF

C
      V11 = -XS1+4.D0*AMPI**2 -(XS2-XS3)**2/(4.D0*XQQ)
      V22 = -XS2+4.D0*AMPI**2 - (XS3-XS1)**2/(4.D0*XQQ)
      V12 = 0.5D0*(XS3-XS1-XS2+4.D0*AMPI**2)-0.25D0*(XS3-XS2)*(XS3-XS1)/XQQ

      F1 = FORM1(0,XQQ,XS1,XS2)
      F2 = FORM2(0,XQQ,XS2,XS1)
      F4 = FORM4(0,XQQ,XS2,XS1,XS3)

C formula 3.46 of [3]
      FFWID3PI = ABS(F1*CONJG(F1))*V11+ABS(F2*CONJG(F2))*V22+
     $       2.D0*REAL(F1*CONJG(F2))*V12

      CALL IFGFACT(2,IMODE,IDUM)
      CALL INIRChLget(IFRCHL)
      IF (IMODE.EQ.0) THEN
C      VERSION A: The 3 pion contribution to the a1 width
C      factor of a1 phase space and zeroing a1 propagator etc.is
C      done in RCHLWIDA1PI
       RQQ=QQ
       IF (IFRCHL.EQ.1) THEN
C       CASE OF RCHL
        FFWID3PI   = RCHLWIDA1PI(RQQ,FFWID3PI)
       ELSE
C       NOT READY YET
        WRITE(*,*) 'FFWID3PI is not ready for non rchl currents'
        STOP
       ENDIF
C      to get the total a1 width the contribution from (KKPI)- and K-K0pi0
C      channels have to be added
      ELSE
C      VERSION B: calculation of 3 pion spectra in tau to 3pi nu channel.

C      factor for phase space of tau to XQQ nu decay and contribution from F4
C      (formula 3.21 of [3])

      FFWID3PI = (- FFWID3PI/3.D0*(1.D0+2.D0*XQQ/(AMTAU**2))+
     $       XQQ*ABS(F4*CONJG(F4)))*(AMTAU**2/XQQ-1.D0)**2

C Flux factor and normalization const.
        FFWID3PI =
     &       GGF2*VUD2/(128.D0*(2.D0*PI)**5*AMTAU)/2.d0
     &            *FFWID3PI
       IF (IFRCHL.EQ.1) THEN
C       CASE OF RCHL
C RChL normalization constant
        FFWID3PI =FFWID3PI/GETFPIRPT(1)**2
       ELSE
C       NOT READY YET
        WRITE(*,*) 'FFWID3PI is not ready for non rchl currents'
        STOP
       ENDIF

      ENDIF

      RETURN
      END

      REAL FUNCTION RCHLWIDA1PI(RQQ,FFWID3PI)
C The 3 pion contribution to the a1 width
C (in [3] simple pretabulation is used through formula 3.48)
C for calculation of g(QQ) of 3.45 3.46 of [3] in RChL style
C a1 propagator has to be taken with the zero width.

      IMPLICIT NONE
      COMPLEX FA1RCHL
      REAL RQQ
      DOUBLE PRECISION FFWID3PI
      COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
      REAL*4            GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
      COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
      DOUBLE PRECISION  XLAM,X,Y,Z
      DOUBLE PRECISION  XAMPI2
      DOUBLE PRECISION  GETFPIRPT
      REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST

      COMMON/RCHT_3PI/        FPI_RPT,FV_RPT,GV_RPT,FA_RPT,BETA_RHO,FK_RPT
     &                       ,FV1_RPT,GV1_RPT
      DOUBLE PRECISION        FPI_RPT,FV_RPT,GV_RPT,FA_RPT,BETA_RHO,FK_RPT
     &                       ,FV1_RPT,GV1_RPT
      DOUBLE PRECISION        PI
      DATA                    PI /3.141592653589793238462643D0/

C     AMA1 should be replaced by variable from the rchl namespace.
      RCHLWIDA1PI=- 1.0/REAL(FA1RCHL(RQQ)*CONJG(FA1RCHL(RQQ)))/RQQ**2
     $            /(96.D0*8.D0*PI**3*AMA1)/(FA_RPT**2*FPI_RPT**2)
     $            *FFWID3PI/2.d0
      END

      DOUBLE PRECISION FUNCTION  GETFPIRPT(I)
      IMPLICIT NONE
      COMMON/RCHT_3PI/        FPI_RPT,FV_RPT,GV_RPT,FA_RPT,BETA_RHO,FK_RPT
     &                       ,FV1_RPT,GV1_RPT
      DOUBLE PRECISION        FPI_RPT,FV_RPT,GV_RPT,FA_RPT,BETA_RHO,FK_RPT
     &                       ,FV1_RPT,GV1_RPT
      INTEGER I
      GETFPIRPT=FPI_RPT
      END


c  tpspline -- dmc 20 Jan 1999
c
c  set up coefficients for bicubic spline with following BC's:
c  * 1st dimension:  3rd divided difference
c  * derivatives periodic in second coordinate
c  * derivatives periodic in third coordinate
c
c  for more control over boundary conditions, use tpspline or tcspline.
c
c  for evaluation of interpolant, see tcspeval.for
c
      subroutine tpspline(x,inx,th,inth,ph,inph,fspl,inf4,inf5,
     >                    wk,nwk,ilinx,ilinth,ilinph,ier)
c
      implicit NONE
      integer inx,inth,inph,inf4,inf5,nwk
      real x(inx),th(inth),ph(inph)
      real fspl(4,4,4,inf4,inf5,inph),wk(nwk)
      integer ilinx,ilinth,ilinph,ier
c
c  input:
c    x(1...inx) -- abscissae, first dimension of data
c   th(1...inth) -- abscissae, second (periodic) dimension of data
c   ph(1...inph) -- abscissae, third (periodic) dimension of data
c   fspl(1,1,1,1..inx,1..inth,1..inph) -- function values
c   inf4 -- fspl dimensioning, inf4.ge.inx required.
c   inf5 -- fspl dimensioning, inf5.ge.inth required.
c
c  output:
c   fspl(*,*,*,1..inx,1..inth,1..inph) -- bicubic spline coeffs (4x4)
c   ...fspl(1,1,1,*,*,*) is not replaced.
c
c   ilinx -- =1 on output if x(inx) pts are nearly evenly spaced (tol=1e-3)
c   ilinth-- =1 on output if th(inth) evenly spaced (tol=1e-3)
c   ilinph-- =1 on output if ph(inph) evenly spaced (tol=1e-3)
c
c   ier -- completion code, 0 for normal
c
c  workspace:
c   wk -- must be at least 5*max(inx,inth,inph) large
c  nwk -- size of workspace
c
c---------------------------------
c  compute tricubic spline of 3d function, given values at the
c  grid crossing points, f(1,1,1,i,j,k)=f(x(i),th(j),ph(k)).
c
c  on evaluation:  for point x btw x(i) and x(i+1), dx=x-x(i)
c                       and th btw th(j) and th(j+1), dt=th-th(j),
c                       and ph btw ph(k) and ph(k+1), dp=ph-ph(k),
c
c   spline =
c       f(1,1,1,i,j,k)+dx*f(2,1,1,i,j,k)+dx2*f(3,1,1,i,j,k)+dx3*f(4,1,1,i,j,k)
c  +dt*(f(1,2,1,i,j,k)+dx*f(2,2,1,i,j,k)+dx2*f(3,2,1,i,j,k)+dx3*f(4,2,1,i,j,k))
c +dt2*(f(1,3,1,i,j,k)+dx*f(2,3,1,i,j,k)+dx2*f(3,3,1,i,j,k)+dx3*f(4,3,1,i,j,k))
c +dt3*(f(1,4,1,i,j,k)+dx*f(2,4,1,i,j,k)+dx2*f(3,4,1,i,j,k)+dx3*f(4,4,1,i,j,k))
c        +dp*(
c       f(1,1,2,i,j,k)+dx*f(2,1,2,i,j,k)+dx2*f(3,1,2,i,j,k)+dx3*f(4,1,2,i,j,k)
c  +dt*(f(1,2,2,i,j,k)+dx*f(2,2,2,i,j,k)+dx2*f(3,2,2,i,j,k)+dx3*f(4,2,2,i,j,k))
c +dt2*(f(1,3,2,i,j,k)+dx*f(2,3,2,i,j,k)+dx2*f(3,3,2,i,j,k)+dx3*f(4,3,2,i,j,k))
c +dt3*(f(1,4,2,i,j,k)+dx*f(2,4,2,i,j,k)+dx2*f(3,4,2,i,j,k)+dx3*f(4,4,2,i,j,k)))
c        +dp2*(
c       f(1,1,3,i,j,k)+dx*f(2,1,3,i,j,k)+dx2*f(3,1,3,i,j,k)+dx3*f(4,1,3,i,j,k)
c  +dt*(f(1,2,3,i,j,k)+dx*f(2,2,3,i,j,k)+dx2*f(3,2,3,i,j,k)+dx3*f(4,2,3,i,j,k))
c +dt2*(f(1,3,3,i,j,k)+dx*f(2,3,3,i,j,k)+dx2*f(3,3,3,i,j,k)+dx3*f(4,3,3,i,j,k))
c +dt3*(f(1,4,3,i,j,k)+dx*f(2,4,3,i,j,k)+dx2*f(3,4,3,i,j,k)+dx3*f(4,4,3,i,j,k)))
c        +dp3*(
c       f(1,1,4,i,j,k)+dx*f(2,1,4,i,j,k)+dx2*f(3,1,4,i,j,k)+dx3*f(4,1,4,i,j,k)
c  +dt*(f(1,2,4,i,j,k)+dx*f(2,2,4,i,j,k)+dx2*f(3,2,4,i,j,k)+dx3*f(4,2,4,i,j,k))
c +dt2*(f(1,3,4,i,j,k)+dx*f(2,3,4,i,j,k)+dx2*f(3,3,4,i,j,k)+dx3*f(4,3,4,i,j,k))
c +dt3*(f(1,4,4,i,j,k)+dx*f(2,4,4,i,j,k)+dx2*f(3,4,4,i,j,k)+dx3*f(4,4,4,i,j,k)))
c
c      where dx2=dx**2 and dx3=dx**3.
c      where dt2=dt**2 and dt3=dt**3.
c      where dp2=dp**2 and dp3=dp**3.
c
c---------------------------------
      integer ierx,ierth,ierph
      real zdumth(inth),zdumx(inx)
c---------------------------------
c
      ier=0
      if(nwk.lt.5*max(inx,inth,inph)) then
         write(6,'('' ?tpspline:  workspace too small.'')')
         ier=1
      endif
      if(inx.lt.2) then
         write(6,'('' ?tpspline:  at least 2 x points required.'')')
         ier=1
      endif
      if(inth.lt.2) then
         write(6,'('' ?tpspline:  need at least 2 theta points.'')')
         ier=1
      endif
      if(inph.lt.2) then
         write(6,'('' ?tpspline:  need at least 2 phi points.'')')
         ier=1
      endif
c
c  check ilinx & x vector
c
      call splinck(x,inx,ilinx,1.0e-3,ierx)
      if(ierx.ne.0) ier=2
c
      if(ier.eq.2) then
         write(6,'('' ?tpspline:  x axis not strict ascending'')')
      endif
c
c  check ilinth & th vector
c
      call splinck(th,inth,ilinth,1.0e-3,ierth)
      if(ierth.ne.0) ier=3
c
      if(ier.eq.3) then
         write(6,'('' ?tpspline:  theta axis not strict ascending'')')
      endif
c
c  check ilinth & th vector
c
      call splinck(ph,inph,ilinph,1.0e-3,ierph)
      if(ierph.ne.0) ier=4
c
      if(ier.eq.4) then
         write(6,'('' ?tpspline:  phi axis not strict ascending'')')
      endif
c
      if(ier.ne.0) return
c
c------------------------------------
c
      call tcspline(x,inx,th,inth,ph,inph,fspl,inf4,inf5,
     >   7,zdumth,7,zdumth,inth,
     >   -1,zdumx,-1,zdumx,inx,
     >   -1,zdumx,-1,zdumx,inx,
     >   wk,nwk,ilinx,ilinth,ilinph,ier)
c
      return
      end


      subroutine run_iii(j,i1,i2,i3,DetGr,Xtwiddle0,Gtwiddle,
     . Shat4,N0)
      implicit none
C---  Fixes Diii using 5.48
c---  knowing D00ii with a correction of order Delta*Diiii

      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,j,i1,i2,i3,n
      double precision DetGr,Xtwiddle0(3),Gtwiddle(3,3)
      double complex Shat4(3,z3max,-2:0),Shat4s(3,z3max,-2:0)

      do ep=-2,0
      do n=1,3
      Shat4s(n,z3(i1,i2,i3),ep)=Shat4(n,z3(i1,i2,i3),ep)
     .   -2d0*(delta(n,i1)*Dv(N0+dzzii(z2(i2,i3)),ep)
     .        +delta(n,i2)*Dv(N0+dzzii(z2(i1,i3)),ep)
     .        +delta(n,i3)*Dv(N0+dzzii(z2(i1,i2)),ep))
      enddo

      Dv(diii(z3(i1,i2,i3))+N0,ep)=-(
     . +Gtwiddle(j,1)*Shat4s(1,z3(i1,i2,i3),ep)
     . +Gtwiddle(j,2)*Shat4s(2,z3(i1,i2,i3),ep)
     . +Gtwiddle(j,3)*Shat4s(3,z3(i1,i2,i3),ep)
     . -DetGr*Dv(diiii(z4(j,i1,i2,i3))+N0,ep))
     . /Xtwiddle0(j)
      enddo

      return
      end


C
C**************************  FXVMC *************************************
C
C  calculate moisture content using extended van Genuchten
C  characteristic equation
C
C***********************************************************************
C
      DOUBLE PRECISION FUNCTION FXVMC(PSI,SS,POR,INOD)
C
      IMPLICIT NONE
      INCLUDE 'CATHY.H'
      INTEGER  INOD
      REAL*8   PNOT,TSR,BETA,B01
      REAL*8   PSI,SS,POR
      INCLUDE 'SOILCHAR.H'
C
      PNOT=VGPNOT(INOD)
      TSR=POR-VGRMC(INOD)
      IF (PSI .LT. PNOT) THEN
         BETA=(PSI/VGPSAT(INOD))**VGN(INOD)
         FXVMC=VGRMC(INOD) + (TSR/((BETA+1.0D0)**VGM(INOD)))
      ELSE
         B01=((PNOT/VGPSAT(INOD))**VGN(INOD)) + 1.0D0
         FXVMC=VGRMC(INOD) + TSR*(B01**(-VGM(INOD))) + SS*(PSI-PNOT)
      END IF
C
      RETURN
      END


!-----------------------------------------------------------------------------
!> This module contains generic methods for minimizing systems of non-linear equations.
!>
!> \todo Add special treatment for n=2 systems. Analytical modification of eigenvalues.
!>
!> \author MHA, February 2012
!-----------------------------------------------------------------------------
module optimizers
  !
  !
  !
  use numconstants, only: machine_prec
  use thermopack_constants, only: verbose
  implicit none
  private

  !> Optimizer aliases
  integer, parameter :: NO_MOD_NEWTON = 1 !< Modefied newton optimizer

  !> A type that contains solver information
  type :: optim_param
    !> Optimizer choice
    integer :: ioptim = NO_MOD_NEWTON
    !> Maximum number of iterations, if applicable
    integer :: max_iter = 1000
    !> Relative tolerance
    real :: rel_tol = 1.0e5*machine_prec
    !> Line search parameter
    real :: wolfe = 1.0e-3
    !> Number of line search trials
    integer :: max_line_search_iter = 10
    !> Terminate besed on gradient infinity norm
    logical :: gradient_termination = .false.
    !> Turn off/on line search control (line search controlled by last param element)
    logical :: line_search_control = .false.
    !
    ! Output:
    !
    !> Number of iterations to solution
    integer :: iter = 0
    !> Objective function value at return
    real :: of = 0.0
    !> Error at return
    real :: error = 0.0
    !> Status flag.
    !> 0 - Solver converged
    !> 1 - No solution found after max_it iterations
    !>-1 - Premature return
    integer :: exitflag = 0
    !> Test eigenvalues of the Jacobean
    logical :: testEigenvalues = .false.
  end type optim_param

  abstract interface
    function error_function(n,X,nparam,param,of,dofdX,of_old) result(error)
      implicit none
      integer, intent(in)                 :: n !< Dimension of X
      real, dimension(n), intent(in)      :: X !< Variables
      integer, intent(in)                 :: nparam !< Dimension of param
      real, dimension(nparam), intent(in) :: param !< Parameter vector
      real, intent(in)                    :: of !< Objective function value
      real, dimension(n), intent(in)      :: dofdX !< Differential of objective function
      real, intent(in)                    :: of_old !< Old objective function value
      real                                :: error !< Calculated error
    end function error_function
  end interface

  public :: NO_MOD_NEWTON
  public :: optim_param
  public :: optimize, setX, prematureReturn
  public :: nelmin
  public :: error_function

contains

  !-----------------------------------------------------------------------------
  !> Interface for optimizer
  !>
  !> \author MHA, February 2012
  !-----------------------------------------------------------------------------
  subroutine optimize(optim,objective,diff,x,param,limit,premterm,getSize,setXvar,&
       error_fun)
    implicit none
    !> Solver information
    type(optim_param), intent(inout)   :: optim
    !> The non-linear function F(x)
    real, external                     :: objective
    !> Function to evaluate the differentials.
    external                           :: diff
    !> Function to limit search
    external                           :: limit
    !> Test for premature termination
    logical, external                  :: premterm
    !> On entry, initial condition. On exit, solution
    real, dimension(:), intent(inout)  :: x
    !> Paramaters used by objective, diff, limit and premterm
    real, dimension(:), intent(inout)  :: param
    !> Get size of problem (Usually size(x))
    integer, external                  :: getSize
    !> Function to update variables
    external                           :: setXvar
    !< Function to calculate error
    procedure(error_function), optional:: error_fun
    !
    select case(optim%ioptim)
    case(NO_MOD_NEWTON)
      call mod_newton(optim,objective,diff,x,param,limit,premterm,getSize,&
           setXvar,error_fun)
    case default
      stop "optimizers::optimize: No such optimizer!"
    end select

  end subroutine optimize

  !-----------------------------------------------------------------------------
  !> Solve min F(x) using modefied Newton method,
  !!
  !!  \f$ x^{n+1} = x^n - H(x^n)^{-1} dF(x^n) \f$.
  !!
  !! where H is the Hessian of F, and dF is the derivative of F.
  !!
  !! \author MHA, February 2012
  !-----------------------------------------------------------------------------
  subroutine mod_newton(optim,objective,diff,x,param,limit,premterm,getSize,setXvar,error_fun)
    implicit none
    type(optim_param), intent(inout)      :: optim     !< Solver information
    real, dimension(:),     intent(inout) :: x         !< Variables
    real, dimension(:),     intent(inout) :: param     !< Paramaters used by objective, diff, limit and premterm
    real, external                        :: objective !< The non-linear function F(x)
    external                              :: diff      !< Function to evaluate the differentials.
    external                              :: limit     !< Function to limit search
    logical, external                     :: premterm  !< Test for premature termination
    integer, external                     :: getSize   !< Get size of problem (size(x)?)
    external                              :: setXvar   !< Function to update variables
    procedure(error_function), optional   :: error_fun !< Function to calculate error
    !
    ! Locals
    real, dimension(size(param)) :: param_old !< Copy of param
    real, dimension(size(x),size(x)) :: H, Hcpy
    real, dimension(size(x))         :: dOFdX,dX,X_old
    real, dimension(3*size(x))         :: work
    integer, dimension(size(x)) :: ipiv
    integer :: iter,i,info,n,ii,nparam
    integer, dimension(1) :: imax
    real :: of, of_old, error, dum
    real :: alpha, wolfe
    real, dimension(size(x),size(x)) :: VL, VR
    real, dimension(size(x)) :: WI, WR
    real, dimension(size(x),size(x)) :: L !Lower triangular matrix
    real, dimension(size(x)) :: D !Diagonal matrix
    real, dimension(size(x)) :: E !Diagonal of mofification matrix
    logical :: call_error_fun
    if (present(error_fun)) then
      call_error_fun = .true.
    else
      call_error_fun = .false.
    endif
    n=size(x)
    nparam=size(param)
    optim%exitflag = 0
    error = -1.0
    do iter=1,optim%max_iter
      call diff(x,param,of,dOFdX,H)
      n = getSize(param)
      if (premterm(x,param,of,dOFdX)) then
        if (verbose) then
          print *,'optimizers::mod_newton: Premature return'
        endif
        optim%iter = iter
        optim%of = of
        optim%error = error
        optim%exitflag = -1
        return
      endif
      Hcpy(1:n,1:n) = H(1:n,1:n)

      if (optim%testEigenvalues) then
        call DGEEV('N', 'N', n, Hcpy, n, WR, WI, VL, n, VR, n, WORK, 3*N, INFO )
        print *,'Eigenvalues, real part: ',wr
        print *,'Eigenvalues, imaginary part: ',wi
        Hcpy(1:n,1:n) = H(1:n,1:n)
      end if
      ! Solve equation system
      dX(1:n) = -dOFdX(1:n)
      if (n > 1) then
        call dsysv('u', n, 1, H(1:n,1:n), n, ipiv, DX, n, work, 3*n, info)
        if (info.ne.0 .OR. sum(DX(1:n)*dOFdX(1:n)) >= 0.0) then
          if (verbose) then
            print *,'mod_newton: Need to do modefied Cholesky'
          endif
          ! Need to ensure a decent direction
          DX(1:n) = -dOFdX(1:n)
          H(1:n,1:n) = Hcpy(1:n,1:n)
          call solveModefiedCholesky(n,H(1:n,1:n),DX)
          if (optim%testEigenvalues) then
            call modefiedCholeskyDecompNoPerm(Hcpy,n,L,D,E)
            do ii = 1, n
              Hcpy(ii,ii) =  Hcpy(ii,ii) + E(ii)
            enddo
            call DGEEV('N', 'N', n, Hcpy, n, WR, WI, VL, n, VR, n, WORK, 3*N, INFO )
            print *,'Eigenvalues modified'
            print *,'Eigenvalues, real part: ',wr
            print *,'Eigenvalues, imaginary part: ',wi
          end if
        endif
      else
        ! Single variable
        if (H(1,1) <= 0.0) then
          ! Need positive definite matrix
          H(1,1) = machine_prec*1000.0
        endif
        DX = -dOFdX/H(1,1)
      endif
      !
      ! Limit search
      call limit(X,param,dX)
      !
      X_old(1:n) = X(1:n)
      param_old(1:nparam) = param(1:nparam)
      alpha = 1.0
      call setXvar(n,nparam,X(1:n),dX(1:n),param,alpha)
      of_old = of
      of = objective(x,param)
      ! Do simple line search to "ensure" reduction in objective function
      wolfe = optim%wolfe*sum(DX(1:n)*dOFdX(1:n))
      do i=1,optim%max_line_search_iter
        if (optim%line_search_control) then
          if (int(param(nparam)) .eq. 0) then
            exit ! Exit from do loop. Line search skipped.
          endif
        endif
        if (of >= of_old + alpha*wolfe) then
          alpha = alpha*0.5**i
          X(1:n) = X_old(1:n)
          param(1:nparam) = param_old(1:nparam)
          call setXvar(n,nparam,X(1:n),dX(1:n),param,alpha)
          of = objective(X,param)
        else
          exit ! Exit from do loop
        endif
      enddo

      ! Calculate error
      if (call_error_fun) then
        error = error_fun(n,X(1:n),nparam,param,of,dofdX(1:n),of_old)
      else
        if (optim%gradient_termination) then
          dOFdX(1:n) = abs(dOFdX(1:n))
          imax = maxloc(dOFdX(1:n))
          error = dOFdX(imax(1))
        else
          if (abs(of_old) < 0.99*optim%rel_tol) then
            dum = 1.0
          else
            dum = 0.0
          endif
          error = abs((of - of_old + dum)/(of_old + dum) - dum)
        endif
      endif

      ! Test for convergence
      if (error < optim%rel_tol) then
        if (verbose) then
          print *,'optimizers::mod_newton: Converged. Number of iterations: ', iter
        endif
        optim%iter = iter
        optim%of = of
        optim%error = error
        return
      endif
    enddo

    if (verbose) then
      print *,'optimizers::mod_newton:  The modified Newton minimizer did not converge.'
      print *,'Differential ',dOFdX
      !call exit(1)
    endif
    optim%exitflag = 1
    optim%of = of
    optim%error = error
    optim%iter = optim%max_iter
  end subroutine mod_newton

  !-----------------------------------------------------------------------------
  !> Set variables
  !>
  !> \author MH, 2013-02-27
  !-----------------------------------------------------------------------------
  subroutine setX(n,nparam,X,dX,param,alpha)
    implicit none
    integer, intent(in) :: n, nparam !< Problem dimension
    real, dimension(n), intent(inout) :: X !< Variables
    real, dimension(n), intent(in)    :: dX !< Change in variables
    real, dimension(nparam), intent(inout) :: param !< Parameter vector
    real, intent(in) :: alpha !< dX scaling
    !
    X(1:n) = X(1:n) + alpha*dX(1:n)
    !
  end subroutine setX

  !-----------------------------------------------------------------------------
  !> No premature return.
  !>
  !> \author MH, 2013-02-27
  !-----------------------------------------------------------------------------
  function prematureReturn(X,param,of,dofdX) result(doReturn)
    implicit none
    real, dimension(:), intent(in)    :: X !< Vapour mole numbers [mole]
    real, dimension(:), intent(in)    :: param !< Parameter vector
    real, intent(in)                  :: of !< Objective function value
    real, dimension(:), intent(in)    :: dofdX !< Differential of objective function
    logical                           :: doReturn !< Terminate minimization?
    !
    doReturn = .false.
  end function prematureReturn

  !-----------------------------------------------------------------------------
  !> Solve \f$ A X = B \f$ using Gill-Murray modified Cholesky factorization of A
  !>
  !> \author MHA, January 2012
  !-----------------------------------------------------------------------------
  subroutine solveModefiedCholesky(n,A,B)
    implicit none
    integer, intent(in) :: n ! Matrix dimension
    real, dimension(n,n), intent(inout) :: A ! Symmetric matrix to be factorized
    real, dimension(n), intent(inout) :: B ! Right hand side
    ! Locals
    real, dimension(n,n) :: L ! Lower triangular matrix
    real, dimension(n) :: D ! Diagonal matrix
    real, dimension(n) :: E ! Diagonal of mofification matrix
    real, parameter :: one = 1.0E+0
    integer :: i

    call modefiedCholeskyDecompNoPerm(A,n,L,D,E)
    ! Solve: L*D*L**T*X = B
    ! Solve L*X = B, overwriting B with X.
    call dtrsm( 'Left', 'Lower', 'No transpose', 'Non-unit', n, &
         1, one, L, n, B, n )
    ! Solve D*X = B, overwriting B with X.
    do i=1,n
      B(i) = B(i)/D(i)
    enddo
    ! Solve L**T*X = B, overwriting B with X.
    call dtrsm( 'Left', 'Lower', 'Transpose', 'Non-unit', n, 1, &
         one, L, n, B, n )

  end subroutine solveModefiedCholesky

  !-----------------------------------------------------------------------------
  !> Method for testing Gill-Murray modified Cholesky (LDL) factorization of A
  !>
  !> \author MHA, January 2012
  !-----------------------------------------------------------------------------
  subroutine testModefiedCholeskyDecomp()
    implicit none
    integer, parameter :: n = 5 ! Matrix dimension
    real, dimension(n,n) :: L, LT ! Lower triangular matrix
    real, dimension(n) :: D ! Diagonal matrix
    real, dimension(n) :: E ! Diagonal of mofification matrix
    real, dimension(n,n) :: DD ! Diagonal matrix
    real, dimension(n,n) :: EE ! Mofification matrix
    real, dimension(n) :: EIG ! Eigenvalues
    real, dimension(n) :: B1=(/1.0, 2.0, 3.0, 4.0, 5.0/) ! RHS1
    real, dimension(n) :: B2=(/1.0, 2.0, 3.0, 4.0, 5.0/) ! RHS2
    real, dimension(3*n) :: work ! Work array
    real, dimension(n,n) :: Acpy ! Copy of A
    integer, dimension(n) :: ipiv
    real :: temp
    integer :: i,j, LWORK, INFO
    ! Symmetric matrix to be factorized
    real, dimension(n,n) :: A
    A(1,:) =  (/36.0, 12.0, 30.0, 6.0, 18.0/)
    A(2,:) = (/12.0, 20.0, 2.0, 10.0, 22.0/)
    A(3,:) = (/30.0, 2.0, 29.0, 1.0, 7.0/)
    A(4,:) = (/6.0, 10.0, 1.0, 14.0, 20.0/)
    A(5,:) = (/18.0, 22.0, 7.0, 20.0, 40.0/)

    Acpy = A
    LWORK=3*n
    INFO = 0
    call DSYEV('N', 'U', N, Acpy, N, EIG, WORK, LWORK, INFO )
    print *,EIG

    call modefiedCholeskyDecompNoPerm(A,n,L,D,E)

    print *,L(1,:)
    print *,L(2,:)
    print *,L(3,:)
    print *,L(4,:)
    print *,L(5,:)
    print *,D
    print *,E

    EE = 0.0
    DD = 0.0

    ! Transpose
    LT = L
    do j = 1,n
      DD(j,j) = D(j)
      EE(j,j) = E(j)
      do i = 1,j-1
        temp = LT(i,j)
        LT(i,j) = LT(j,i)
        LT(j,i) = temp
      end do
    end do

    L = MATMUL(L,DD)
    L = MATMUL(L,LT)

    Acpy = L
    INFO = 0
    call DSYEV('N', 'U', N, Acpy, N, EIG, WORK, LWORK, INFO )
    print *,EIG

    L = A - L
    print *,L(1,:)
    print *,L(2,:)
    print *,L(3,:)
    print *,L(4,:)
    print *,L(5,:)

    Acpy = A + EE
    call dsysv('u', n, 1, Acpy, n, ipiv, B1, n, work, 3*n, info)
    print *,B1

    Acpy = A
    call solveModefiedCholesky(n,Acpy,B2)
    print *,B2

  end subroutine testModefiedCholeskyDecomp

  !-----------------------------------------------------------------------------
  !> Compute Gill-Murray modified Cholesky (LDL) factorization of A.
  !!
  !! If A is negative definite, or singular, the matrix is modified:
  !!
  !! \f$ A + E = L D L^T \f$
  !!
  !! Where E is a diagonal small norm matrix making A+E positive definite.
  !!
  !! \author MHA, January 2012
  !-----------------------------------------------------------------------------
  subroutine modefiedCholeskyDecomp(A,n,L,D,P)
    implicit none
    integer, intent(in) :: n !< Symmetric matrix dimension
    real, dimension(n,n), intent(inout) :: A !< Symmetric matrix to be factorized
    real, dimension(n,n), intent(out) :: L !< Lower triangular matrix
    real, dimension(n), intent(out) :: D !< Diagonal matrix
    integer, dimension(n), intent(out) :: P !< Permutations
    !
    ! Locals
    real, dimension(n,n) :: C
    real, parameter :: mu = machine_prec*1.0e3
    real :: gamma, delta, beta, xi, theta, temp, maxVal
    integer :: i,j,s,q,iTemp

    if (n <= 2) then
      write(*,*) 'util::modefiedCholeskyDecomp - Intended for matrices with n>2'
      call stoperror('')
    endif

    ! Initialize matrices and vectors
    L(:,:) = 0.0
    D(:) = 0.0
    C(:,:) = 0.0
    gamma = 0.0
    do i = 1,n
      L(i,i) = 1.0
      c(i,i) = A(i,i)
      gamma = max(gamma, abs(A(i,i)))
      P(i) = i
    enddo

    ! Compute modification parameters
    xi = 0.0
    do i = 1,n
      do j = 1,n
        if (j /= i) then
          xi = max(xi, abs(A(i,j)))
        endif
      end do
    enddo
    delta = mu*max(gamma+xi,1.0)
    beta = max(gamma, mu)
    beta = max(beta, xi/sqrt(n**2-1.0))
    beta = sqrt(beta)

    do j = 1,n
      ! Find q that results in Best Permutation with j
      maxVal = abs(C(j,j))
      q = j
      do i = j+1,n
        if (maxVal < abs(C(i,i))) then
          maxVal = abs(C(i,i))
          q = i
        endif
      end do

      ! Permute d,c,l,a
      temp = d(q)
      d(q) = d(j)
      d(j) = temp
      iTemp = P(q)
      P(q) = P(j)
      P(j) = iTemp
      call interChangeRow(C,n,j,q)
      call interChangeColumn(L,n,j,q)
      call interChangeRow(L,n,j,q)
      call interChangeColumn(L,n,j,q)
      call interChangeRow(A,n,j,q)
      call interChangeColumn(A,n,j,q)

      do s = 1,j-1
        l(j,s) = c(j,s)/d(s)
      enddo
      do i = j+1,n
        c(i,j) = A(i,j) - sum(l(j,1:j-1)*c(i,1:j-1))
      enddo
      theta = 0.0
      if (j < n) then
        do s = j+1,n
          theta = max(theta, abs(c(s,j)))
        enddo
      endif
      d(j) = max(abs(c(j,j)), (theta/beta)**2)
      d(j) = max(d(j), delta)
      if (j < n) then
        do i = j+1,n
          c(i,i) = c(i,i) - (c(i,j)**2)/d(j)
        end do
      end if
    end do

  end subroutine modefiedCholeskyDecomp

  !-----------------------------------------------------------------------------
  !> Swap row j and q in matrix A
  !>
  !> \author MHA, January 2012
  !-----------------------------------------------------------------------------
  subroutine interChangeRow(A,n,j,q)
    implicit none
    integer, intent(in) :: n !< Symmetric matrix dimension
    integer, intent(in) :: j !< Row index
    integer, intent(in) :: q !< Row index
    real, dimension(n,n), intent(inout) :: A !< Symmetric matrix
    !
    ! Locals
    real, dimension(n) :: row
    row(:) = A(j,:)
    A(j,:) = A(q,:)
    A(q,:) = row(:)
  end subroutine interChangeRow

  !-----------------------------------------------------------------------------
  !> Swap column j and q in matrix A
  !>
  !> \author MHA, January 2012
  !-----------------------------------------------------------------------------
  subroutine interChangeColumn(A,n,j,q)
    implicit none
    integer, intent(in) :: n !< Symmetric matrix dimension
    integer, intent(in) :: j !< Column index
    integer, intent(in) :: q !< Column index
    real, dimension(n,n), intent(inout) :: A !< Symmetric matrix
    !
    ! Locals
    real, dimension(n,1) :: column
    column(:,1) = A(:,j)
    A(:,j) = A(:,q)
    A(:,q) = column(:,1)
  end subroutine interChangeColumn

  !-----------------------------------------------------------------------------
  !> Compute Gill-Murray modified Cholesky (LDL) factorization of A.
  !!
  !! If A is negative definite, or singular, the matrix is modified:
  !!
  !! \f$ A + E = L D L^T \f$
  !!
  !! Where E is a diagonal small norm matrix making A+E positive definite.
  !!
  !! \author MHA, January 2012
  !-----------------------------------------------------------------------------
  subroutine modefiedCholeskyDecompNoPerm(A,n,L,D,E)
    implicit none
    integer, intent(in) :: n !< Symmetric matrix dimension
    real, dimension(n,n), intent(in) :: A !< Symmetric matrix to be factorized
    real, dimension(n,n), intent(out) :: L !< Lower triangular matrix
    real, dimension(n), intent(out) :: D !< Diagonal matrix
    real, dimension(n), intent(out) :: E !< Diagonal of modification matrix
    !
    ! Locals
    real, dimension(n,n) :: C
    real, parameter :: mu = machine_prec*1.0e2
    real :: gamma, delta, beta, xi, theta
    integer :: i,j,s

    if (n < 2) then
      write(*,*) 'util::modefiedCholeskyDecompNoPerm - Intended for matrices with n>=2'
      call stoperror('')
    endif

    ! Initialize matrices and vectors
    L(:,:) = 0.0
    D(:) = 0.0
    C(:,:) = 0.0
    E(:) = 0.0
    gamma = 0.0
    do i = 1,n
      L(i,i) = 1.0
      C(i,i) = A(i,i)
      gamma = max(gamma, abs(A(i,i)))
    enddo

    ! Compute modification parameters
    xi = 0.0
    do i = 1,n
      do j = 1,n
        if (j /= i) then
          xi = max(xi, abs(A(i,j)))
        endif
      end do
    enddo
    delta = mu*max(gamma+xi,1.0)
    beta = max(gamma, mu)
    beta = max(beta, xi/sqrt(n**2-1.0))
    beta = sqrt(beta)

    do j = 1,n
      do s = 1,j-1
        L(j,s) = C(j,s)/D(s)
      enddo
      do i = j+1,n
        C(i,j) = A(i,j) - sum(L(j,1:j-1)*C(i,1:j-1))
      enddo
      theta = 0.0
      if (j < n) then
        do s = j+1,n
          theta = max(theta, abs(c(s,j)))
        enddo
      endif
      D(j) = max(abs(C(j,j)), (theta/beta)**2)
      D(j) = max(D(j), delta)

      E(j)=D(j)-C(j,j)
      if (j < n) then
        do i = j+1,n
          C(i,i) = C(i,i) - (C(i,j)**2)/D(j)
        end do
      end if
    end do

  end subroutine modefiedCholeskyDecompNoPerm

  !-----------------------------------------------------------------------------
  !> NELMIN minimizes a function using the Nelder-Mead algorithm
  !!
  !! \author KEGT
  !-----------------------------------------------------------------------------
  subroutine nelmin ( fn, n, start, xmin, ynewlo, reqmin, step, konvge, kcount, &
       icount, numres, ifault )

    !*****************************************************************************80
    !
    !! NELMIN minimizes a function using the Nelder-Mead algorithm.
    !
    !  Discussion:
    !
    !    This routine seeks the minimum value of a user-specified function.
    !
    !    Simplex function minimisation procedure due to Nelder+Mead(1965),
    !    as implemented by O'Neill(1971, Appl.Statist. 20, 338-45), with
    !    subsequent comments by Chambers+Ertel(1974, 23, 250-1), Benyon(1976,
    !    25, 97) and Hill(1978, 27, 380-2)
    !
    !    The function to be minimized must be defined by a function of
    !    the form
    !
    !      function fn ( x, f )
    !      real ( kind = 8 ) fn
    !      real ( kind = 8 ) x(*)
    !
    !    and the name of this subroutine must be declared EXTERNAL in the
    !    calling routine and passed as the argument FN.
    !
    !    This routine does not include a termination test using the
    !    fitting of a quadratic surface.
    !
    !  Modified:
    !
    !    27 February 2008
    !
    !  Author:
    !
    !    FORTRAN77 version by R ONeill
    !    FORTRAN90 version by John Burkardt
    !
    !  Reference:
    !
    !    John Nelder, Roger Mead,
    !    A simplex method for function minimization,
    !    Computer Journal,
    !    Volume 7, 1965, pages 308-313.
    !
    !    R ONeill,
    !    Algorithm AS 47:
    !    Function Minimization Using a Simplex Procedure,
    !    Applied Statistics,
    !    Volume 20, Number 3, 1971, pages 338-345.
    !
    !  Parameters:
    !
    !    Input, external FN, the name of the function which evaluates
    !    the function to be minimized.
    !
    !    Input, integer ( kind = 4 ) N, the number of variables.
    !
    !    Input/output, real ( kind = 8 ) START(N).  On input, a starting point
    !    for the iteration.  On output, this data may have been overwritten.
    !
    !    Output, real ( kind = 8 ) XMIN(N), the coordinates of the point which
    !    is estimated to minimize the function.
    !
    !    Output, real ( kind = 8 ) YNEWLO, the minimum value of the function.
    !
    !    Input, real ( kind = 8 ) REQMIN, the terminating limit for the variance
    !    of function values.
    !
    !    Input, real ( kind = 8 ) STEP(N), determines the size and shape of the
    !    initial simplex.  The relative magnitudes of its elements should reflect
    !    the units of the variables.
    !
    !    Input, integer ( kind = 4 ) KONVGE, the convergence check is carried out
    !    every KONVGE iterations.
    !
    !    Input, integer ( kind = 4 ) KCOUNT, the maximum number of function
    !    evaluations.
    !
    !    Output, integer ( kind = 4 ) ICOUNT, the number of function evaluations
    !    used.
    !
    !    Output, integer ( kind = 4 ) NUMRES, the number of restarts.
    !
    !    Output, integer ( kind = 4 ) IFAULT, error indicator.
    !    0, no errors detected.
    !    1, REQMIN, N, or KONVGE has an illegal value.
    !    2, iteration terminated because KCOUNT was exceeded without convergence.
    !
    implicit none

    integer ( kind = 4 ) n

    real    ( kind = 8 ), parameter :: ccoeff = 0.5D+00
    real    ( kind = 8 ) del
    real    ( kind = 8 ) dn
    real    ( kind = 8 ) dnn
    real    ( kind = 8 ), parameter :: ecoeff = 2.0D+00
    real    ( kind = 8 ), parameter :: eps = 0.001D+00
    real    ( kind = 8 ), external :: fn
    integer ( kind = 4 ) i
    integer ( kind = 4 ) icount
    integer ( kind = 4 ) ifault
    integer ( kind = 4 ) ihi
    integer ( kind = 4 ) ilo
    integer ( kind = 4 ) j
    integer ( kind = 4 ) jcount
    integer ( kind = 4 ) kcount
    integer ( kind = 4 ) konvge
    integer ( kind = 4 ) l
    integer ( kind = 4 ) nn
    integer ( kind = 4 ) numres
    real    ( kind = 8 ) p(n,n+1)
    real    ( kind = 8 ) p2star(n)
    real    ( kind = 8 ) pbar(n)
    real    ( kind = 8 ) pstar(n)
    real    ( kind = 8 ), parameter :: rcoeff = 1.0D+00
    real    ( kind = 8 ) reqmin
    real    ( kind = 8 ) rq
    real    ( kind = 8 ) start(n)
    real    ( kind = 8 ) step(n)
    real    ( kind = 8 ) x
    real    ( kind = 8 ) xmin(n)
    real    ( kind = 8 ) y(n+1)
    real    ( kind = 8 ) y2star
    real    ( kind = 8 ) ylo
    real    ( kind = 8 ) ynewlo
    real    ( kind = 8 ) ystar
    real    ( kind = 8 ) z
    !
    !  Check the input parameters.
    !
    if ( reqmin <= 0.0D+00 ) then
       ifault = 1
       return
    end if

    if ( n < 1 ) then
       ifault = 1
       return
    end if

    if ( konvge < 1 ) then
       ifault = 1
       return
    end if

    icount = 0
    numres = 0

    jcount = konvge
    dn = real ( n, kind = 8 )
    nn = n + 1
    dnn = real ( nn, kind = 8 )
    del = 1.0D+00
    rq = reqmin * dn
    !
    !  Initial or restarted loop.
    !
    do

       do i = 1, n
          p(i,nn) = start(i)
       end do

       y(nn) = fn ( start )
       icount = icount + 1

       do j = 1, n
          x = start(j)
          start(j) = start(j) + step(j) * del
          do i = 1, n
             p(i,j) = start(i)
          end do
          y(j) = fn ( start )
          icount = icount + 1
          start(j) = x
       end do
       !
       !  The simplex construction is complete.
       !
       !  Find highest and lowest Y values.  YNEWLO = Y(IHI) indicates
       !  the vertex of the simplex to be replaced.
       !
       ylo = y(1)
       ilo = 1

       do i = 2, nn
          if ( y(i) < ylo ) then
             ylo = y(i)
             ilo = i
          end if
       end do
       !
       !  Inner loop.
       !
       do

          if ( kcount <= icount ) then
             exit
          end if

          ynewlo = y(1)
          ihi = 1

          do i = 2, nn
             if ( ynewlo < y(i) ) then
                ynewlo = y(i)
                ihi = i
             end if
          end do
          !
          !  Calculate PBAR, the centroid of the simplex vertices
          !  excepting the vertex with Y value YNEWLO.
          !
          do i = 1, n
             z = 0.0D+00
             do j = 1, nn
                z = z + p(i,j)
             end do
             z = z - p(i,ihi)
             pbar(i) = z / dn
          end do
          !
          !  Reflection through the centroid.
          !
          do i = 1, n
             pstar(i) = pbar(i) + rcoeff * ( pbar(i) - p(i,ihi) )
          end do

          ystar = fn ( pstar )
          icount = icount + 1
          !
          !  Successful reflection, so extension.
          !
          if ( ystar < ylo ) then

             do i = 1, n
                p2star(i) = pbar(i) + ecoeff * ( pstar(i) - pbar(i) )
             end do

             y2star = fn ( p2star )
             icount = icount + 1
             !
             !  Check extension.
             !
             if ( ystar < y2star ) then

                do i = 1, n
                   p(i,ihi) = pstar(i)
                end do

                y(ihi) = ystar
                !
                !  Retain extension or contraction.
                !
             else

                do i = 1, n
                   p(i,ihi) = p2star(i)
                end do

                y(ihi) = y2star

             end if
             !
             !  No extension.
             !
          else

             l = 0
             do i = 1, nn
                if ( ystar < y(i) ) then
                   l = l + 1
                end if
             end do

             if ( 1 < l ) then

                do i = 1, n
                   p(i,ihi) = pstar(i)
                end do

                y(ihi) = ystar
                !
                !  Contraction on the Y(IHI) side of the centroid.
                !
             else if ( l == 0 ) then

                do i = 1, n
                   p2star(i) = pbar(i) + ccoeff * ( p(i,ihi) - pbar(i) )
                end do

                y2star = fn ( p2star )
                icount = icount + 1
                !
                !  Contract the whole simplex.
                !
                if ( y(ihi) < y2star ) then

                   do j = 1, nn
                      do i = 1, n
                         p(i,j) = ( p(i,j) + p(i,ilo) ) * 0.5D+00
                         xmin(i) = p(i,j)
                      end do
                      y(j) = fn ( xmin )
                      icount = icount + 1
                   end do

                   ylo = y(1)
                   ilo = 1

                   do i = 2, nn
                      if ( y(i) < ylo ) then
                         ylo = y(i)
                         ilo = i
                      end if
                   end do

                   cycle
                   !
                   !  Retain contraction.
                   !
                else

                   do i = 1, n
                      p(i,ihi) = p2star(i)
                   end do
                   y(ihi) = y2star

                end if
                !
                !  Contraction on the reflection side of the centroid.
                !
             else if ( l == 1 ) then

                do i = 1, n
                   p2star(i) = pbar(i) + ccoeff * ( pstar(i) - pbar(i) )
                end do

                y2star = fn ( p2star )
                icount = icount + 1
                !
                !  Retain reflection?
                !
                if ( y2star <= ystar ) then

                   do i = 1, n
                      p(i,ihi) = p2star(i)
                   end do
                   y(ihi) = y2star

                else

                   do i = 1, n
                      p(i,ihi) = pstar(i)
                   end do
                   y(ihi) = ystar

                end if

             end if

          end if
          !
          !  Check if YLO improved.
          !
          if ( y(ihi) < ylo ) then
             ylo = y(ihi)
             ilo = ihi
          end if

          jcount = jcount - 1

          if ( 0 < jcount ) then
             cycle
          end if
          !
          !  Check to see if minimum reached.
          !
          if ( icount <= kcount ) then

             jcount = konvge

             z = 0.0D+00
             do i = 1, nn
                z = z + y(i)
             end do
             x = z / dnn

             z = 0.0D+00
             do i = 1, nn
                z = z + ( y(i) - x )**2
             end do

             if ( z <= rq ) then
                exit
             end if

          end if

       end do
       !
       !  Factorial tests to check that YNEWLO is a local minimum.
       !
       do i = 1, n
          xmin(i) = p(i,ilo)
       end do

       ynewlo = y(ilo)

       if ( kcount < icount ) then
          ifault = 2
          exit
       end if

       ifault = 0

       do i = 1, n
          del = step(i) * eps
          xmin(i) = xmin(i) + del
          z = fn ( xmin )
          icount = icount + 1
          if ( z < ynewlo ) then
             ifault = 2
             exit
          end if
          xmin(i) = xmin(i) - del - del
          z = fn ( xmin )
          icount = icount + 1
          if ( z < ynewlo ) then
             ifault = 2
             exit
          end if
          xmin(i) = xmin(i) + del
       end do

       if ( ifault == 0 ) then
          exit
       end if
       !
       !  Restart the procedure.
       !
       do i = 1, n
          start(i) = xmin(i)
       end do

       del = eps
       numres = numres + 1

    end do

    return
  end subroutine nelmin

end module optimizers


!==========================================================================
elemental function gsw_sa_from_sstar (sstar, p, long, lat)
!==========================================================================
!
! Calculates Absolute Salinity, SA, from Preformed Salinity, Sstar.
!
! Sstar  : Preformed Salinity                              [g/kg]
! p      : sea pressure                                    [dbar]
! long   : longitude                                       [deg E]
! lat    : latitude                                        [deg N]
!
! gsw_sa_from_sstar   : Absolute Salinity                  [g/kg]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_saar

use gsw_mod_error_functions, only : gsw_error_code, gsw_error_limit

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sstar, p, long, lat

real (r8) :: gsw_sa_from_sstar

real (r8) :: saar

character (*), parameter :: func_name = "gsw_sa_from_sstar"

saar = gsw_saar(p,long,lat)

if (saar.gt.gsw_error_limit) then

   gsw_sa_from_sstar = gsw_error_code(1,func_name,saar)

else

   ! In the Baltic Sea, Sstar = SA, and note that gsw_saar returns zero
   ! for SAAR in the Baltic.

   gsw_sa_from_sstar = sstar*(1.0_r8 + saar)/(1.0_r8 - 0.35_r8*saar)

end if

return
end function

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


      implicit real *8 (a-h,o-z)
      complex *16 z1,z2,zk,ima
      data ima/(0.0d0,1.0d0)/

      done = 1
      pi = atan(done)*4

      ntest = 6

      z1 = 8 + ima*0.2d0

      rsc = 1.0d10
      zk = z1*2*pi/rsc
      call test_hfmm3d_scale(rsc,zk,i1)

      rsc = 1.0d-9
      zk = z1*2*pi/rsc
      call test_hfmm3d_scale(rsc,zk,i2)

      z1 = 5.0d0 + ima*5.0d0
      rsc = 1.0d10
      zk = z1*2*pi/rsc
      call test_hfmm3d_scale(rsc,zk,i3)

      rsc = 1.0d-9
      zk = z1*2*pi/rsc
      call test_hfmm3d_scale(rsc,zk,i4)

      z1 = 1.0d0 + ima*5.0d0
      rsc = 1.0d10
      zk = z1*2*pi/rsc
      call test_hfmm3d_scale(rsc,zk,i5)

      rsc = 1.0d-9
      zk = z1*2*pi/rsc
      call test_hfmm3d_scale(rsc,zk,i6)

      nsuccess = i1+i2+i3+i4+i5+i6
      open(unit=33,file='print_testres.txt',access='append')
      write(33,'(a,i1,a,i1,a)') 'Successfully completed ', nsuccess,
     1   ' out of ', ntest, ' in hfmm3d scale testing suite'

      stop

      stop
      end

      subroutine test_hfmm3d_scale(rsc,zk,isuccess)

      implicit none
      integer ns
      double precision, allocatable :: source(:,:)
      double complex, allocatable :: charge(:),dipvec(:,:)
      double complex, allocatable :: pot(:),potex(:)
      double complex, allocatable :: grad(:,:),gradex(:,:)

      double precision eps,rsc
      double complex eye,zk
      integer i,j,k,ntest,ier
      double precision hkrand,thresh,erra,ra
      integer isuccess

      data eye/(0.0d0,1.0d0)/

c
cc      initialize printing routine
c
      call prini(6,13)
      write(*,*)
      write(*,*)
      write(*,*) "================================="
      write(*,*)
      write(*,*)

      ns = 10000

      allocate(source(3,ns))
      allocate(charge(ns))
      allocate(dipvec(3,ns))
      allocate(pot(ns))
      allocate(grad(3,ns))

      eps = 0.51d-6

c
c
c       example demonstrating use of
c        source to source, charges, pot + gradient
c

c
cc      generate sources with distribution unif^2
c
c
      do i=1,ns
        source(1,i) = hkrand(0)**2*rsc
        source(2,i) = hkrand(0)**2*rsc
        source(3,i) = hkrand(0)**2*rsc

        charge(i) = hkrand(0) + eye*hkrand(0)
        dipvec(1,i) = hkrand(0) + eye*hkrand(0)
        dipvec(2,i) = hkrand(0) + eye*hkrand(0)
        dipvec(3,i) = hkrand(0) + eye*hkrand(0)

        pot(i) = 0
        grad(1,i) = 0
        grad(2,i) = 0
        grad(3,i) = 0
      enddo

      call hfmm3d_s_cd_g(eps,zk,ns,source,charge,dipvec,
     1      pot,grad,ier)
      ntest = 10
      allocate(potex(ntest),gradex(3,ntest))

      thresh = 2.0d0**(-51)*rsc

      do i=1,ntest
        potex(i) = 0
        gradex(1,i) = 0
        gradex(2,i) = 0
        gradex(3,i) = 0
      enddo

      call h3ddirectcdg(1,zk,source,charge,dipvec,ns,source,
     1  ntest,potex,gradex,thresh)

      erra = 0
      ra = 0
      do i=1,ntest
        erra = erra + abs(potex(i)-pot(i))**2
        erra = erra + abs(gradex(1,i)-grad(1,i))**2
        erra = erra + abs(gradex(2,i)-grad(2,i))**2
        erra = erra + abs(gradex(3,i)-grad(3,i))**2

        ra = ra + abs(potex(i))**2
        ra = ra + abs(gradex(1,i))**2 + abs(gradex(2,i))**2 +
     1   abs(gradex(3,i))**2
      enddo

      call prin2('pot=*',pot,2*ntest)
      call prin2('potex=*',potex,2*ntest)

      erra = sqrt(erra/ra)

      call prin2('zk=*',zk,1)
      call prin2('rsc=*',rsc,1)
      call prin2('l2 rel err=*',erra,1)

      isuccess = 0

      if(erra.lt.5*eps) isuccess = 1

      return
      end
c----------------------------------------------------------
c


c=======================================================================
c
c     subroutine OPTE
c
c     Optimization for ALLOCTE - Tracking Error Constraint
c
c-----------------------------------------------------------------------
      SUBROUTINE opte ( n, cov, rho, covb, varb, rhob,
     &                  neq, nin, ccst, bcst, cinf, csup,
     &                  temax, maxiter, epsilon,
     &                  iwork, dwork, wopt, delopt, optte, info )
c-----------------------------------------------------------------------
c
c     INPUT
c        n      : number of asset(s) (> 1)                       integer
c        cov    : n*n-array, covariance matrix (n*n)              double
c        rho    : n-array, expected return(s) (n)                 double
c        covb   : n-array, covariance asset vs.index (n)          double
c        varb   : variance of index/benchmark                     double
c        rhob   : expected return of index/benchmark              double
c        neq    : number equality constraints                    integer
c        nin    : number inequality constraints                  integer
c        ccst   : matrix of linear constraints (n*(neq+nin))      double
c        bcst   : vector of linear constraints (neq+nin)          double
c        cinf   : lower bounds (n)                                double
c        csup   : upper bounds (n)                                double
c        temax  : tracking error constraint (>0)                  double
c        maxdic : maximum iteration (dichotomy)                  integer
c        epsdic : precision (dichotomy)                           double
c        epskat : Kato sensibility parameter                      double
c
c     WORKSPACE
c        iwork  : vector ( 16*n + neq + 2*nin + 1 )              integer
c        dwork  : matrix                                          double
c                 n*(7*n + neq + nin + 42)
c                 + 2*neq + 3*nin + 4
c
c     OUTPUT
c        wopt   : optimal portfolio vector (n)                   double
c        delopt :
c        optte  : optimal Tracking Error                         double
c        info   : diagnostic argument                           integer
c
c     CALL
c        WZERO  : put zero at the values of a vector less than eps
c                 and increase the greatest element with residual
c        YV     : copy a vector in a vector
c        XV     : computing scalar product of two vectors = V1'*V2
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, neq, nin, maxiter, info
      DOUBLE PRECISION rhob, varb, temax, epsilon, optte, delopt
      DOUBLE PRECISION cov(*), rho(*), cinf(*), csup(*), ccst(*),
     &                 bcst(*), wopt(*), covb(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, niter, pdwopt, pite, pdte, piwq, pdwq, pccs,
     &        pbcs, plin, plagr, neqtot, nintot, infoq, infote, infotmp
      DOUBLE PRECISION emret, tesav, delsav, epste, eps, delmin, delmax,
     &                 rdtmax
      PARAMETER ( eps = 1.0E-30 )
c
c     external subroutines
      EXTERNAL WZERO, YV, XV, ctit, qp
c
c     intrinsic functions
      INTRINSIC abs
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piwq = 1
c     piwq  : pointer for internal workspaces of QUAPRO
c             needs ( 3*n + neq + 2*nin + 1 )
      pite = piwq + ( 3*n + neq + 2*nin + 1 )
c     pite  : pointer for EXATER, needs*( 13*n )
c
c     Total size of iwork array = ( 16*n + neq + 2*nin + 1 )
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdwopt = 1
c     pdwopt : pointer for wopt save, need ( n )
      pccs = pdwopt + ( n )
c     pccs   : pointer for matrix constraint in CTIT
c              needs ( n *( neq + nin + 1))
      pbcs = pccs + ( n *( neq + nin + 1))
c     pbcs   : pointer for vector constraint in CTIT
c              needs ( neq + nin + 1 )
      plin = pbcs + ( neq + nin + 1 )
c     plin   : pointer for linear part in CTIT, needs ( n )
      pdwq   = plin + ( n )
c     pdwq   : pointer for workspace of QUAPRO
c              needs ( n*n + 6*n + nin )
      plagr  = pdwq + ( n*n + 6*n + nin )
c     plagr  : pointer for Lagrangian QUARPO
c              needs ( n + neq + nin )
      pdte   = pdwq + ( n + neq + nin )
c     pdte   : pointer for EXATER needs ( n*(6*n+32) + 3 )
c
c     Total size of dwork = n*(7*n + neq + nin + 42 )
c                           + 2*neq + 3*nin + 4
c-----------------------------------------------------------------------
c
c     computes max of returns
      rdtmax = rho(1)
      DO i=2,n
         rdtmax = MAX( rdtmax, rho(i) )
      ENDDO
      delmax  = rdtmax - rhob
c
c     initializations
      infotmp = 0
      tesav   = 0
      delsav  = 0
      delopt  = -delmax
      delmin  = -delmax
      epste   = 2.*epsilon
      optte   = 0
      niter   = 0
c
c     stop test: (niter >= maxiter)&(|optTE - maxTE| <= epsilon)
      DO WHILE ( ((niter+1).le. maxiter).and.(epste .gt. epsilon) )
c
c      increase number of iteration
       niter = niter + 1
c
c      constraints matrix and linear part
       CALL ctit ( n, rhob, rho, covb,
     &            delopt, neq, nin, ccst, bcst,
     &            neqtot, nintot, dwork(pccs), dwork(pbcs), dwork(plin))
c
c      quadratic solver (QP)
c      min [w*Q*w - p*w] s.t. C*w <= b, cinf <= w <= csup
       CALL qp ( n, cov, dwork(plin), dwork(pccs),
     &           dwork(pbcs), cinf, csup, neqtot, nintot,
     &           iwork(piwq), dwork(pdwq), dwork(plagr), wopt,
     &           infoq )
c
c       if wopt(i)< myzero -> wopt(i) = 0
c                           -> increase max[wopt(i)]
        CALL WZERO ( n, wopt, eps )
c
c       optimal ex-ante mean return = w'*rho
        CALL XV ( n, wopt, rho, emret )
c
c       optimal over performance
        delopt = emret - rhob
c
c       optimal ex-ante Tracking Error
        CALL EXATER ( n, wopt, cov, covb, varb, dwork(pdte),
     &                optte, infote)
c
c       stop test: epste = |optTE - maxTE|
        epste = abs(optte - temax)
c
c       error management
        IF (infoq .LT. 0) THEN
           IF (infoq .ne. 1001) THEN
              RETURN
           ELSE
              infotmp = 1001
           ENDIF
        ELSE
           infotmp = 0
           delsav  = delopt
           tesav   = optte
           CALL YV ( n, wopt, dwork(pdwopt) )
        ENDIF
c
c       dichotomy (case niter=1 and niter>1)
        IF (niter .EQ. 1) THEN
           IF (temax .ge. optte) THEN
               delmin = delopt - epsilon
           ELSE
               info = 107
               RETURN
           ENDIF
        ENDIF
c
        IF (niter .GT. 1) THEN
           IF (temax .GT. optte) THEN
               delmin = delopt - epsilon
           ELSE
               delmax = delopt + epsilon
           ENDIF
        ENDIF
c
c       dichotomy ->
        delopt = (delmax + delmin)/2.0
c
c     end while
      ENDDO
c
      IF (infotmp .eq. 0) THEN
           info   = infotmp
           delopt = delsav
           optte  = tesav
           CALL YV ( n, dwork(pdwopt), wopt )
      ENDIF
c
      IF ((niter + 1) .gt. maxiter) info = 106
c
      RETURN
      END


      subroutine gemver(alpha,beta,lda,n,A,ldb,B,u1,v1,u2,v2,w,x,y,z)
      integer incx, incy, i, j, n
      double precision alpha, beta, zero, one
      double precision w(*), x(*), y(*), u1(*), u2(*), v1(*), v2(*)
      double precision z(n)
      double precision A(lda,*), B(ldb,*)
c
c   GEMVER
c   in
c     A : column matrix, u1 : vector, u2 : vector, v1 : vector, v2 : vector,
c     alpha : scalar, beta : scalar,
c     y : vector, z : vector
c   out
c     B : column matrix, x : vector, w : vector
c
      incx = 1
      incy = 1
      one = 1.0d0
      zero = 0.0d0
c
c     B = A + u1 * v1' + u2 * v2'
c     x = beta * (B' * y) + z
c     w = alpha * (B * x)
c
c
c  Copy A so that it doesn't get overwritten.
c
      do j = 1,n
         do  i = 1,n
            B(i,j) = A(i,j)
         enddo
c      do j = 1,n
c         call dcopy(n, A(1,j), incx, B(1,j), incx)
      enddo
c
c  Rank 1 updates
c
      call dger(n, n, one, u1, incx, v1, incx, B, ldb )
      call dger(n, n, one, u2, incx, v2, incx, B, ldb )
c
c  Copy z so that it doesn't get overwritten.
c
      call dcopy(n, z, incx, x, incy)
c
c     x = beta * (B' * y) + z  (z is x here)
c
      call dgemv( 't', n, n, beta, B, lda, y, incx, one, x, incx )
c
c     w = alpha * (B * x)
c
      call dgemv( 'n', n, n, alpha, B, lda, x, incx, zero, w, incx )
c
      return
      end


          subroutine filtro_per_z(zk)

! ------------------------------------------------------ !
!             filtro periodico                           !
!             F. Califano, Marzo 2001                    !
! ------------------------------------------------------ !

!**************************************************
!  MPI PARALLEL VERSION: VALENTINI-FAGANELLO 2009
!   3D PARALLEL VERSION: FAGANELLO 2010
!**************************************************

use parameter_mod
use box_mod
use filtro_per_mod
use deriv_mod, only: savez

IMPLICIT NONE

  integer :: m, m1, m2
  REAL(dp), dimension(nz)  :: zk

!  filtro

! **    z Filtering

        call drfftf(nz, zk, savez)

        m = 1

          do m1 = 2, nz - 1, 2

          m2 = m1 + 1

          zk(m1) = zk(m1) * work4z(m)
          zk(m2) = zk(m2) * work4z(m)

        m = m + 1

!write(*,898) m, work4z(m)

        enddo

!898     format(1x, 1i3, 1x, 1e12.5)
!stop

          zk = zk * ninvz

! **    Filtered function

        call drfftb(nz, zk, savez)

       return
       end


      MODULE interp_I
      INTERFACE
!...Generated by Pacific-Sierra Research 77to90  4.3E  10:48:32   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
      SUBROUTINE interp (XARR, YARR, NARR, XVAL, YVAL, ACCY)
      USE vast_kind_param,ONLY: DOUBLE
      INTEGER MXORD
      PARAMETER (MXORD = 11)
      REAL(DOUBLE), DIMENSION(NARR), INTENT(IN) :: XARR
      REAL(DOUBLE), DIMENSION(NARR), INTENT(IN) :: YARR
      INTEGER, INTENT(IN) :: NARR
      REAL(DOUBLE), INTENT(IN) :: XVAL
      REAL(DOUBLE), INTENT(OUT) :: YVAL
      REAL(DOUBLE), INTENT(IN) :: ACCY
!...This routine performs I/O.
      END SUBROUTINE
      END INTERFACE
      END MODULE


!> \file tpot.f90
!! \BRIEF
!>    Module with tpot subroutine - compute potential T from in situ T,S,P
MODULE mtpot
CONTAINS
!>    Compute potential temperature from arrays of in situ temp, salinity, and pressure.
!!    This subroutine is needed because sw_ptmp is a function (using scalars not arrays)
SUBROUTINE tpot(salt, tempis, press, pressref, N, tempot)
  !    Purpose:
  !    Compute potential temperature from arrays of in situ temp, salinity, and pressure.
  !    Needed because sw_ptmp is a function

#if USE_PRECISION == 2
#   define SGLE(x)    (x)
#else
#   define SGLE(x)    REAL(x)
#endif

  USE msingledouble
  USE msw_ptmp
  IMPLICIT NONE

  !> number of records
!f2py intent(hide) n
  INTEGER, intent(in) :: N

! INPUT variables
  !> salinity [psu]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: salt
  !> in situ temperature [C]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: tempis
  !> pressure [db]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: press
  !> pressure reference level [db]
  REAL(kind=rx), INTENT(in) :: pressref

! OUTPUT variables:
  !> potential temperature [C] for pressref
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: tempot

  REAL(kind=r8) :: dsalt, dtempis, dpress, dpressref
  REAL(kind=r8) :: dtempot

  INTEGER :: i

! REAL(kind=r8) :: sw_ptmp
! EXTERNAL sw_ptmp

  DO i = 1,N
     dsalt     = DBLE(salt(i))
     dtempis   = DBLE(tempis(i))
     dpress    = DBLE(press(i))
     dpressref = DBLE(pressref)

     dtempot   = sw_ptmp(dsalt, dtempis, dpress, dpressref)

     tempot(i) = SGLE(dtempot)
  END DO

  RETURN
END SUBROUTINE tpot
END MODULE mtpot


c     Subroutine to convert date to jultime
c     AJ_Kettle, Aug22/2017
c     22Feb2020: applied to USAF update files

      SUBROUTINE str_to_dt_pvwave3(d_jday,
     +  s_date,s_time,i_datefmt,i_timefmt)

      IMPLICIT NONE
c********************************************
      DOUBLE PRECISION    :: d_jday
      DOUBLE PRECISION    :: d_jday_pre
      DOUBLE PRECISION    :: d_jday_ref

      CHARACTER(LEN=10)   :: s_date
      CHARACTER(LEN=8)    :: s_time
      INTEGER             :: i_datefmt,i_timefmt

      CHARACTER(LEN=4)    :: s_year
      CHARACTER(LEN=2)    :: s_mon
      CHARACTER(LEN=2)    :: s_day
      CHARACTER(LEN=2)    :: s_hour
      CHARACTER(LEN=2)    :: s_min
      CHARACTER(LEN=2)    :: s_sec

      REAL                :: f_year,f_mon,f_day
      REAL                :: f_hour,f_min,f_sec

      REAL                :: f_year_ref,f_mon_ref,f_day_ref
      REAL                :: f_hour_ref,f_min_ref,f_sec_ref
c********************************************
c      print*,'s_date=',TRIM(s_date)//'x'//s_time

c     Get different date elements
      IF (i_datefmt.EQ.1) THEN    !US format
       s_mon =s_date(1:2)
       s_day =s_date(4:5)
       s_year=s_date(7:10)
       GOTO 2
      ENDIF
      IF (i_datefmt.EQ.2) THEN    !European format
       s_day =s_date(1:2)
       s_mon =s_date(4:5)
       s_year=s_date(7:10)
       GOTO 2
      ENDIF
      print*,'unrecognized date flag'
2     CONTINUE

      IF (i_timefmt.EQ.-1) THEN
       s_hour=s_time(1:2)
       s_min =s_time(4:5)
       s_sec =s_time(7:8)
       GOTO 4
      ENDIF
      print*,'unrecognized time flag'
      STOP 'str_to_dt_pvwave3'
4     CONTINUE

      READ(s_day,*)  f_day
      READ(s_mon,*)  f_mon
      READ(s_year,*) f_year
      READ(s_hour,*) f_hour
      READ(s_min,*)  f_min
      READ(s_sec,*)  f_sec

      d_jday_pre=DBLE( 367.0*f_year-
     +   INT(7.0*(f_year+INT((f_mon+9.0)/12.0))/4.0)-
     +   INT(3.0*(INT((f_year+INT((f_mon-9.0)/7.0))/100.0)+1.0)/4.0)+
     +   INT(275.0*f_mon/9.0)+f_day ) +
     +   DBLE(100000.0)+
     +   DBLE(f_hour/24.0)+DBLE(f_min/(24.0*60.0))+
     +   DBLE(f_sec/(24.0*3600.0))
c*********************************************
c     Find reference

      f_day_ref =14.0
      f_mon_ref =9.0
      f_year_ref=1752.0
      f_hour_ref=0.0
      f_min_ref =0.0
      f_sec_ref =0.0

      d_jday_ref=DBLE( 367.0*f_year_ref-
     +   INT(7.0*(f_year_ref+INT((f_mon_ref+9.0)/12.0))/4.0)-
     +   INT(3.0*(INT((f_year_ref+
     +     INT((f_mon_ref-9.0)/7.0))/100.0)+1.0)/4.0)+
     +   INT(275.0*f_mon_ref/9.0)+f_day_ref ) +
     +   DBLE(100000.0)+
     +   DBLE(f_hour_ref/24.0)+DBLE(f_min_ref/(24.0*60.0))+
     +   DBLE(f_sec_ref/(24.0*3600.0))
c*********************************************
      d_jday=d_jday_pre-d_jday_ref

c      print*,'d_jday...',d_jday_pre,d_jday_ref,d_jday
c      CALL SLEEP(1)
c*********************************************
      RETURN
      END


!==============================================================================
! Module AQUIFER_MODULE                                           (28-Jun-2017)
!
! Written by:
! 	   Dr. Randal J. Barnes
!     Department of Civil, Environmental, and Geo- Engineering
!     University of Minnesota
!     <barne003@umn.edu>
!==============================================================================

!==============================================================================
MODULE AQUIFER_MODULE
!==============================================================================
   USE CONSTANTS_MODULE
   IMPLICIT NONE

   !===========================================================================
   ! Type T_AQUIFER
   !===========================================================================
   TYPE T_AQUIFER
      REAL(8) :: Base         = 0         ! base elevation of aquifer
      REAL(8) :: Thickness    = INFINITY  ! aquifer thickness
      REAL(8) :: Porosity     = -1        ! aquifer porosity
      REAL(8) :: Conductivity = 1         ! hydraulic conductivity k
   END TYPE T_AQUIFER

   !===========================================================================
   ! INTERFACES
   !===========================================================================
   INTERFACE DischargeToVelocity
      MODULE PROCEDURE DischargeToVelocity_Aquifer
   END INTERFACE

   INTERFACE ElevationToPotential
      MODULE PROCEDURE ElevationToPotential_Aquifer
   END INTERFACE

   INTERFACE ElevationToPotentialStats
      MODULE PROCEDURE ElevationToPotentialStats_Aquifer
   END INTERFACE

   INTERFACE HeadToPotential
      MODULE PROCEDURE HeadToPotential_Aquifer
   END INTERFACE

   INTERFACE PotentialToElevation
      MODULE PROCEDURE PotentialToElevation_Aquifer
   END INTERFACE

   INTERFACE PotentialToHead
      MODULE PROCEDURE PotentialToHead_Aquifer
   END INTERFACE

   INTERFACE Reset
      MODULE PROCEDURE Reset_Aquifer
   END INTERFACE

   INTERFACE SetBase
      MODULE PROCEDURE SetBase_Aquifer
   END INTERFACE

   INTERFACE SetConductivity
      MODULE PROCEDURE SetConductivity_Aquifer
   END INTERFACE

   INTERFACE SetPorosity
      MODULE PROCEDURE SetPorosity_Aquifer
   END INTERFACE

   INTERFACE SetThickness
      MODULE PROCEDURE SetThickness_Aquifer
   END INTERFACE

CONTAINS

   !---------------------------------------------------------------------------
   ! DischargeToVelocity_Aquifer
   !---------------------------------------------------------------------------
   FUNCTION DischargeToVelocity_Aquifer( Aquifer, Head, Q ) RESULT( V )

   ! Declare the arguments.
   TYPE(T_AQUIFER),       INTENT(IN)  :: Aquifer
   REAL(8),               INTENT(IN)  :: Head
   REAL(8), DIMENSION(2), INTENT(IN)  :: Q

   REAL(8), DIMENSION(2)              :: V

   ! Compute the velocity
   IF( Head > Aquifer%Thickness ) THEN
      V = Q / ( Aquifer%Thickness * Aquifer%Porosity )
   ELSE
      V = Q / ( Head * Aquifer%Porosity )
   END IF

   END FUNCTION DischargeToVelocity_Aquifer

   !---------------------------------------------------------------------------
   ! ElevationToPotential_Aquifer
   !---------------------------------------------------------------------------
   FUNCTION ElevationToPotential_Aquifer( Aquifer, Z ) RESULT( Potential )

   ! Declare the arguments.
   TYPE(T_AQUIFER), INTENT(IN) :: Aquifer
   REAL(8),         INTENT(IN) :: Z

   REAL(8)                     :: Potential

   ! Compute the potential.
   Potential = HeadToPotential( Aquifer, Z-Aquifer%Base )

   END FUNCTION ElevationToPotential_Aquifer

   !---------------------------------------------------------------------------
   ! ElevationToPotentialStats_Aquifer
   !---------------------------------------------------------------------------
   SUBROUTINE ElevationToPotentialStats_Aquifer( Aquifer, Zev, Zstd, Pev, Pstd )

   ! Declare the arguments.
   TYPE(T_AQUIFER), INTENT(IN)  :: Aquifer
   REAL(8),         INTENT(IN)  :: Zev       ! expected value of piezometric elevation
   REAL(8),         INTENT(IN)  :: Zstd      ! standard deviation of piezometric elevation
   REAL(8),         INTENT(OUT) :: Pev       ! expected value of discharge potential
   REAL(8),         INTENT(OUT) :: Pstd      ! standard deviation of discharge potential

   ! Declare local variables.
   REAL(8) :: Head

   ! Compute the expected value and the standard deviation of the discharge
   ! potential from the expected value and the standard deviation of the piezometric
   ! elevation, using a first-order, second moment approximation.
   Head = Zev - Aquifer%Base

   IF( Head < Aquifer%Thickness ) THEN
      Pev = 0.5*Aquifer%Conductivity * ( Head**2 + Zstd**2 )
      Pstd = Aquifer%Conductivity * ABS(Head) * Zstd
   ELSE
      Pev = Aquifer%Conductivity * Aquifer%Thickness * ( Head - 0.5*Aquifer%Thickness )
      Pstd = Aquifer%Conductivity * Aquifer%Thickness * Zstd
   END IF

   END SUBROUTINE ElevationToPotentialStats_Aquifer

   !---------------------------------------------------------------------------
   ! HeadToPotential_Aquifer
   !---------------------------------------------------------------------------
   FUNCTION HeadToPotential_Aquifer( Aquifer, Head ) RESULT( Potential )

   ! Declare the arguments.
   TYPE(T_AQUIFER), INTENT(IN) :: Aquifer
   REAL(8),         INTENT(IN) :: Head

   REAL(8)                     :: Potential

   ! Compute the discharge potential from the given head.
   IF( Head < Aquifer%Thickness ) THEN
      Potential = 0.5*Aquifer%Conductivity * Head * Head
   ELSE
      Potential = Aquifer%Conductivity * Aquifer%Thickness * ( Head - 0.5*Aquifer%Thickness )
   END IF

   END FUNCTION HeadToPotential_Aquifer

   !---------------------------------------------------------------------------
   ! PotentialToElevation_Aquifer
   !---------------------------------------------------------------------------
   FUNCTION PotentialToElevation_Aquifer( Aquifer, Potential ) RESULT( Elevation )

   ! Declare the arguments.
   TYPE(T_AQUIFER), INTENT(IN) :: Aquifer
   REAL(8),         INTENT(IN) :: Potential

   REAL(8)                     :: Elevation

   ! Compute the elevation.
   Elevation = PotentialToHead( Aquifer, Potential ) + Aquifer%Base

   END FUNCTION PotentialToElevation_Aquifer

   !---------------------------------------------------------------------------
   ! PotentialToHead_Aquifer
   !
   ! Notes:
   !
   ! o   A negative discharge potential is returned as a 0 head.
   !---------------------------------------------------------------------------
   FUNCTION PotentialToHead_Aquifer( Aquifer, Potential ) RESULT( Head )

   ! Declare the arguments.
   TYPE(T_AQUIFER), INTENT(IN) :: Aquifer
   REAL(8),         INTENT(IN) :: Potential

   REAL(8)                     :: Head

   ! Declare local variables.
   REAL(8) :: Term

   ! Compute the head from the given discharge potential.
   Term = 0.5 * Aquifer%Conductivity * Aquifer%Thickness**2

   IF( Potential < EPSILON(1.0_8) ) THEN
      Head = -1
   ELSE IF( Potential < Term ) THEN
      Head = SQRT( 2*Potential / Aquifer%Conductivity )
   ELSE
      Head  = ( Potential + Term ) / ( Aquifer%Conductivity * Aquifer%Thickness )
   END IF

   END FUNCTION PotentialToHead_Aquifer

   !---------------------------------------------------------------------------
   ! Reset_Aquifer
   !---------------------------------------------------------------------------
   SUBROUTINE Reset_Aquifer( Aquifer )

   ! Declare the arguments.
   TYPE(T_AQUIFER), INTENT(INOUT) :: Aquifer

   ! Reset the parameters the defaults.
   Aquifer%Base         = 0
   Aquifer%Thickness    = INFINITY
   Aquifer%Porosity     = -1
   Aquifer%Conductivity = 1

   END SUBROUTINE Reset_Aquifer

   !---------------------------------------------------------------------------
   ! SetBase_Aquifer
   !---------------------------------------------------------------------------
   SUBROUTINE SetBase_Aquifer( Aquifer, Base )

   ! Declare the arguments.
   TYPE(T_AQUIFER), INTENT(INOUT) :: Aquifer
   REAL(8),         INTENT(IN)    :: Base

   ! Set the conductivity.
   Aquifer%Base = Base

   END SUBROUTINE SetBase_Aquifer

   !---------------------------------------------------------------------------
   ! SetConductivity_Aquifer
   !---------------------------------------------------------------------------
   SUBROUTINE SetConductivity_Aquifer( Aquifer, Conductivity )

   ! Declare the arguments.
   TYPE(T_AQUIFER), INTENT(INOUT) :: Aquifer
   REAL(8),         INTENT(IN)    :: Conductivity

   ! Set the conductivity.
   Aquifer%Conductivity = Conductivity

   END SUBROUTINE SetConductivity_Aquifer

   !---------------------------------------------------------------------------
   ! SetPorosity_Aquifer
   !---------------------------------------------------------------------------
   SUBROUTINE SetPorosity_Aquifer( Aquifer, Porosity )

   ! Declare the arguments.
   TYPE(T_AQUIFER), INTENT(INOUT) :: Aquifer
   REAL(8),         INTENT(IN)    :: Porosity

   ! Set the conductivity.
   Aquifer%Porosity = Porosity

   END SUBROUTINE SetPorosity_Aquifer

   !---------------------------------------------------------------------------
   ! SetThickness_Aquifer
   !---------------------------------------------------------------------------
   SUBROUTINE SetThickness_Aquifer( Aquifer, Thickness )

   ! Declare the arguments.
   TYPE(T_AQUIFER), INTENT(INOUT) :: Aquifer
   REAL(8),         INTENT(IN)    :: Thickness

   ! Set the conductivity.
   Aquifer%Thickness = Thickness

   END SUBROUTINE SetThickness_Aquifer

!==============================================================================
END MODULE AQUIFER_MODULE
!==============================================================================


            program main
            DOUBLE precision A(2048,2048), B(2048,2048), C(2048,2048),alpha,beta
            integer i, j
            M = 2048
            N = 2048
            K = 2048
            LDA = 2048
            LDB = 2048
            LDC = 2048
            alpha = 1.0
            beta = 1.0

            do i = 1, 2048
            do j = 1, 2048
            a(i,j) = i;
            b(i,j) = j;
            c(i,j) = 0
            end do
            end do

            CALL DGEMM('T','N',M,N,K,alpha,A,LDA,B,LDB,beta,C,LDC)

            end


!-----------------------------------------------------------------------
!
! Header with QFunctions
!
      include 't502-operator-f.h'
!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceed/fortran.h'

      integer ceed,err,i,j
      integer stridesu_small(3),stridesu_large(3)
      integer erestrictx,erestrictu
      integer erestrictui_small,erestrictui_large
      integer bx_small,bu_small,bx_large,bu_large
      integer qf_setup,qf_mass
      integer op_setup_small,op_mass_small,op_setup_large,op_mass_large
      integer qdata_small,qdata_large,x,u,v
      integer nelem,p,q,scale
      parameter(nelem=15)
      parameter(p=5)
      parameter(q=8)
      parameter(scale=3)
      integer nx,nu
      parameter(nx=nelem+1)
      parameter(nu=nelem*(p-1)+1)
      integer indx(nelem*2)
      integer indu(nelem*p)
      real*8 arrx(nx)
      integer*8 voffset,xoffset

      real*8 hu(nu*2),hv(nu*2)
      real*8 total1,total2

      character arg*32

      external setup,mass

      call getarg(1,arg)
      call ceedinit(trim(arg)//char(0),ceed,err)

      do i=0,nx-1
        arrx(i+1)=i/(nx-1.d0)
      enddo
      do i=0,nelem-1
        indx(2*i+1)=i
        indx(2*i+2)=i+1
      enddo

      call ceedelemrestrictioncreate(ceed,nelem,2,1,1,nx,ceed_mem_host,&
     & ceed_use_pointer,indx,erestrictx,err)

      do i=0,nelem-1
        do j=0,p-1
          indu(p*i+j+1)=2*(i*(p-1)+j)
        enddo
      enddo

      call ceedelemrestrictioncreate(ceed,nelem,p,2,1,2*nu,ceed_mem_host,&
     & ceed_use_pointer,indu,erestrictu,err)
      stridesu_small=[1,q,q]
      call ceedelemrestrictioncreatestrided(ceed,nelem,q,1,q*nelem,&
     & stridesu_small,erestrictui_small,err)
      stridesu_large=[1,q*scale,q*scale]
      call ceedelemrestrictioncreatestrided(ceed,nelem,q*scale,1,&
     & q*nelem*scale,stridesu_large,erestrictui_large,err)

      call ceedbasiscreatetensorh1lagrange(ceed,1,1,2,q,ceed_gauss,bx_small,err)
      call ceedbasiscreatetensorh1lagrange(ceed,1,2,p,q,ceed_gauss,bu_small,err)
      call ceedbasiscreatetensorh1lagrange(ceed,1,1,2,q*scale,&
     & ceed_gauss,bx_large,err)
      call ceedbasiscreatetensorh1lagrange(ceed,1,2,p,q*scale,&
     & ceed_gauss,bu_large,err)

! Common QFunctions

      call ceedqfunctioncreateinterior(ceed,1,setup,&
     &SOURCE_DIR&
     &//'t502-operator.h:setup'//char(0),qf_setup,err)
      call ceedqfunctionaddinput(qf_setup,'weight',1,ceed_eval_weight,err)
      call ceedqfunctionaddinput(qf_setup,'x',1,ceed_eval_grad,err)
      call ceedqfunctionaddoutput(qf_setup,'rho',1,ceed_eval_none,err)

      call ceedqfunctioncreateinterior(ceed,1,mass,&
     &SOURCE_DIR&
     &//'t502-operator.h:mass'//char(0),qf_mass,err)
      call ceedqfunctionaddinput(qf_mass,'rho',1,ceed_eval_none,err)
      call ceedqfunctionaddinput(qf_mass,'u',2,ceed_eval_interp,err)
      call ceedqfunctionaddoutput(qf_mass,'v',2,ceed_eval_interp,err)

      call ceedvectorcreate(ceed,nx,x,err)
      xoffset=0
      call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,arrx,xoffset,err)

! Small operator

      call ceedoperatorcreate(ceed,qf_setup,ceed_qfunction_none,&
     & ceed_qfunction_none,op_setup_small,err)
      call ceedoperatorcreate(ceed,qf_mass,ceed_qfunction_none,&
     & ceed_qfunction_none,op_mass_small,err)

      call ceedvectorcreate(ceed,nelem*q,qdata_small,err)

      call ceedoperatorsetfield(op_setup_small,'weight',&
     & ceed_elemrestriction_none,bx_small,ceed_vector_none,err)
      call ceedoperatorsetfield(op_setup_small,'x',erestrictx,&
     & bx_small,ceed_vector_active,err)
      call ceedoperatorsetfield(op_setup_small,'rho',erestrictui_small,&
     & ceed_basis_collocated,ceed_vector_active,err)
      call ceedoperatorsetfield(op_mass_small,'rho',erestrictui_small,&
     & ceed_basis_collocated,qdata_small,err)
      call ceedoperatorsetfield(op_mass_small,'u',erestrictu,&
     & bu_small,ceed_vector_active,err)
      call ceedoperatorsetfield(op_mass_small,'v',erestrictu,&
     & bu_small,ceed_vector_active,err)

! Large operator

      call ceedoperatorcreate(ceed,qf_setup,ceed_qfunction_none,&
     & ceed_qfunction_none,op_setup_large,err)
      call ceedoperatorcreate(ceed,qf_mass,ceed_qfunction_none,&
     & ceed_qfunction_none,op_mass_large,err)

      call ceedvectorcreate(ceed,nelem*q*scale,qdata_large,err)

      call ceedoperatorsetfield(op_setup_large,'weight',&
     & ceed_elemrestriction_none,bx_large,ceed_vector_none,err)
      call ceedoperatorsetfield(op_setup_large,'x',erestrictx,&
     & bx_large,ceed_vector_active,err)
      call ceedoperatorsetfield(op_setup_large,'rho',erestrictui_large,&
     & ceed_basis_collocated,ceed_vector_active,err)
      call ceedoperatorsetfield(op_mass_large,'rho',erestrictui_large,&
     & ceed_basis_collocated,qdata_large,err)
      call ceedoperatorsetfield(op_mass_large,'u',erestrictu,&
     & bu_large,ceed_vector_active,err)
      call ceedoperatorsetfield(op_mass_large,'v',erestrictu,&
     & bu_large,ceed_vector_active,err)

! Setup U, V

      call ceedvectorcreate(ceed,2*nu,u,err)
      call ceedvectorgetarraywrite(u,ceed_mem_host,hu,voffset,err)
      do i=1,nu
        hu(voffset+2*i-1)=1.
        hu(voffset+2*i)=2.
      enddo
      call ceedvectorrestorearray(u,hu,voffset,err)
      call ceedvectorcreate(ceed,2*nu,v,err)

! Small apply

      call ceedoperatorapply(op_setup_small,x,qdata_small,&
     & ceed_request_immediate,err)
      call ceedoperatorapply(op_mass_small,u,v,ceed_request_immediate,err)

      call ceedvectorgetarrayread(v,ceed_mem_host,hv,voffset,err)
      total1=0.
      total2=0.
      do i=1,nu
        total1=total1+hv(voffset+2*i-1)
        total2=total2+hv(voffset+2*i)
      enddo
      if (abs(total1-1.)>1.0d-10) then
! LCOV_EXCL_START
        write(*,*) 'Computed Area: ',total1,' != True Area: 1.0'
! LCOV_EXCL_STOP
      endif
      if (abs(total2-2.)>1.0d-10) then
! LCOV_EXCL_START
        write(*,*) 'Computed Area: ',total2,' != True Area: 2.0'
! LCOV_EXCL_STOP
      endif
      call ceedvectorrestorearrayread(v,hv,voffset,err)

! Large apply

      call ceedoperatorapply(op_setup_large,x,qdata_large,&
     & ceed_request_immediate,err)
      call ceedoperatorapply(op_mass_large,u,v,ceed_request_immediate,err)

      call ceedvectorgetarrayread(v,ceed_mem_host,hv,voffset,err)
      total1=0.
      total2=0.
      do i=1,nu
        total1=total1+hv(voffset+2*i-1)
        total2=total2+hv(voffset+2*i)
      enddo
      if (abs(total1-1.)>1.0d-10) then
! LCOV_EXCL_START
        write(*,*) 'Computed Area: ',total1,' != True Area: 1.0'
! LCOV_EXCL_STOP
      endif
      if (abs(total2-2.)>1.0d-10) then
! LCOV_EXCL_START
        write(*,*) 'Computed Area: ',total2,' != True Area: 2.0'
! LCOV_EXCL_STOP
      endif
      call ceedvectorrestorearrayread(v,hv,voffset,err)

      call ceedvectordestroy(qdata_small,err)
      call ceedvectordestroy(qdata_large,err)
      call ceedvectordestroy(x,err)
      call ceedvectordestroy(u,err)
      call ceedvectordestroy(v,err)
      call ceedoperatordestroy(op_mass_small,err)
      call ceedoperatordestroy(op_setup_small,err)
      call ceedoperatordestroy(op_mass_large,err)
      call ceedoperatordestroy(op_setup_large,err)
      call ceedqfunctiondestroy(qf_mass,err)
      call ceedqfunctiondestroy(qf_setup,err)
      call ceedbasisdestroy(bu_small,err)
      call ceedbasisdestroy(bx_small,err)
      call ceedbasisdestroy(bu_large,err)
      call ceedbasisdestroy(bx_large,err)
      call ceedelemrestrictiondestroy(erestrictu,err)
      call ceedelemrestrictiondestroy(erestrictx,err)
      call ceedelemrestrictiondestroy(erestrictui_small,err)
      call ceedelemrestrictiondestroy(erestrictui_large,err)
      call ceeddestroy(ceed,err)
      end
!-----------------------------------------------------------------------


c Find specified value in ordered integer vector

	integer function ifindi(n, ia, iv)

	implicit none

c	Parameters:
	integer		n
	integer		ia(n)	! [1..n] Vector to search
	integer		iv	! Value to find

c	Local variables:
	integer		i
	integer		k	! 2^(no. of chops)

      if (n.le.0) then
         ifindi = 0
         return
      endif

      if (iv.lt.ia(1) .or. iv.gt.ia(n)) then
c        Outside range of vector
         ifindi=0
         return
      endif

      k = 2
      i = nint(real(n)/k)
10    if (k.gt.2*n) then
c        Value not in vector
         ifindi = 0
         return
      endif
      k = k*2
      if (iv.lt.ia(i)) then
c        Value smaller:  Search below
         i = i-nint(real(n)/k)
         goto 10
      endif
      if (iv.gt.ia(i)) then
c        Value larger:  Search above
         i = i+nint(real(n)/k)
         goto 10
      endif

c     Value found: iv == ia[i]
      ifindi = i
      return
      end


      SUBROUTINE EZFFTF (N,R,AZERO,A,B,WSAVE)
C
C                       VERSION 3  JUNE 1979
C
      DIMENSION       R(1)       ,A(1)       ,B(1)       ,WSAVE(1)
      IF (N-2) 101,102,103
  101 AZERO = R(1)
      RETURN
  102 AZERO = .5*(R(1)+R(2))
      A(1) = .5*(R(1)-R(2))
      RETURN
  103 DO 104 I=1,N
         WSAVE(I) = R(I)
  104 CONTINUE
      CALL RFFTF (N,WSAVE,WSAVE(N+1))
      CF = 2./FLOAT(N)
      CFM = -CF
      AZERO = .5*CF*WSAVE(1)
      NS2 = (N+1)/2
      NS2M = NS2-1
      DO 105 I=1,NS2M
         A(I) = CF*WSAVE(2*I)
         B(I) = CFM*WSAVE(2*I+1)
  105 CONTINUE
      IF (MOD(N,2) .EQ. 1) RETURN
      A(NS2) = .5*CF*WSAVE(N)
      B(NS2) = 0.
      RETURN
      END


C
C ------------------------------------------------------------------
C
      SUBROUTINE DMVPC(NBLOCK, BET, MAXJ, J, S, NUMBER, RESNRM,
     *     ORTHCF, RV)
C
      INTEGER NBLOCK, MAXJ, J, NUMBER
      DOUBLE PRECISION BET(NBLOCK,1), S(MAXJ,1), RESNRM(1),
     *     ORTHCF(1), RV(1)
C
C THIS SUBROUTINE COMPUTES THE NORM AND THE SMALLEST ELEMENT
C (IN ABSOLUTE VALUE) OF THE VECTOR BET*SJI, WHERE SJI
C IS AN NBLOCK VECTOR OF THE LAST NBLOCK ELEMENTS OF THE ITH
C EIGENVECTOR OF T.  THESE QUANTITIES ARE THE RESIDUAL NORM
C AND THE ORTHOGONALITY COEFFICIENT RESPECTIVELY FOR THE
C CORRESPONDING RITZ PAIR.  THE ORTHOGONALITY COEFFICIENT IS
C NORMALIZED TO ACCOUNT FOR THE LOCAL REORTHOGONALIZATION.
C
      INTEGER I, K, M
      DOUBLE PRECISION DDOT, DNRM2, DABS, DMIN1
C
      M = J - NBLOCK + 1
      DO 20 I=1,NUMBER
         DO 10 K=1,NBLOCK
            RV(K) = DDOT(NBLOCK,S(M,I),1,BET(K,1),NBLOCK)
            IF (K.EQ.1) ORTHCF(I) = DABS(RV(K))
            ORTHCF(I) = DMIN1(ORTHCF(I),DABS(RV(K)))
   10    CONTINUE
         RESNRM(I) = DNRM2(NBLOCK,RV,1)
   20 CONTINUE
      RETURN
      END