      PROGRAM LANCELOT_simplet
!
!-------------------------------------------------------------------------------
!                                                                              !
!    This programs provides a test for lancelot_simple.f90                     !
!                                                                              !
!    Ph. L. Toint, November 2007                                               !
!                                                                              !
!-------------------------------------------------------------------------------
!                                                                              !
!       Copyright reserved, Gould/Orban/Toint, for GALAHAD productions         !
!                                                                              !
!------------------------------------------------------------------------------!
!
       USE LANCELOT_simple_double
       IMPLICIT NONE
       INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) ! set precision
       REAL ( KIND = wp ), PARAMETER :: infinity = 10.0_wp ** 20
       INTEGER :: n, neq, nin, iters, maxit, print_level, exit_code
       REAL ( KIND = wp ) :: gradtol, feastol, fx
       CHARACTER ( LEN = 10 ), ALLOCATABLE, DIMENSION(:) :: VNAMES, CNAMES
       REAL ( KIND = wp ),     ALLOCATABLE, DIMENSION(:) :: BL, BU, X, CX, Y
       EXTERNAL :: FUN, GRAD, HESS
!
! THE TEST PROBLEM DIMENSIONS (user defined)
!
       n   = 2  ! number of variables
       neq = 1  ! number of equality constraints, excluding fixed variables
       nin = 1  ! number of inequality (<= 0) constraints, excluding bounds
!
! allocate space for problem defining vectors
!
       ALLOCATE( X( n  ), BL( n ), BU( n ), CX( neq+nin ), Y( neq+nin ) )
       ALLOCATE( VNAMES( n  ), CNAMES( neq+nin ) )
!
! starting point
!
       X(1) = -1.2_wp                 ! starting point (componentwise)
       X(2) =  1.0_wp
!
! bounds on the variables
!
       BL(1) =  0.0_wp                ! lower bounds (componentwise)
       BL(2) = -infinity
       BU(1) =  infinity              ! upper bounds (componentwise)
       BU(2) =  3.0_wp
!
! names
!
       VNAMES(1) = 'x1'               ! variables
       VNAMES(2) = 'x2'
       CNAMES(1) = 'Equality'         ! equality constraints
       CNAMES(2) = 'Inequality'       ! inequality constraints
!
! algorithmic parameters
!
       maxit       = 100
       gradtol     = 0.00001_wp
       feastol     = 0.00001_wp
       print_level = 1
!
! call LANCELOT simple for a number of test cases
!
       WRITE(6,*) '====================================================', &
                  ' ================'
       CALL LANCELOT_simple( 0, X, fx, exit_code )
       WRITE(6,*) '==================== TEST 1: EXIT_CODE = ', exit_code, &
                  '  ======================'
!
       X(1) = -1.2_wp
       X(2) =  1.0_wp
       CALL LANCELOT_simple( 2, X, fx, exit_code, NEQ = -1 )
       WRITE(6,*) '==================== TEST 2: EXIT_CODE = ', exit_code, &
                  ' ======================'
!
       X(1) = -1.2_wp
       X(2) =  1.0_wp
       CALL LANCELOT_simple( 2, X, fx, exit_code, NIN = -1 )
       WRITE(6,*) '==================== TEST 3: EXIT_CODE = ', exit_code, &
                  '  ======================'
!
       X(1) = -1.2_wp
       X(2) =  1.0_wp
       CALL LANCELOT_simple( 2, X, fx, exit_code )
       WRITE(6,*) '==================== TEST 4: EXIT_CODE = ', exit_code, &
                  '  ======================'
       X(1) = -1.2_wp
       X(2) =  1.0_wp
       CALL LANCELOT_simple( 2, X, fx, exit_code, FUN )
       WRITE(6,*) '==================== TEST 5: EXIT_CODE = ', exit_code, &
                  '  ======================'
!
       X(1) = -1.2_wp
       X(2) =  1.0_wp
       CALL LANCELOT_simple( 2, X, fx, exit_code, MY_FUN = FUN )
       WRITE(6,*) '==================== TEST 6: EXIT_CODE = ', exit_code, &
                  '  ======================'
!
       X(1) = -1.2_wp
       X(2) =  1.0_wp
       CALL LANCELOT_simple( 2, X, fx, exit_code, MY_FUN = FUN, MY_GRAD = GRAD )
       WRITE(6,*) '==================== TEST 7: EXIT_CODE = ', exit_code, &
                  '  ======================'
!
       X(1) = -1.2_wp
       X(2) =  1.0_wp
       CALL LANCELOT_simple( 2, X, fx, exit_code,                         &
                            MY_FUN = FUN, MY_GRAD = GRAD,                 &
                            MY_HESS = HESS, PRINT_LEVEL = 0 )
       WRITE(6,*) '==================== TEST 8: EXIT_CODE = ', exit_code, &
                  '  ======================'
!
       X(1) = -1.2_wp
       X(2) =  1.0_wp
       CALL LANCELOT_simple( n,  X, fx, exit_code,                        &
                            MY_FUN = FUN, MY_GRAD = GRAD,                 &
                            MY_HESS =  HESS, BL  =  BL, BU   =   BU,      &
                            VNAMES   =  VNAMES, CNAMES =  CNAMES,         &
                            NEQ = neq, NIN = nin, CX = CX, Y = Y,         &
                            ITERS   = iters  , MAXIT   =   maxit,         &
                            GRADTOL = gradtol, FEASTOL = feastol,         &
                            PRINT_LEVEL = print_level )
       WRITE(6,*) ' CX = ', CX
       WRITE(6,*) ' Y  = ', Y
       WRITE(6,*) '==================== Test 9: EXIT_CODE = ', exit_code, &
                  '  ======================'
!
       X(1) = -1.2_wp
       X(2) =  1.0_wp
       CALL LANCELOT_simple( n,  X, fx, exit_code,                         &
                            MY_FUN = FUN, MY_GRAD = GRAD, MY_HESS =  HESS, &
                            BL  =  BL, BU   =   BU, NIN  =  1, NEQ = 1 )
       WRITE(6,*) '==================== Test 10: EXIT_CODE = ', exit_code, &
                  ' ======================'
!
! clean up
!
       DEALLOCATE( X, BL, BU, CX, Y )
       DEALLOCATE( VNAMES, CNAMES )
!
       STOP
!
       END PROGRAM LANCELOT_simplet
!
!...............................................................................
!
       SUBROUTINE FUN ( X, F, i )
       INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) ! set precision
       REAL( KIND = wp ), INTENT( IN )   :: X( : )
       REAL( KIND = wp ), INTENT( OUT )  :: F
       INTEGER, INTENT( IN ), OPTIONAL   :: i
       IF ( .NOT. PRESENT( i ) ) THEN
!         the objective function value (user defined)
!===============================================================================
          F = 100.0_wp*(X(2)-X(1)**2)**2 +(1.0_wp-X(1))**2                     !
!===============================================================================
       ELSE
          SELECT CASE ( i )
          CASE ( 1 )
!             the equality constraint value (user defined)
!===============================================================================
              F = X(1)+3.0_wp*X(2)-3.0_wp                                      !
!===============================================================================
          CASE ( 2 )
!             the inequality constraint value (user defined)
!===============================================================================
              F = X(1)**2+X(2)**2-4.0_wp                                       !
!===============================================================================
          END SELECT
       END IF
       RETURN
       END SUBROUTINE FUN
!
!...............................................................................
!
       SUBROUTINE GRAD( X, G, i )
       INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) ! set precision
       REAL( KIND = wp ), INTENT( IN )  :: X( : )
       REAL( KIND = wp ), INTENT( OUT ) :: G( : )
       INTEGER, INTENT( IN ), OPTIONAL  :: i
       IF ( .NOT. PRESENT( i ) ) THEN
!          the objective functions's gradient components (user defined)
!===============================================================================
           G( 1 ) = -400.0_wp*(X(2)-X(1)**2)*X(1)-2.0_wp*(1.0_wp-X(1))         !
           G( 2 ) =  200.0_wp*(X(2)-X(1)**2)                                   !
!===============================================================================
       ELSE
          SELECT CASE ( i )
          CASE ( 1 )
!             the equality constraint's gradient components (user defined)
!===============================================================================
              G( 1 ) =  1.0_wp                                                 !
              G( 2 ) =  3.0_wp                                                 !
!===============================================================================
          CASE ( 2 )
!            the inequality constraint's gradient components (user defined)
!===============================================================================
              G( 1 ) =  2.0_wp*X(1)                                            !
              G( 2 ) =  2.0_wp*X(2)                                            !
!===============================================================================
          END SELECT
       END IF
       RETURN
       END SUBROUTINE GRAD
!
!...............................................................................
!
       SUBROUTINE HESS( X, H, i )
       INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) ! set precision
       REAL( KIND = wp ), INTENT( IN )  :: X( : )
       REAL( KIND = wp ), INTENT( OUT ) :: H( : )
       INTEGER, INTENT( IN ), OPTIONAL  :: i
       IF ( .NOT. PRESENT( i ) ) THEN
!        the entries of the upper triangle of the objective function's
!        Hessian  matrix, stored by columns (user defined)
!===============================================================================
          H( 1 ) = -400.0_wp*(X(2)-3.0_wp*X(1)**2)+2.0_wp                      !
          H( 2 ) = -400.0_wp*X(1)                                              !
          H( 3 ) =  200.0_wp                                                   !
!===============================================================================
       ELSE
          SELECT CASE ( i )
          CASE ( 1 )
!             the entries of the upper triangle of the equality
!             constraint's Hessian matrix, stored by columns (user defined)
!===============================================================================
              H( 1 ) = 0.0_wp                                                  !
              H( 2 ) = 0.0_wp                                                  !
              H( 3 ) = 0.0_wp                                                  !
!===============================================================================
          CASE ( 2 )
!            the entries of the upper triangle of the inequality
!            constraint's Hessian matrix, stored by columns (user defined)
!===============================================================================
              H( 1 ) = 2.0_wp                                                  !
              H( 2 ) = 0.0_wp                                                  !
              H( 3 ) = 2.0_wp                                                  !
!===============================================================================
          END SELECT
       END IF
       RETURN
       END SUBROUTINE HESS
!...............................................................................


      MODULE global
      IMPLICIT NONE
      SAVE
      REAL*8,ALLOCATABLE :: NI(:,:), NE(:,:), VX(:,:), PH(:,:), FFT(:,:)
      REAL*8,ALLOCATABLE :: EX(:,:), FD0(:,:), FD1(:,:), FD2(:,:)
      REAL*8,ALLOCATABLE :: PHM(:,:), VXM(:,:), NIM(:,:),NEM(:,:)

      INTEGER   :: NX
      INTEGER   :: K,  NXP1, NXP2, NXP3, NXP4, J, CJ
      INTEGER   :: TIDATA, NTIME, FFTSRT, TIMAT, TRES
      INTEGER   :: CC, PRC, DC

      REAL*8    :: DX, DT, LX, P, B, XC, DN, EX0, T1, T2, LO, TOL, W
      REAL*8    :: NE0, NI0, DNE, DNI, L0E, L0I, VX0, DNV, L0V
      REAL*8    :: N0E, N0I, BT, ALP

      END MODULE global


      subroutine dwpow1(n,v,iv,pr,pi,ip,rr,ri,ir,ierr)
c!purpose
c     computes V^P with V real vector and P complex vector
c!calling sequence
c     subroutine dwpow1(n,v,iv,pr,pi,ip,rr,ri,ir,ierr)
c     integer n,iv,ip,ir,ierr
c     double precision v(*),pr(*),pi(*),rr(*),ri(*)
c
c     n    : number of elements of V and P vectors
c     v    : array containing  V elements
c            V(i)=v(1+(i-1)*iv)
c     iv   : increment between two V elements in v (may be 0)
c     pr   : array containing real part of P elements
c            real(P(i))=pr(1+(i-1)*iv)
c     pi   : array containing imaginary part of P elements
c            imag(P(i))=pi(1+(i-1)*iv)
c     ip   : increment between two P elements in p (may be 0)
c     rr   : array containing real part of the results vector R:
c            real(R(i))=rr(1+(i-1)*ir)
c     ri   : array containing imaginary part of the results vector R:
c            imag(R(i))=ri(1+(i-1)*ir)
c     ir   : increment between two R elements in rr and ri
c     ierr : error flag
c            ierr=0 if ok
c            ierr=1 if 0**0
c            ierr=2 if  0**k with k<0
c!origin
c Serge Steer INRIA 1996
c!
c     Copyright INRIA
      integer n,iv,ierr,ierr1
      double precision v(*),pr(*),pi(*),rr(*),ri(*)
c
      ierr=0
      iscmpl=0
c

      ii=1
      iip=1
      iir=1
      do 20 i=1,n
         call dwpowe(v(ii),pr(iip),pi(iip),rr(iir),ri(iir),ierr1)
c         if(ierr.ne.0) return
         ierr=max(ierr,ierr1)
         ii=ii+iv
         iip=iip+ip
         iir=iir+ir
 20   continue
