!-----------------------------------------------------------------------
!
! Header with common subroutine
!
      include 't320-basis-f.h'
!
! Header with QFunctions
!
      include 't510-operator-f.h'
!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceed/fortran.h'

      integer ceed,err,i,j,k
      integer stridesutet(3),stridesuhex(3)
      integer erestrictxtet,erestrictutet,erestrictuitet,&
&             erestrictxhex,erestrictuhex,erestrictuihex
      integer bxtet,butet,bxhex,buhex
      integer qf_setuptet,qf_masstet,qf_setuphex,qf_masshex
      integer op_setuptet,op_masstet,op_setuphex,op_masshex,op_setup,op_mass
      integer qdatatet,qdatahex,x,u,v
      integer nelemtet,nelemhex,ptet,phex,qtet,qhex,d
      integer row,col,offset
      parameter(nelemtet=6)
      parameter(ptet=6)
      parameter(qtet=4)
      parameter(nelemhex=6)
      parameter(phex=3)
      parameter(qhex=4)
      parameter(d=2)
      integer ndofs,nqptstet,nqptshex,nqpts,nx,ny,nxtet,nytet,nxhex
      parameter(nx=3)
      parameter(ny=3)
      parameter(nxtet=3)
      parameter(nytet=1)
      parameter(nxhex=3)
      parameter(ndofs=(nx*2+1)*(ny*2+1))
      parameter(nqptstet=nelemtet*qtet)
      parameter(nqptshex=nelemhex*qhex*qhex)
      parameter(nqpts=nqptstet+nqptshex)
      integer indxtet(nelemtet*ptet),indxhex(nelemhex*phex*phex)
      real*8 arrx(d*ndofs)
      integer*8 voffset,xoffset

      real*8 qref(d*qtet)
      real*8 qweight(qtet)
      real*8 interp(ptet*qtet)
      real*8 grad(d*ptet*qtet)

      real*8 hv(ndofs)
      real*8 total

      character arg*32

      external setup,mass

      call getarg(1,arg)

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

! DoF Coordinates
      do i=0,ny*2
        do j=0,nx*2
          arrx(i+j*(ny*2+1)+0*ndofs+1)=1.d0*i/(2*ny)
          arrx(i+j*(ny*2+1)+1*ndofs+1)=1.d0*j/(2*nx)
        enddo
      enddo

      call ceedvectorcreate(ceed,d*ndofs,x,err)
      xoffset=0
      call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,arrx,xoffset,err)

! Qdata Vectors
      call ceedvectorcreate(ceed,nqptstet,qdatatet,err)
      call ceedvectorcreate(ceed,nqptshex,qdatahex,err)

! Tet Elements
      do i=0,2
        col=mod(i,nx)
        row=i/nx
        offset=col*2+row*(nx*2+1)*2

        indxtet(i*2*ptet+1)=2+offset
        indxtet(i*2*ptet+2)=9+offset
        indxtet(i*2*ptet+3)=16+offset
        indxtet(i*2*ptet+4)=1+offset
        indxtet(i*2*ptet+5)=8+offset
        indxtet(i*2*ptet+6)=0+offset

        indxtet(i*2*ptet+7)=14+offset
        indxtet(i*2*ptet+8)=7+offset
        indxtet(i*2*ptet+9)=0+offset
        indxtet(i*2*ptet+10)=15+offset
        indxtet(i*2*ptet+11)=8+offset
        indxtet(i*2*ptet+12)=16+offset
      enddo

! -- Restrictions
      call ceedelemrestrictioncreate(ceed,nelemtet,ptet,d,ndofs,d*ndofs,&
     & ceed_mem_host,ceed_use_pointer,indxtet,erestrictxtet,err)

      call ceedelemrestrictioncreate(ceed,nelemtet,ptet,1,1,ndofs,&
     & ceed_mem_host,ceed_use_pointer,indxtet,erestrictutet,err)
      stridesutet=[1,qtet,qtet]
      call ceedelemrestrictioncreatestrided(ceed,nelemtet,qtet,1,nqptstet,&
     & stridesutet,erestrictuitet,err)

! -- Bases
      call buildmats(qref,qweight,interp,grad)
      call ceedbasiscreateh1(ceed,ceed_triangle,d,ptet,qtet,interp,grad,qref,&
     & qweight,bxtet,err)
      call buildmats(qref,qweight,interp,grad)
      call ceedbasiscreateh1(ceed,ceed_triangle,1,ptet,qtet,interp,grad,qref,&
     & qweight,butet,err)