c
      return
      end


    MODULE blas_extended_red_op

      ! Fortran 95 Bindings Generic Interface Blocks
      ! .  for section 4.?.? -- Reduction Operations
      ! .  using external procedures.
      ! Written on 18 December 2000
      ! .  Susan Blackford, UT-ICL

      PRIVATE
      PUBLIC :: dot, sum

      INTERFACE dot
        ! x and y must have same shape
        SUBROUTINE dot_d(x,y,r,alpha,beta,prec)
          USE blas_operator_arguments, ONLY : blas_prec_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: x(:), y(:)
          REAL (wp), INTENT (INOUT) :: r
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_prec_type), INTENT (IN), OPTIONAL :: prec
        END SUBROUTINE dot_d
        SUBROUTINE dot_z(x,y,r,conj,alpha,beta,prec)
          USE blas_operator_arguments, ONLY : blas_conj_type, &
                                              blas_prec_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: x(:), y(:)
          COMPLEX (wp), INTENT (INOUT) :: r
          TYPE (blas_conj_type), INTENT (IN), OPTIONAL :: conj
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_prec_type), INTENT (IN), OPTIONAL :: prec
        END SUBROUTINE dot_z
        SUBROUTINE dot_s(x,y,r,alpha,beta,prec)
          USE blas_operator_arguments, ONLY : blas_prec_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: x(:), y(:)
          REAL (wp), INTENT (INOUT) :: r
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_prec_type), INTENT (IN), OPTIONAL :: prec
        END SUBROUTINE dot_s
        SUBROUTINE dot_c(x,y,r,conj,alpha,beta,prec)
          USE blas_operator_arguments, ONLY : blas_conj_type, &
                                              blas_prec_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: x(:), y(:)
          COMPLEX (wp), INTENT (INOUT) :: r
          TYPE (blas_conj_type), INTENT (IN), OPTIONAL :: conj
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_prec_type), INTENT (IN), OPTIONAL :: prec
        END SUBROUTINE dot_c
      END INTERFACE

      INTERFACE sum
        FUNCTION sum_d(x,prec)
          USE blas_operator_arguments, ONLY : blas_prec_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: x(:)
          TYPE (blas_prec_type), INTENT (IN), OPTIONAL :: prec
          REAL (wp) :: sum_d
        END FUNCTION sum_d
        FUNCTION sum_z(x,prec)
          USE blas_operator_arguments, ONLY : blas_prec_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: x(:)
          TYPE (blas_prec_type), INTENT (IN), OPTIONAL :: prec
          COMPLEX (wp) :: sum_z
        END FUNCTION sum_z
        FUNCTION sum_s(x,prec)
          USE blas_operator_arguments, ONLY : blas_prec_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: x(:)
          TYPE (blas_prec_type), INTENT (IN), OPTIONAL :: prec
          REAL (wp) :: sum_s
        END FUNCTION sum_s
        FUNCTION sum_c(x,prec)
          USE blas_operator_arguments, ONLY : blas_prec_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: x(:)
          TYPE (blas_prec_type), INTENT (IN), OPTIONAL :: prec
          COMPLEX (wp) :: sum_c
        END FUNCTION sum_c
      END INTERFACE

    END MODULE blas_extended_red_op


c
c
c     =====================================================
      subroutine clawpack46_limiter(maxm,meqn,mwaves,mbc,mx,
     &      wave,s,mthlim)
c     =====================================================
c
c     # Apply a limiter to the waves.
c     # The limiter is computed by comparing the 2-norm of each wave with
c     # the projection of the wave from the interface to the left or
c     # right onto the current wave.  For a linear system this would
c     # correspond to comparing the norms of the two waves.  For a
c     # nonlinear problem the eigenvectors are not colinear and so the
c     # projection is needed to provide more limiting in the case where the
c     # neighboring wave has large norm but points in a different direction
c     # in phase space.
c
c     # The specific limiter used in each family is determined by the
c     # value of the corresponding element of the array mthlim, as used in
c     # the function philim.
c     # Note that a different limiter may be used in each wave family.
c
c     # dotl and dotr denote the inner product of wave with the wave to
c     # the left or right.  The norm of the projections onto the wave are then
c     # given by dotl/wnorm2 and dotr/wnorm2, where wnorm2 is the 2-norm
c     # of wave.
c
      implicit none

      integer maxm, meqn, mwaves, mbc, mx

      integer  mthlim(mwaves)
      double precision wave(1-mbc:maxm+mbc, meqn, mwaves)
      double precision s(1-mbc:maxm+mbc, mwaves)

      integer mw,i, m, ibc
      double precision dotr, wnorm2, dotl, wlimitr
      double precision philim

c      write(6,*) 'Messed with limiter.f'

c     Memory errors are all coming from boundary conditions not be
c     set correctly in the sphere case.
      do m = 1,meqn
         do mw = 1,mwaves
            do ibc = 1,mbc
c               wave(1-ibc,m,mw) = 0
c               wave(mx+ibc,m,mw) = 0
            enddo
         enddo
      enddo

c
      do mw = 1,mwaves
         if (mthlim(mw) .eq. 0) then
            continue
         endif
         dotr = 0.d0
         do  i = 0, mx+1
            wnorm2 = 0.d0
            dotl = dotr
            dotr = 0.d0
            do m = 1,meqn
               wnorm2 = wnorm2 + wave(i,m,mw)**2
               dotr = dotr + wave(i,m,mw)*wave(i+1,m,mw)
            enddo

            if (i .gt. 0 .and. wnorm2 .ne. 0) then
               if (s(i,mw) .gt. 0.d0) then
                  wlimitr = philim(wnorm2, dotl, mthlim(mw))
               else
                  wlimitr = philim(wnorm2, dotr, mthlim(mw))
               endif

               do m=1,meqn
                  wave(i,m,mw) = wlimitr * wave(i,m,mw)
               enddo
            endif
         enddo
      enddo

      return
      end


!*==cgbtrs.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CGBTRS
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CGBTRS + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB,
!                          INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          TRANS
!       INTEGER            INFO, KL, KU, LDAB, LDB, N, NRHS
!       ..
!       .. Array Arguments ..
!       INTEGER            IPIV( * )
!       COMPLEX            AB( LDAB, * ), B( LDB, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CGBTRS solves a system of linear equations
!>    A * X = B,  A**T * X = B,  or  A**H * X = B
!> with a general band matrix A using the LU factorization computed
!> by CGBTRF.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] TRANS
!> \verbatim
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations.
!>          = 'N':  A * X = B     (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose)
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in] KL
!> \verbatim
!>          KL is INTEGER
!>          The number of subdiagonals within the band of A.  KL >= 0.
!> \endverbatim
!>
!> \param[in] KU
!> \verbatim
!>          KU is INTEGER
!>          The number of superdiagonals within the band of A.  KU >= 0.
!> \endverbatim
!>
!> \param[in] NRHS
!> \verbatim
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!> \endverbatim
!>
!> \param[in] AB
!> \verbatim
!>          AB is COMPLEX array, dimension (LDAB,N)
!>          Details of the LU factorization of the band matrix A, as
!>          computed by CGBTRF.  U is stored as an upper triangular band
!>          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
!>          the multipliers used during the factorization are stored in
!>          rows KL+KU+2 to 2*KL+KU+1.
!> \endverbatim
!>
!> \param[in] LDAB
!> \verbatim
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
!> \endverbatim
!>
!> \param[in] IPIV
!> \verbatim
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices; for 1 <= i <= N, row i of the matrix was
!>          interchanged with row IPIV(i).
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is COMPLEX array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, the solution matrix X.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexGBcomputational
!
!  =====================================================================
      SUBROUTINE CGBTRS(Trans,N,Kl,Ku,Nrhs,Ab,Ldab,Ipiv,B,Ldb,Info)
      IMPLICIT NONE
!*--CGBTRS141
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Trans
      INTEGER Info , Kl , Ku , Ldab , Ldb , N , Nrhs