! -- QFunctions
      call ceedqfunctioncreateinterior(ceed,1,setup,&
     &SOURCE_DIR&
     &//'t510-operator.h:setup'//char(0),qf_setuptet,err)
      call ceedqfunctionaddinput(qf_setuptet,'weight',1,ceed_eval_weight,err)
      call ceedqfunctionaddinput(qf_setuptet,'dx',d*d,ceed_eval_grad,err)
      call ceedqfunctionaddoutput(qf_setuptet,'rho',1,ceed_eval_none,err)

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

! -- Operators
! ---- Setup Tet
      call ceedoperatorcreate(ceed,qf_setuptet,ceed_qfunction_none,&
     & ceed_qfunction_none,op_setuptet,err)
      call ceedoperatorsetfield(op_setuptet,'weight',&
     & ceed_elemrestriction_none,bxtet,ceed_vector_none,err)
      call ceedoperatorsetfield(op_setuptet,'dx',erestrictxtet,&
     & bxtet,ceed_vector_active,err)
      call ceedoperatorsetfield(op_setuptet,'rho',erestrictuitet,&
     & ceed_basis_collocated,qdatatet,err)
! ---- Mass Tet
      call ceedoperatorcreate(ceed,qf_masstet,ceed_qfunction_none,&
     & ceed_qfunction_none,op_masstet,err)
      call ceedoperatorsetfield(op_masstet,'rho',erestrictuitet,&
     & ceed_basis_collocated,qdatatet,err)
      call ceedoperatorsetfield(op_masstet,'u',erestrictutet,&
     & butet,ceed_vector_active,err)
      call ceedoperatorsetfield(op_masstet,'v',erestrictutet,&
     & butet,ceed_vector_active,err)

! Hex Elements
      do i=0,nelemhex-1
        col=mod(i,nx)
        row=i/nx
        offset=(nxtet*2+1)*(nytet*2)*(1+row)+col*2
        do j=0,phex-1
          do k=0,phex-1
            indxhex(phex*(phex*i+k)+j+1)=offset+k*(nxhex*2+1)+j
          enddo
        enddo
      enddo

! -- Restrictions
      call ceedelemrestrictioncreate(ceed,nelemhex,phex*phex,d,ndofs,d*ndofs,&
     & ceed_mem_host,ceed_use_pointer,indxhex,erestrictxhex,err)

      call ceedelemrestrictioncreate(ceed,nelemhex,phex*phex,1,1,ndofs,&
     & ceed_mem_host,ceed_use_pointer,indxhex,erestrictuhex,err)
      stridesuhex=[1,qhex*qhex,qhex*qhex]
      call ceedelemrestrictioncreatestrided(ceed,nelemhex,qhex*qhex,&
     & 1,nqptshex,stridesuhex,erestrictuihex,err)

! -- Bases
      call ceedbasiscreatetensorh1lagrange(ceed,d,d,phex,qhex,ceed_gauss,&
     & bxhex,err)
      call ceedbasiscreatetensorh1lagrange(ceed,d,1,phex,qhex,ceed_gauss,&
     & buhex,err)

! -- QFunctions
      call ceedqfunctioncreateinterior(ceed,1,setup,&
     &SOURCE_DIR&
     &//'t510-operator.h:setup'//char(0),qf_setuphex,err)
      call ceedqfunctionaddinput(qf_setuphex,'_weight',1,ceed_eval_weight,err)
      call ceedqfunctionaddinput(qf_setuphex,'dx',d*d,ceed_eval_grad,err)
      call ceedqfunctionaddoutput(qf_setuphex,'rho',1,ceed_eval_none,err)

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

! -- Operators
! ---- Setup Hex
      call ceedoperatorcreate(ceed,qf_setuphex,ceed_qfunction_none,&
     & ceed_qfunction_none,op_setuphex,&
     & err)
      call ceedoperatorsetfield(op_setuphex,'_weight',&
     & ceed_elemrestriction_none,bxhex,ceed_vector_none,err)
      call ceedoperatorsetfield(op_setuphex,'dx',erestrictxhex,&
     & bxhex,ceed_vector_active,err)
      call ceedoperatorsetfield(op_setuphex,'rho',erestrictuihex,&
     & ceed_basis_collocated,qdatahex,err)
! ---- Mass Hex
      call ceedoperatorcreate(ceed,qf_masshex,ceed_qfunction_none,&
     & ceed_qfunction_none,op_masshex,&
     & err)
      call ceedoperatorsetfield(op_masshex,'rho',erestrictuihex,&
     & ceed_basis_collocated,qdatahex,err)
      call ceedoperatorsetfield(op_masshex,'u',erestrictuhex,&
     & buhex,ceed_vector_active,err)
      call ceedoperatorsetfield(op_masshex,'v',erestrictuhex,&
     & buhex,ceed_vector_active,err)

! Composite Operators
      call ceedcompositeoperatorcreate(ceed,op_setup,err)
      call ceedcompositeoperatoraddsub(op_setup,op_setuptet,err)
      call ceedcompositeoperatoraddsub(op_setup,op_setuphex,err)

      call ceedcompositeoperatorcreate(ceed,op_mass,err)
      call ceedcompositeoperatoraddsub(op_mass,op_masstet,err)
      call ceedcompositeoperatoraddsub(op_mass,op_masshex,err)

! Apply Setup Operator
      call ceedoperatorapply(op_setup,x,ceed_vector_none,&
     & ceed_request_immediate,err)

! Apply Mass Operator
      call ceedvectorcreate(ceed,ndofs,u,err)
      call ceedvectorsetvalue(u,1.d0,err)
      call ceedvectorcreate(ceed,ndofs,v,err)
      call ceedvectorsetvalue(v,0.d0,err)

      call ceedoperatorapplyadd(op_mass,u,v,ceed_request_immediate,err)

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

      call ceedvectorsetvalue(v,1.d0,err)
      call ceedoperatorapplyadd(op_mass,u,v,ceed_request_immediate,err)

! Check Output
      call ceedvectorgetarrayread(v,ceed_mem_host,hv,voffset,err)
      total=-ndofs
      do i=1,ndofs
        total=total+hv(voffset+i)
      enddo
      if (abs(total-1.)>1.0d-10) then
! LCOV_EXCL_START
        write(*,*) 'Computed Area: ',total,' != True Area: 1.0'
! LCOV_EXCL_STOP
      endif
      call ceedvectorrestorearrayread(v,hv,voffset,err)

! Cleanup
      call ceedqfunctiondestroy(qf_setuptet,err)
      call ceedqfunctiondestroy(qf_masstet,err)
      call ceedoperatordestroy(op_setuptet,err)
      call ceedoperatordestroy(op_masstet,err)
      call ceedqfunctiondestroy(qf_setuphex,err)
      call ceedqfunctiondestroy(qf_masshex,err)
      call ceedoperatordestroy(op_setuphex,err)
      call ceedoperatordestroy(op_masshex,err)
      call ceedoperatordestroy(op_setup,err)
      call ceedoperatordestroy(op_mass,err)
      call ceedelemrestrictiondestroy(erestrictutet,err)
      call ceedelemrestrictiondestroy(erestrictxtet,err)
      call ceedelemrestrictiondestroy(erestrictuitet,err)
      call ceedelemrestrictiondestroy(erestrictuhex,err)
      call ceedelemrestrictiondestroy(erestrictxhex,err)
      call ceedelemrestrictiondestroy(erestrictuihex,err)
      call ceedbasisdestroy(butet,err)
      call ceedbasisdestroy(bxtet,err)
      call ceedbasisdestroy(buhex,err)
      call ceedbasisdestroy(bxhex,err)
      call ceedvectordestroy(x,err)
      call ceedvectordestroy(u,err)
      call ceedvectordestroy(v,err)
      call ceedvectordestroy(qdatatet,err)
      call ceedvectordestroy(qdatahex,err)
      call ceeddestroy(ceed,err)
      end
!-----------------------------------------------------------------------


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     subroutine dmatinv: invert a quadratic matrix, needed
!        during QMDFF fit
!
!     part of QMDFF
!

subroutine dmatinv (A,LDM,N,D)
IMPLICIT NONE
!
!     *** Deklaration globaler Variablen ***
!
INTEGER, INTENT(IN) :: LDM, N
REAL*8, INTENT(OUT)   :: D
REAL*8, INTENT(INOUT) :: A(LDM,*)
!
!     *** Deklaration lokaler Variablen ***
!
INTEGER             :: I, J, K, L(N), M(N)
REAL*8                :: BIGA, TEMP
REAL*8, PARAMETER     :: TOL = 1.0D-12

D = 1.0
DO K = 1, N
   L(K) = K
   M(K) = K
   BIGA = A(K,K)
   DO J = K, N
      DO I = K, N
         IF ( ABS(BIGA).LT.ABS(A(J,I)) ) THEN
            BIGA = A(J,I)
            L(K) = I
            M(K) = J
         END IF
      END DO
   END DO
   J = L(K)
   IF ( J.GT.K ) THEN
      DO I = 1, N
         TEMP = -A(I,K)
         A(I,K) = A(I,J)
         A(I,J) = TEMP
      END DO
   END IF
   I = M(K)
   IF ( I.GT.K ) THEN
      DO J = 1, N
         TEMP = -A(K,J)
         A(K,J) = A(I,J)
         A(I,J) = TEMP
      END DO
   END IF
   IF ( ABS(BIGA).LT.TOL ) THEN
      D = 0.0
      RETURN
   END IF
   DO I = 1, N
      IF ( I.NE.K ) A(K,I) = A(K,I)/(-BIGA)
   END DO
   DO I = 1, N
      DO J = 1, N
         IF ( I.NE.K ) THEN
            IF ( J.NE.K ) A(J,I) = A(K,I)*A(J,K) + A(J,I)
         END IF
      END DO
   END DO
   DO J = 1, N
      IF ( J.NE.K ) A(J,K) = A(J,K)/BIGA
   END DO
   D = MAX(-1.0D25,MIN(1.0D25,D))
   D = D*BIGA
   A(K,K) = 1.0/BIGA
END DO

K = N
!
!     write matrix A for output
!
DO
   K = K - 1
   IF ( K.LE.0 ) EXIT
   I = L(K)
   IF ( I.GT.K ) THEN
      DO J = 1, N
         TEMP = A(K,J)
         A(K,J) = -A(I,J)
         A(I,J) = TEMP
      END DO
   END IF
   J = M(K)
   IF ( J.GT.K ) THEN
      DO I = 1, N
         TEMP = A(I,K)
         A(I,K) = -A(I,J)
         A(I,J) = TEMP
      END DO
   END IF
END DO

return
end subroutine dmatinv


      SUBROUTINE CGERU( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
*
*  -- Automatically Tuned Linear Algebra Software (ATLAS)
*     (C) Copyright 2000 All Rights Reserved
*
*  -- ATLAS routine -- F77 Interface -- Version 3.9.24 -- December 25, 2000
*
*  Author         : Antoine P. Petitet
*  Originally developed at the University of Tennessee,
*  Innovative Computing Laboratory,  Knoxville TN, 37996-1301, USA.
*
*  ---------------------------------------------------------------------
*
*  -- Copyright notice and Licensing terms:
*
*  Redistribution  and  use in  source and binary forms, with or without
*  modification, are  permitted provided  that the following  conditions
*  are met:
*
*  1. Redistributions  of  source  code  must retain the above copyright
*     notice, this list of conditions and the following disclaimer.
*  2. Redistributions in binary form must reproduce  the above copyright
*     notice,  this list of conditions, and the  following disclaimer in
*     the documentation and/or other materials provided with the distri-
*     bution.
*  3. The name of the University,  the ATLAS group,  or the names of its
*     contributors  may not be used to endorse or promote products deri-
*     ved from this software without specific written permission.
*
*  -- Disclaimer:
*
*  THIS  SOFTWARE  IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
*  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,  INCLUDING,  BUT NOT
*  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
*  A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY
*  OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,  INDIRECT, INCIDENTAL, SPE-
*  CIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
*  TO,  PROCUREMENT  OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
*  OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEO-
*  RY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT  (IN-
*  CLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
*  THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*  ---------------------------------------------------------------------
*
*     .. Scalar Arguments ..
      INTEGER            INCX, INCY, LDA, M, N
      COMPLEX            ALPHA
*     ..
*     .. Array Arguments ..
      COMPLEX            A( LDA, * ), X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  CGERU performs the rank 1 operation
*
*     A := alpha*x*y' + A,
*
*  where alpha is a scalar,  x is an m-element vector, y is an n-element
*  vector and A is an m by n matrix.
*
*  Arguments
*  =========
*
*  M       (input)                       INTEGER
*          On entry,  M  specifies the number of rows of  the matrix  A.
*          M must be at least zero. Unchanged on exit.
*
*  N       (input)                       INTEGER
*          On entry, N  specifies the number of columns of the matrix A.
*          N  must be at least zero. Unchanged on exit.
*
*  ALPHA   (input)                       COMPLEX
*          On entry, ALPHA specifies the scalar alpha.   When  ALPHA  is
*          supplied as zero then the arrays X and Y need not be set on
*          input. Unchanged on exit.
*
*  X       (input)                       COMPLEX array
*          On entry,  X  is an incremented array of dimension  at  least
*          ( 1 + ( m - 1 ) * abs( INCX ) ).  Before entry, the incremen-
*          ted array X must contain the vector x. Unchanged on exit.
*
*  INCX    (input)                       INTEGER
*          On entry, INCX specifies the increment for the elements of X.
*          INCX must not be zero. Unchanged on exit.
*
*  Y       (input)                       COMPLEX array
*          On entry,  Y  is an incremented array of dimension  at  least
*          ( 1 + ( n - 1 ) * abs( INCY ) ).  Before entry, the incremen-
*          ted array Y must contain the vector y. Unchanged on exit.
*
*  INCY    (input)                       INTEGER
*          On entry, INCY specifies the increment for the elements of Y.
*          INCY must not be zero. Unchanged on exit.
*
*  A       (input/output)                COMPLEX array
*          On entry,  A  is an array of DIMENSION ( LDA, n ). Before en-
*          try, the leading m by n part of the array  A must contain the
*          matrix coefficients. On exit, A is overwritten by the updated
*          matrix.
*
*  LDA     (input)                       INTEGER
*          On entry, LDA  specifies the first dimension of A as declared
*          in the calling (sub) program. LDA must be at least  max(1,m).
*          Unchanged on exit.
*
*  Further Details
*  ===============
*
*  For further information on the Level 1 BLAS specification, see:
*
*  ``A Proposal for Standard Linear Algebra Subprograms''  by R. Hanson,
*  F. Krogh and C. Lawson, ACM SIGNUM Newsl., 8(16), 1973,
*
*  ``Basic Linear Algebra Subprograms for Fortran Usage''  by C. Lawson,
*  R. Hanson, D. Kincaid and F. Krogh,  ACM Transactions on Mathematical
*  Software, 5(3) pp 308-323, 1979.
*
*  For further information on the Level 2 BLAS specification, see:
*
*  ``An  Extended Set of  FORTRAN  Basic Linear Algebra Subprograms'' by
*  J. Dongarra,  J. Du Croz,  S. Hammarling and R. Hanson,  ACM Transac-
*  tions on Mathematical Software, 14(1) pp 1-17, 1988.
*
*  ``Algorithm 656: An extended Set of Basic Linear Algebra Subprograms:
*  Model Implementation and Test Programs''  by J. Dongarra, J. Du Croz,
*  S. Hammarling and R. Hanson,  ACM  Transactions on Mathematical Soft-
*  ware, 14(1) pp 18-32, 1988.
*
*  For further information on the Level 3 BLAS specification, see:
*
*  ``A Set of Level 3 Basic Linear Algebra Subprograms'' by J. Dongarra,
*  J. Du Croz, I. Duff and S. Hammarling, ACM Transactions on Mathemati-
*  cal Software, 16(1), pp 1-17, 1990.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            INFO
*     ..
*     .. External Subroutines ..
      EXTERNAL           ATL_F77WRAP_CGERU, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
      INFO = 0
*
      IF(      M.LT.0 ) THEN
         INFO = 1
      ELSE IF( N.LT.0 ) THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 ) THEN
         INFO = 5
      ELSE IF( INCY.EQ.0 ) THEN
         INFO = 7
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = 9
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGERU ', INFO )
         RETURN
      END IF
*
      CALL ATL_F77WRAP_CGERU( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
*
      RETURN
*
*     End of CGERU
*
      END


SUBROUTINE DiffZuniform3D(var,varZ,order,DiffStencilArray,Nx,Ny,Nz,alpha)
! By Allan P. Engsig-Karup.
!FIXME: this script has not been tested for bugs
USE Precision
USE DataTypes
IMPLICIT NONE
INTEGER :: Nx, Ny, Nz, rank, order, alpha, i,j,k
REAL(KIND=long), DIMENSION(2*alpha+1,2*alpha+1,2) :: DiffStencilArray
REAL(KIND=long), DIMENSION(Nz,Nx,Ny) :: var, varZ
REAL(KIND=long), DIMENSION(2*alpha+1) :: Stencil
rank = 2*alpha+1
! one-sided
DO k = 1, alpha
	Stencil = DiffStencilArray(1:rank,k,order)
	DO j = 1, Ny
		DO i = 1, Nx
			varZ(k,i,j) = DOT_PRODUCT(Stencil,var(1:rank,i,j))
		END DO
	END DO
END DO
! centered
Stencil = DiffStencilArray(1:rank,alpha+1,order)
DO j = 1, Ny
	DO i = 1, Nx
		DO k = alpha+1, Nz-alpha
			varZ(k,i,j) = DOT_PRODUCT(Stencil,var(k-alpha:k+alpha,i,j))
		END DO
	END DO
END DO
! one-sided
DO k = Nz-alpha+1, Nz
	Stencil = DiffStencilArray(1:rank,2*alpha+1-(Nz-k),order)
	DO j = 1, Ny
		DO i = 1, Nx
			varZ(k,i,j) = DOT_PRODUCT(Stencil,var(Nz+1-rank:Nz,i,j))
		END DO
	END DO
END DO

END SUBROUTINE DiffZuniform3D


      FUNCTION BESSJP (N,X)
      IMPLICIT NONE
      REAL *8 X,BESSJP,BESSJ
      INTEGER N
      IF (N.EQ.0) THEN
        BESSJP=-BESSJ(1,X)
      ELSE IF(X.EQ.0.D0) THEN
        X=1.D-30
      ELSE
        BESSJP=BESSJ(N-1,X)-(DFLOAT(N)/X)*BESSJ(N,X)
      ENDIF
      RETURN
      END


      subroutine gdcp2i(n, itab, m)
c!purpose
c       decomposition of an integer n in a base tw0.
c       n=a1+a2*2+a3*2**2+.........+am*2**(m-1).
c!calling sequence
c     subroutine gdcp2i(n,itab,m)
c     integer n,itab,m
c
c        n     : integer to be decomposed (n.le.32767)
c
c        itab  :logical vector of dimension 15.
c               in output: if(a(i-1).ne.0)then itab(i)=.true.
c               else itab(i)=.false.
c
c        m     :the number of itab elements to be consider in output.
c
c!originator
c  j. hanen -september 1978-ensm-nantes.
c!
c
      dimension ipow2(15)
      logical itab(*)
c
      data ipow2(1), ipow2(2), ipow2(3), ipow2(4), ipow2(5),
     * ipow2(6), ipow2(7), ipow2(8), ipow2(9), ipow2(10),
     * ipow2(11), ipow2(12), ipow2(13), ipow2(14), ipow2(15)
     * /16384,8192,4096,2048,1024,512,256,128,64,32,16,8,4,2,1/
c
      m = 0
      k = 15
      nn = abs(n)
      if (nn.gt.32767) nn = mod(nn,32767)
      do 30 i=1,15
         if (nn.lt.ipow2(i)) go to 10
         itab(k) = .true.
         nn = nn - ipow2(i)
         if (m.eq.0) m = k
         go to 20
   10    itab(k) = .false.
   20    k = k - 1
   30 continue
c
      return
      end


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of rhof in forward (tangent) mode:
!   variations   of useful results: rhof
!   with respect to varying inputs: *temp *tsal *pres
!   Plus diff mem management of: temp:in tsal:in pres:in
! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!> @brief rhof(i,j,k,ismpl) calculates the density of the fluid (in kg/m^3),
!> @param[in] i cell index, direction I0
!> @param[in] j cell index, direction J0
!> @param[in] k cell index, direction K0
!> @param[in] ismpl local sample index
!> @return rho  [kg/m^3]
!> @details
!> rhow(i,j,k,ismpl) calculates the density in (in kg/m^3) of brine,
!> given temperature (t, in c) pressure (p,in pa), and salinity (s, in
!> mol/L) at node(i,j,k)\n
!>
!> Source:\n
!> Batzle, M., & Wang, Z., Seismic properties of pore fluids,
!> GEOPHYSICS, 57(11), 1396–1408 (1992).
!> http://dx.doi.org/10.1190/1.1443207 \n\n
!>
!>   Pressures 5-100 MPa, Temperature 20-350°C, Salinity <=320 g/L\n \n
!>
!>  CODE VERIFICATION:\n
!>   INPUT:  TEMP = 298.15K  P =0.1013 MPa  S = 0.25 g/g      OUTPUT: RHO = 1187.35 kg/m3\n
!>   INPUT:  TEMP = 393.15K  P =   30 MPa   S = 0.10 g/g      OUTPUT: RHO = 1027.06 kg/m3\n\n
!>
!> ARGUMENTS NAME    TYPE    UNITS           DESCRIPTION\n
!>     INPUT:        Temp  Real    T                 C       Temperature \n
!>                         Real    P         Pa      Pressure\n
!>                         Real    S         g/g     Salinity in mass fraction\n
!>    OUTPUT:        LABEL            RHO            Real     kg/m3  Density of brine \n
DOUBLE PRECISION FUNCTION g_RHOF(i, j, k, ismpl, rhof)
  USE ARRAYS

  USE g_ARRAYS

  USE MOD_FLOW
  IMPLICIT NONE
! Location indices
  INTEGER, INTENT(IN) :: i
  INTEGER, INTENT(IN) :: j
  INTEGER, INTENT(IN) :: k
! Sample index
  INTEGER :: ismpl
! Temperature (degC)
  DOUBLE PRECISION :: t
  DOUBLE PRECISION :: g_t
! Pressure (MPa)
  DOUBLE PRECISION :: p
  DOUBLE PRECISION :: g_p
! Salinity (mol/L)
  DOUBLE PRECISION :: s
  DOUBLE PRECISION :: g_s
! Salinity fraction (g/L)
  DOUBLE PRECISION :: sr
  DOUBLE PRECISION :: g_sr
! Molar mass of NaCl [g/mol]
! double precision, parameter :: mmnacl = 58.44277d0
  DOUBLE PRECISION, PARAMETER :: mmnacl=58.44d0
! Pure water density (kg/m3)
  DOUBLE PRECISION :: rw
  DOUBLE PRECISION :: g_rw
  DOUBLE PRECISION, EXTERNAL :: RHOW
	double precision, external :: g_rhow
! Pure water density (g/cm3)
  DOUBLE PRECISION :: rw_gcm3
  DOUBLE PRECISION :: g_rw_gcm3
! Fluid density (g/cm3)
  DOUBLE PRECISION :: rhof_gcm3
  DOUBLE PRECISION :: g_rhof_gcm3
  DOUBLE PRECISION :: temp0
  DOUBLE PRECISION :: temp1
  DOUBLE PRECISION :: rhof
! Local Temperature (degC)
  g_t = g_temp(i, j, k, ismpl)
  t = temp(i, j, k, ismpl)
! Local Pressure [MPa]
  g_p = pa_conv1*g_pres(i, j, k, ismpl)
  p = pres(i, j, k, ismpl)*pa_conv1
! Local salinity [mol/L]
  g_s = g_tsal(i, j, k, ismpl)
  s = tsal(i, j, k, ismpl)
! Pure water density [kg/m3]
  g_rw = g_RHOW(p, g_p, t, g_t, rw)
  IF (s .LE. 0.0d0) THEN
    g_rhof = g_rw
    rhof = rw
  ELSE
! mol/L (Molarity) > g/g (Mass fraCtion)
    temp0 = s/(rw+mmnacl*s)
    g_sr = mmnacl*(g_s-temp0*(g_rw+mmnacl*g_s))/(rw+mmnacl*s)
    sr = mmnacl*temp0
! Pure water density [g/cm3]
    g_rw_gcm3 = g_rw/1.0d3
    rw_gcm3 = rw/1.0d3
! Batzle, Equation (27b), densities in g/cm3
    temp0 = 3.0d0*t - 3.3d3*sr + 47.0d0*p*sr - 13.0d0*p + 80.0d0
    temp1 = 0.44d0*sr + 1.0d-6*(3.0d2*p-2.4d3*p*sr+t*temp0) + 0.668d0
    g_rhof_gcm3 = g_rw_gcm3 + temp1*g_sr + sr*(0.44d0*g_sr+&
&     1.0d-6*(3.0d2*g_p-2.4d3*(sr*g_p+p*g_sr)+temp0*g_t+t*(3.0d0&
&     *g_t-3.3d3*g_sr+47.0d0*(sr*g_p+p*g_sr)-13.0d0*g_p)))
    rhof_gcm3 = rw_gcm3 + sr*temp1
! Fluid density [kg/m3]
    g_rhof = 1.0d3*g_rhof_gcm3
    rhof = rhof_gcm3*1.0d3
  END IF
  RETURN
END FUNCTION g_RHOF


      subroutine SparseAp(iper, ilwork, iBC,  nvar,
     &                    col,  row,    lhsK, p)

C============================================================================
C
C "SparseAp": This routine performs the product of a sparsley stored matrix
C             lhsK(nvar*nvar, nnz_tot) and a vector p(nshg, nvar). The
C             results of the product is returned in p(nshg, nvar).
C
C Nahid Razmara, Spring 2000. (Sparse Matrix)
C============================================================================

c
      include "common.h"
c
c
c.... Data declaration
c
	integer	col(nshg+1),	row(nnz*nshg),
     &          iper(nshg),     ilwork(nlwork)
	real*8	lhsK(nvar*nvar,nnz_tot)
        real*8 	p(nshg,nvar),	q(nshg,nvar)
c
	real*8	tmp1,	tmp2,	tmp3,	tmp4,	tmp5
c
c.... communicate:: copy the master's portion of uBrg to each slave
c
      if (numpe > 1) then
         call commu (p, ilwork, nvar, 'out')
      endif
c
c.... local periodic boundary conditions (no communications)
c
        do j=1,nvar
           p(:,j)=p(iper(:),j)
        enddo
c
c       slave has masters value, for abc we need to rotate it
c        (if this is a vector only no SCALARS)
        if((iabc==1)) !are there any axisym bc's
     &     call rotabc(p(1,2), iBC,  'out')
c
c.... clear the vector
c
	q=zero
c
c.... Perform Matrix-Vector (AP) product
c
 	do i = 1, nshg
	    do k = col(i), col(i+1)-1
c
              j = row(k)
c
               do ii = 1, nvar
                  do jj = 1, nvar
                     id = (jj - 1) * nvar + ii
                     q(i,ii) = q(i,ii) + lhsK(id,k)*p(j,jj)
                  enddo
               enddo
c
	    enddo
	enddo

c
	p =  q
c
c
c.... -------------------->   communications <-------------------------
c
c
        if((iabc==1))           !are there any axisym bc's
     &       call rotabc(p(1,2), iBC, 'in ')
c
        if (numpe > 1) then
c
c.... send slave's copy of uBrg to the master
c
           call commu (p  , ilwork, nvar, 'in ')
c
c.... nodes treated on another processor are eliminated
c
           numtask = ilwork(1)
           itkbeg = 1

           do itask = 1, numtask

              iacc   = ilwork (itkbeg + 2)
              numseg = ilwork (itkbeg + 4)

              if (iacc .eq. 0) then
                 do is = 1,numseg
                    isgbeg = ilwork (itkbeg + 3 + 2*is)
                    lenseg = ilwork (itkbeg + 4 + 2*is)
                    isgend = isgbeg + lenseg - 1
                    p(isgbeg:isgend,:) = zero
                 enddo
              endif

              itkbeg = itkbeg + 4 + 2*numseg

           enddo
        endif
c
	return
	end


      SUBROUTINE MB01UX( SIDE, UPLO, TRANS, M, N, ALPHA, T, LDT, A, LDA,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute one of the matrix products
C
C       A : = alpha*op( T ) * A, or A : = alpha*A * op( T ),
C
C     where alpha is a scalar, A is an m-by-n matrix, T is a quasi-
C     triangular matrix, and op( T ) is one of
C
C        op( T ) = T   or   op( T ) = T',  the transpose of T.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SIDE    CHARACTER*1
C             Specifies whether the upper quasi-triangular matrix H
C             appears on the left or right in the matrix product as
C             follows:
C             = 'L':  A := alpha*op( T ) * A;
C             = 'R':  A := alpha*A * op( T ).
C
C     UPLO    CHARACTER*1.
C             Specifies whether the matrix T is an upper or lower
C             quasi-triangular matrix as follows:
C             = 'U':  T is an upper quasi-triangular matrix;
C             = 'L':  T is a lower quasi-triangular matrix.
C
C     TRANS   CHARACTER*1
C             Specifies the form of op( T ) to be used in the matrix
C             multiplication as follows:
C             = 'N':  op( T ) = T;
C             = 'T':  op( T ) = T';
C             = 'C':  op( T ) = T'.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix A.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix A.  N >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar alpha. When alpha is zero then T is not
C             referenced and A need not be set before entry.
C
C     T       (input) DOUBLE PRECISION array, dimension (LDT,k)
C             where k is M when SIDE = 'L' and is N when SIDE = 'R'.
C             On entry with UPLO = 'U', the leading k-by-k upper
C             Hessenberg part of this array must contain the upper
C             quasi-triangular matrix T. The elements below the
C             subdiagonal are not referenced.
C             On entry with UPLO = 'L', the leading k-by-k lower
C             Hessenberg part of this array must contain the lower
C             quasi-triangular matrix T. The elements above the
C             supdiagonal are not referenced.
C
C     LDT     INTEGER
C             The leading dimension of the array T.  LDT >= max(1,k),
C             where k is M when SIDE = 'L' and is N when SIDE = 'R'.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading M-by-N part of this array must
C             contain the matrix A.
C             On exit, the leading M-by-N part of this array contains
C             the computed product.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,M).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0 and ALPHA<>0,  DWORK(1)  returns the
C             optimal value of LDWORK.
C             On exit, if  INFO = -12,  DWORK(1)  returns the minimum
C             value of LDWORK.
C             This array is not referenced when alpha = 0.
C
C     LDWORK  The length of the array DWORK.
C             LDWORK >= 1,       if alpha =  0 or MIN(M,N) = 0;
C             LDWORK >= 2*(M-1), if SIDE  = 'L';
C             LDWORK >= 2*(N-1), if SIDE  = 'R'.
C             For maximal efficiency LDWORK should be at least
C             NOFF*N + M - 1,    if SIDE  = 'L';
C             NOFF*M + N - 1,    if SIDE  = 'R';
C             where NOFF is the number of nonzero elements on the
C             subdiagonal (if UPLO = 'U') or supdiagonal (if UPLO = 'L')
C             of T.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The technique used in this routine is similiar to the technique
C     used in the SLICOT [1] subroutine MB01UW developed by Vasile Sima.
C     The required matrix product is computed in two steps. In the first
C     step, the triangle of T specified by UPLO is used; in the second
C     step, the contribution of the sub-/supdiagonal is added. If the
C     workspace can accommodate parts of A, a fast BLAS 3 DTRMM
C     operation is used in the first step.
C
C     REFERENCES
C
C     [1] Benner, P., Mehrmann, V., Sima, V., Van Huffel, S., and
C         Varga, A.
C         SLICOT - A subroutine library in systems and control theory.
C         In: Applied and computational control, signals, and circuits,
C         Vol. 1, pp. 499-539, Birkhauser, Boston, 1999.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, May 2008 (SLICOT version of the HAPACK routine DTRQML).
C     V. Sima, Aug. 2011.
C
C     KEYWORDS
C
C     Elementary matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         SIDE, TRANS, UPLO
      INTEGER           INFO, LDA, LDT, LDWORK, M, N
      DOUBLE PRECISION  ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*), T(LDT,*)
C     .. Local Scalars ..
      LOGICAL           LQUERY, LSIDE, LTRAN, LUP
      CHARACTER         ATRAN
      INTEGER           I, IERR, J, K, NOFF, PDW, PSAV, WRKMIN, WRKOPT,
     $                  XDIF
      DOUBLE PRECISION  TEMP
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DLASCL, DLASET, DTRMM, DTRMV,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX, MIN
C
C     .. Executable Statements ..
C
C     Decode and test the input scalar arguments.
C
      INFO  = 0
      LSIDE = LSAME( SIDE,  'L' )
      LUP   = LSAME( UPLO,  'U' )
      LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
      IF ( LSIDE ) THEN
         K = M
      ELSE
         K = N
      END IF
      WRKMIN = MAX( 1, 2*( K - 1 ) )
      LQUERY = LDWORK.EQ.-1
C
      IF ( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) ) THEN
         INFO = -1
      ELSE IF ( ( .NOT.LUP ).AND.( .NOT.LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -2
      ELSE IF ( ( .NOT.LTRAN ).AND.( .NOT.LSAME( TRANS, 'N' ) ) ) THEN
         INFO = -3
      ELSE IF ( M.LT.0 ) THEN
         INFO = -4
      ELSE IF ( N.LT.0 ) THEN
         INFO = -5
      ELSE IF ( LDT.LT.MAX( 1, K ) ) THEN
         INFO = -8
      ELSE IF ( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF ( ALPHA.NE.ZERO .AND. MIN( M, N ).GT.0 ) THEN
         IF( LQUERY ) THEN
            IF ( LSIDE ) THEN
               WRKOPT = ( M/2 )*N + M - 1
            ELSE
               WRKOPT = ( N/2 )*M + N - 1
            END IF
            WRKOPT = MAX( WRKOPT, WRKMIN )
            DWORK(1) = DBLE( WRKOPT )
            RETURN
         ELSE IF ( LDWORK.LT.WRKMIN ) THEN
            DWORK(1) = DBLE( WRKMIN )
            INFO = -12
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01UX', -INFO )
         RETURN
      END IF
C
C     Quick return, if possible.
C
      IF ( MIN( M, N ).EQ.0 )
     $   RETURN
C
      IF ( ALPHA.EQ.ZERO ) THEN
C
C        Set A to zero and return.
C
         CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
         RETURN
      END IF
C
C     Save and count off-diagonal entries of T.
C
      IF ( LUP ) THEN
         CALL DCOPY( K-1, T(2,1), LDT+1, DWORK, 1 )
      ELSE
         CALL DCOPY( K-1, T(1,2), LDT+1, DWORK, 1 )
      END IF
      NOFF = 0
C
      DO 5 I = 1, K-1
         IF ( DWORK(I).NE.ZERO )
     $      NOFF = NOFF + 1
    5 CONTINUE
C
C     Compute optimal workspace.
C
      IF ( LSIDE ) THEN
         WRKOPT = NOFF*N + M - 1
      ELSE
         WRKOPT = NOFF*M + N - 1
      END IF
C
      PSAV = K
      IF ( .NOT.LTRAN ) THEN
         XDIF = 0
      ELSE
         XDIF = 1
      END IF
      IF ( .NOT.LUP )
     $   XDIF = 1 - XDIF
      IF ( .NOT.LSIDE )
     $   XDIF = 1 - XDIF
C
      IF ( LDWORK.GE.WRKOPT ) THEN
C
C        Enough workspace for a fast BLAS 3 calculation.
C        Save relevant parts of A in the workspace and compute one of
C        the matrix products
C          A : = alpha*op( triu( T ) ) * A, or
C          A : = alpha*A * op( triu( T ) ),
C        involving the upper/lower triangle of T.
C
         PDW = PSAV
         IF ( LSIDE ) THEN
            DO 20 J = 1, N
               DO 10 I = 1, M-1
                  IF ( DWORK(I).NE.ZERO ) THEN
                     DWORK(PDW) = A(I+XDIF,J)
                     PDW = PDW + 1
                  END IF
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 30 J = 1, N-1
               IF ( DWORK(J).NE.ZERO ) THEN
                  CALL DCOPY( M, A(1,J+XDIF), 1, DWORK(PDW), 1 )
                  PDW = PDW + M
               END IF
   30       CONTINUE
         END IF
         CALL DTRMM( SIDE, UPLO, TRANS, 'Non-unit', M, N, ALPHA, T,
     $               LDT, A, LDA )
C
C        Add the contribution of the offdiagonal of T.
C
         PDW = PSAV
         XDIF = 1 - XDIF
         IF( LSIDE ) THEN
            DO 50 J = 1, N
               DO 40 I = 1, M-1
                  TEMP = DWORK(I)
                  IF ( TEMP.NE.ZERO ) THEN
                     A(I+XDIF,J) = A(I+XDIF,J) + ALPHA * TEMP *
     $                                           DWORK(PDW)
                     PDW = PDW + 1
                  END IF
   40          CONTINUE
   50       CONTINUE
         ELSE
            DO 60 J = 1, N-1
               TEMP = DWORK(J)*ALPHA
               IF ( TEMP.NE.ZERO ) THEN
                  CALL DAXPY( M, TEMP, DWORK(PDW), 1, A(1,J+XDIF), 1 )
                  PDW = PDW + M
               END IF
   60       CONTINUE
         END IF
      ELSE
C
C        Use a BLAS 2 calculation.
C
         IF ( LSIDE ) THEN
            DO 80 J = 1, N
C
C              Compute the contribution of the offdiagonal of T to
C              the j-th column of the product.
C
               DO 70 I = 1, M - 1
                  DWORK(PSAV+I-1) = DWORK(I)*A(I+XDIF,J)
   70          CONTINUE
C
C              Multiply the triangle of T by the j-th column of A,
C              and add to the above result.
C
               CALL DTRMV( UPLO, TRANS, 'Non-unit', M, T, LDT, A(1,J),
     $                     1 )
               CALL DAXPY( M-1, ONE, DWORK(PSAV), 1, A(2-XDIF,J), 1 )
   80       CONTINUE
         ELSE
            IF ( LTRAN ) THEN
               ATRAN = 'N'
            ELSE
               ATRAN = 'T'
            END IF
            DO 100 I = 1, M
C
C              Compute the contribution of the offdiagonal of T to
C              the i-th row of the product.
C
               DO 90 J = 1, N - 1
                  DWORK(PSAV+J-1) = A(I,J+XDIF)*DWORK(J)
   90          CONTINUE
C
C              Multiply the i-th row of A by the triangle of T,
C              and add to the above result.
C
               CALL DTRMV( UPLO, ATRAN, 'Non-unit', N, T, LDT, A(I,1),
     $                     LDA )
               CALL DAXPY( N-1, ONE, DWORK(PSAV), 1, A(I,2-XDIF), LDA )
  100       CONTINUE
         END IF
C
C        Scale the result by alpha.
C
         IF ( ALPHA.NE.ONE )
     $      CALL DLASCL( 'General', 0, 0, ONE, ALPHA, M, N, A, LDA,
     $                   IERR )
      END IF
      DWORK(1) = DBLE( MAX( WRKMIN, WRKOPT ) )
      RETURN
C *** Last line of MB01UX ***
      END


*DECK BESK1
      FUNCTION BESK1 (X)
C***BEGIN PROLOGUE  BESK1
C***PURPOSE  Compute the modified (hyperbolic) Bessel function of the
C            third kind of order one.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESK1-S, DBESK1-D)
C***KEYWORDS  FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS,
C             THIRD KIND
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESK1(X) computes the modified (hyperbolic) Bessel function of third
C kind of order one for real argument X, where X .GT. 0.
C
C Series for BK1        on the interval  0.          to  4.00000D+00
C                                        with weighted error   7.02E-18
C                                         log weighted error  17.15
C                               significant figures required  16.73
C                                    decimal places required  17.67
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESI1, BESK1E, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  BESK1
      DIMENSION BK1CS(11)
      LOGICAL FIRST
      SAVE BK1CS, NTK1, XMIN, XSML, XMAX, FIRST
      DATA BK1CS( 1) /    .0253002273 389477705E0 /
      DATA BK1CS( 2) /   -.3531559607 76544876E0 /
      DATA BK1CS( 3) /   -.1226111808 22657148E0 /
      DATA BK1CS( 4) /   -.0069757238 596398643E0 /
      DATA BK1CS( 5) /   -.0001730288 957513052E0 /
      DATA BK1CS( 6) /   -.0000024334 061415659E0 /
      DATA BK1CS( 7) /   -.0000000221 338763073E0 /
      DATA BK1CS( 8) /   -.0000000001 411488392E0 /
      DATA BK1CS( 9) /   -.0000000000 006666901E0 /
      DATA BK1CS(10) /   -.0000000000 000024274E0 /
      DATA BK1CS(11) /   -.0000000000 000000070E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESK1
      IF (FIRST) THEN
         NTK1 = INITS (BK1CS, 11, 0.1*R1MACH(3))
         XMIN = EXP (MAX(LOG(R1MACH(1)), -LOG(R1MACH(2))) + .01)
         XSML = SQRT (4.0*R1MACH(3))
         XMAXT = -LOG(R1MACH(1))
         XMAX = XMAXT - 0.5*XMAXT*LOG(XMAXT)/(XMAXT+0.5)
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESK1',
     +   'X IS ZERO OR NEGATIVE', 2, 2)
      IF (X.GT.2.0) GO TO 20
C
      IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'BESK1',
     +   'X SO SMALL K1 OVERFLOWS', 3, 2)
      Y = 0.
      IF (X.GT.XSML) Y = X*X
      BESK1 = LOG(0.5*X)*BESI1(X) +
     1  (0.75 + CSEVL (.5*Y-1., BK1CS, NTK1))/X
      RETURN
C
 20   BESK1 = 0.
      IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BESK1',
     +   'X SO BIG K1 UNDERFLOWS', 1, 1)
      IF (X.GT.XMAX) RETURN
C
      BESK1 = EXP(-X) * BESK1E(X)
C
      RETURN
      END


C============================================================================
C                CTEQ-TEA Parton Distribution Functions: version 2015
C                       October 1, 2015
C
C   When using these PDFs, please cite the references below
C
C
C   This package provides a standard interface for CT10, CT12
C   (unpublished), and CT14 parton distribution functions,
C   including CT14QED.
C
C   The following sets of CTEQ PDF table files can be computed
C    with this program:
C               PDF                             References
C   (1) 1+50 sets of CT10 NNLO PDF's;             [1]
C   (2' ) 1+52 sets of CT10 NLO PDF's;            [2]
C   (2'') 1+52 sets of CT10W NLO PDF's;           [2]
C   (3) 4 sets of CT10W NNLO and NLO PDF's        [2]
C       with alternative alpha_s values;
C   (4) 1+56 sets of CT14 NNLO PDF's;             [3]
C   (5) 1+56 sets of CT14 NLO PDF's;              [3]
C   (6) 2 sets of CT14 LO PDF's;                  [3]
C   (7) 11 CT14 NNLO sets and 11 CT14 NLO sets    [3]
C       with alternative alpha_s values
C   (8) 3 CT14 NNLO and 3 CT14 NLO sets           [3]
C       with up to 3, 4, and 6 active quark flavors
C   (9) 4 CT14 NNLO sets with intrinsic charm     [X]
C   (10) 6 CT14QED sets (LO QED, NLO QCD)         [4]
C        3 each for proton and neutron

C   References
C   [1] J. Gao, M. Guzzi, J. Huston, H.-L. Lai, Z. Li, P. M. Nadolsky,
C       J. Pumplin, D. Stump, C.-P. Yuan,  arXiv:1302.6246 [hep-ph]
C   [2] H.-L. Lai, M. Guzzi, J. Huston, Z. Li, P. M. Nadolsky,
C       J. Pumplin, and C.-P. Yuan, arXiv: 1007.2241 [hep-ph]
C   [3] S. Dulat, T.-J. Hou, J. Gao, M. Guzzi, J. Huston,
C       P. M. Nadolsky, J. Pumplin, C. Schmidt, D. Stump, and
C       C.-P. Yuan, arXiv:1506.07443
C   [4] C. Schmidt, J. Pumplin, D. Stump, C.-P. Yuan, arXiv:1509.02905
C
C ===========================================================================
C   The table grids are generated for
C    *  10^-9 < x < 1 and 1.3 < Q < 10^5 (GeV).
C
C   PDF values outside of the above range are returned using extrapolation.
C
C   The Table_Files are assumed to be in the working directory.
C
C   Before using the PDF, it is necessary to do the initialization by
C       Call SetCT14(Tablefile)
C   where Tablefile is a 40-character text string with the name of the
c   the desired PDF specified in the above table.table (.pds) file
C
C   Other provided functions include:
C   The function CT14Pdf (Iparton, X, Q)
C     returns the parton distribution inside the proton for parton [Iparton]
C     at [X] Bjorken_X and scale [Q] (GeV) in PDF set [Iset].
C     Iparton  is the parton label (5, 4, 3, 2, 1, 0, -1, ......, -5)
C                              for (b, c, s, d, u, g, u_bar, ..., b_bar).
C     Iparton=10 is the label for the photon, if it is available.
C
C   The function CT14Alphas (Q)
C     returns the value of the QCD coupling strength alpha_s(Q) at
C     an energy scale Q. The alpha_s value is obtained from the interpolation
C     of a numerical table of alpha_s included in each .pds file.
C     In the PDF fit, the alpha_s values are obtained at each momentum
c     scale by evolution in the HOPPET program at the respective QCD order
C     (NLO or NNLO). The table of alpha_s values at discrete Q values
C     is included in the input .pds file. The function CT14Alphas
c     estimates alpha_s at an arbitrary Q value, which agrees
c     with the direct evolution by HOPPET within a fraction of percent
c     point at typical Q.
C
C   The function CT14Mass(i)
c     returns the value of the quark mass for the i-th flavor.
c     The flavors are:
c     1  2  3  4  5  6
c     u  d  s  c  b  t
c
C   Values of various PDF parameters assumed in the computation of the
c    PDFs can be obtained by
C     Call CT14GetPars( xmin,Qini,Qmax,Nloops,Nfl,IHDN,Lpho),
C   which returns
c     xmin, the minimal value of x;
c     Qmin,  the initial Q scale for the PDF evolution;
c     Qmax,  the maximal Q scale included in the PDF table;
c     Nloop, the number of QCD loops (order of the PDF in the QCD coupling);
c     Nfl,   the maximal number of quark flavors assumed in the PDF and
c            alpha_s evolution;
C     IHDN,  Hadron (proton = 1,  neutron = 0)
C     Lpho,  Logical variable, which returns .true. if LO QED evolution
C            and photon PDF included, otherwise .false.

C   These programs, as provided, are in double precision.  By removing the
C   "Implicit Double Precision" lines, they can also be run in single
C   precision.
C   If you have detailed questions concerning these CT14 distributions,
C   or if you find problems/bugs using this package, direct inquires to
C   nadolsky@smu.edu.
C
C===========================================================================

      Function CT14Pdf (Iparton, X, Q)
      Implicit Double Precision (A-H,O-Z)
      Logical Warn, Lpho, Lbig, Lnp
      integer isetch, ipdsformat
      Common
     > / CtqPar2 / Nx, Nt, NfMx, MxVal, Ihadron
     > / QCDtbl /  AlfaQ, Qalfa, Ipk, Iorder, Nfl !for external use
     >  /Setchange/ Isetch, ipdsset, ipdsformat
      Common / Photon / Lpho

      Data Warn /.true./
      Data Qsml /.3d0/
      save Warn

      if (ipdsset.ne.1)
     >  STOP 'CT14Pdf: the PDF table was not initialized'

      If (X .lt. 0d0 .or. X .gt. 1D0) Then
        Print *, 'X out of range in CT14Pdf: ', X
        CT14Pdf = 0D0
        Return
      Endif

      If (Q .lt. Qsml) Then
        Print *, 'Q out of range in CT14Pdf: ', Q
        Stop
      Endif

      Lbig = (abs(Iparton).gt.NfMx)
      Lnp = (Iparton.ne.10)
      If (Lbig.and.((Lpho.and.Lnp).or.(.not.Lpho))) Then
        If (Warn) Then
C        print a warning for calling extra flavor
          Warn = .false.
          Print *, 'Warning: Iparton out of range in CT14Pdf! '
          Print *, 'Iparton, MxFlvN0: ', Iparton, NfMx
        Endif
        CT14Pdf = 0D0
      else

        CT14Pdf = PartonX12 (Iparton, X, Q)
        if (CT14Pdf.lt.0D0) CT14Pdf = 0D0
      endif                     !if (abs(Iparton...

      Return

C                             ********************
      End

      Subroutine SetCT14(Tablefile)
      Implicit Double Precision (A-H,O-Z)
      Character Tablefile*40
      Common /Setchange/ Isetch, ipdsset, ipdsformat
      data ipdsset, ipdsformat/0,0/
      save

      IU= NextUnb()
c      Open(IU, File=Tablefile, Status='OLD', Err=100)
       call OpenData(TableFile)
      Call Readpds0 (IU)
      Close (IU)
      Isetch=1; ipdsset=1
      Return

 100  Print *, ' Data file ', Tablefile, ' cannot be opened '
     >  //'in SetCT14!!'
      Stop
C                             ********************
      End

      subroutine CT14GetPars(xmin,Qini,Qmax,Nloops,Nfl,IHDN,Lphoton)
c Get various parameters associated with the PDF grid
c Output: xmin  is the minimal value of x
c         Qmin  is the initial Q scale
c         Qmax  is the maximal Q scale
c         Nloop is the number of QCD loops
c         Nfl   is the maximal number of quark flavors
c         IHDN  is the hadron type (proton: IHDN=1, neutron: IHDN=0)
c         Lphoton  is .true. if LO QED and photon included,
c               otherwise .false
      implicit none
      double precision Qini0, Qmax0, Xmin0, xmin, Qini, Qmax
      integer Nloops, Ipk, Iorder, Nfl,Nfl0, IHDN
      integer Nx, Nt, Nfmx, Mxval, Ihadron
      double precision AlfaQ, Qalfa
      Logical Lpho, Lphoton

      common / XQrange / Qini0, Qmax0, Xmin0
      common / QCDtbl /  AlfaQ, Qalfa, Ipk, Iorder, Nfl0
      common / CtqPar2 / Nx, Nt, NfMx, MxVal, Ihadron
      common / Photon/ Lpho

      Qini=Qini0; Qmax=Qmax0; Xmin=Xmin0
      Nloops=Iorder-1; Nfl=Nfl0; Lphoton=Lpho
      IHDN=Ihadron

      return
      end

      Function CT14Alphas (QQ)

      Implicit Double Precision (A-H,O-Z)

Carl  The following match those in mEvlPac.F for v05t:
      PARAMETER (MXX = 204, MXQ = 50, MXF = 6, MaxVal=4)
c      PARAMETER (MXPQX = (MXF+1+MaxVal) * MXQ * MXX)
      double precision Alsout

      Common
     > / CtqPar1 / qBase,XV(0:MXX), TV(0:MXQ),AlsCTEQ(0:mxq)
     > / CtqPar2 / Nx, Nt, NfMx, MxVal, Ihadron
     > / CtqPar3 / UPD(0:mxx-1,0:mxq-1,-(mxf+1):(MaxVal))
     > / XQrange / Qini, Qmax, Xmin
     > /Setchange/ Isetch, ipdsset, ipdsformat

      Data Q, JQ /-1D0, 0/
      save

      if (ipdsset.ne.1)
     >  STOP 'CT14Alphas: the PDF table was not initialized'

      if (ipdsformat.lt.11) then
        print *
        print *,
     >    'STOP in CT14alphas: the PDF table file has an older format'
        print *,
     >    'and does not include the table of QCD coupling values.'
        print *,
     >    'You can still compute the PDFs, but do not call'
        print *,
     >    'the CT14alphas function for the interpolation of alpha_s.'
        stop
      endif

      Q = QQ
      tt = log(log(Q/qBase))

c         --------------   Find lower end of interval containing Q, i.e.,
c                          get jq such that qv(jq) .le. q .le. qv(jq+1)...
      JLq = -1
      JU = NT+1
 13   If (JU-JLq .GT. 1) Then
        JM = (JU+JLq) / 2
        If (tt .GE. TV(JM)) Then
            JLq = JM
          Else
            JU = JM
          Endif
          Goto 13
       Endif

      If     (JLq .LE. 0) Then
         Jq = 0
      Elseif (JLq .LE. Nt-2) Then
C                                  keep q in the middle, as shown above
         Jq = JLq - 1
      Else
C                         JLq .GE. Nt-1 case:  Keep at least 4 points >= Jq.
        Jq = Nt - 3

      Endif
C                                 This is the interpolation variable in Q
      Call Polint4F (TV(jq), AlsCTEQ(jq), tt, Alsout)

      CT14Alphas = Alsout

      Return
C                                       ********************
      End

      function CT14Mass(i)
c     Returns the value of the quark mass for the i-th flavor
c     The flavors are:
c     1  2  3  4  5  6
c     u  d  s  c  b  t
      implicit none
      double precision CT14Mass, Amass
      integer  Isetch, ipdsset, i, ipdsformat
      common/Setchange/ Isetch, ipdsset, ipdsformat
     >  / Masstbl / Amass(6)

      if (ipdsset.ne.1)
     >  STOP 'CT14Mass: the PDF table was not initialized'

      CT14Mass = Amass(i)

      return
      end

      Subroutine Readpds0 (Nu)
      Implicit Double Precision (A-H,O-Z)
      Character Line*80
      integer ipdsformat
Carl  The following match those in mEvlPac.F for v05t:
      PARAMETER (MXX = 204, MXQ = 50, MXF = 6, MaxVal=4)
c      PARAMETER (MXPQX = (MXF+1+MaxVal) * MXQ * MXX)
      double precision qv(0:mxq)
      logical Lpho

      Common
     > / CtqPar1 / qBase,XV(0:MXX),TV(0:MXQ),AlsCTEQ(0:mxq)
     > / CtqPar2 / Nx, Nt, NfMx, MxVal, Ihadron
     > / CtqPar3 / UPD(0:mxx-1,0:mxq-1,-(mxf+1):(MaxVal))
     > / XQrange / Qini, Qmax, Xmin
     > / Masstbl / Amass(6)
     > / QCDtbl /  AlfaQ, Qalfa, Ipk, Iorder, Nfl !for external use
     > /Setchange/ Isetch, ipdsset, ipdsformat
      common / Photon/ Lpho

Carl  Default is no photon
      Ipho=0
      Lpho=.false.

      Read  (Nu, '(A)') Line
      Read  (Nu, '(A)') Line

      if (Line(1:11) .eq. '  ipk, Ordr') then !post-CT10 .pds format;
c Set alphas(MZ) at scale Zm, quark masses, and evolution type
        ipdsformat = 10           !Post-CT10 .pds format
        Read (Nu, *) ipk, Dr, Qalfa, AlfaQ, (amass(i),i=1,6)
        Iorder = Nint(Dr)
        read (Nu, '(A)') Line
        if (Line(1:7) .eq. '  IMASS' ) then
          ipdsformat = 11         !CT12 .pds format
          read (Nu, '(A)') Line
          read (Line,*,End=22,Err=22)
     >           aimass, fswitch, N0, IHDN, N0, Nfmx, MxVal, Ipho
          goto 26
22        continue
          Ipho = 0
          read (Line,*)
     >           aimass, fswitch, N0, IHDN, N0, Nfmx, MxVal
26        continue
          Nfl=Nfmx
          Ihadron=IHDN
          IF (Ipho.eq.1) then
             Lpho=.true.
          endif
        else                      !Pre-CT12 format
          Read  (Nu, *) N0, N0, N0, NfMx, MxVal
        endif                     !Line(1:7)

      else                        !old .pds format;
        ipdsformat = 6            !CTEQ6.6 .pds format; alpha_s  is not specified
        Read (Nu, *) Dr, fl, Alambda, (amass(i),i=1,6)  !set Lambda_QCD
        Iorder = Nint(Dr); Nfl = Nint(fl)

        Read  (Nu, '(A)') Line
        Read  (Nu, *) dummy,IHDN,dummy, NfMx, MxVal, N0
        Ihadron=IHDN
      endif                       !Line(1:11...

      Read  (Nu, '(A)') Line
      Read  (Nu, *) NX,  NT, N0, NG, N0

      if (ng.gt.0) Read  (Nu, '(A)') (Line, i=1,ng+1)

      Read  (Nu, '(A)') Line
      if (ipdsformat.ge.11) then  !CT12 format with alpha_s values
        Read  (Nu, *) QINI, QMAX, (qv(i),TV(I), AlsCTEQ(I), I =0, NT)
      else                        !pre-CT12 format
        Read  (Nu, *) QINI, QMAX, (qv(i),TV(I), I =0, NT)
      endif                       !ipdsformat.ge.11

c check that qBase is consistent with the definition of Tv(0:nQ) for 2 values of Qv
      qbase1 = Qv(1)/Exp(Exp(Tv(1)))
      qbase2 = Qv(nT)/Exp(Exp(Tv(NT)))
      if (abs(qbase1-qbase2).gt.1e-5) then
        print *, 'Readpds0: something wrong with qbase'
        print *,'qbase1, qbase2=',qbase1,qbase2
        stop
      else
        qbase=(qbase1+qbase2)/2.0d0
      endif                     !abs(qbase1...

      Read  (Nu, '(A)') Line
      Read  (Nu, *) XMIN, aa, (XV(I), I =1, NX)
      XV(0)=0D0

C                  Since quark = anti-quark for nfl>2 at this stage,
C                  we Read  out only the non-redundent data points
C                  No of flavors = NfMx sea + 1 gluon + Nfval valence+ipho
Carl               including the photon if (Lpho.eq.true)
Carl  Nfmin = the lowest parton index in the array (It is negative.)
      Nfmin = -(NfMx+ipho)
Carl
c      Nblk = (NX+1) * (NT+1)
c      Npts =  Nblk  * (NfMx+1+MxVal)
      Read  (Nu, '(A)') Line
      READ  (Nu, *, IOSTAT=IRR)
     >   (((UPD(ix,it,ip), ix=0,NX),it=0,NT),ip=NFmin,MxVal)
c      Read  (Nu, *, IOSTAT=IRET) (UPD(I), I=1,Npts)

      Return
C                        ****************************
      End

      Function PartonX12 (IPRTN, XX, QQ)

c  Given the parton distribution function in the array U in
c  COMMON / PEVLDT / , this routine interpolates to find
c  the parton distribution at an arbitray point in x and q.
c
      Implicit Double Precision (A-H,O-Z)

Carl  The following match those in mEvlPac.F for v05t:
      PARAMETER (MXX = 204, MXQ = 50, MXF = 6, MaxVal=4)
c      PARAMETER (MXPQX = (MXF+1+MaxVal) * MXQ * MXX)

      Common
     > / CtqPar1 / qBase, XV(0:MXX), TV(0:MXQ),AlsCTEQ(0:mxq)
     > / CtqPar2 / Nx, Nt, NfMx, MxVal, Ihadron
     > / CtqPar3 / UPD(0:mxx-1,0:mxq-1,-(mxf+1):(MaxVal))
     > / XQrange / Qini, Qmax, Xmin
     > /Setchange/ Isetch, ipdsset, ipdsformat

      Dimension fvec(4), fij(4)
      Dimension xvpow(0:mxx)
      Data OneP / 1.00001 /
      Data xpow / 0.3d0 /       !**** choice of interpolation variable
      Data nqvec / 4 /
      Data ientry / 0 /
      Data X, Q, JX, JQ /-1D0, -1D0, 0, 0/
      Save xvpow
      Save X, Q, JX, JQ, JLX, JLQ
      Save ss, const1, const2, const3, const4, const5, const6
      Save sy2, sy3, s23, tt, t12, t13, t23, t24, t34, ty2, ty3
      Save tmp1, tmp2, tdet

c store the powers used for interpolation on first call...
      if(Isetch .eq. 1) then
         Isetch = 0

         xvpow(0) = 0D0
         do i = 1, nx
            xvpow(i) = xv(i)**xpow
         enddo
      elseIf((XX.eq.X).and.(QQ.eq.Q)) then
      	goto 99
      endif

      X = XX
      Q = QQ
      tt = log(log(Q/qBase))

c      -------------    find lower end of interval containing x, i.e.,
c                       get jx such that xv(jx) .le. x .le. xv(jx+1)...
      JLx = -1
      JU = Nx+1
 11   If (JU-JLx .GT. 1) Then
         JM = (JU+JLx) / 2
         If (X .Ge. XV(JM)) Then
            JLx = JM
         Else
            JU = JM
         Endif
         Goto 11
      Endif
C                     Ix    0   1   2      Jx  JLx         Nx-2     Nx
C                           |---|---|---|...|---|-x-|---|...|---|---|
C                     x     0  Xmin               x                 1
C
      If     (JLx .LE. -1) Then
        Print '(A,1pE12.4)','Severe error: x <= 0 in PartonX12! x = ',x
        Stop
      ElseIf (JLx .Eq. 0) Then
         Jx = 0
      Elseif (JLx .LE. Nx-2) Then

C                For interior points, keep x in the middle, as shown above
         Jx = JLx - 1
      Elseif (JLx.Eq.Nx-1 .or. x.LT.OneP) Then

C                  We tolerate a slight over-shoot of one (OneP=1.00001),
C              perhaps due to roundoff or whatever, but not more than that.
C                                      Keep at least 4 points >= Jx
         Jx = JLx - 2
      Else
        Print '(A,1pE12.4)','Severe error: x > 1 in PartonX12! x = ',x
        Stop
      Endif
C          ---------- Note: JLx uniquely identifies the x-bin; Jx does not.

C                       This is the variable to be interpolated in
      ss = x**xpow

      If (JLx.Ge.2 .and. JLx.Le.Nx-2) Then

c     initiation work for "interior bins": store the lattice points in s...
      svec1 = xvpow(jx)
      svec2 = xvpow(jx+1)
      svec3 = xvpow(jx+2)
      svec4 = xvpow(jx+3)

      s12 = svec1 - svec2
      s13 = svec1 - svec3
      s23 = svec2 - svec3
      s24 = svec2 - svec4
      s34 = svec3 - svec4

      sy2 = ss - svec2
      sy3 = ss - svec3

c constants needed for interpolating in s at fixed t lattice points...
      const1 = s13/s23
      const2 = s12/s23
      const3 = s34/s23
      const4 = s24/s23
      s1213 = s12 + s13
      s2434 = s24 + s34
      sdet = s12*s34 - s1213*s2434
      tmp = sy2*sy3/sdet
      const5 = (s34*sy2-s2434*sy3)*tmp/s12
      const6 = (s1213*sy2-s12*sy3)*tmp/s34

      EndIf

c         --------------Now find lower end of interval containing Q, i.e.,
c                          get jq such that qv(jq) .le. q .le. qv(jq+1)...
      JLq = -1
      JU = NT+1
 12   If (JU-JLq .GT. 1) Then
         JM = (JU+JLq) / 2
         If (tt .GE. TV(JM)) Then
            JLq = JM
         Else
            JU = JM
         Endif
         Goto 12
       Endif

      If     (JLq .LE. 0) Then
         Jq = 0
      Elseif (JLq .LE. Nt-2) Then
C                                  keep q in the middle, as shown above
         Jq = JLq - 1
      Else
C                         JLq .GE. Nt-1 case:  Keep at least 4 points >= Jq.
        Jq = Nt - 3

      Endif
C                                   This is the interpolation variable in Q

      If (JLq.GE.1 .and. JLq.LE.Nt-2) Then
c                                        store the lattice points in t...
      tvec1 = Tv(jq)
      tvec2 = Tv(jq+1)
      tvec3 = Tv(jq+2)
      tvec4 = Tv(jq+3)

      t12 = tvec1 - tvec2
      t13 = tvec1 - tvec3
      t23 = tvec2 - tvec3
      t24 = tvec2 - tvec4
      t34 = tvec3 - tvec4

      ty2 = tt - tvec2
      ty3 = tt - tvec3

      tmp1 = t12 + t13
      tmp2 = t24 + t34

      tdet = t12*t34 - tmp1*tmp2

      EndIf

c get the pdf function values at the lattice points...

 99   If (Iprtn.eq.10) then
         Ip = -nfmx-1
      else If (Iprtn .Gt. MxVal) Then
         Ip = - Iprtn
      Else
         Ip = Iprtn
      EndIf

      Do it = 1, nqvec
        J1  = jq-1+it

       If (Jx .Eq. 0) Then
C                      For the first 4 x points, interpolate x^2*f(x,Q)
C                      This applies to the two lowest bins JLx = 0, 1
C            We can not put the JLx.eq.1 bin into the "interrior" section
C                           (as we do for q), since Upd(J1) is undefined.
         fij(1) = 0
         fij(2) = Upd(1,j1,ip) * XV(1)**2
         fij(3) = Upd(2,j1,ip) * XV(2)**2
         fij(4) = Upd(3,j1,ip) * XV(3)**2
C
C                 Use Polint which allows x to be anywhere w.r.t. the grid

         Call Polint4F (XVpow(0), Fij(1), ss, Fx)

         If (x .GT. 0D0)  Fvec(it) =  Fx / x**2
C                                              Pdf is undefined for x.eq.0
       ElseIf  (JLx .Eq. Nx-1) Then
C                                                This is the highest x bin:

        Call Polint4F (XVpow(Nx-3), Upd(jx,j1,ip), ss, Fx)

        Fvec(it) = Fx

       Else
C                       for all interior points, use Jon's in-line function
C                              This applied to (JLx.Ge.2 .and. JLx.Le.Nx-2)
         sf2 = Upd(jx+1,J1,ip)
         sf3 = Upd(jx+2,J1,ip)

         g1 =  sf2*const1 - sf3*const2
         g4 = -sf2*const3 + sf3*const4

         Fvec(it) = (const5*(Upd(jx,j1,ip)-g1)
     &               + const6*(Upd(jx+3,j1,ip)-g4)
     &               + sf2*sy3 - sf3*sy2) / s23

       Endif

      enddo
C                                   We now have the four values Fvec(1:4)
c     interpolate in t...

      If (JLq .LE. 0) Then
C                         1st Q-bin, as well as extrapolation to lower Q
        Call Polint4F (TV(0), Fvec(1), tt, ff)

      ElseIf (JLq .GE. Nt-1) Then
C                         Last Q-bin, as well as extrapolation to higher Q
        Call Polint4F (TV(Nt-3), Fvec(1), tt, ff)
      Else
C                         Interrior bins : (JLq.GE.1 .and. JLq.LE.Nt-2)
C       which include JLq.Eq.1 and JLq.Eq.Nt-2, since Upd is defined for
C                         the full range QV(0:Nt)  (in contrast to XV)
        tf2 = fvec(2)
        tf3 = fvec(3)

        g1 = ( tf2*t13 - tf3*t12) / t23
        g4 = (-tf2*t34 + tf3*t24) / t23

        h00 = ((t34*ty2-tmp2*ty3)*(fvec(1)-g1)/t12
     &    +  (tmp1*ty2-t12*ty3)*(fvec(4)-g4)/t34)

        ff = (h00*ty2*ty3/tdet + tf2*ty3 - tf3*ty2) / t23
      EndIf

      PartonX12 = ff

      Return
C                                       ********************
      End

      SUBROUTINE POLINT4F (XA,YA,X,Y)

      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C  The POLINT4 routine is based on the POLINT routine from "Numerical Recipes",
C  but assuming N=4, and ignoring the error estimation.
C  suggested by Z. Sullivan.
      DIMENSION XA(*),YA(*)

      H1=XA(1)-X
      H2=XA(2)-X
      H3=XA(3)-X
      H4=XA(4)-X

      W=YA(2)-YA(1)
      DEN=W/(H1-H2)
      D1=H2*DEN
      C1=H1*DEN

      W=YA(3)-YA(2)
      DEN=W/(H2-H3)
      D2=H3*DEN
      C2=H2*DEN

      W=YA(4)-YA(3)
      DEN=W/(H3-H4)
      D3=H4*DEN
      C3=H3*DEN

      W=C2-D1
      DEN=W/(H1-H3)
      CD1=H3*DEN
      CC1=H1*DEN

      W=C3-D2
      DEN=W/(H2-H4)
      CD2=H4*DEN
      CC2=H2*DEN

      W=CC2-CD1
      DEN=W/(H1-H4)
      DD1=H4*DEN
      DC1=H1*DEN

      If((H3+H4).lt.0D0) Then
         Y=YA(4)+D3+CD2+DD1
      Elseif((H2+H3).lt.0D0) Then
         Y=YA(3)+D2+CD1+DC1
      Elseif((H1+H2).lt.0D0) Then
         Y=YA(2)+C2+CD1+DC1
      ELSE
         Y=YA(1)+C1+CC1+DC1
      ENDIF

      RETURN
C               *************************
      END

      Function NextUnb()
C                                 Returns an unallocated FORTRAN i/o unit.
      Logical EX
C
      Do 10 N = 10, 300
         INQUIRE (UNIT=N, OPENED=EX)
         If (.NOT. EX) then
            NextUnb = N
            Return
         Endif
 10   Continue
      Stop ' There is no available I/O unit. '
C               *************************
      End
C


!*****************************************************************************************
!>
!  Driver for [[dop853]] on van der Pol's equation.
!
!### See also
!  * Based on [dr_dop853.f](http://www.unige.ch/~hairer/prog/nonstiff/dr_dop853.f)
!
!### Results
!  ![Forward Test](|media|/dop853_forward.png)
!  ![Backward Test](|media|/dop853_backward.png)
!
!@note This requires [pyplot-fortran](https://github.com/jacobwilliams/pyplot-fortran).

    program dop853_test

    use dop853_module
    use dop853_constants
    use iso_fortran_env, only: output_unit
    use pyplot_module

    implicit none

    integer,parameter               :: n     = 2                !! dimension of the system
    integer,dimension(n),parameter  :: icomp = [1,2]            !! indices of `y` where we need dense output
    integer,parameter               :: iout  = 3                !! output routine (and dense output) is used during integration
    real(wp),parameter              :: tol   = 1.0e-12_wp       !! required (relative) tolerance
    real(wp),parameter              :: x0    = 0.0_wp           !! initial `x` value
    real(wp),parameter              :: xf    = 100.0_wp         !! endpoint of integration
    real(wp),dimension(n),parameter :: y0    = [0.0_wp,0.1_wp]  !! initial `y` value
    real(wp),parameter              :: dx    = 0.01_wp          !! time step for dense output

    logical,parameter :: make_plots = .true. !! use pyplot to generate plots.

    type(dop853_class) :: prop
    real(wp),dimension(n) :: y
    real(wp),dimension(1) :: rtol,atol
    real(wp) :: x,xend
    integer :: i,idid,j,nfcn,nstep,naccpt,nrejct
    logical :: status_ok
    type(pyplot) :: plt
    real(wp),dimension(:),allocatable :: t_vec, y_vec, yp_vec
    integer :: istat !! pyplot-fortran status flag

    x = x0
    y = y0
    xend = xf
    rtol = tol
    atol = tol
    call prop%initialize(   fcn       = fvpol,    &
                            n         = n,        &
                            solout    = solout,   &
                            icomp     = icomp,    &
                            nstiff    = 1,        &
                            status_ok = status_ok )
    !all other parameters use defaults

    if (status_ok) then

        call prop%integrate(x,y,xend,rtol,atol,iout,idid)
        call prop%info(nfcn,nstep,naccpt,nrejct)

        if (make_plots) then
            t_vec  = [t_vec,x]        !last point
            y_vec  = [y_vec,y(1)]
            yp_vec = [yp_vec,y(2)]
        end if

        ! print final solution
        write (output_unit,'(1X,A,F6.2,A,2E18.10)') &
                'x =',x ,'    y =',y(1),y(2)

        ! print statistics
        write (output_unit,'(A,D8.2)') '       tol=',tol
        write (output_unit,'(A,I5,A,I4,A,I4,A,I3)') &
                ' fcn=',nfcn,' step=',nstep,' accpt=',naccpt,' rejct=',nrejct

        ! plot:
        if (make_plots) then
            call plt%initialize(grid=.true.,xlabel='y(x)',&
                              ylabel='y''(x)',&
                              title='van der Pol''s Equation ($\mu = 0.2$)',legend=.true.)
            call plt%add_plot(y_vec,yp_vec,label='Forward',&
                              linestyle='r-',linewidth=2,&
                              xlim=[-3.0_wp,3.0_wp], ylim=[-3.0_wp,3.0_wp],istat=istat)
            call plt%savefig('dop853_forward.png',istat=istat)
            call plt%destroy()

            deallocate(t_vec )
            deallocate(y_vec )
            deallocate(yp_vec)
        end if

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

        write(*,*) ''
        write(*,*) 'backwards test'
        write(*,*) ''
        call prop%destroy()
        call prop%initialize(fcn=fvpol,n=n,solout=solout2,status_ok = status_ok)
        call prop%integrate(x,y,x0,rtol,atol,iout=1,idid=idid)

        write(*,*) ''
        write(*,*) 'error:', norm2(y-y0)
        write(*,*) ''

        ! plot:
        if (make_plots) then
            call plt%initialize(grid=.true.,xlabel='y(x)',&
                            ylabel='y''(x)',&
                            title='van der Pol''s Equation ($\mu = 0.2$)',legend=.true.)

            call plt%add_plot(y_vec,yp_vec,label='Backward',&
                            linestyle='r-',linewidth=2,&
                            xlim=[-3.0_wp,3.0_wp], ylim=[-3.0_wp,3.0_wp],istat=istat)

            call plt%savefig('dop853_backward.png',istat=istat)
            call plt%destroy()
        end if

    else
      write(output_unit,'(A)') 'error calling INITIALIZE.'
    end if

    contains
!*****************************************************************************************

!*******************************************************************************
!>
!  Prints solution at equidistant output-points
!  by using [[contd8]], the continuous collocation solution.
!  This is for an `iout=3` case.
!
!@note This routine uses Fortran 2008 LHS automatic allocations.

    subroutine solout(me,nr,xold,x,y,irtrn,xout)

    implicit none

    class(dop853_class),intent(inout) :: me
    integer,intent(in)                :: nr
    real(wp),intent(in)               :: xold
    real(wp),intent(in)               :: x
    real(wp),dimension(:),intent(in)  :: y
    integer,intent(inout)             :: irtrn
    real(wp),intent(out)              :: xout   !! the point where we want the next output reported

    if ( nr==1 ) then
        write (output_unit,'(1X,A,F6.2,A,2E18.10,A,I4)') &
                'x =',x,&
                '    y =',y(1),y(2),&
                '    nstep =',nr - 1
        xout = dx
    else
        do
            if ( x<xout ) exit
            write (output_unit,'(1X,A,F6.2,A,2E18.10,A,I4)') &
                     'x =',xout,&
                     '    y =',&
                     prop%contd8(1,xout),&
                     prop%contd8(2,xout),&
                     '    nstep =',nr - 1
            xout = xout + dx
        end do
    end if

    if (make_plots) then
        if (allocated(t_vec)) then !fortran 2008 lhs allocations
            t_vec  = [t_vec,x]
            y_vec  = [y_vec,y(1)]
            yp_vec = [yp_vec,y(2)]
        else
            t_vec  = [x]
            y_vec  = [y(1)]
            yp_vec = [y(2)]
        end if
    end if

    end subroutine solout
!*******************************************************************************

!*******************************************************************************
!>
!  Prints a normal step from [[dop853]] (for `iout=1`).
!
!@note This routine uses Fortran 2008 LHS automatic allocations.

    subroutine solout2(me,nr,xold,x,y,irtrn,xout)

    implicit none

    class(dop853_class),intent(inout) :: me
    integer,intent(in)                :: nr
    real(wp),intent(in)               :: xold
    real(wp),intent(in)               :: x
    real(wp),dimension(:),intent(in)  :: y
    integer,intent(inout)             :: irtrn
    real(wp),intent(out)              :: xout   !! not used for `iout=1`.

    write (output_unit,'(1X,A,F6.2,A,2E18.10,A,I4)') &
                    'x =',x,&
                    '    y =',y(1),y(2),&
                    '    nstep =',nr - 1

    if (make_plots) then
        if (allocated(t_vec)) then
            t_vec  = [t_vec,x]
            y_vec  = [y_vec,y(1)]
            yp_vec = [yp_vec,y(2)]
        else
            t_vec  = [x]
            y_vec  = [y(1)]
            yp_vec = [y(2)]
        end if
    end if

    end subroutine solout2
!*******************************************************************************

!*******************************************************************************
!>
! Right-hand side of van der Pol's equation:
! \( y'' = \mu(1-y^2)y' - y \).
!
!### Reference
! * Weisstein, Eric W. "[van der Pol Equation](http://mathworld.wolfram.com/vanderPolEquation.html)."
!   From MathWorld--A Wolfram Web Resource.
!
!@note The [original code](http://www.unige.ch/~hairer/prog/nonstiff/dr_dop853.f)
!      had a slightly different equation.

    subroutine fvpol(me,x,y,f)

    implicit none

    class(dop853_class),intent(inout) :: me
    real(wp),intent(in)               :: x
    real(wp),dimension(:),intent(in)  :: y  !! \( [y, y' ] \)
    real(wp),dimension(:),intent(out) :: f  !! \( [y', y'' ] \)

    real(wp),parameter :: mu  = 0.2_wp  !! \( \mu \) in van der Pol's equation.

    f(1) = y(2)
    f(2) = mu*(1.0_wp-y(1)**2)*y(2) - y(1)

    end subroutine fvpol
!*******************************************************************************

    end program dop853_test
!*****************************************************************************************


      subroutine torus_setprob(example_in,alpha_in)
      implicit none

      double precision pi
      common /compi/ pi

      double precision alpha_in, alpha
      common /toruscomm/ alpha

      integer example_in, example
      common /excomm_example/ example

      double precision revs_per_sec_comm, r0_comm
      common /comm_torus/ revs_per_sec_comm, r0_comm

      pi = 4.d0*atan(1.d0)

      example = example_in
      alpha = alpha_in

      end


! { dg-do run }
! verifies basic functioning of the ishft and ishftc intrinsics
if (ishft (1_1, 0) /= 1) call abort
if (ishft (1_1, 1) /= 2) call abort
if (ishft (3_1, 1) /= 6) call abort
if (ishft (-1_1, 1) /= -2) call abort
if (ishft (-1_1, -1) /= 127) call abort
if (ishft (96_1, 2) /= -128) call abort

if (ishft (1_2, 0) /= 1) call abort
if (ishft (1_2, 1) /= 2) call abort
if (ishft (3_2, 1) /= 6) call abort
if (ishft (-1_2, 1) /= -2) call abort
if (ishft (-1_2, -1) /= 32767) call abort
if (ishft (16384_2 + 8192_2, 2) /= -32768_4) call abort

if (ishft (1_4, 0) /= 1) call abort
if (ishft (1_4, 1) /= 2) call abort
if (ishft (3_4, 1) /= 6) call abort
if (ishft (-1_4, 1) /= -2) call abort
if (ishft (-1_4, -1) /= 2147483647) call abort
if (ishft (1073741824_4 + 536870912_4, 2) /= -2147483648_8) call abort

if (ishft (1_8, 0) /= 1) call abort
if (ishft (1_8, 1) /= 2) call abort
if (ishft (3_8, 1) /= 6) call abort
if (ishft (-1_8, 1) /= -2) call abort
if (ishft (-1_8, -60) /= z'F') call abort

if (ishftc (1_1, 0) /= 1) call abort
if (ishftc (1_1, 1) /= 2) call abort
if (ishftc (3_1, 1) /= 6) call abort
if (ishftc (-1_1, 1) /= -1) call abort
if (ishftc (-1_1, -1) /= -1) call abort
if (ishftc (ishftc (96_1, 2), -2) /= 96) call abort

if (ishftc (1_2, 0) /= 1) call abort
if (ishftc (1_2, 1) /= 2) call abort
if (ishftc (3_2, 1) /= 6) call abort
if (ishftc (-1_2, 1) /= -1) call abort
if (ishftc (-1_2, -1) /= -1) call abort
if (ishftc (ishftc (25000_2, 2), -2) /= 25000) call abort

if (ishftc (1_4, 0) /= 1) call abort
if (ishftc (1_4, 1) /= 2) call abort
if (ishftc (3_4, 1) /= 6) call abort
if (ishftc (-1_4, 1) /= -1) call abort
if (ishftc (-1_4, -1) /= -1) call abort
if (ishftc (ishftc (1325876_4, 2), -2) /= 1325876) call abort

if (ishftc (1_8, 0) /= 1) call abort
if (ishftc (1_8, 1) /= 2) call abort
if (ishftc (3_8, 1) /= 6) call abort
if (ishftc (-1_8, 1) /= -1) call abort
if (ishftc (-1_8, -1) /= -1) call abort
if (ishftc (ishftc (1325876_8, 2), -2) /= 1325876) call abort
end


module operation_def
	use base_types, only : base_type
	use omp_lib

	implicit none

	! Define custom operator types

	! Type-bound procedure
	type, extends(base_type) :: multiply_type
	  integer :: null_op
		contains
		procedure :: multiply => multiplication_b
	end type

	contains

	subroutine multiplication(op,v,dv,n)
		type(base_type) :: op
		real(kind=8), dimension(op%nx,op%ny), intent(in) :: v
		real(kind=8), dimension(op%nx,op%ny), intent(out) :: dv
		integer i,j,n

		!$omp target teams distribute parallel do collapse(2)
		do i=1,op%nx
			do j=1,op%ny
				dv(i,j) = op%array(i,j)*v(i,j)
			end do ! j
		end do ! i
		!$omp end target teams distribute parallel do

	end subroutine multiplication

	subroutine multiplication_b(op,v,dv,n)
		class(multiply_type) :: op
		real(kind=8), dimension(op%nx,op%ny), intent(in) :: v
		real(kind=8), dimension(op%nx,op%ny), intent(out) :: dv
		integer i,j,n

		!$omp target teams distribute parallel do collapse(2)
		do i=1,op%nx
			do j=1,op%ny
				dv(i,j) = op%array(i,j)*v(i,j)
			end do ! j
		end do ! i
		!$omp end target teams distribute parallel do

	end subroutine multiplication_b

end module operation_def


      double complex function F41mF(psq,s,t)
c--- note: ordering of arguments to function is taken from, e.g.
c---       arXiV:0804.4149v3 (App. B) and not hep-ph/0607139 (Eq. 21)
      implicit none
c      include 'scale.f'
      double precision s,t,psq
c      double precision den
c      double complex qlI4,qlI3
      double complex Lsm1

c      den=s*t
c--- MODIFIED: added factor of 1/2 and removed finite pieces from poles
c      F41mF=
c     . +den*qlI4(0d0,0d0,0d0,psq,s,t,0d0,0d0,0d0,0d0,musq,0)/2d0
c     . -   s*qlI3(0d0,0d0,s,0d0,0d0,0d0,musq,0)
c     . -   t*qlI3(0d0,0d0,t,0d0,0d0,0d0,musq,0)
c     . + psq*qlI3(0d0,0d0,psq,0d0,0d0,0d0,musq,0)

c--- NOTE: checked on 8/30/09 that Lsm1 == (expression above)
      F41mF=Lsm1(-s,-psq,-t,-psq)

      return
      end


      SUBROUTINE getdiam(amat_i, amat_p, data_array, kcdiam)
      USE vmec_main
      USE vmec_params, ONLY: signgs
      USE realspace
      USE vforces, ONLY : r12=>armn_o, ru12=>azmn_e
      USE vsvd
      USE vspline
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER kcdiam
      REAL(rprec), DIMENSION(isnodes,*) :: amat_i
      REAL(rprec), DIMENSION(ipnodes,*) :: amat_p
      REAL(rprec), DIMENSION(*) :: data_array
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      INTEGER, PARAMETER :: ilimit = 2
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: js, lk, l
      REAL(rprec), DIMENSION(ns) :: gp, gi, gip
      REAL(rprec), DIMENSION(isnodes) :: amat2_i
      REAL(rprec) :: wdiam, z12, tv, ti, t2, sum1
C-----------------------------------------------

      kcdiam = 0
      IF (iphidiam.eq.0 .or. iresidue.lt.ilimit) RETURN
!
!       COMPUTE FIT TO DIAMAGNETIC SIGNAL, USING EQUILIBRIUM RELATION
!       (modified 7/96 by SPH)
!
!       PHI-DIAMAG = 2*pi*INT[ Gp dp/ds + Gi d(<Bu>)/ds ]
!
!       WHERE
!
!       Gp = Ru * Z * <SQRT(g)> /(R * phip)
!       Gi = Ru * Z * iota / R
!

      kcdiam = kcdiam + 1
c-7/96  dNewPhiedge = signgs*twopi*hs*Ssum_1(ns1,phip(2),1)
c-7/96  VacPhiedge  = signgs*bsubvvac*hs*Ssum_1(ns1,vrm2(2),1)
c-7/96  delphid0    = VacPhiedge - dNewPhiedge

      wdiam = one/sigma_delphid
      gp(1) = zero
      gi(1) = zero
      DO js = 2, ns
         gp(js) = zero
         DO lk = 1, nznt
            l = js + ns*(lk - 1)
            z12 = .5_dp*(z1(l,0)+z1(l-1,0)+shalf(l)*(z1(l,1)+z1(l-1,1)))
            gp(js) = gp(js) + ru12(l)*z12/r12(l)*wint(l)
         END DO
      END DO
!
!       NOTE: gip terms comes from linearizing the iota*d/ds[current*iota]
!             terms
!
      DO js = 2, ns
         tv = twopi*vp(js)/phip(js)
         ti = -gp(js)*signgs*wdiam
         gi(js) = ti*iotas(js)
         gp(js) = -gp(js)*tv*wdiam
         gip(js) = ti*(current(js)*iotaf(js)-current(js-1)*iotaf(js-1))
      END DO

      CALL splinint (gi, current, amat_i(1,kcdiam), hstark, u_ib, u1_ib
     1   , w_ib, w1_ib, nk_ib, isnodes, intder, ns)

      CALL splinint (gip(2), current(2), amat2_i, hstark, u_ia, u1_ia,
     1   w_ia, w1_ia, nk_ia, isnodes, intfun, ns1)

      CALL splinint (gp, presint, amat_p(1,kcdiam), hthom, u_pb, u1_pb,
     1   w_pb, w1_pb, nk_pb, ipnodes, intder, ns)

      amat_i(:isnodes,kcdiam) = amat_i(:isnodes,kcdiam) + amat2_i(:
     1   isnodes)

      t2 = mu0*pthommax                        !!*pfac moved to getthom
      amat_p(:ipnodes,kcdiam) = t2*amat_p(:ipnodes,kcdiam)
      sum1 = SUM(iotas(2:ns)*gip(2:ns))
      data_array(kcdiam) = wdiam*phidiam + sum1
      IF (iequi .eq. 0) THEN
!
!       Eliminate p variation until well-converged
!
!@        DO i = 1,ipnodes
!@          data_array(kcdiam) = data_array(kcdiam) -
!@     >    amat_p(i,kcdiam)*ythom(i)
!@          amat_p(i,kcdiam) = 0.
!@        END DO

!
!       FINAL OUTPUT (ALSO USE FOR DEBUGGING)
!
      ELSE
!
!       Integrate by parts
!
         delphid = gp(ns)*presf(ns) + gi(ns)*iotaf(ns)*current(ns) -
     1      gp(2)*presf(1) - gi(2)*current(1)*iotaf(1)
         DO js = 2, ns1
            delphid = delphid - presf(js)*(gp(js+1)-gp(js)) - iotaf(js)*
     1         current(js)*(gi(js+1)-gi(js))
         END DO
         delphid = delphid/wdiam
      ENDIF
!@        DO js = 2,ns
!@        END DO
!@
!@        sumi = SUM(amat_i(:isnodes,kcdiam)*ystark(:isnodes))
!@     >       - SUM(amat2_i(isnodes)*ystark(:isnodes))
!@        sump = bla_dot(ipnodes,amat_p(1,kcdiam),1,ythom,1)
!@
!@        WRITE(*,1212)delphid,(sumi+sump)/wdiam,delphid0
!@ 1212   FORMAT(' DelPhid = ',1pe10.3,' PhiD = ',1pe10.3,
!@     >   ' DelPhid0 = ',1pe10.3)

      END SUBROUTINE getdiam


      SUBROUTINE coeffs(nsurf, npt, x, p, q, r)
      USE stel_kinds
      USE normalize_data
      USE ballooning_data
      USE fmesh_quantities
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER,INTENT(in) :: nsurf,npt
      REAL(rprec),INTENT(in), DIMENSION (npt) :: x
      REAL(rprec),INTENT(out), DIMENSION(npt) :: p, q, r
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      REAL(rprec), DIMENSION(npt) :: k_s, c2, b2, bsuppar,
     1   c2n, b2n, bsupparn
      REAL(rprec) :: prespn, phipn2, eps2,
     1  factor, phipc, iotac, prespc, iotapc
!------------------------------------------------------------------------

!...  values of surface quantities at current surface

      phipc=phipf(nsurf)                                              ! derivative of toroidal magnetic flux
      iotac=iotaf(nsurf)                                              ! iota
      iotapc=iotapf(nsurf)                                            ! radial iota derivative
      prespc=prespf(nsurf)                                            ! radial pressure gradient

      CALL summodosd(nsurf, npt, x, c2, k_s, bsuppar, b2,
     1   iotac, iotapc, prespc)
      IF (lfail_balloon) THEN
         RETURN
      END IF

      b2n = b2/(b0_v**2)                                              ! magnetic field normalized to B_0
      bsupparn = r0*bsuppar/b0_v
      c2n = c2*(amin**2)                                              ! perpend. wave vector squared
      prespn = 2*prespc/(beta0*b0_v**2)                               ! pressure normalized to p_0
      phipn2=(phipc/(b0_v*amin**2))**2                                ! perpend. lengths normalized to a
      eps2=(r0/amin)**2
      factor=eps2*beta0*prespn/phipn2

!...   P, Q and R:  ballooning coefficients

      p=bsupparn*c2n/b2n
      q=factor*k_s/bsupparn
      r=c2n/(b2n*bsupparn)

      END SUBROUTINE coeffs


module PlantComponent
    use, intrinsic :: iso_c_binding

    type, public, bind(C) :: PlantInput
        integer(c_int) :: doy, endsim
        real(c_float) :: tmax, tmin, par, swfac1, swfac2
    end type PlantInput

    type, public, bind(C) :: PlantModel
        real(c_float) :: e, fc, lai, nb, n, pt, pg, di, par
        real(c_float) :: rm, dwf, intc, tmax, tmin, p1, sla
        real(c_float) :: pd, emp1, emp2, lfmax, dwc, tmn
        real(c_float) :: dwr, dw, dn, w, wc, wr, wf, tb, intot, dlai, fl
        real(c_float) :: swfac1, swfac2
        integer(c_int) :: doy, endsim, count
    end type PlantModel
contains
    !***********************************************************************
    !     subroutine lais
    !     calculates the canopy leaf area index (lai)
    !-----------------------------------------------------------------------
    !     input:  fl, di, pd, emp1, emp2, n, nb, swfac1, swfac2, pt, dn
    !     output: dlai
    !************************************************************************
    ! pure
    subroutine lais(fl, di, pd, emp1, emp2, n, nb, swfac1, swfac2, pt, &
            dn, p1, sla, dlai)

        !-----------------------------------------------------------------------
        implicit none
        save
        real :: pd, emp1, emp2, n, nb, dlai, swfac, a, dn, p1, sla
        real :: swfac1, swfac2, pt, di, fl
        !-----------------------------------------------------------------------

        swfac = min(swfac1, swfac2)
        if (fl == 1.0) then
            a = exp(emp2 * (n - nb))
            dlai = swfac * pd * emp1 * pt * (a / (1 + a)) * dn
        elseif (fl == 2.0) then

            dlai = - pd * di * p1 * sla

        endif
        !-----------------------------------------------------------------------
        return
    end subroutine lais
    !***********************************************************************

    !****************************************************************************
    !     subroutine pgs
    !     calculates the canopy gross photosysntesis rate (pg)
    !*****************************************************************************
    ! pure
    subroutine pgs(swfac1, swfac2, par, pd, pt, lai, pg)

        !-----------------------------------------------------------------------
        implicit none
        real :: par, lai, pg, pt, y1
        real :: swfac1, swfac2, swfac, rowspc, pd

        !-----------------------------------------------------------------------
        !     rowsp = row spacing
        !     y1 = canopy light extinction coefficient

        swfac = min(swfac1, swfac2)
        rowspc = 60.0
        y1 = 1.5 - 0.768 * ((rowspc * 0.01)**2 * pd)**0.1
        pg = pt * swfac * 2.1 * par / pd * (1.0 - exp(-y1 * lai))

        !-----------------------------------------------------------------------
        return
    end subroutine pgs
    !***********************************************************************

    !***********************************************************************
    !     subroutine pts
    !     calculates the factor that incorporates the effect of temperature
    !     on photosynthesis
    !************************************************************************
    subroutine pts(tmax, tmin, pt)
        !-----------------------------------------------------------------------
        implicit none
        real :: pt, tmax, tmin

        !-----------------------------------------------------------------------
        pt = 1.0 - 0.0025 * ((0.25 * tmin + 0.75 * tmax) - 26.0)**2

        !-----------------------------------------------------------------------
        return
    end subroutine pts
    !***********************************************************************
    !***********************************************************************

    subroutine rate(m)
        use iso_c_binding
        implicit none
        type(PlantModel) :: m

        m%tmn = 0.5 * (m%tmax + m%tmin)
        call pts(m%tmax, m%tmin, m%pt)
        call pgs(m%swfac1, m%swfac2, m%par, m%pd, m%pt, m%lai, m%pg)

        if (m%n < m%lfmax) then
            !         vegetative phase
            m%fl = 1.0
            m%e = 1.0
            m%dn = m%rm * m%pt

            call lais(m%fl, m%di, m%pd, m%emp1, m%emp2, m%n, m%nb, m%swfac1, m%swfac2, m%pt, &
                    m%dn, m%p1, m%sla, m%dlai)
            m%dw = m%e * (m%pg) * m%pd
            m%dwc = m%fc * m%dw
            m%dwr = (1 - m%fc) * m%dw
            m%dwf = 0.0

        else
            !         reproductive phase
            m%fl = 2.0

            if (m%tmn >= m%tb .and. m%tmn <= 25) then
                m%di = (m%tmn - m%tb)
            else
                m%di = 0.0
            endif

            m%intc = m%intc + m%di
            m%e = 1.0
            call lais(m%fl, m%di, m%pd, m%emp1, m%emp2, m%n, m%nb, m%swfac1, m%swfac2, m%pt, &
                    m%dn, m%p1, m%sla, m%dlai)
            m%dw = m%e * (m%pg) * m%pd
            m%dwf = m%dw
            m%dwc = 0.0
            m%dwr = 0.0
            m%dn = 0.0
        endif
    end subroutine rate

    subroutine c_rate(m) bind(c, name = 'pm_rate')
        implicit none
        type(PlantModel) :: m
        call rate(m)
    end subroutine c_rate

    subroutine update(m, input)
        type(PlantModel) :: m
        type(PlantInput) :: input
        m%tmax = input%tmax
        m%tmin = input%tmin
        m%par = input%par
        m%swfac1 = input%swfac1
        m%swfac2 = input%swfac2
    end subroutine update

    subroutine c_update(m, input) bind(c, name = 'pm_update')
        implicit none
        type(PlantModel) :: m
        type(PlantInput) :: input
        call update(m, input)
    end subroutine c_update

    subroutine integ(m)
        use iso_c_binding
        implicit none
        type(PlantModel) :: m

        m%lai = m%lai + m%dlai
        m%w = m%w + m%dw
        m%wc = m%wc + m%dwc
        m%wr = m%wr + m%dwr
        m%wf = m%wf + m%dwf

        m%lai = max(m%lai, 0.0)
        m%w = max(m%w, 0.0)
        m%wc = max(m%wc, 0.0)
        m%wr = max(m%wr, 0.0)
        m%wf = max(m%wf, 0.0)

        m%n = m%n + m%dn
        if (m%intc > m%intot) then
            m%endsim = 1
            return
        endif
    end subroutine integ

    subroutine c_integ(m) bind(c, name = 'pm_integ')
        implicit none
        type(PlantModel) :: m
        call integ(m)
    end subroutine c_integ
end module PlantComponent


module cell_to_edge_module

  use bl_types, only: dp_t
  use bl_error_module, only: bl_error
  use bl_constants_module
  use restrict_base_module
  implicit none

  private

  public :: cell_to_edge

contains

  subroutine cell_to_edge(s0_cell,s0_edge)

    use bl_constants_module, only: HALF
    use geometry, only: r_start_coord, r_end_coord, nr, &
                        numdisjointchunks, spherical

    real(kind=dp_t), intent(in   ) :: s0_cell(:,0:)
    real(kind=dp_t), intent(inout) :: s0_edge(:,0:)

    real(kind=dp_t)                ::  s0min,s0max,tmp
    integer                        ::  n,r,i,nlevs

    if (spherical .eq. 1) then
       call bl_error('calling cell_to_edge with spherical .eq. 1')
    end if

    nlevs = size(s0_cell,dim=1)

    do n=1,nlevs
       do i=1,numdisjointchunks(n)
          !$OMP PARALLEL DO PRIVATE(r,tmp,s0min,s0max)
          do r=r_start_coord(n,i),r_end_coord(n,i)+1

             if (r .eq. 0) then
                ! if we are at lower domain boundary
                s0_edge(n,r) = s0_cell(n,r)

             else if (r .eq. 1) then
                ! if we are at lower domain boundary+1
                s0_edge(n,r) = HALF*(s0_cell(n,r-1)+s0_cell(n,r))

             else if (r .eq. r_start_coord(n,i)) then
                ! if we are at bottom of coarse-fine interface that is
                ! not a domain boundary.  We do an average analogous
                ! to the 7/12 - 1/12 averaging but use the fact that
                ! the two coarse cells below the interface have an
                ! width of 2*dx and the two fine cells above the
                ! interface have a width of dx.  This is computed from
                ! Colella and Woodward 1984, Eq. 1.6

                ! we are computing the edge value at r-1/2

                ! zones r and r+1 on the fine (current) level are above
                ! the interface

                ! zones r/2-1 and r/2-2 on the coarse level are below
                ! the interface
                tmp = 0.3_dp_t*s0_cell(n-1,r/2-1) + &
                      0.9_dp_t*s0_cell(n,r) - &
                      SIXTH*   s0_cell(n,r+1) - &
                      (ONE/30.0_dp_t)*s0_cell(n-1,r/2-2)
                s0min      = min(s0_cell(n-1,r/2-1),s0_cell(n,r))
                s0max      = max(s0_cell(n-1,r/2-1),s0_cell(n,r))
                s0_edge(n,r) = min(max(tmp,s0min),s0max)

             else if (r .eq. nr(n)) then
                ! if we are at upper domain boundary
                s0_edge(n,r) = s0_cell(n,r-1)

             else if (r .eq. nr(n)-1) then
                ! if we are at upper domain boundary-1
                s0_edge(n,r) = HALF*(s0_cell(n,r)+s0_cell(n,r-1))

             else if (r .eq. r_end_coord(n,i)+1) then
                ! if we are at top of coarse-fine interface that is
                ! not a domain boundary.  We do an average analogous
                ! to the 7/12 - 1/12 averaging but use the fact that
                ! the two coarse cells above the interface have an
                ! width of 2*dx and the two fine cells below the
                ! interface have a width of dx.  This is computed from
                ! Colella and Woodward 1984, Eq. 1.6

                ! we are computing the edge value at r-1/2

                ! zones r-1 and r-2 on the fine (current) level are below
                ! the interface

                ! zones r/2 and r/2+1 on the coarse level are above
                ! the interface

                s0_edge(n,r) = 0.3_dp_t*s0_cell(n-1,r/2) + &
                               0.9_dp_t*s0_cell(n,r-1) - &
                               SIXTH*   s0_cell(n,r-2) - &
                               (ONE/30.0_dp_t)*s0_cell(n-1,r/2+1)
                s0min      = min(s0_cell(n-1,r/2),s0_cell(n,r-1))
                s0max      = max(s0_cell(n-1,r/2),s0_cell(n,r-1))
                s0_edge(n,r) = min(max(tmp,s0min),s0max)

             else
                ! fourth order
                tmp = 7.d0/12.d0 * (s0_cell(n,r  ) + s0_cell(n,r-1)) &
                     -1.d0/12.d0 * (s0_cell(n,r+1) + s0_cell(n,r-2))
                s0min      = min(s0_cell(n,r),s0_cell(n,r-1))
                s0max      = max(s0_cell(n,r),s0_cell(n,r-1))
                s0_edge(n,r) = min(max(tmp,s0min),s0max)
             end if

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

    ! make the edge values synchronous across levels
    call restrict_base(s0_edge,.false.)

  end subroutine cell_to_edge

end module cell_to_edge_module