!     ..
!     .. Array Arguments ..
      INTEGER Ipiv(*)
      COMPLEX Ab(Ldab,*) , B(Ldb,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX ONE
      PARAMETER (ONE=(1.0E+0,0.0E+0))
!     ..
!     .. Local Scalars ..
      LOGICAL lnoti , notran
      INTEGER i , j , kd , l , lm
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL CGEMV , CGERU , CLACGV , CSWAP , CTBSV , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      Info = 0
      notran = LSAME(Trans,'N')
      IF ( .NOT.notran .AND. .NOT.LSAME(Trans,'T') .AND.                &
     &     .NOT.LSAME(Trans,'C') ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Kl<0 ) THEN
         Info = -3
      ELSEIF ( Ku<0 ) THEN
         Info = -4
      ELSEIF ( Nrhs<0 ) THEN
         Info = -5
      ELSEIF ( Ldab<(2*Kl+Ku+1) ) THEN
         Info = -7
      ELSEIF ( Ldb<MAX(1,N) ) THEN
         Info = -10
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('CGBTRS',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 .OR. Nrhs==0 ) RETURN
!
      kd = Ku + Kl + 1
      lnoti = Kl>0
!
      IF ( notran ) THEN
!
!        Solve  A*X = B.
!
!        Solve L*X = B, overwriting B with X.
!
!        L is represented as a product of permutations and unit lower
!        triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
!        where each transformation L(i) is a rank-one modification of
!        the identity matrix.
!
         IF ( lnoti ) THEN
            DO j = 1 , N - 1
               lm = MIN(Kl,N-j)
               l = Ipiv(j)
               IF ( l/=j ) CALL CSWAP(Nrhs,B(l,1),Ldb,B(j,1),Ldb)
               CALL CGERU(lm,Nrhs,-ONE,Ab(kd+1,j),1,B(j,1),Ldb,B(j+1,1),&
     &                    Ldb)
            ENDDO
         ENDIF
!
         DO i = 1 , Nrhs
!
!           Solve U*X = B, overwriting B with X.
!
            CALL CTBSV('Upper','No transpose','Non-unit',N,Kl+Ku,Ab,    &
     &                 Ldab,B(1,i),1)
         ENDDO
!
      ELSEIF ( LSAME(Trans,'T') ) THEN
!
!        Solve A**T * X = B.
!
         DO i = 1 , Nrhs
!
!           Solve U**T * X = B, overwriting B with X.
!
            CALL CTBSV('Upper','Transpose','Non-unit',N,Kl+Ku,Ab,Ldab,  &
     &                 B(1,i),1)
         ENDDO
!
!        Solve L**T * X = B, overwriting B with X.
!
         IF ( lnoti ) THEN
            DO j = N - 1 , 1 , -1
               lm = MIN(Kl,N-j)
               CALL CGEMV('Transpose',lm,Nrhs,-ONE,B(j+1,1),Ldb,        &
     &                    Ab(kd+1,j),1,ONE,B(j,1),Ldb)
               l = Ipiv(j)
               IF ( l/=j ) CALL CSWAP(Nrhs,B(l,1),Ldb,B(j,1),Ldb)
            ENDDO
         ENDIF
!
      ELSE
!
!        Solve A**H * X = B.
!
         DO i = 1 , Nrhs
!
!           Solve U**H * X = B, overwriting B with X.
!
            CALL CTBSV('Upper','Conjugate transpose','Non-unit',N,Kl+Ku,&
     &                 Ab,Ldab,B(1,i),1)
         ENDDO
!
!        Solve L**H * X = B, overwriting B with X.
!
         IF ( lnoti ) THEN
            DO j = N - 1 , 1 , -1
               lm = MIN(Kl,N-j)
               CALL CLACGV(Nrhs,B(j,1),Ldb)
               CALL CGEMV('Conjugate transpose',lm,Nrhs,-ONE,B(j+1,1),  &
     &                    Ldb,Ab(kd+1,j),1,ONE,B(j,1),Ldb)
               CALL CLACGV(Nrhs,B(j,1),Ldb)
               l = Ipiv(j)
               IF ( l/=j ) CALL CSWAP(Nrhs,B(l,1),Ldb,B(j,1),Ldb)
            ENDDO
         ENDIF
      ENDIF
!
!     End of CGBTRS
!
      END SUBROUTINE CGBTRS


module time_update_mod
  use kind_params_mod
  use kernel_mod
  use argument_mod
  use grid_mod
  use field_mod
  implicit none

  !=======================================

  type, extends(kernel_type) :: next_sshu
     type(go_arg), dimension(5) :: meta_args =  &
          (/ go_arg(GO_READWRITE, GO_CU, GO_POINTWISE),  &
             go_arg(GO_READ,      GO_CU, GO_STENCIL(000,011,000)),  &
             go_arg(GO_READ,      GO_GRID_MASK_T),    &
             go_arg(GO_READ,      GO_GRID_AREA_T),    &
             go_arg(GO_READ,      GO_GRID_AREA_U)     &
           /)

     !> We update only those points within the internal region
     !! of the simulated domain.
     integer :: ITERATES_OVER = GO_INTERNAL_PTS

     !> Although the staggering of variables used in an Arakawa
     !! C grid is well defined, the way in which they are indexed is
     !! an implementation choice. This can be thought of as choosing
     !! which grid-point types have the same (i,j) index as a T
     !! point. This kernel assumes that the U,V and F points that
     !! share the same index as a given T point are those immediately
     !! to the North and East of it.
     integer :: index_offset = GO_OFFSET_NE

  contains
    procedure, nopass :: code => next_sshu_code
  end type next_sshu

  !=======================================

  type, extends(kernel_type) :: next_sshv
     type(go_arg), dimension(5) :: meta_args =  &
          (/ go_arg(GO_READWRITE, GO_CV, GO_POINTWISE),  &
             go_arg(GO_READ,      GO_CV, GO_STENCIL(010,010,000)),  &
             go_arg(GO_READ,      GO_GRID_MASK_T),    &
             go_arg(GO_READ,      GO_GRID_AREA_T),    &
             go_arg(GO_READ,      GO_GRID_AREA_V)     &
           /)

     !> We update only those points within the internal region
     !! of the simulated domain.
     integer :: ITERATES_OVER = GO_INTERNAL_PTS

     !> Although the staggering of variables used in an Arakawa
     !! C grid is well defined, the way in which they are indexed is
     !! an implementation choice. This can be thought of as choosing
     !! which grid-point types have the same (i,j) index as a T
     !! point. This kernel assumes that the U,V and F points that
     !! share the same index as a given T point are those immediately
     !! to the North and East of it.
     integer :: index_offset = GO_OFFSET_NE

  contains
    procedure, nopass :: code => next_sshv_code
  end type next_sshv

contains

  !================================================

  subroutine invoke_next_sshu(sshn_u, sshn)
    implicit none
    type(r2d_field), intent(inout) :: sshn_u
    type(r2d_field), intent(in)    :: sshn
    ! Locals
    integer :: ji, jj

    do jj = sshn_u%internal%ystart, sshn_u%internal%ystop, 1
      do ji = sshn_u%internal%xstart, sshn_u%internal%xstop, 1

        call next_sshu_code(ji, jj, sshn_u%data, sshn%data, &
                            sshn_u%grid%tmask, &
                            sshn_u%grid%area_t, sshn_u%grid%area_u)
      end do
    end do

  end subroutine invoke_next_sshu

  !================================================

  subroutine next_sshu_code(ji,jj, sshn_u, sshn, &
                            tmask,e12t,e12u)
    implicit none
    integer,                  intent(in)    :: ji, jj
    integer,  dimension(:,:), intent(in)    :: tmask
    real(go_wp), dimension(:,:), intent(in)    :: e12t, e12u
    real(go_wp), dimension(:,:), intent(inout) :: sshn_u
    real(go_wp), dimension(:,:), intent(in)    :: sshn
    ! Locals
    real(go_wp) :: rtmp1
    if(tmask(ji,jj) + tmask(ji+1,jj) <= 0)  return   !jump over non-computational domain

    IF(tmask(ji,jj) * tmask(ji+1,jj) > 0) THEN
      rtmp1 = e12t(ji,jj) * sshn(ji,jj) + e12t(ji+1,jj) * sshn(ji+1,jj)
      sshn_u(ji,jj) = 0.5_go_wp * rtmp1 / e12u(ji,jj)
    ELSE IF(tmask(ji,jj) <= 0) THEN
      sshn_u(ji,jj) = sshn(ji+1,jj)
    ELSE IF(tmask(ji+1,jj) <= 0) THEN
      sshn_u(ji,jj) = sshn(ji,jj)
    END IF
  end subroutine next_sshu_code

  !================================================

  subroutine invoke_next_sshv(sshn_v, sshn)
    implicit none
    type(r2d_field), intent(inout) :: sshn_v
    type(r2d_field), intent(in)    :: sshn
    ! Locals
    integer :: ji, jj

    do jj = sshn_v%internal%ystart, sshn_v%internal%ystop, 1
      do ji = sshn_v%internal%xstart, sshn_v%internal%xstop, 1

        call next_sshv_code(ji, jj,  &
                            sshn_v%data, sshn%data, &
                            sshn_v%grid%tmask,      &
                            sshn_v%grid%area_t, sshn_v%grid%area_v)
      end do
    end do

  end subroutine invoke_next_sshv

  !================================================

  subroutine next_sshv_code(ji, jj, &
                            sshn_v, sshn, tmask, e12t, e12v)
    implicit none
    integer,                  intent(in)    :: ji, jj
    integer,  dimension(:,:), intent(in)    :: tmask
    real(go_wp), dimension(:,:), intent(in)    :: e12t, e12v
    real(go_wp), dimension(:,:), intent(inout) :: sshn_v
    real(go_wp), dimension(:,:), intent(in)    :: sshn
    ! Locals
    real(go_wp) :: rtmp1

    if(tmask(ji,jj) + tmask(ji,jj+1) <= 0)  return !jump over non-computational domain
    if(tmask(ji,jj) * tmask(ji,jj+1) > 0) then
      rtmp1 = e12t(ji,jj) * sshn(ji,jj) + e12t(ji,jj+1) * sshn(ji,jj+1)
      sshn_v(ji,jj) = 0.5_go_wp * rtmp1 / e12v(ji,jj)
    else if(tmask(ji,jj) <= 0) then
      sshn_v(ji,jj) = sshn(ji,jj+1)
    else if(tmask(ji,jj+1) <= 0) then
      sshn_v(ji,jj) = sshn(ji,jj)
    end if

  end subroutine next_sshv_code

  !================================================

end module time_update_mod


program main
!=================================================================
!
!  ZHEEVR Example. (based on the Intel MKL example)
!  ==============
!
!  Program computes eigenvalues specified by a selected range of values
!  and corresponding eigenvectors of a complex Hermitian matrix A using the
!  Relatively Robust Representations.
!
!  Description.
!  ============
!
!  The routine computes selected eigenvalues and, optionally, eigenvectors of
!  an n-by-n complex Hermitian matrix A. The eigenvector v(j) of A satisfies
!
!  A*v(j) = lambda(j)*v(j)
!
!  where lambda(j) is its eigenvalue. The computed eigenvectors are
!  orthonormal.
!  Eigenvalues and eigenvectors can be selected by specifying either a range
!  of values or a range of indices for the desired eigenvalues.
!
!  =============================================================================
!
!
! ifort -assume nounderscore -O3 -g -Icompil/magma-2.5.3/include -Lcompil/magma-2.5.3/lib -lmagma -o diag diag.f90 -mkl

  use omp_lib
  use magma
implicit none
!     .. Parameters ..
integer N
parameter (N = 5000)
logical OUTPUT
parameter (OUTPUT = .false.)
! Version indicates which algorithm to use 1=ZHEEV, 2=ZHEEVD, 3=ZHEEVR, 4=ZHEEVX
integer VERSION
integer LDA, LDZ
parameter (LDA = N, LDZ = N)
integer LWMAX
parameter (LWMAX = 1000000)
!
!     .. Local Scalars ..
integer i, info, lwork, lrwork, liwork, il, iu, m, ompthreads
double precision abstol, vl, vu
double precision :: tstart, tend
character(len=2) :: arg

!
!     .. Local Arrays ..
integer isuppz(N), iwork(LWMAX), ifail(N)
double precision w(N), rwork(LWMAX)
double precision ar(LDA*2, N*2)
double complex a(LDA, N), z(LDZ, N), work(LWMAX)
equivalence(ar,a)

! MAGMA stuff
!magma_devptr_t :: dA, dZ
integer(kind=8) :: dA, dZ, queue
integer          :: dev
complex*16       :: wA(N), wZ( n, n )
integer          :: ldwa, nb, ldwz
integer          :: mout(1)

!
!     .. External Subroutines ..
external ZHEEV
external ZHEEVX
external ZHEEVD
external ZHEEVR
!
!     .. Auxillary Subroutines ..
interface
    subroutine PRINT_MATRIX (Desc, M, N, A, Lda, Maxnum)
        character*(*), intent(in) :: Desc
        integer, intent (in) :: M
        integer, intent (in) :: N
        double complex, intent(in) :: A(Lda, *)
        integer, intent(in) :: Lda
        integer, intent(in), optional :: Maxnum
    end subroutine PRINT_MATRIX
    subroutine PRINT_RMATRIX (Desc, M, N, R, Lda, Maxnum)
        character*(*), intent(in) :: Desc
        integer, intent (in) :: M
        integer, intent (in) :: N
        double precision, intent(in) :: R(Lda, *)
        integer, intent(in) :: Lda
        integer, intent(in), optional :: Maxnum
    end subroutine PRINT_RMATRIX
end interface
!
!     .. Intrinsic Functions ..
intrinsic INT, MIN

!
!     .. Executable Statements ..
!
!     Populate matrix with random values
call random_seed()
call random_number(ar)

VERSION=3  ! default

call get_command_argument(1, arg)
if (len_trim(arg) == 0) then
  VERSION=3
else
  READ(arg,*)VERSION
endif

if (OUTPUT .eqv. .true.) then
  write (*, *) 'ZHEEVR Example Program Results'
endif

!     Negative ABSTOL means using the default value
abstol = -1.0
!     Set VL, VU to compute eigenvalues in half-open (VL,VU] interval,
!     and change the second parameter in the call to ZHEEVR to 'Values'
vl = -5.0
vu = 5.0
!
!     Query the optimal workspace.
!
lwork = -1
lrwork = -1
liwork = -1

ompthreads = omp_get_max_threads()
tstart = omp_get_wtime()

! MAGMA
call magmaf_init()
dev = 0
call magmaf_queue_create( dev, queue )

info = magmaf_zmalloc( dA, m*n )
info = magmaf_zmalloc( dZ, m*n )
ldwa = N
ldwz = N
nb = magmaf_get_zhetrd_nb( N )

   ! difference setmatrix vs copymatrix? Same interface
call magmaf_zsetmatrix( m, n, a, LDA, dA, LDA, queue )
call magmaf_queue_sync( queue )

! Version indicates which algorithm to use 1=ZHEEV, 2=ZHEEVD, 3=ZHEEVR, 4=ZHEEVX
if (VERSION == 1) then
  !!     Compute all eigenvalues and eigenvectors using QR
  call ZHEEV( 'Vectors', 'Lower', N, a, LDA, w, work, lwork, rwork, info)
  lwork = MIN( LWMAX, INT( work( 1 ) ) )
  !     Solve eigenproblem.
  call ZHEEV( 'Vectors', 'Lower', N, a, LDA, w, work, lwork, rwork, info)
else if (VERSION == 2) then
! Program computes all eigenvalues and eigenvectors of a complex Hermitian matrix A using divide and conquer algorithm,
  call ZHEEVD( 'Vectors', 'Lower', N, a, LDA, w, work, lwork, rwork, &
              lrwork, iwork, liwork, info)
      lwork = MIN( LWMAX, INT( work( 1 ) ) )
      lrwork = MIN( LWMAX, INT( rwork( 1 ) ) )
      liwork = MIN( LWMAX, iwork( 1 ) )
!  *     Solve eigenproblem.  *
  call ZHEEVD( 'Vectors', 'Lower', N, a, LDA, w, work, lwork, rwork, &
              lrwork, iwork, liwork, info)
else if (VERSION == 3) then
! Relatively Robust Representation (RRR)
  !     Compute all eigenvalues and eigenvectors (indicated by the second
  !     parameter (RANGE='All')
  call ZHEEVR('Vectors', 'All', 'Lower', N, a, LDA, vl, vu, il, iu, abstol, &
          & m, w, z, LDZ, isuppz, work, lwork, rwork, lrwork, iwork, liwork, &
          & info)
  lwork = MIN(LWMAX, INT(work(1)))
  lrwork = MIN(LWMAX, INT(rwork(1)))
  liwork = MIN(LWMAX, iwork(1))
  !
  !     Solve eigenproblem.
  !
  call ZHEEVR('Vectors', 'Values', 'Lower', N, a, LDA, vl, vu, il, iu, abstol, &
          & m, w, z, LDZ, isuppz, work, lwork, rwork, lrwork, iwork, liwork, &
          & info)
else if (VERSION == 4) then
!  QR iteration, expert
  call ZHEEVX( 'Vectors', 'Values', 'Lower', N, a, LDA, vl, vu, il, iu, abstol, &
               m, w, z, LDZ, work, lwork, rwork, iwork, ifail, info)
  lwork = MIN( LWMAX, INT( work( 1 ) ) )
  !     Solve eigenproblem.
  call ZHEEVX( 'Vectors', 'Values', 'Lower', N, a, LDA, vl, vu, il, iu, abstol, &
               m, w, z, LDZ, work, lwork, rwork, iwork, ifail, info)

else if ( VERSION == 11 ) then

   write( 5,*) "Not implemented yet. Come back later!"

else if ( VERSION == 12 ) then

   call MAGMAF_ZHEEVD_GPU( 'Vectors', 'Lower', n, dA, LDA, w, &
        wA, ldwa, work, lwork, rwork, lrwork, iwork, liwork, info)

   lwork = max( N + N*NB, 2*N + N**2 )
   lrwork = 1 + 5*N + 2*N**2
   liwork = 3 + 5*N

   call MAGMAF_ZHEEVD_GPU( 'Vectors', 'Lower', n, dA, LDA, w, &
        wA, ldwa, work, lwork, rwork, lrwork, iwork, liwork, info)

else if ( VERSION == 13 ) then

   call MAGMAF_ZHEEVR_GPU( 'Vectors', 'All', 'Lower', n, dA, LDA, vl, vu, il, iu, abstol, &
           mout, w,  dZ, ldz, isuppz, wA, ldwa, wZ, ldwz, work, lwork, rwork, lrwork, iwork, liwork, &
           info)
   lwork = (n+1)*n
   lrwork = max( 1, 24*n )
   liwork = max( 1, 10*n )

   call MAGMAF_ZHEEVR_GPU( 'Vectors', 'All', 'Lower', n, dA, LDA, vl, vu, il, iu, abstol, &
        mout, w,  dZ, ldz, isuppz, wA, ldwa, wZ, ldwz, work, lwork, rwork, lrwork, iwork, liwork, &
        info)
   m = mout(1)

else if ( VERSION == 14 ) then

   write( 5,*) "Not implemented yet. Come back later!"

   !magmaf_zheevx_gpu( jobz, range, uplo, n, dA, ldda, vl, vu, il, iu, abstol,  &
!        mout, w, dZ, lddz, wA, ldwa, wZ, ldwz, work, lwork, rwork, iwork, ifail, info )

!   call MAGMAF_ZHEEVX_GPU( 'Vectors', 'Values', 'Lower', n, dA, LDA, vl, vu, il, iu, abstol, &
!       m, w, dZ, LDZ, wA, ldwa, wZ, ldwz, &
!       work, lwork, rwork, iwork, ifail, info )

   !!  lwork = MIN( LWMAX, INT( work( 1 ) ) )
!!  call MAGMAF_ZHEEVX_GPU( 'Vectors', 'Values', 'Lower', N, dA, LDA, vl, vu, il, iu, abstol, &
!!       m, w, dZ, LDZ, wA, ldwa, wZ, ldwz, &
!!       work, lwork, rwork, iwork, ifail, info)

endif

call magmaf_zgetmatrix( m, n, dA, lda, a, lda, queue )
call magmaf_queue_sync( queue )

!
!     Check for convergence.
!
if (info>0) then
    write (*, *) 'The algorithm failed to compute eigenvalues.'
    STOP
endif
tend = omp_get_wtime()

!
!     Print the number of eigenvalues found.
!
write (*, '(A,I1,A,I2,A,F6.2)', advance="no") 'alg=', VERSION, ',threads=', ompthreads, ',time=', tend-tstart
write (*, '(A,I5)', advance="no") ',N=', N
write (*, '(A,I5)') ',number_eigenvalues_found=', m
!
!     Print eigenvalues.
!

if (OUTPUT .eqv. .true.) then
  if (VERSION == 1 .or. VERSION == 2) then
    m = N
    z = a
  endif
  call PRINT_RMATRIX('Selected eigenvalues', 1, m, w, 1, Maxnum = 12)
!
!     Print eigenvectors.
!
  call PRINT_MATRIX('Selected eigenvectors (stored columnwise)', N, m, z, LDZ, Maxnum = 12)
endif

call magmaf_queue_destroy( queue )
info = magmaf_free( dA )
info = magmaf_free( dZ )
call magmaf_finalize()

end program main
!
!     End of ZHEEVR Example.
!
!  =============================================================================
!
!     Auxiliary routine: printing a matrix.
!
subroutine PRINT_MATRIX(Desc, M, N, A, Lda, Maxnum)
    implicit none
    character*(*), intent(in) :: Desc
    integer, intent (in) :: M
    integer, intent (in) :: N
    double complex, intent(in) :: A(Lda, *)
    integer, intent(in) :: Lda
    integer, intent(in), optional :: Maxnum
    !
    integer i, j, Nprint
    !
    if (present(Maxnum)) then
        Nprint = Maxnum
    else
        Nprint = M
    endif
    write (*, *)
    write (*, *) Desc
    do i = 1, MIN(Nprint, M)
        write (*, 99001) (A(i, j), j = 1, N)
        !
        99001    FORMAT (11(:, 1X, '(', F6.2, ',', F6.2, ')'))
    enddo
    if (Nprint < M) then
        write (*, *) "..."
    endif
end

!
!     Auxiliary routine: printing a real matrix.
!
subroutine PRINT_RMATRIX(Desc, M, N, R, Lda, Maxnum)
    implicit none
    character*(*), intent(in) :: Desc
    integer, intent (in) :: M
    integer, intent (in) :: N
    double precision, intent(in) :: R(Lda, *)
    integer, intent(in) :: Lda
    integer, intent(in), optional :: Maxnum
    !
    integer i, j, Nprint
    !
    if (present(Maxnum)) then
        Nprint = Maxnum
    else
        Nprint = M
    endif
    write (*, *)
    write (*, *) Desc
    do i = 1, MIN(Nprint, M)
        write (*, 99001) (R(i, j), j = 1, N)
        !
        99001    FORMAT (11(:, 1X, F6.2))
    enddo
    if (Nprint < M) then
        write (*, *) "..."
    endif
end


$ Declare
   SUBROUTINE CrackGrowthLaw (A1, m1, A2, m2, DK0, K1C, fy, fu, Smax, dK, a, dadn)
!
! parameters
   USE PublicPar
   IMPLICIT NONE
!
   DOUBLE PRECISION, INTENT(IN)    :: A1
   DOUBLE PRECISION, INTENT(IN)    :: m1
   DOUBLE PRECISION, INTENT(IN)    :: A2
   DOUBLE PRECISION, INTENT(IN)    :: m2
   DOUBLE PRECISION, INTENT(IN)    :: DK0
   DOUBLE PRECISION, INTENT(IN)    :: K1C
   DOUBLE PRECISION, INTENT(IN)    :: fy
   DOUBLE PRECISION, INTENT(IN)    :: fu
   DOUBLE PRECISION, INTENT(IN)    :: Smax
   DOUBLE PRECISION, INTENT(IN)    :: dK
   DOUBLE PRECISION, INTENT(IN)    :: a
   DOUBLE PRECISION, INTENT(OUT)   :: dadn
!
! declarations
   DOUBLE PRECISION  :: ep, eq
   DOUBLE PRECISION  :: f, A0, dKth, dKeff, Kmax, curve
!
! Fatigue crack growth curves (N,mm)
! material: steel in air (Modified from BS 7910)
!
   ep = 2
   eq = 2
!
! Crack growth laws
   IF (law.EQ.2) THEN
!
! Following 2-stage law BS7910:2013
      IF (DK.LE.DK0) THEN
	     dadn = 0.D0
	  ELSE
	     dadn = MIN ((A2 * (DK**m2)),(A1 * (DK**m1)))
      END IF
   ELSE IF (law.EQ.1) THEN
!
! Following Forman Mettu
      Kmax = dK / (1.D0 - R)
      CALL Parameter_f (Smax, fy, fu, f, A0)
      CALL CrackGrowthThreshold (DK0, a, f, A0, dKth)
      dKeff = (1.D0-f)/(1.D0-R)*dK
      IF (dK.LE.dKth) THEN
         dadn = 0.D0
      ELSE IF (Kmax.GE.K1C) THEN
         dadn = 1.D0   ! Hele grote waarde gegeven. Feitelijk treedt breuk op
      ELSE
         curve = ((1.D0-dKth/dK)**ep)/((1.D0-Kmax/K1C)**eq)
         dadn = A1*curve*(dKeff)**m1
      END IF
   END IF
!
! End subroutine
   RETURN
   END


!   --------------------------------------------------------------------
!   DMET DELUX 2000	Subrutine	h5kalk
!   --------------------------------------------------------------------
!   HENSIKT :
!   Beregner transferfunksjoner i stamp for begge lektere
!
!   METODE :
!   Tar inn frekvensvektor, konstantverdier fra lektergeometri og
!   alle beregnede koeffisienter for stamp. Benytter
!   matematiske modeller for svingesystemer og kalkulererer
!   det dimensjonsløse utslaget for stampebevegelsen til begge lektere.
!   Teorien er presentert i rapporten. På grunn av komplekse formler
!   er uttrykkene faktorisert i stor grad.
!
!   KALLESEKVENS:
!   CALL h5kalk(n,nl,L,Br,D,M,A33,B33,A55,B55,C55,I55,k,omega,rho,g,H5)
!
!   PARAMETERE:
!   Navn	I/O	Type			Innhold/Beskrivelse
!   ....................................................................
!   omega	I	flyttals vektor		bølgefrekvens
!   n		I	heltall			antall frekvensintervaller
!   nl		I/O	heltall			antall lektere
!   k		I	flyttallsvektor		bølgetall
!   pi		I	flyttall		pi
!   g		I/O	flyttall		tyngdelfeltsakselerasjon
!   H3		I/O	flyttalls matrise	transferfunksjon hiv
!   H5		I/O	flyttalls matrise	transferfunksjon stamp
!   delta3	I/O	flyttalls matrise	fasevinkel hiv
!   delta5	I/O	flyttalls matrise	fasevinkel stamp
!   A33		I/O	flyttalls matrise	tilleggsmasse hiv
!   A55		I/O 	flyttalls matrise	tilleggsmasse stamp
!   B33		I/O	flyttalls matrise	demping hiv
!   B55		I/O	flyttalls matrise	demping stamp
!   C33		I/O	flyttalls vektor	fjørkoeffisient hiv
!   C55		I/O	flyttalls vektor	fjærkoeffisient stamp
!   L		I/O	heltalls vektor		lengde på lekter
!   Br		I/O 	heltalls vektor		bredde på lekter
!   D		I/O	flyttalls vektor	dypgang på lekter
!   H		I/O	flyttalls vektor	dybde i riss for lekter
!   M		I/O	flyttalls vektor	masse lekter
!   GML		I/O	flyttalls vektor	langskips metasenter
!   I55		I/O	flyttalls vektor	andre arealmoment langskips
!   pi		I/O	flyttall		pi
!   rho		I/O	flyttall		tetthet sjøvann
!   g		I/O	flyttall		tyngdeakselerasjonen
!
!
!   INTERNE VARIABLE:
!   Navn			Funksjon
!   .....................................................................
!   i,j				tellevariabler
!   F5A,F5A1,F5A2		faktorer i uttrykk
!   eta5nevner			faktor i uttrykk
!   eta5A			utslag for lekter i meter
!
!
!   SKRIVEFILER:
!   Navn			Eventuell beskrivelse
!   .....................................................................
!   H5plot22.txt		skriver resultat for visuell kontroll
!
!
!   --------------------------------------------------------------------
!
!   Programmert av:	     Tor Erik Larsen
!   Dato/Versjon  : 	     27.04.15 / 1.0
!
!   --------------------------------------------------------------------

SUBROUTINE h5kalk(n,nl,L,Br,D,M,A33,B33,A55,B55 &
     ,C55,I55,k,omega,rho,g,H5)
  IMPLICIT NONE
  !Erklærer variable
  INTEGER::n,nl,i,j
  REAL rho,g
  REAL,DIMENSION(1:nl)::L,Br,D,M,I55,C55
  REAL,DIMENSION(1:n,1:nl)::A33,B33,A55,B55
  DOUBLE PRECISION,DIMENSION(1:n)::k,omega
  DOUBLE PRECISION,DIMENSION(1:n,1:nl)::F5A1,F5A2,eta5nevner,F5A
  DOUBLE PRECISION,DIMENSION(1:n,1:nl)::eta5A,H5

  !Beregner eksitasjonskraft F5A
  DO i=1,n
     DO j=1,nl
        F5A1(i,j) = (rho*g*Br(j)*EXP(-k(i)*D(j)) &
             - omega(i)**2 * (A33(i,j)/L(j))* EXP(-k(i)*D(j)/2.0 ) )

        F5A2(i,j) =  L(j)*COS(k(i)*L(j) / 2.0) &
             - (2.0 / k(i) )*SIN( k(i)*L(j) / 2.0 )

        eta5nevner(i,j) = (k(i)**2) &
             * SQRT(  (C55(j) - (I55(j) + A55(i,j))*omega(i)**2 )**2 &
             + (B55(i,j)*omega(i))**2   )
     END DO
  END DO

  !Multipliserer faktorene i nevner
  DO i=1,n
     DO j=1,nl
        F5A (i,j) = F5A1(i,j) * F5A2(i,j)
     END DO
  END DO

  !Beregner eta5A
  DO i=1,n
     DO j=1,nl
        eta5A(i,j) = F5A(i,j) / eta5nevner(i,j)
     END DO
  END DO

  !Beregner transferfunksjonen H5
  DO i=1,n
     DO j=1,nl
        H5(i,j) = ABS(eta5A(i,j))
     END DO
  END DO

  !Skriver H5 til plottefil for visuell sjekk
  OPEN(488,FILE="H5plot22.txt",ACTION="WRITE",STATUS="UNKNOWN")
  DO i=1,n
     WRITE(488,*) omega(i), H5(i,1), H5(i,2)
  END DO
  CLOSE(488)

  RETURN
END SUBROUTINE h5kalk


SUBROUTINE Geider_Droop
    !Add phyto. Carbon into existing Geider model
USE bio_MOD
implicit none
integer :: k

! Half saturation constant for Zoo grazing
real, parameter :: Kp = 0.5

! Regenration constant from detritus to DIN (d-1)
real, parameter :: RDN= 0.1

real    :: rhochl, theta,QN, CHL
real    :: SI,Lno3, PC
real    :: par_, rhoI !Nitrogen uptake rate
real    :: NO3, PHY, PHYC, ZOO, DET
real    :: mz,gmax

mz   = params(imz)
gmax = params(igmax)

DO k = 1, nlev
   tf_p= TEMPBOL(Ep, Temp(k))
   NO3 = Vars(iNO3,    k)
   PHYC= Vars(iPHYC(1),k)
   PHY = Vars(iPHY(1), k)
   ZOO = Vars(iZOO,    k)
   CHL = Vars(iCHL(1), k)
   DET = Vars(iDET,    k)
   QN  = PHY/PHYC !Cellular N:C ratio (mol N: mol C)
   ! Check whether in the MLD or not
   if (k .lt. N_MLD) then
      par_ = PAR(k)
   else
      par_ = PARavg
   endif
   ! Loss rate of phytoplankton to detritus equals to zero

   ! Define phytoplankton Chl-to-carbon ratio (gChl/molC)
   theta = CHL/PHYC

   ! Save data:
   Varout(oQN(1),k)    = QN
   Varout(oTheta(1),k) = theta

   ! Main phyto. subroutine
   call PHY_GeiderDroop(Temp(k), par_, NO3, QN, theta, &
                        Lno3, SI, PC, rhoI, rhochl)

   ! N limitation
   Varout(oLno3(1),k) = Lno3
   Varout(oSI(1),  k) = SI

   ! The total amount of phytoplankton grazed by zooplankton (molN;gmax is the maximal specific ingestion rate!)
   tf_z   = TEMPBOL(Ez,Temp(k))
   gbar   = grazing(grazing_formulation,Kp,PHY)
   INGES  = ZOO*gmax*tf_z * gbar
   Zmort  = ZOO*ZOO*mz*tf_z  !Mortality term for ZOO

   !Zooplankton excretion rate (-> DOM)
   RES = INGES*(1d0-GGE-unass)

   !ZOOPLANKTON EGESTION (-> POM)
   EGES = INGES*unass

   ! For production/destruction matrix:
   pp_ND = RDN*DET*tf_z
   pp_NZ = ZOO*RES
   pp_DZ = ZOO*EGES+Zmort
   pp_ZP = ZOO*INGES

   Varout(oDET,k)   = DET+dtdays*(pp_DZ - pp_ND)
   Varout(oNO3,k)   = NO3+dtdays*(pp_ND+pp_NZ-PHYC*rhoI)

   ! Equation for PHY. nitrogen (decouple nutrient uptake and photosynthesis)
   Varout(oPHY(1),k)= PHY+dtdays*(PHYC*rhoI-pp_ZP)
   Varout(oZOO,k)   = ZOO+dtdays*(pp_ZP-pp_DZ-pp_NZ)

   ! Equation for PHY. carbon
   Varout(oPHYC(1),k)=PHYC+dtdays*(PHYC*PC - pp_ZP/QN)

   Varout(omuNet(1), k) = PC
   Varout(oGraz(1), k)  = pp_ZP/PHY
   Varout(oZ2N,k) = pp_NZ
   Varout(oD2N,k) = pp_ND

   Varout(oCHLt,k)  =CHL + dtdays*(rhochl*PC*PHYC - pp_ZP/QN)*theta

   Varout(oCHL(1),k)=Varout(oCHLt,k)

   ! Calculate NPP based on incubation light
   call PHY_GeiderDroop(Temp(k), PAR(k), NO3, QN, theta, &
                        Lno3, SI, PC, rhoI, rhochl)
   Varout(oPPt,k)=PHYC*PC
   Varout(oPON,k)=PHY+ZOO+DET
enddo
End subroutine Geider_Droop

subroutine PHY_GeiderDroop(Temp, PAR, NO3, QN, theta, Lno3, SI, muC, rhoI, rhochl)
use bio_MOD, only: params, irhom, TEMPBOL, Ep, iaI0, thetamax, imu0
use bio_MOD, only: tf_p

implicit none

real, intent(in)  :: Temp, PAR, NO3, QN, theta

! Minimal and maximal N:C ratio
real, parameter   :: QNmin = 0.06, QNmax = 0.18, dQN = 0.12

! Nitrogen uptake rate
real, intent(out) :: rhoI

! Carbon based photosynthetical rate
real, intent(out) :: muC

! Indices for light and nutrient limitation
real, intent(out) :: Lno3, SI, rhochl

real :: PCmax
!Half-saturation constant for N uptake
real, parameter :: KN = 0.2

!Temperature coefficient
tf_p = TEMPBOL(Ep, Temp)

! DIN uptake by phytoplankton (Ward 2017)
rhoI = params(irhom)*NO3/(NO3 + KN)*(QNmax-QN)/dQN*tf_p

! N limitation
Lno3 = (QN-QNmin)/dQN

!Maximal photosynthesis rate (regulated by QN)
PCmax= params(imu0)*tf_P*Lno3

!The light limitation index (fpar)
SI = 1d0 - exp(-params(iaI0)*PAR*theta/PCmax)

! Photosynthesis rate (d-1)
muC= PCmax*SI

! define rhochl (gChl/molC;the fraction of phytoplankton carbon production that is devoted to Chl synthesis)
rhochl = thetamax*muC/(params(iaI0)*PAR*theta)
return
end subroutine PHY_GeiderDroop


C
      SUBROUTINE MIXR(PR,TS,T,RH,W,QC2)
C$$$  SUBPROGRAM DOCUMENTATION  BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    MIXR         COMPUTES MIXING RATIO
C   PRGMMR: L. D. BURROUGHS  ORG: W/NMC21    DATE: 03-03-06
C
C ABSTRACT: COMPUTES THE MIXING RATIO FROM PRES, TEMP, AND REL HUM
C           BY USING THE TETONS FORMULATION IN THE SMITHSONIAN
C           METEOROLOGICAL TABLES.
C
C PROGRAM HISTORY LOG:
C   03-03-06  L. D. BURROUGHS
C
C USAGE:    CALL MIXR(PR,TS,T,RH,W,QC2)
C
C   INPUT ARGUMENT LIST:
C     PR       - PRESSURE - R*4 (MB) (USED WHEN EQ POT TEMP (EPT) IS
C                COMPUTED FOR CONSTANT PRESSURE SURFACES)
C     T        - AIR TEMPERATURE AT THE GIVEN PRESSURE - R*4 (DEG K)
C     RH       - RELATIVE HUMIDITY AT GIVEN PRESSURE AND TEMPERATURE -
C                R*4 (PERCENT) (USED WHEN EPT IS COMPUTED FOR CONSTANT
C                PRESSURE SURFACES OR AT SFC WHEN 1000 MB RH IS ASSUMED
C                TO BE THE SAME AS THE SURFACE RH)
C
C   OUTPUT ARGUMENT LIST:
C     W        - MIXING RATIO (KG/KG) R*4
C
C   INPUT FILES:
C     NONE
C
C   OUTPUT FILES:
C     NONE
C
C   SUBPROGRAMS CALLED:
C
C     UNIQUE:    - NONE
C
C     LIBRARY:
C       W3LIB    - NONE
C
C       IMSL     - NONE
C
C       SPECIAL  - EXP     ALOG
C
C REMARKS: NONE
C
C     VARIABLES:
C
C       INPUT    - NONE
C
C       INTERNAL - CP         = SPECIFIC HEAT OF DRY AIR AT CNST PRES -
C                               R*4 (CAL/((GM OF DRY AIR)*DEG K))
C                  ES         = SATURATION VAPOR PRESSURE - R*4 (MB)
C                  WS         = SATURATION MIXING RATIO - R*4 (G WATER
C                               VAPOR/G DRY AIR)
C                  W          = MIXING RATIO FOR A GIVEN RH - R*4
C
C       OUTPUT   - NONE
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN90
C   MACHINE:  IBM SP
C
C$$$
      IMPLICIT none

      SAVE
! Arguments
      REAL PR, TS, T, RH, W, QC2
! Local
      REAL CP, D, ES1, ES, ESS1, ESS
      REAL a, b, c, e
      REAL a1, b1, c1, d1, e1
      REAL ws, wss
C
C          SET CONSTANTS
C
      CP=.240
      D=LOG10(6.1071)
      IF(RH.LE.0.)GO TO 1050
C
C          COMPUTE SATURATION VAPOR PRESSURE
C
      IF(TS.GE.273.16)THEN
         ES1=(17.2694*T-4717.31)/(T-35.86)
         IF(ES1.GE.174.673)GO TO 1050
         ES=6.1078*EXP(ES1)
         ESS1=(17.2694*TS-4717.31)/(TS-35.86)
         IF(ESS1.GE.174.673)GO TO 1050
         ESS=6.1078*EXP(ESS1)
      ELSE
         IF(T.LE.0.)GO TO 1050
         A=-9.09718*((273.16/T)-1.)
         B=-3.56654*LOG10(273.16/T)
         C= 0.876793*(1.-(T/273.16))
         D= LOG10(6.1071)
         E= A+B+C+D
         ! Error, found by lizo@oceanweather.com ES=ALOG10(E)
         ES = 10**E
         A1=-9.09718*((273.16/TS)-1.)
         B1=-3.56654*LOG10(273.16/TS)
         C1= 0.876793*(1.-(TS/273.16))
         D1= LOG10(6.1071)
         E1= A1+B1+C1+D1
         ! Error, found by lizo@oceanweather.com ESS=ALOG10(E1)
         ESS = 10**E1
      ENDIF
C
C          COMPUTE SATURATION MIXING RATIO, MIXING RATIO, AND VAPOR
C          PRESSURE
C
      WS=0.622*ES/(PR-ES)
      WSS=0.622*ESS/(PR-ESS)
      W=RH*WS/100.
      QC2=W-WSS
      E=PR*W/(W+0.622)
      GO TO 1060

 1050 CONTINUE
      W=0.
C
 1060 RETURN
      END


program testgas
       integer*4 ibuf(18),ibufb(3), ibuf1(18)
       character filename*60

      common /gparameters/  a, b, c, v0, q, psi00, &
     &                      psiout, rho1, sigbulge2, &
     &                      rmdisk, rdisk, zdisk, outdisk, drtrunc, &
     &                      potcor1

   integer, parameter :: n=1000,m=50
   real :: dens(n),z(n)
   real :: r,cs,gamma,mz,norm,mz2,rs(m),zm(m),z2m(m)

   filename='dbh.dat'
   call readharmfile(filename,ibuf)

  print*,pot(0.,0.),zdisk

  do j=1,m
  r=j/(1.*m)*16
  cs=10./65.6
  gamma=5./3.
  gamma=1.
  psi0=pot(r,0.)
  norm=0.
  mz2=0.
  mz=0.
  do i=1,n
   z(i)=(i-1)/(1.*n)*20*zdisk
   dens(i)=exp(-gamma*(pot(r,z(i))-psi0)/cs**2)
   mz=mz+dens(i)*z(i)
   mz2=mz2+dens(i)*z(i)**2
   norm=norm+dens(i)
  enddo
  mz=mz/norm
  mz2=mz2/norm
  rs(j)=r
  zm(j)=mz
  z2m(j)=mz2
  enddo

  open(unit=1,file='testgas.data',status='UNKNOWN')
  do i=1,m
   write(1,*) rs(i),zm(i),z2m(i)
  enddo
  close(1)

 end program


program main
 implicit none
 integer               :: i,j,k,deg,paso,ierr
 real                  :: energy, oto,ot,factor=0.0, sumfactor=0.0
 real                  :: energy0=99999999999.0
 real                  :: energy_average = 0.0
 real                  :: oto_average = 0.0
 real                  :: ot_average  = 0.0
 real                  :: tt,tot
 real                  :: tt_average  = 0.0
 real                  :: tot_average = 0.0
 real                  :: rv(3,3),vr(3,3),cell_0(6),volume_0=0.0
 real                  :: cell_1_tmp = 0.0
 real                  :: cell_1_average = 0.0
 real                  :: cell_1_average_qrt=0.0
 real                  :: cell_3_average = 0.0
 real,parameter        :: k_b = 8.6173303e-5
 real,parameter        :: temperature = 450.0
 real                  :: beta = 1.0/(k_b*temperature)
 character(len=40)     :: filename
 read_file: do
  read(5,*,iostat=ierr)i,j,energy,(cell_0(k),k=1,6),ot,oto,tt,tot,filename
  if (ierr/=0) exit read_file
  if(energy<=energy0)energy0=energy
 end do read_file
 rewind(5)
 read_file2: do
  read(5,*,iostat=ierr)i,j,energy,(cell_0(k),k=1,6),ot,oto,tt,tot,filename
  if (ierr/=0) exit read_file2
  factor=exp(-beta*(energy-energy0))
  sumfactor=sumfactor+factor
 end do read_file2
 !write(6,*) sumfactor,energy0
 rewind(5)
 read_again: do
  read(5,*,iostat=ierr)i,j,energy,(cell_0(k),k=1,6),ot,oto,tt,tot,filename
  if (ierr/=0) exit read_again
  call cell(rv,vr,cell_0)
  volume_0= volume(rv)
  cell_0(4)=90.0
  cell_0(5)=90.0
  cell_0(6)=120.0
  cell_1_tmp= extract_a(cell_0,volume_0)
  call cell(rv,vr,cell_0)
  factor=exp(-beta*(energy-energy0))/sumfactor
  tt_average = tt_average + tt*factor
  tot_average = tot_average + tot*factor
  ot_average = ot_average + ot*factor
  oto_average = oto_average + oto*factor
  energy_average= energy_average+energy*factor
  cell_1_average= cell_1_average+cell_1_tmp*factor
  cell_3_average= cell_3_average+cell_0(3)*factor
 end do read_again
 rewind(5)
 read_again2: do
  read(5,*,iostat=ierr)i,j,energy,(cell_0(k),k=1,6),filename
  if (ierr/=0) exit read_again2
  call cell(rv,vr,cell_0)
  cell_0(4)=90.0
  cell_0(5)=90.0
  cell_0(6)=120.0
  cell_1_tmp= extract_a(cell_0,volume_0)
  !cell_1_tmp=(0.09643*volume_0)/cell_0(3)
  call cell(rv,vr,cell_0)
  factor=exp(-beta*(energy-energy0))/sumfactor
  !cell_1_average_qrt=cell_1_average_qrt+((0.5*(cell_0(1)+cell_0(2))-cell_1_average)**2)*factor
  cell_1_average_qrt=cell_1_average_qrt+((cell_1_tmp-cell_1_average)**2)*factor
 end do read_again2
 cell_1_average_qrt=sqrt(cell_1_average_qrt)
 write(6,*)i,energy_average,cell_1_average,cell_1_average_qrt,cell_3_average,volume(rv),&
           ot_average,oto_average,tt_average,tot_average
contains
real function csc_deg(x)
 implicit none
 real :: x
 csc_deg = -(2*sin(x))/(cos(2*x)-1.0)
 return
end function csc_deg
real function cot_deg(x)
 implicit none
 real :: x
 cot_deg = -(sin(2*x))/(cos(2*x)-1.0)
 return
end function cot_deg
real function extract_a(cell_0,v)
 implicit none
 real :: cell_0(6),v
 real :: pi,DEGTORAD
 real :: alp,bet,gam
 real :: cosa,cosb,cosg
 real :: sina,sinb,sing
 pi = ACOS(-1.0)
 DEGTORAD=pi/180.0
 IF(cell_0(4) == 90.0) THEN
   cosa = 0.0
 ELSE
   ALP=cell_0(4)*degtorad
   COSA=cos(ALP)
 ENDIF
 IF(cell_0(5) == 90.0) THEN
   cosb = 0.0
 ELSE
   bet = cell_0(5)*degtorad
   cosb = cos(bet)
 ENDIF
 IF(cell_0(6) == 90.0) then
   sing = 1.0
   cosg = 0.0
 ELSE
   gam = cell_0(6)*degtorad
   sing = sin(gam)
   cosg = cos(gam)
 ENDIF

 extract_a = (sqrt(v)*sqrt(csc_deg(gam)))/( sqrt(cell_0(3))*( &
  1.0-cosb**2-(cosb**2)*(cot_deg(gam)**2)+&
  2.0*cosa*cosb*cot_deg(gam)*csc_deg(gam)-(cosa**2)*(csc_deg(gam)**2))**(1.0/4.0))

! Sqrt[Csc[\[Gamma]]])/(Sqrt[
!   c] (1 - Cos[\[Beta]]^2 - Cos[\[Beta]]^2 Cot[\[Gamma]]^2 +
!     2 Cos[\[Alpha]] Cos[\[Beta]] Cot[\[Gamma]] Csc[\[Gamma]] -
!     Cos[\[Alpha]]^2 Csc[\[Gamma]]^2)^(1/4))

! extract_a = (sqrt(v)*sqrt(csc_deg(gam))/ &
!  ( cell_0(3))*(1.0-cosb**2-(cosb**2)*(cot_deg(gam)**2)+&
!  2.0*cosa*cosb*cot_deg(gam)*csc_deg(gam)-(cosa**2)*(csc_deg(gam)**2))**(1.0/4.0)) )
!extract_a= (V*csc_deg(gam))/(cell_0(2)*cell_0(3)*Sqrt( &
!  1.0-cosb**2-(cosb**2)*(cot_deg(gam)**2)+&
!  2.0*cosa*cosb*cot_deg(gam)*csc_deg(gam)-(cosa**2)*(csc_deg(gam)**2))**(1.0/4.0))

 return
end function extract_a
SUBROUTINE cell(rv,vr,cell_0)
 implicit none
 integer :: i,j
 real, intent(in)  :: cell_0(6)
 real, intent(out) :: rv(3,3),vr(3,3)
 real :: alp,bet
 real :: cosa,cosb,cosg
 real :: gam,sing
 real :: pi,DEGTORAD
 pi = ACOS(-1.0)
 DEGTORAD=pi/180.0
 IF(cell_0(4) == 90.0) THEN
   cosa = 0.0
 ELSE
   ALP=cell_0(4)*degtorad
   COSA=cos(ALP)
 ENDIF
 IF(cell_0(5) == 90.0) THEN
   cosb = 0.0
 ELSE
   bet = cell_0(5)*degtorad
   cosb = cos(bet)
 ENDIF
 IF(cell_0(6) == 90.0) then
   sing = 1.0
   cosg = 0.0
 ELSE
   gam = cell_0(6)*degtorad
   sing = sin(gam)
   cosg = cos(gam)
 ENDIF
 rv(1,1) = cell_0(1)
 rv(1,2) = cell_0(2)*cosg
 rv(1,3) = cell_0(3)*cosb
 rv(2,1) = 0.0
 rv(2,2) = cell_0(2)*sing
 rv(2,3) = cell_0(3)*(cosa - cosb*cosg)/sing
 rv(3,1) = 0.0
 rv(3,2) = 0.0
 rv(3,3) = sqrt( cell_0(3)*cell_0(3) - rv(1,3)*rv(1,3) - rv(2,3)*rv(2,3))
 call inverse(rv,vr,3)
! print*,'Cell:'
! WRITE(*,'(6F14.7)')( cell_0(j), j=1,6 )
! print*,'Box:'
! DO i=1,3
!    WRITE(*,'(F14.7,F14.7,F14.7)')( rv(i,j), j=1,3 )
! ENDDO
! WRITE(*,*)'----------------------------------------'
! WRITE(*,*)'bOX:'
! DO i=1,3
!    WRITE(*,'(F14.7,F14.7,F14.7)')( vr(i,j), j=1,3 )
! ENDDO
 RETURN
END SUBROUTINE cell
!
SUBROUTINE uncell(rv,cell_0)
  implicit none
  real,intent(out) :: cell_0(6)
  real,intent(in)  :: rv(3,3)
  integer  :: i,j
  real     :: temp(6)
  REAL :: radtodeg,PI
  PI=ACOS(-1.0)
  radtodeg=180.0/PI
!
  do i = 1,3
    temp(i) = 0.0
    do j = 1,3
      temp(i) = temp(i) + rv(j,i)**2
    enddo
    temp(i) = sqrt(temp(i))
  enddo
  cell_0(1) = abs(temp(1))
  cell_0(2) = abs(temp(2))
  cell_0(3) = abs(temp(3))
  do i = 1,3
    temp(3+i) = 0.0
  enddo
  do j = 1,3
    temp(4) = temp(4) + rv(j,2)*rv(j,3)
    temp(5) = temp(5) + rv(j,1)*rv(j,3)
    temp(6) = temp(6) + rv(j,1)*rv(j,2)
  enddo
  temp(4) = temp(4)/(temp(2)*temp(3))
  temp(5) = temp(5)/(temp(1)*temp(3))
  temp(6) = temp(6)/(temp(1)*temp(2))
  cell_0(4) = radtodeg*acos(temp(4))
  cell_0(5) = radtodeg*acos(temp(5))
  cell_0(6) = radtodeg*acos(temp(6))
!  Avoid round off errors for 90.0 and 120.0 degrees
  DO i=4,6
     if (abs(cell_0(i) - 90.0 ).lt.0.00001) cell_0(i) = 90.0
     if (abs(cell_0(i) - 120.0).lt.0.00001) cell_0(i) = 120.0
  ENDDO
!
  return
end subroutine uncell
!
subroutine inverse(a,c,n)
!============================================================
! Inverse matrix
! Method: Based on Doolittle LU factorization for Ax=b
! Alex G. December 2009
!-----------------------------------------------------------
! input ...
! a(n,n) - array of coefficients for matrix A
! n      - dimension
! output ...
! c(n,n) - inverse matrix of A
! comments ...
! the original matrix a(n,n) will be destroyed
! during the calculation
!===========================================================
 implicit none
 integer n
 real a(n,n), c(n,n)
 real L(n,n), U(n,n), b(n), d(n), x(n)
 real coeff
 integer i, j, k
! step 0: initialization for matrices L and U and b
! Fortran 90/95 aloows such operations on matrices
 L=0.0
 U=0.0
 b=0.0
! step 1: forward elimination
 do k=1, n-1
   do i=k+1,n
      coeff=a(i,k)/a(k,k)
      L(i,k) = coeff
      do j=k+1,n
         a(i,j) = a(i,j)-coeff*a(k,j)
      end do
   end do
 end do
! Step 2: prepare L and U matrices
! L matrix is a matrix of the elimination coefficient
! + the diagonal elements are 1.0
 do i=1,n
  L(i,i) = 1.0
 end do
! U matrix is the upper triangular part of A
 do j=1,n
  do i=1,j
    U(i,j) = a(i,j)
  end do
 end do
!
! Step 3: compute columns of the inverse matrix C
 do k=1,n
  b(k)=1.0
  d(1) = b(1)
! Step 3a: Solve Ld=b using the forward substitution
  do i=2,n
    d(i)=b(i)
    do j=1,i-1
      d(i) = d(i) - L(i,j)*d(j)
    end do
  end do
! Step 3b: Solve Ux=d using the back substitution
  x(n)=d(n)/U(n,n)
  do i = n-1,1,-1
    x(i) = d(i)
    do j=n,i+1,-1
      x(i)=x(i)-U(i,j)*x(j)
    end do
    x(i) = x(i)/u(i,i)
  end do
! Step 3c: fill the solutions x(n) into column k of C
  do i=1,n
    c(i,k) = x(i)
  end do
  b(k)=0.0
 end do
 return
END SUBROUTINE inverse
!
real function volume(rv)
  implicit none
  real, intent(in)  :: rv(3,3)
  real       :: r1x
  real       :: r1y
  real       :: r1z
  real       :: r2x
  real       :: r2y
  real       :: r2z
  real       :: r3x
  real       :: r3y
  real       :: r3z
  real       :: vol
!
  r1x = rv(1,1)
  r1y = rv(2,1)
  r1z = rv(3,1)
  r2x = rv(1,2)
  r2y = rv(2,2)
  r2z = rv(3,2)
  r3x = rv(1,3)
  r3y = rv(2,3)
  r3z = rv(3,3)
  vol = r1x*(r2y*r3z - r2z*r3y) + r1y*(r3x*r2z - r3z*r2x) + r1z*(r2x*r3y - r2y*r3x)
  volume = abs(vol)
  RETURN
end function
end program main


! In this module we define the variables needed for the numerical
! calculation of the second derivative of the kinetic energy
! h is the step length while h2 is the squared inverse step length

MODULE derivative_step
USE constants
    REAL(DP), PUBLIC  :: h = 0.001_dp
    REAL(DP), PUBLIC  :: h2 = 1000000_dp
END MODULE derivative_step

! Begin of main program

PROGRAM vmc_helium
USE constants
IMPLICIT NONE
INTEGER :: number_cycles, max_variations, thermalization, &
           dimension, number_particles
REAL(DP) ::  step_length
REAL(DP), ALLOCATABLE, DIMENSION(:) :: cumulative_e, cumulative_e2

    !   Read in data
    CALL initialise(dimension, number_particles, max_variations, &
                    number_cycles, thermalization, step_length)
    ! allocate array for expectation values
    ALLOCATE(cumulative_e(max_variations), cumulative_e2(max_variations))
    cumulative_e=0.0_dp ;  cumulative_e2=0.0_dp
    !  Do the mc sampling
    CALL mc_sampling(dimension, number_particles, max_variations, &
                     thermalization, number_cycles, step_length, &
                     cumulative_e, cumulative_e2)
    ! Print out results
    CALL output(max_variations, number_cycles, cumulative_e, cumulative_e2)
END PROGRAM vmc_helium

! Monte Carlo sampling with the Metropolis algorithm

SUBROUTINE mc_sampling(dimension, number_particles, max_variations,  &
                       thermalization, number_cycles, step_length,   &
                       cumulative_e, cumulative_e2)
USE constants
USE f90library
IMPLICIT NONE
REAL(DP), DIMENSION(max_variations), INTENT(INOUT) ::  cumulative_e, cumulative_e2
INTEGER, INTENT(IN) :: dimension, number_particles, max_variations, &
                       number_cycles, thermalization
REAL(DP), INTENT(IN) ::   step_length
INTEGER ::  cycles, variate, accept, dim, i, j
INTEGER idum
REAL(DP) :: wfnew, wfold, alpha, energy, energy2, &
                      delta_e, wave_function, local_energy
REAL(DP), ALLOCATABLE, DIMENSION(:,:) :: r_old, r_new
    alpha = 0.0_dp
    idum=-1
    ! allocate matrices which contain the position of the particles
    ALLOCATE(r_new(dimension, number_particles))
    ALLOCATE(r_old(dimension, number_particles))
    ! loop over variational parameters
    DO variate=1,  max_variations
       ! initialisations of variational parameters and energies
       alpha = alpha + 0.1_dp
       energy = 0.0_dp; energy2 = 0.0_dp; accept =0; delta_e=0.0_dp;
       !  initial trial position, note calling with alpha
       !  and in three dimensions
       DO i = 1,  number_particles
          DO j=1, dimension
             r_old(j,i) = step_length*(ran1(idum)-0.5_dp)/alpha
          ENDDO
       ENDDO
       wfold = wave_function(r_old, alpha, dimension, number_particles)
       ! loop over monte carlo cycles
       DO cycles = 1, number_cycles+thermalization
          ! new position
          DO i = 1,  number_particles
             DO j=1, dimension
                r_new(j,i)=r_old(j,i) + step_length*(ran1(idum)-0.5_dp)/alpha
             ENDDO
          ENDDO
          wfnew = wave_function(r_new, alpha, dimension, number_particles)
          ! Metropolis test
          IF (ran1(idum) <= wfnew*wfnew/wfold/wfold ) THEN
             r_old=r_new
             wfold = wfnew
             accept = accept+1
          ENDIF
          ! compute local energy
          IF ( cycles > thermalization ) THEN
             delta_e = local_energy(r_old, alpha, wfold, &
                                    dimension, number_particles)
             ! update energies
             energy = energy+delta_e
             energy2 = energy2+delta_e*delta_e
          ENDIF
       ENDDO   ! end of loop over MC trials
       WRITE(*,*)'variational parameter and accepted steps', alpha, accept
       ! update the energy average and its squared
       cumulative_e(variate) = energy/number_cycles
       cumulative_e2(variate) = energy2/number_cycles
    ENDDO    ! end of loop over variational  steps
    DEALLOCATE ( r_old, r_new)
END SUBROUTINE  mc_sampling  ! end mc_sampling function

! Function to compute the squared wave function

REAL(DP) FUNCTION wave_function(r, alpha,dimension, number_particles)
USE constants
IMPLICIT NONE
INTEGER, INTENT(IN) :: dimension, number_particles
REAL(DP), DIMENSION(dimension,number_particles), INTENT(IN) :: r
REAL(DP), INTENT(IN) :: alpha
INTEGER ::  i, j
REAL(DP) :: argument, r_single_particle
    argument = 0.0_dp
    DO i = 1, number_particles
       r_single_particle = 0.0_dp
       DO j = 1, dimension
          r_single_particle = r_single_particle+ r(j,i)*r(j,i)
       ENDDO
       argument = argument + SQRT(r_single_particle)
    ENDDO
    argument = argument*alpha
    wave_function = EXP(-argument)
END FUNCTION wave_function

! Function to calculate the local energy

REAL(DP) FUNCTION local_energy(r, alpha, wfold, dimension, &
                                       number_particles)
USE derivative_step
USE constants
IMPLICIT NONE
INTEGER, INTENT(IN) :: dimension, number_particles
REAL(DP), DIMENSION(dimension,number_particles), INTENT(IN) :: r
REAL(DP), INTENT(IN) :: alpha, wfold
INTEGER :: i, j , k
REAL(DP) :: e_local, wfminus, wfplus, e_kinetic, e_potential, &
                    r_12, r_single_particle, wave_function
REAL(DP), ALLOCATABLE, DIMENSION(:,:) :: r_plus, r_minus
    ! allocate matrices which contain the position of the particles
    ! the function matrix is defined in the progam library
    ALLOCATE(r_plus(dimension, number_particles))
    ALLOCATE(r_minus(dimension, number_particles))
    r_plus = r; r_minus = r
    ! compute the kinetic energy
    e_kinetic = 0.0_dp
    DO i = 1, number_particles
       DO j = 1, dimension
          r_plus(j,i) = r(j,i)+h
          r_minus(j,i) = r(j,i)-h
          wfminus = wave_function(r_minus, alpha, dimension, number_particles)
          wfplus  = wave_function(r_plus, alpha, dimension, number_particles)
          e_kinetic = e_kinetic-(wfminus+wfplus-2*wfold)
          r_plus(j,i) = r(j,i)
          r_minus(j,i) = r(j,i)
       ENDDO
    ENDDO
    ! include electron mass and hbar squared and divide by wave function
    e_kinetic = 0.5_dp*h2*e_kinetic/wfold
    ! compute the potential energy
    e_potential = 0.0_dp
    ! contribution from electron-proton potential
    DO i = 1, number_particles
       r_single_particle = 0.0_dp
       DO j = 1, dimension
          r_single_particle = r_single_particle+r(j,i)*r(j,i)
       ENDDO
       e_potential = e_potential-number_particles/SQRT(r_single_particle)
    ENDDO
    ! contribution from electron-electron potential
    DO i = 1, number_particles-1
       DO J= i+1, number_particles
	  r_12 = 0
          DO k = 1, dimension
             r_12 = r_12+(r(k,i)-r(k,j))*(r(k,i)-r(k,j))
          ENDDO
	  e_potential =  e_potential+1/SQRT(r_12)
       ENDDO
    ENDDO
    local_energy = e_potential+e_kinetic
    DEALLOCATE (r_plus, r_minus)
END FUNCTION local_energy

SUBROUTINE initialise(dimension, number_particles, max_variations, &
                      number_cycles, thermalization, step_length)
USE constants
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: dimension, number_particles, max_variations, &
                          number_cycles, thermalization
REAL(DP), INTENT(INOUT) ::   step_length
    WRITE(*,*)'number of particles = '
    READ(*,*) number_particles
    WRITE(*,*)'dimensionality = '
    READ(*,*) dimension
    WRITE(*,*)'maximum variational parameters = '
    READ(*,*) max_variations
    WRITE(*,*)'# Thermalization  steps= '
    READ(*,*) thermalization
    WRITE(*,*)'# MC steps= '
    READ(*,*)number_cycles
    WRITE(*,*)'# step length= '
    READ(*,*)step_length
END SUBROUTINE initialise

SUBROUTINE output(max_variations, number_cycles, cumulative_e, cumulative_e2)
USE constants
IMPLICIT NONE
REAL(DP), DIMENSION(max_variations), INTENT(IN) ::  cumulative_e, &
                                                            cumulative_e2
INTEGER, INTENT(IN) :: max_variations, number_cycles
INTEGER :: i
REAL(DP) :: alpha, variance, error
    ! open output file
    OPEN(UNIT=6,FILE='output_file')
    alpha = 0
    DO i=1, max_variations
       alpha = alpha+0.1_dp
       variance = cumulative_e2(i)-cumulative_e(i)*cumulative_e(i)
       error=SQRT(variance/number_cycles)
       WRITE(6,*)alpha,cumulative_e(i),variance, error
    ENDDO
    CLOSE(6)
END SUBROUTINE  output


C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 2011 by UCAR                   *
C     *                                                               *
C     *       University Corporation for Atmospheric Research         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                     FFTPACK  version 5.1                      *
C     *                                                               *
C     *                 A Fortran Package of Fast Fourier             *
C     *                                                               *
C     *                Subroutines and Example Programs               *
C     *                                                               *
C     *                             by                                *
C     *                                                               *
C     *               Paul Swarztrauber and Dick Valent               *
C     *                                                               *
C     *                             of                                *
C     *                                                               *
C     *         the National Center for Atmospheric Research          *
C     *                                                               *
C     *                Boulder, Colorado  (80307)  U.S.A.             *
C     *                                                               *
C     *                   which is sponsored by                       *
C     *                                                               *
C     *              the National Science Foundation                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
      SUBROUTINE COSQ1I (N, WSAVE, LENSAV, IER)
      INTEGER    N, LENSAV, IER
      REAL       WSAVE(LENSAV)
C
      IER = 0
      IF (LENSAV .LT. 2*N + INT(LOG(REAL(N))/LOG(2.)) +4) THEN
        IER = 2
        CALL XERFFT ('COSQ1I', 3)
        GO TO 300
      ENDIF
C
      PIH = 2.*ATAN(1.)
      DT = PIH/FLOAT(N)
      FK = 0.
      DO 101 K=1,N
         FK = FK+1.
         WSAVE(K) = COS(FK*DT)
  101 CONTINUE
      LNSV = N + INT(LOG(REAL(N))/LOG(2.)) +4
      CALL RFFT1I (N, WSAVE(N+1), LNSV, IER1)
      IF (IER1 .NE. 0) THEN
        IER = 20
        CALL XERFFT ('COSQ1I',-5)
      ENDIF
  300 CONTINUE
      RETURN
      END


module NScool_terminal
   use NScool_def

   character(len=*), parameter :: scival = 'es15.6', intval = 'i15', fltval = 'f15.6'
   integer, parameter :: num_terminal_cols = 11, terminal_col_width=15

   character(len=*), parameter :: terminal_count_fmt = '(11'//intval//')'
   character(len=*), parameter :: terminal_title_fmt = '(11a15)'
   character(len=*), parameter :: terminal_val_fmt = '('//intval//',2'//scival//',8'//fltval//')'
   character(len=terminal_col_width),dimension(num_terminal_cols) :: terminal_cols  &
         & = [character(len=terminal_col_width) ::  'model', 'time', 'dt', 'lg(Lsurf)', 'lg(Teff)', &
         & 'lg(Lnu)','lg(Lnuc)','max(lgT)','lg(P[Tmax])','min(lgT)','lg(P[Tmin])' ]

   ! logical :: terminal_first_call = .TRUE.

   contains
   subroutine do_write_terminal(id,ierr,print_header)
       use constants_def
      use iso_fortran_env, only : output_unit
      integer, intent(in) :: id
      integer, intent(out) :: ierr
      logical, intent(in), optional :: print_header
      type(NScool_info), pointer :: s
      real(dp) :: Lnu, Lnuc
      character(len=16) ::terminal_date, terminal_time, terminal_zone

      call get_NScool_info_ptr(id,s,ierr)
      if (ierr /= 0) return

      Lnu = dot_product(s% enu,s% dm)
      Lnuc = dot_product(s% enuc, s% dm)

      ! got rid of the datestring write, for purposes of testing output
      ! first time called: write datestring
      ! if (terminal_first_call) then
      !     call date_and_time(terminal_date,terminal_time,terminal_zone)
      !     write (output_unit,'(a,"/",2a,/)') trim(terminal_date),trim(terminal_time),trim(terminal_zone)
      !     terminal_first_call = .FALSE.
      !  end if

      ! write a header line upon request
      if (present(print_header)) then
         if (print_header) then
            write (output_unit,*)
            write(output_unit,terminal_title_fmt) adjustr(terminal_cols)
            write (output_unit,*)
         end if
      end if

      ! write the row
      write(output_unit,terminal_val_fmt) s% model, s% tsec, s% dt, log10(s% Lsurf), log10(s% Teff),  &
         &  log10(Lnu), safelog10(Lnuc), maxval(s% lnT)/ln10, log10(s% P(maxloc(s% lnT))),  &
         &  minval(s% lnT)/ln10, log10(s% P(minloc(s% T)))

     contains
         function safelog10(x)
             real(dp), intent(in) :: x
             real(dp) :: safelog10
             if (x <= 0.0_dp) then
                 safelog10 = 0.0_dp
             else
                 safelog10 = log10(x)
             end if
         end function safelog10
   end subroutine do_write_terminal

end module NScool_terminal


!*==dsygvd.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DSYGVD
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DSYGVD + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK,
!                          LWORK, IWORK, LIWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBZ, UPLO
!       INTEGER            INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N
!       ..
!       .. Array Arguments ..
!       INTEGER            IWORK( * )
!       DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), W( * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DSYGVD computes all the eigenvalues, and optionally, the eigenvectors
!> of a real generalized symmetric-definite eigenproblem, of the form
!> A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and
!> B are assumed to be symmetric and B is also positive definite.
!> If eigenvectors are desired, it uses a divide and conquer algorithm.
!>
!> The divide and conquer algorithm makes very mild assumptions about
!> floating point arithmetic. It will work on machines with a guard
!> digit in add/subtract, or on those binary machines without guard
!> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!> Cray-2. It could conceivably fail on hexadecimal or decimal machines
!> without guard digits, but we know of none.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] ITYPE
!> \verbatim
!>          ITYPE is INTEGER
!>          Specifies the problem type to be solved:
!>          = 1:  A*x = (lambda)*B*x
!>          = 2:  A*B*x = (lambda)*x
!>          = 3:  B*A*x = (lambda)*x
!> \endverbatim
!>
!> \param[in] JOBZ
!> \verbatim
!>          JOBZ is CHARACTER*1
!>          = 'N':  Compute eigenvalues only;
!>          = 'V':  Compute eigenvalues and eigenvectors.
!> \endverbatim
!>
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangles of A and B are stored;
!>          = 'L':  Lower triangles of A and B are stored.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrices A and B.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is DOUBLE PRECISION array, dimension (LDA, N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the
!>          leading N-by-N upper triangular part of A contains the
!>          upper triangular part of the matrix A.  If UPLO = 'L',
!>          the leading N-by-N lower triangular part of A contains
!>          the lower triangular part of the matrix A.
!>
!>          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
!>          matrix Z of eigenvectors.  The eigenvectors are normalized
!>          as follows:
!>          if ITYPE = 1 or 2, Z**T*B*Z = I;
!>          if ITYPE = 3, Z**T*inv(B)*Z = I.
!>          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
!>          or the lower triangle (if UPLO='L') of A, including the
!>          diagonal, is destroyed.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is DOUBLE PRECISION array, dimension (LDB, N)
!>          On entry, the symmetric matrix B.  If UPLO = 'U', the
!>          leading N-by-N upper triangular part of B contains the
!>          upper triangular part of the matrix B.  If UPLO = 'L',
!>          the leading N-by-N lower triangular part of B contains
!>          the lower triangular part of the matrix B.
!>
!>          On exit, if INFO <= N, the part of B containing the matrix is
!>          overwritten by the triangular factor U or L from the Cholesky
!>          factorization B = U**T*U or B = L*L**T.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!> \endverbatim
!>
!> \param[out] W
!> \verbatim
!>          W is DOUBLE PRECISION array, dimension (N)
!>          If INFO = 0, the eigenvalues in ascending order.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If N <= 1,               LWORK >= 1.
!>          If JOBZ = 'N' and N > 1, LWORK >= 2*N+1.
!>          If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal sizes of the WORK and IWORK
!>          arrays, returns these values as the first entries of the WORK
!>          and IWORK arrays, and no error message related to LWORK or
!>          LIWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] IWORK
!> \verbatim
!>          IWORK is INTEGER array, dimension (MAX(1,LIWORK))
!>          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!> \endverbatim
!>
!> \param[in] LIWORK
!> \verbatim
!>          LIWORK is INTEGER
!>          The dimension of the array IWORK.
!>          If N <= 1,                LIWORK >= 1.
!>          If JOBZ  = 'N' and N > 1, LIWORK >= 1.
!>          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.
!>
!>          If LIWORK = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal sizes of the WORK and
!>          IWORK arrays, returns these values as the first entries of
!>          the WORK and IWORK arrays, and no error message related to
!>          LWORK or LIWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  DPOTRF or DSYEVD returned an error code:
!>             <= N:  if INFO = i and JOBZ = 'N', then the algorithm
!>                    failed to converge; i off-diagonal elements of an
!>                    intermediate tridiagonal form did not converge to
!>                    zero;
!>                    if INFO = i and JOBZ = 'V', then the algorithm
!>                    failed to compute an eigenvalue while working on
!>                    the submatrix lying in rows and columns INFO/(N+1)
!>                    through mod(INFO,N+1);
!>             > N:   if INFO = N + i, for 1 <= i <= N, then the leading
!>                    minor of order i of B is not positive definite.
!>                    The factorization of B could not be completed and
!>                    no eigenvalues or eigenvectors were computed.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup doubleSYeigen
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Modified so that no backsubstitution is performed if DSYEVD fails to
!>  converge (NEIG in old code could be greater than N causing out of
!>  bounds reference to A - reported by Ralf Meyer).  Also corrected the
!>  description of INFO and the test on ITYPE. Sven, 16 Feb 05.
!> \endverbatim
!
!> \par Contributors:
!  ==================
!>
!>     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
!>
!  =====================================================================
      SUBROUTINE DSYGVD(Itype,Jobz,Uplo,N,A,Lda,B,Ldb,W,Work,Lwork,     &
     &                  Iwork,Liwork,Info)
      IMPLICIT NONE
!*--DSYGVD231
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Jobz , Uplo
      INTEGER Info , Itype , Lda , Ldb , Liwork , Lwork , N
!     ..
!     .. Array Arguments ..
      INTEGER Iwork(*)
      DOUBLE PRECISION A(Lda,*) , B(Ldb,*) , W(*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.0D+0)
!     ..
!     .. Local Scalars ..
      LOGICAL lquery , upper , wantz
      CHARACTER trans
      INTEGER liopt , liwmin , lopt , lwmin
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL DPOTRF , DSYEVD , DSYGST , DTRMM , DTRSM , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC DBLE , MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      wantz = LSAME(Jobz,'V')
      upper = LSAME(Uplo,'U')
      lquery = (Lwork==-1 .OR. Liwork==-1)
!
      Info = 0
      IF ( N<=1 ) THEN
         liwmin = 1
         lwmin = 1
      ELSEIF ( wantz ) THEN
         liwmin = 3 + 5*N
         lwmin = 1 + 6*N + 2*N**2
      ELSE
         liwmin = 1
         lwmin = 2*N + 1
      ENDIF
      lopt = lwmin
      liopt = liwmin
      IF ( Itype<1 .OR. Itype>3 ) THEN
         Info = -1
      ELSEIF ( .NOT.(wantz .OR. LSAME(Jobz,'N')) ) THEN
         Info = -2
      ELSEIF ( .NOT.(upper .OR. LSAME(Uplo,'L')) ) THEN
         Info = -3
      ELSEIF ( N<0 ) THEN
         Info = -4
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -6
      ELSEIF ( Ldb<MAX(1,N) ) THEN
         Info = -8
      ENDIF
!
      IF ( Info==0 ) THEN
         Work(1) = lopt
         Iwork(1) = liopt
!
         IF ( Lwork<lwmin .AND. .NOT.lquery ) THEN
            Info = -11
         ELSEIF ( Liwork<liwmin .AND. .NOT.lquery ) THEN
            Info = -13
         ENDIF
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('DSYGVD',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
!
!     Form a Cholesky factorization of B.
!
      CALL DPOTRF(Uplo,N,B,Ldb,Info)
      IF ( Info/=0 ) THEN
         Info = N + Info
         RETURN
      ENDIF
!
!     Transform problem to standard eigenvalue problem and solve.
!
      CALL DSYGST(Itype,Uplo,N,A,Lda,B,Ldb,Info)
      CALL DSYEVD(Jobz,Uplo,N,A,Lda,W,Work,Lwork,Iwork,Liwork,Info)
      lopt = MAX(DBLE(lopt),DBLE(Work(1)))
      liopt = MAX(DBLE(liopt),DBLE(Iwork(1)))
!
      IF ( wantz .AND. Info==0 ) THEN
!
!        Backtransform eigenvectors to the original problem.
!
         IF ( Itype==1 .OR. Itype==2 ) THEN
!
!           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
!           backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y
!
            IF ( upper ) THEN
               trans = 'N'
            ELSE
               trans = 'T'
            ENDIF
!
            CALL DTRSM('Left',Uplo,trans,'Non-unit',N,N,ONE,B,Ldb,A,Lda)
!
         ELSEIF ( Itype==3 ) THEN
!
!           For B*A*x=(lambda)*x;
!           backtransform eigenvectors: x = L*y or U**T*y
!
            IF ( upper ) THEN
               trans = 'T'
            ELSE
               trans = 'N'
            ENDIF
!
            CALL DTRMM('Left',Uplo,trans,'Non-unit',N,N,ONE,B,Ldb,A,Lda)
         ENDIF
      ENDIF
!
      Work(1) = lopt
      Iwork(1) = liopt
!
!
!     End of DSYGVD
!
      END SUBROUTINE DSYGVD


subroutine dsyr2m (uplo,transa,transb,m,n, alpha,a,lda,b,ldb,beta,c,ldc)
  !
  !  Purpose
  !  =======
  !
  !  dsyr2m performs one of the matrix-matrix operations
  !
  !     op1(C) := alpha*op2( A )*op2( B ) + beta*op1(C),
  !
  !  where  op1( X ) means that only the UPPER or only the LOWER
  !  part of X is accessed
  !
  !  and  op2( X ) is one of
  !
  !     op2( X ) = X   or   op2( X ) = X',
  !
  !  alpha and beta are scalars, and A, B and C are matrices, with
  !  op2( A ) an m by n matrix,
  !  op2( B ) an n by m matrix, and
  !  C an m by m matrix.
  !
  !     uplo: 'U'pper or 'L'ower
  !     transa,transb: op2( X ) = X   or   op2( X ) = X', with X=A,B
  !     m: number of rows of op2(A) and op2(B) and of
  !        rows and columns of C
  !     n: number of columns of op2(A) and op2(B)
  !     alpha
  !     op2(A): mXn matrix
  !     lda: leading dimension of a
  !     op2(B): mXn matrix
  !     ldb: leading dimension of b
  !     beta
  !     c: symmetric mXm matrix,
  !        stored either above (uplo='U') or below (uplo='L') the
  !        diagonal
  !     ldc: leading dimension of c
  !
  implicit none
  character*1 uplo,transa,transb
  integer m,n,lda,ldb,ldc
  double precision alpha,beta
  double precision a(lda,*), b(ldb,*), c(ldc,m)

  integer nblock
  parameter (nblock=128)
  double precision one,zero
  parameter (one=1.0d0, zero=0.0d0)

  integer j,ii,jj,imax,jmax
  logical upper,atrans,btrans

  logical lsame
  external lsame

  upper=lsame(uplo, 'U')
  atrans=lsame(transa, 'T')
  btrans=lsame(transb, 'T')

  if(.not.upper .and. .not.atrans .and. btrans) then
     do ii=1,m,nblock
        imax=min(m,ii+nblock-1)
        do j=ii,imax
           call dgemv('n', imax-j+1, n, alpha, a(j,1), lda, b(j,1), ldb, beta, c(j,j), 1)
        end do
        if(imax.lt.m) call dgemm('n','t',m-imax,imax-ii+1,n, alpha,a(imax+1,1),lda,b(ii,1),ldb, beta,c(imax+1,ii),ldc)
     end do
  else if(.not.upper .and. atrans .and. .not.btrans) then
     do ii=1,m,nblock
        imax=min(m,ii+nblock-1)
        do j=ii,imax
           call dgemv('t', n, imax-j+1, alpha, a(1,j), lda, b(1,j), 1, beta, c(j,j), 1)
        end do
        if(imax.lt.m) &
             call dgemm('t','n',m-imax,imax-ii+1,n,alpha,a(1,imax+1),lda,b(1,ii),ldb,beta,c(imax+1,ii),ldc)
     end do
  else if(upper .and. atrans .and. .not.btrans) then
     do jj=1,m,nblock
        jmax=min(m,jj+nblock-1)
        do j=jj,jmax
           call dgemv('t', n, j-jj+1, alpha, a(1,jj), lda,b(1,j), 1, beta, c(jj,j), 1)
        end do
        if(jj.ne.1) call dgemm('t','n',jj-1,jmax-jj+1,n,alpha,a(1,1),lda,b(1,jj),ldb,beta,c(1,jj),ldc)
     end do
  else
     stop 'wrong parameter in dsyr2m'
  end if
end subroutine dsyr2m


!     Sort each unstru. grid element into strips along x or y to speed up interpolation later
!     In:
!            is_xy - 1: search along x; 2: along y
!            nbin - # of bins along x/y
!            mne_bin - max. # of elem. per bin
!            nebg,npbg - # of elem. and nodes for the unstr. grid (background grid)
!            xbg,ybg,i34,nmbg - x,y, and connectivity table for unstr. grid
!     Out:
!            ne_bin(1:nbin) - # of elem. for each bin
!            ie_bin(1:nbin,1:ne_bin) - list of elem. for each bin
!            xybin(1:nbin+1) - x or y coord. of each bin line

      subroutine stripsearch_unstr(is_xy,nbin,mne_bin,nebg,npbg,xbg,ybg,i34,nmbg, &
     &ne_bin,ie_bin,xybin,binwid)
      implicit real(8)(a-h,o-z)

      integer, intent(in) :: is_xy,nbin,mne_bin,nebg,npbg,i34(nebg),nmbg(nebg,4)
      real(8), intent(in) :: xbg(npbg),ybg(npbg)
      integer, intent(out) :: ne_bin(nbin),ie_bin(nbin,mne_bin)
      real(8), intent(out) :: xybin(nbin+1),binwid

      if(is_xy/=1.and.is_xy/=2.or.mne_bin<=0.or.nbin<=0) stop 'STRIPSEARCH: Check is_xy etc'
!'
      ie_bin(nbin,mne_bin)=0 !test memory leak
      xmin_bg=minval(xbg)-1.e-2
      xmax_bg=maxval(xbg)+1.e-2
      ymin_bg=minval(ybg)-1.e-2
      ymax_bg=maxval(ybg)+1.e-2

!     Bucket strip sorting
!     If an element i is in ie_bin(l,:), it's 'physically' in it (i.e. at least one internal point
!     is inside the bin l; 1<=l<=nbin).
!     If a given pt is inside bin l, search ie_bin(l,:); in addition, also search neighboring
!     (if any) bins if it's right on the border
      ne_bin=0
      write(95,*)'Max/min:',xmin_bg,xmax_bg,ymin_bg,ymax_bg,'; coord. of bin lines'
      do i=1,nbin+1
        xbin=xmin_bg+(xmax_bg-xmin_bg)/nbin*(i-1)
        ybin=ymin_bg+(ymax_bg-ymin_bg)/nbin*(i-1)
        if(is_xy==1) then
          xybin(i)=xbin
        else
          xybin(i)=ybin
        endif
        write(95,*)i,xybin(i)
      enddo !i
      binwid=(xybin(nbin+1)-xybin(1))/nbin !bin width
      if(binwid<=0) stop 'STRIPSEARCH: negative bin width'

!      print*, 'min/max=',xmin_bg,xmax_bg,ymin_bg,ymax_bg,xybin(1),xybin(nbin+1),binwid

!     Set limits
!      if(is_xy==1) then
!        xy_min=xmin_bg; xy_max=xmax_bg
!      else
!        xy_min=ymin_bg; xy_max=ymax_bg
!      endif

      iabort=0 !flag for success in binning elements
      do i=1,nebg
        if(is_xy==1) then
          bmin=minval(xbg(nmbg(i,:))); bmax=maxval(xbg(nmbg(i,1:i34(i))))
        else
          bmin=minval(ybg(nmbg(i,:))); bmax=maxval(ybg(nmbg(i,1:i34(i))))
        endif
        ibin_min=(bmin-xybin(1))/binwid+1 !estimate
        ibin_min=min(nbin,max(1,ibin_min))
!        ibin_max=min(nbin,int((bmax-xybin(1))/binwid+1))

        ibin1=0 !start bin #
        ibin2=0 !end bin #
        do l=ibin_min,nbin !min0(ibin_max+1,nbin)
          if(bmin>=xybin(l).and.bmin<xybin(l+1)) ibin1=l
          if(bmax>=xybin(l).and.bmax<=xybin(l+1)) ibin2=l
          if(ibin1/=0.and.ibin2/=0) exit
        enddo !l

        if(ibin1==0.or.ibin2==0) then
          write(11,*)'STRIPSEARCH: Cannot find a bin:',i,ibin1,ibin2,bmin,bmax,ibin_min,binwid
          do l=1,nbin+1
            write(11,*)l,xybin(l)
          enddo !l
          stop
        endif
        if(ibin1>ibin2) then
          write(*,*)'STRIPSEARCH: Reversed bin'
          stop
        endif
        do l=ibin1,ibin2
          ne_bin(l)=ne_bin(l)+1
          if(ne_bin(l)>mne_bin) then
            if(iabort==0) print*, 'Aborting...'
            iabort=1
          endif
          if(iabort==0) ie_bin(l,ne_bin(l))=i
        enddo !l
      enddo !i=1,nebg

      mne_bin2=maxval(ne_bin)
      if(iabort==0) then
        print*, 'STRIPSEARCH: done bucket sorting; actual max. elements in a bin = ',mne_bin2
      else !failed
        write(*,*)'STRIPSEARCH: Failed in bucket sort; max. elements in a bin needs to be ',mne_bin2
!'
        stop
      endif

      end subroutine stripsearch_unstr