!  *********************************************************************
!  *                                                                   *
!  *                        subroutine intr3d                          *
!  *                                                                   *
!  *********************************************************************
!  Mixed Precision Version 1.1
!  Written by Gordon A. Fenton, TUNS, Aug. 2, 1993
!  Latest Update: Feb. 22, 1994
!
!  PURPOSE  creates the parameter matrices required for the interior cell
!           subdivision of LAS3G.
!
!  Notes:
!   1) arrays B and R are destroyed in this routine.
!
!  Requires:
!   1) from libGAFsim:	DSIFA, DSISL, DCHOL2, DAXPY, DSWAP, DDOT, IDAMAX
!-----------------------------------------------------------------------------
      subroutine intr3d( R, ir, B, ib, S, is, CI, AI, iout, tol )
      real*8 R(ir,*), B(ib,*), S(is,*), DA(27)
      real CI(*), AI(27,*)
      integer indx(27)

   1  format(a,a,a)
   2  format(a,e13.4)
!							factorize R
      call dsifa(R,ir,27,indx,ierr)
      if( ierr .ne. 0 ) then
         write(iout,1)'Error: unable to factorize interior covariance matrix in INTR3D.'
         stop
      endif
!							make a copy of S
      do 50 j = 1, 7
         do 20 i = 1, 27
            DA(i) = S(i,j)
  20     continue
!							and solve for A
         call dsisl(R,ir,27,indx,DA)
!							store in real*4
         do 30 i = 1, 27
            AI(i,j) = DA(i)
  30     continue
!							update B
         do 40 i = 1, j
            do 40 k = 1, 27
               B(i,j) = B(i,j) - S(k,i)*DA(k)
  40     continue
  50  continue
!							Cholesky Decomposition
      call dchol2( B, ib, 7, rerr )
      if( rerr .gt. tol ) then
         write(iout,1)'Warning: Cholesky decomposition of interior covariance matrix B'
         write(iout,2)'         has maximum relative error of ',rerr
      endif
!							store in real*4
      ii = 0
      do 60 j = 1, 7
      do 60 i = 1, j
         ii = ii + 1
         CI(ii) = B(i,j)
  60  continue

      return
      end


SUBROUTINE fmrmat(vmfl,dsbar,dlam,dee,rmat)
!
! This subroutine forms the rmat matrix.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::vmfl(:),dsbar,dlam,dee(:,:)
 REAL(iwp),INTENT(OUT)::rmat(:,:)
 REAL(iwp)::acat(4,4),acatc(4,4),qmat(4,4),temp(4,4),con,zero=0.0_iwp,    &
   pt5=0.5_iwp,one=1.0_iwp,three=3.0_iwp
 INTEGER::i,j
 temp=zero
 temp(1,1)=one
 temp(1,2)=-pt5
 temp(1,4)=-pt5
 temp(2,1)=-pt5
 temp(2,2)=one
 temp(2,4)=-pt5
 temp(3,3)=three
 temp(4,1)=-pt5
 temp(4,2)=-pt5
 temp(4,4)=one
 DO i=1,4
   DO j=1,4
     acat(i,j)=vmfl(i)*vmfl(j)
   END DO
 END DO
 acat=(temp-acat)/dsbar
 acatc=matmul(dee,acat)
 qmat=acatc*dlam
 DO i=1,4
   qmat(i,i)=qmat(i,i)+one
 END DO
 DO i=1,4
   con=qmat(i,i)
   qmat(i,i)=one
   qmat(i,:)=qmat(i,:)/con
   DO j=1,4
     IF(j/=i)THEN
       con=qmat(j,i)
       qmat(j,i)=zero
       qmat(j,:)=qmat(j,:)-qmat(i,:)*con
     END IF
   END DO
 END DO
 rmat=matmul(qmat,dee)
RETURN
END SUBROUTINE fmrmat


      SUBROUTINE SROTMGF (SD1,SD2,SX1,SY1,SPARAM)
C
C     CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
C     THE SECOND COMPONENT OF THE 2-VECTOR  (SQRT(SD1)*SX1,SQRT(SD2)*
C     SY2)**T.
C     WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
C
C     SFLAG=-1.E0     SFLAG=0.E0        SFLAG=1.E0     SFLAG=-2.E0
C
C       (SH11  SH12)    (1.E0  SH12)    (SH11  1.E0)    (1.E0  0.E0)
C     H=(          )    (          )    (          )    (          )
C       (SH21  SH22),   (SH21  1.E0),   (-1.E0 SH22),   (0.E0  1.E0).
C     LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
C     RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
C     VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)
C
C     THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
C     INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
C     OF SD1 AND SD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
C
      DIMENSION SPARAM(5)
C
      DATA ZERO,ONE,TWO /0.E0,1.E0,2.E0/
      DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
      IF(.NOT. SD1 .LT. ZERO) GO TO 10
C       GO ZERO-H-D-AND-SX1..
          GO TO 60
   10 CONTINUE
C     CASE-SD1-NONNEGATIVE
      SP2=SD2*SY1
      IF(.NOT. SP2 .EQ. ZERO) GO TO 20
          SFLAG=-TWO
          GO TO 260
C     REGULAR-CASE..
   20 CONTINUE
      SP1=SD1*SX1
      SQ2=SP2*SY1
      SQ1=SP1*SX1
C
      IF(.NOT. ABS(SQ1) .GT. ABS(SQ2)) GO TO 40
          SH21=-SY1/SX1
          SH12=SP2/SP1
C
          SU=ONE-SH12*SH21
C
          IF(.NOT. SU .LE. ZERO) GO TO 30
C         GO ZERO-H-D-AND-SX1..
               GO TO 60
   30     CONTINUE
               SFLAG=ZERO
               SD1=SD1/SU
               SD2=SD2/SU
               SX1=SX1*SU
C         GO SCALE-CHECK..
               GO TO 100
   40 CONTINUE
          IF(.NOT. SQ2 .LT. ZERO) GO TO 50
C         GO ZERO-H-D-AND-SX1..
               GO TO 60
   50     CONTINUE
               SFLAG=ONE
               SH11=SP1/SP2
               SH22=SX1/SY1
               SU=ONE+SH11*SH22
               STEMP=SD2/SU
               SD2=SD1/SU
               SD1=STEMP
               SX1=SY1*SU
C         GO SCALE-CHECK
               GO TO 100
C     PROCEDURE..ZERO-H-D-AND-SX1..
   60 CONTINUE
          SFLAG=-ONE
          SH11=ZERO
          SH12=ZERO
          SH21=ZERO
          SH22=ZERO
C
          SD1=ZERO
          SD2=ZERO
          SX1=ZERO
C         RETURN..
          GO TO 220
C     PROCEDURE..FIX-H..
   70 CONTINUE
      IF(.NOT. SFLAG .GE. ZERO) GO TO 90
C
          IF(.NOT. SFLAG .EQ. ZERO) GO TO 80
          SH11=ONE
          SH22=ONE
          SFLAG=-ONE
          GO TO 90
   80     CONTINUE
          SH21=-ONE
          SH12=ONE
          SFLAG=-ONE
   90 CONTINUE
      GO TO IGO,(120,150,180,210)
C     PROCEDURE..SCALE-CHECK
  100 CONTINUE
  110     CONTINUE
          IF(.NOT. SD1 .LE. RGAMSQ) GO TO 130
               IF(SD1 .EQ. ZERO) GO TO 160
               ASSIGN 120 TO IGO
C              FIX-H..
               GO TO 70
  120          CONTINUE
               SD1=SD1*GAM**2
               SX1=SX1/GAM
               SH11=SH11/GAM
               SH12=SH12/GAM
          GO TO 110
  130 CONTINUE
  140     CONTINUE
          IF(.NOT. SD1 .GE. GAMSQ) GO TO 160
               ASSIGN 150 TO IGO
C              FIX-H..
               GO TO 70
  150          CONTINUE
               SD1=SD1/GAM**2
               SX1=SX1*GAM
               SH11=SH11*GAM
               SH12=SH12*GAM
          GO TO 140
  160 CONTINUE
  170     CONTINUE
          IF(.NOT. ABS(SD2) .LE. RGAMSQ) GO TO 190
               IF(SD2 .EQ. ZERO) GO TO 220
               ASSIGN 180 TO IGO
C              FIX-H..
               GO TO 70
  180          CONTINUE
               SD2=SD2*GAM**2
               SH21=SH21/GAM
               SH22=SH22/GAM
          GO TO 170
  190 CONTINUE
  200     CONTINUE
          IF(.NOT. ABS(SD2) .GE. GAMSQ) GO TO 220
               ASSIGN 210 TO IGO
C              FIX-H..
               GO TO 70
  210          CONTINUE
               SD2=SD2/GAM**2
               SH21=SH21*GAM
               SH22=SH22*GAM
          GO TO 200
  220 CONTINUE
          IF(SFLAG)250,230,240
  230     CONTINUE
               SPARAM(3)=SH21
               SPARAM(4)=SH12
               GO TO 260
  240     CONTINUE
               SPARAM(2)=SH11
               SPARAM(5)=SH22
               GO TO 260
  250     CONTINUE
               SPARAM(2)=SH11
               SPARAM(3)=SH21
               SPARAM(4)=SH12
               SPARAM(5)=SH22
  260 CONTINUE
          SPARAM(1)=SFLAG
          RETURN
      END


      double complex function qlfndd(n,x,iep)
C----Implementation of DD Eq. 4.11
C----%\cite{Denner:2005nn}
C----\bibitem{Denner:2005nn}
C----  A.~Denner and S.~Dittmaier,
C----  %``Reduction schemes for one-loop tensor integrals,''
C----  Nucl.\ Phys.\  B {\bf 734}, 62 (2006)
C----  [arXiv:hep-ph/0509141].
C----  %%CITATION = NUPHA,B734,62;%%

      implicit none
      include 'qlconstants.f'
      integer j,n,infty
      double complex xm1,x,cln
      double precision iep
      logical qlzero
      parameter(infty=16) ! number of terms in sum

      xm1=x-cone
      if (abs(x) .lt. 10d0) then
        if (qlzero(abs(x-cone))) then
          qlfndd=czip
        else
          qlfndd=(cone-dcmplx(x**(n+1)))*(cln(xm1,iep)-cln(x,iep))
        endif
        do j=0,n
          qlfndd=qlfndd-dcmplx(x**(n-j))/dfloat(j+1)
        enddo
      elseif (abs(x) .ge. 10d0) then
        qlfndd=cln(cone-cone/x,iep)
        do j=n+1,n+infty
          qlfndd=qlfndd+dcmplx(x**(n-j))/dfloat(j+1)
        enddo
      endif

      return
      end


$ Declare
   SUBROUTINE SIGrefC ( a, c, B, W, Spm, Spb, Sref)
!
! Parameters
   USE PublicPar
   IMPLICIT NONE
!
   DOUBLE PRECISION, INTENT(IN)    :: a     ! Crack depth
   DOUBLE PRECISION, INTENT(IN)    :: c     ! Crack width
   DOUBLE PRECISION, INTENT(IN)    :: B     ! Plate thickness
   DOUBLE PRECISION, INTENT(IN)    :: W     ! Plate width
   DOUBLE PRECISION, INTENT(IN)    :: Spm   ! primary membrane stress
   DOUBLE PRECISION, INTENT(IN)    :: Spb   ! primary bending stress
   DOUBLE PRECISION, INTENT(OUT)   :: Sref  ! reference stress
!
! Declarations
   DOUBLE PRECISION                :: alphadacc
!
! Calculate reference stress
   IF (FlawType .EQ. 2) THEN
      IF (W .GE. 2*(c+B)) THEN
		 alphadacc = (a/B)/(1+(B/c))
	  ELSE
		 alphadacc = (2*a/B)*(c/W)
	  END IF
	  Sref = (Spb + DSQRT(Spb*Spb+9.D0*Spm*Spm*(1.D0-alphadacc)*(1.D0-alphadacc))) / (3.D0*(1.D0-alphadacc)*(1.D0-alphadacc))
   ELSE
	  Sref = (Spb + DSQRT(Spb*Spb+9.D0*Spm*Spm)) / (3.D0 * (1.D0 - (2.D0*a/W)))
   END IF
!
! End subroutine
   RETURN
   END


c=======================================================================
c
c
c     subroutine RNLSS
c
c     Robust Non-Linear Least Square optimization, smooth solution
c
c-----------------------------------------------------------------------
      SUBROUTINE rnlss ( simext, mxpar, xini, nfct, moyobs, covobs,
     &                   skobs, spadim, grid, epsbfg, musmo, matsmo,
     &                   liudat, iudata, ldudat, dudata,
     &                   iwork, dwork, xpar, info )
c-----------------------------------------------------------------------
c     INPUT
c            simext : entry point of an external subroutine
c                     provided by the user
c            mxpar  : number of parameters to find               integer
c            xini   : initial solution  vector(mxpar)             double
c            nfct   : number of functions (observations)         integer
c            moyobs : mean observations  vector(nfct)             double
c            covobs : covariance matrix of observations
c                     vectorized matrix(nfct*nfct)                double
c            skobs  : stress coefficient of observations          double
c            spadim : space dimension                            integer
c            grid   : grid     vector(nfct*spadim)                double
c            epsbfg : BFGS precision stop test                    double
c            musmo  : smoothing coefficient                       double
c            matsmo : smoothing matrix  vector(mxpar*mxpar)       double
c            liudat : size of integer user data for SIMEXT       integer
c            iudata : integer user data for SIMEXT               integer
c                     vector(liudat)
c            ldudat : size of double prec. user data for SIMEXT  integer
c            dudata : double precision user data for SIMEXT       double
c                     vector(ldudat)
c
c     WORKSPACE
c            iwork  : workspace                                  integer
c                     vector( 2*mxopt + 4 + 12*nfct + liudat )
c            dwork  : double precision  workspace                 double
c                     vector(  mxopt*(mxopt+19)/2
c                            + (mxpar*(mxpar+2))
c                            + nfct*(7*nfct+mxpar+spadim+33)
c                            + 2 + ldudat )
c                     with mxopt = mxpar + 1
c
c     OUTPUT
c            xpar   : solution  vector(mxpar)                     double
c            info   : = 0 successful exit                        integer
c
c     CALL
c        INIRNLS : initial computing of RNLS
c        YV      : copy a vector in a vector
c        IVX     : initialization at a scalar of a vector
c        PMX     : computing M*X = matrix
c                  ( M matrix(n*m), X scalar, gives M*X matrix(n*m) )
c        YVI     : copy a vector of integers in a vector of integers
c        BFGSBOXS: quasi-Newton optimizer with BFGS method
c                  ( short call version )
c        SIMRNLSS: subroutine used by BFGS to compute the value of the
c                  function and its gradient, smooth solution
c
c-----------------------------------------------------------------------
c
c     SIMEXT SIGNATURE
c
c     INPUT
c            nfct   : number of functions                        integer
c            mxopt  : size of the vector solution                integer
c            xopt   : solution  vector(mxopt)                     double
c            spadim : space dimension                            integer
c            grid   : grid     vector(nfct*spadim)                double
c            liudat : size of integers data provided by the user integer
c            iusdat : integers user data provided by the user
c                     vector(liudat)                             integer
c            ldudat : size of doubles data provided by the user  integer
c            dusdat : doubles user data provided by the user
c                     vector(ldudat)                              double
c
c     OUTPUT :
c            funct  : functions   vector(nfct)                    double
c            jacob  : jacobian    matrix(nfct*mx)                 double
c            info   : = 0 successful exit                        integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     external functions
      EXTERNAL simext, simrnlss, YV, YVI, IVX, PMX, bfgsboxs, inirnls
c
c     arguments i/o
      INTEGER mxpar, nfct, spadim, liudat, ldudat, info
      INTEGER iudata(*)
      DOUBLE PRECISION skobs, epsbfg, musmo
      DOUBLE PRECISION moyobs(*), xini(*), grid(*), matsmo(*),
     &                 covobs(nfct,*), dudata(*), xpar(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER mxopt, totitr, totsim
      INTEGER piwbf, pnfct, pspad, pliu, pldu, pinfo, piwu,
     &        pxopt, pbinf, pbsup, pgrad, pdwbf, pwsnls, pwsext,
     &        piwini, pdwini,
     &        pgrid, psk, palpha, pbeta, pvp, prspec, prcov, psmo, pdwu
      DOUBLE PRECISION inilam, lplus, infini, eigmax, funct
      PARAMETER ( inilam = 10.0, lplus = 0.0001, infini = 1.E20 )
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
      mxopt = mxpar + 1
c
c     pointers for integer work space  : iwork
c
      piwini = 1
c     piwini : pointer for INIRNLS who needs (12*nfct), so 12*nfct more
      piwbf = piwini + 12*nfct
c     piwbf  : pointer for BFGSBOXS who needs (2*mxopt + 1),
c             so (2*mxopt + 1) more
      pnfct = piwbf + (2*mxopt + 1)
c     pnfct  : pointer for the number of functions, communication
c              with SIMUL ( simulator of user ), so 1 more
      pspad = pnfct + 1
c     pspad  : pointer for the space dimension, so 1 more
      pliu   = pspad + 1
c     pliu   : pointer for size of integers data provided by the user,
c              ( communication with SIMEXT, user simulator )
      pldu   = pliu + 1
c     pldu   : pointer for size of doubles data provided by the user,
c              ( communication with SIMEXT, user simulator )
      pinfo  = pldu + 1
c     pinfo  : pointer for info (errors of simnls), so 1 more
      piwu = pinfo + 1
c     piwu  : pointer for user SIMEXT workspace, so (liudat) more
c
c     so size of iwork array = ( 2*mxopt + 6 + 12*nfct + liudat )
c
c
c     pointers for double precision work space  : dwork
c
      prcov = 1
c     prcov : pointer for the reverse covariance matrix,
c             so (nfct*nfct) more
      pdwini = prcov + nfct*nfct
c     pdwini: pointer for INIRNLS who needs nfct*(2*nfct+27),
c             so nfct*(2*nfct+27) more
      pxopt = pdwini + nfct*(2*nfct+27)
c     pxopt : pointer for vector solution of optmization, so mxopt more
      pbinf = pxopt + mxopt
c     pbinf : pointer for inferior bounds binf, so mxopt more
      pbsup = pbinf + mxopt
c     pbsup : pointer for superior bounds bsup, so mxopt more
      pgrad = pbsup + mxopt
c     pgrad : pointer for gradient at solution, so mxopt more
c
      pdwbf = pgrad + mxopt
c     pdwbf : pointer for BFGSBOXS who needs ( mxopt*(mxopt+11)/2 )
c             so ( mxopt*(mxopt+11)/2 ) more
c
      pwsnls = pdwbf + mxopt*(mxopt+11)/2
c     pwsnls: pointer for internal workspace of SIMRNLSS,
c             so (nfct*(3*nfct+mxpar+3)+2*mxpar) more
      pwsext = pwsnls + (nfct*(3*nfct+mxpar+4)+2*mxpar)
c     pwsext: pointer for workspace ( communication with SIMNLS,
c             and SIMEXT, BFGSBOXS simulator ),
c             so ( nfct*(spadim+nfct+2) + 2 + ldudat ) more
      pgrid = pwsext
c     pgrid : pointer for grid matrix ( communication with SIMEXT,
c             user simulator ), so (nfct*spadim) more
      psk = pgrid + (nfct*spadim)
c     psk   : pointer for the stress coefficient k ( communication
c             with SIMRNLSS, user simulator ), so 1 more
      palpha = psk + 1
c     palpha: pointer for the coefficient alpha ( communication
c             with SIMRNLSS, user simulator ), so 1 more
      pbeta = palpha + 1
c     pbeta : pointer for the vector beta ( communication with SIMRNLSS,
c             user simulator ), so (nfct) more
      pvp = pbeta + nfct
c     pvp   : pointer for the eigenvestors matrix ( communication
c             with SIMRNLSS user simulator ), so (nfct*nfct) more
      prspec = pvp + nfct*nfct
c     prspec: pointer for eigenvalues reverse vector ( communication
c             with SIMRNLSS, user simulator ), so nfct more
      psmo = prspec + nfct
c     psmo  : pointer for the smoothing matrix ( communication
c             with SIMNLSS, BFGSBOXS simulator ), so (mxpar*mxpar) more
      pdwu = psmo + (mxpar*mxpar)
c     pdwu   : pointer for user SIMEXT workspace, so (ldudat) more
c
c        so size of dwork array = nfct*nfct + nfct*(2*nfct+27)
c                               + 4*mxopt + mxopt*(mxopt+11)/2
c                               + nfct*(3*nfct+mxpar+4)
c                               + (mxpar*mxpar) + 2*mxpar
c                               + nfct*(spadim+nfct+2) + 2 + ldudat
c        with mxopt = mxpar + 1
c                      = mxopt*(mxopt+19)/2 + (mxpar*(mxpar+2))
c                      + nfct*(7*nfct+mxpar+spadim+33) + 2 + ldudat
c
c.......................................................................
c
c     initial computing for SIMRNLSS
      CALL inirnls ( nfct, moyobs, covobs, skobs,
     &               iwork(piwini), dwork(pdwini),
     &               dwork(palpha), dwork(pbeta), dwork(pvp),
     &               dwork(prspec), dwork(prcov), eigmax, info )
      IF ( info .NE. 0 ) RETURN
c
c     initialization of xopt
      CALL YV ( mxpar, xini, dwork(pxopt) )
c
c     initialization of lambda > eigmax + epsilon
      dwork(pxopt+mxopt-1) = inilam*eigmax
c
c     initializations of bounds
      CALL IVX ( mxopt, dwork(pbsup), infini )
      CALL IVX ( mxopt-1, dwork(pbinf), -infini )
      dwork(pbinf+mxopt-1) = eigmax * ( 1 + lplus )
c
c     compute smoothing matrix musmo*matsmo
      CALL PMX ( mxpar, mxpar, matsmo, musmo, dwork(psmo) )
c
c     communication with SIMEXT (user simulator)
      iwork(pnfct) = nfct
      iwork(pspad) = spadim
      iwork(pliu) = liudat
      iwork(pldu) = ldudat
      iwork(pinfo)= 0
      CALL YV ( nfct*spadim, grid, dwork(pgrid) )
      CALL YV ( ldudat, dudata, dwork(pdwu) )
      CALL YVI ( liudat, iudata, iwork(piwu) )
      dwork(psk)= skobs
c
c     optimization BFGS
      CALL bfgsboxs ( simrnlss, simext, mxopt, dwork(pxopt), epsbfg,
     &                dwork(pbinf), dwork(pbsup),
     &                iwork(piwbf), dwork(pdwbf), dwork(pxopt),
     &                funct, dwork(pgrad), totitr, totsim, info)
c
      CALL YV ( mxpar, dwork(pxopt), xpar )
c
c     error code
      IF (iwork(pinfo) .NE. 0) THEN
         info = iwork(pinfo)
         RETURN
      ENDIF
c
      RETURN
      END


! RUN: bbc -emit-fir %s -o - | FileCheck %s

! CHECK-LABEL: floor_test1
subroutine floor_test1(i, a)
    integer :: i
    real :: a
    i = floor(a)
    ! CHECK: %[[f:.*]] = fir.call @llvm.floor.f32
    ! CHECK: fir.convert %[[f]] : (f32) -> i32
  end subroutine
  ! CHECK-LABEL: floor_test2
  subroutine floor_test2(i, a)
    integer(8) :: i
    real :: a
    i = floor(a, 8)
    ! CHECK: %[[f:.*]] = fir.call @llvm.floor.f32
    ! CHECK: fir.convert %[[f]] : (f32) -> i64
  end subroutine


MODULE Basis_m
  USE NumParameters_m

  IMPLICIT NONE

  PRIVATE
  PUBLIC :: Basis_t,Read_Basis,Write_Basis,Basis_IS_allocated

  TYPE :: Basis_t
    integer                         :: nb         = 0
    integer                         :: nq         = 0

    character (len=:),  allocatable :: Basis_name

    real(kind=Rk),   allocatable :: x(:)
    real(kind=Rk),   allocatable :: w(:)
    real(kind=Rk),   allocatable :: d0gb(:,:)      ! basis functions d0gb(nq,nb)
    real(kind=Rk),   allocatable :: d1gb(:,:,:)    ! basis functions d2gb(nq,nb,1)
    real(kind=Rk),   allocatable :: d2gb(:,:,:,:)  ! basis functions d2gb(nq,nb,1,1)

  END TYPE Basis_t

CONTAINS
  FUNCTION Basis_IS_allocated(Basis) RESULT(alloc)

    TYPE(Basis_t),   intent(in)  :: Basis
    logical                      :: alloc

    alloc =             allocated(Basis%x)
    alloc = alloc .AND. allocated(Basis%w)
    alloc = alloc .AND. allocated(Basis%d0gb)
    alloc = alloc .AND. allocated(Basis%d1gb)
    alloc = alloc .AND. allocated(Basis%d2gb)

  END FUNCTION Basis_IS_allocated
  RECURSIVE SUBROUTINE Write_Basis(Basis)
  USE UtilLib_m

    TYPE(Basis_t),       intent(in)  :: Basis

    write(out_unitp,*) '-------------------------------------------------'
    write(out_unitp,*) 'Write_Basis'
    write(out_unitp,*) 'nb,nq',Basis%nb,Basis%nq
    IF (Basis_IS_allocated(Basis)) THEN
      CALL Write_RVec(Basis%x,out_unitp,5,name_info='x')
      write(out_unitp,*)
      CALL Write_RVec(Basis%w,out_unitp,5,name_info='w')
      write(out_unitp,*)
      CALL Write_RMat(Basis%d0gb,out_unitp,5,name_info='d0gb')
      write(out_unitp,*)
      CALL Write_RMat(Basis%d1gb(:,:,1),out_unitp,5,name_info='d1gb')
      write(out_unitp,*)
      CALL Write_RMat(Basis%d2gb(:,:,1,1),out_unitp,5,name_info='d2gb')
    ELSE
      write(out_unitp,*) ' Basis tables (x, w, dngb) are not allocated.'
    END IF

    write(out_unitp,*) '-------------------------------------------------'

  END SUBROUTINE Write_Basis
  RECURSIVE SUBROUTINE Read_Basis(Basis,nio)
    USE UtilLib_m

    TYPE(Basis_t),       intent(inout)  :: Basis
    integer,             intent(in)     :: nio

    integer                         :: err_io

    integer                         :: nb,nq,k
    character (len=Name_len)        :: name
    real(kind=Rk)                   :: A,B,scaleQ,Q0,scaleTps,sigma,k0

    NAMELIST /basis_nD/ name,nb,nq,A,B,scaleQ,Q0,scaleTps,sigma,k0

    nb        = 0
    nq        = 0
    A         = ZERO
    B         = ZERO
    Q0        = ZERO
    scaleQ    = ONE
    scaleTps  = HALF
    sigma     = QUARTER
    k0        = ONE
    name      = '0'

    read(nio,nml=basis_nD,IOSTAT=err_io)
    write(out_unitp,nml=basis_nD)
    IF (err_io < 0) THEN
      write(out_unitp,basis_nD)
      write(out_unitp,*) ' ERROR in Read_Basis'
      write(out_unitp,*) '  while reading the namelist "basis_nD"'
      write(out_unitp,*) ' end of file or end of record'
      write(out_unitp,*) ' Probably, you forget a basis set ...'
      write(out_unitp,*) ' Check your data !!'
      STOP ' ERROR in Read_Basis: problems with the namelist.'
    END IF
    IF (err_io > 0) THEN
      write(out_unitp,basis_nD)
      write(out_unitp,*) ' ERROR in Read_Basis'
      write(out_unitp,*) '  while reading the namelist "basis_nD"'
      write(out_unitp,*) ' Probably, some arguments of namelist are wrong.'
      write(out_unitp,*) ' Check your data !!'
      STOP ' ERROR in Read_Basis: problems with the namelist.'
    END IF

    Basis%nb        = nb
    Basis%nq        = nq
    Basis%Basis_name      = trim(adjustl(name))
    CALL string_uppercase_TO_lowercase(Basis%Basis_name)

    SELECT CASE (Basis%Basis_name)
    CASE ('boxab')
      CALL Construct_Basis_Sin(Basis)
      Q0      = A
      scaleQ  = pi/(B-A)
    CASE default
      STOP 'ERROR in Read_Basis: no default basis.'
    END SELECT

    CALL Scale_Basis(Basis,Q0,scaleQ)
    CALL CheckOrtho_Basis(Basis,nderiv=2)

    CALL Write_Basis(Basis)

  END SUBROUTINE Read_Basis
  SUBROUTINE Construct_Basis_Sin(Basis) ! sin : boxAB with A=0 and B=pi
  USE UtilLib_m

    TYPE(Basis_t),       intent(inout)  :: Basis

    real(kind=Rk)          :: dx
    integer                :: ib,iq,nb,nq

    nb = Basis%nb
    nq = Basis%nq
    dx = pi/nq

    ! grid and weight
    Basis%x = [(dx*(iq-HALF),iq=1,nq)]
    Basis%w = [(dx,iq=1,nq)]

    allocate(Basis%d0gb(nq,nb))
    allocate(Basis%d1gb(nq,nb,1))
    allocate(Basis%d2gb(nq,nb,1,1))

    DO ib=1,nb
      Basis%d0gb(:,ib)     =          sin(Basis%x(:)*ib) / sqrt(pi*HALF)
      Basis%d1gb(:,ib,1)   =  ib    * cos(Basis%x(:)*ib) / sqrt(pi*HALF)
      Basis%d2gb(:,ib,1,1) = -ib**2 * Basis%d0gb(:,ib)
    END DO

    IF (nb == nq) THEN
      Basis%d0gb(:,nb)      = Basis%d0gb(:,nb)      / sqrt(TWO)
      Basis%d1gb(:,nb,:)    = Basis%d1gb(:,nb,:)    / sqrt(TWO)
      Basis%d2gb(:,nb,:,:)  = Basis%d2gb(:,nb,:,:)  / sqrt(TWO)
    END IF

  END SUBROUTINE Construct_Basis_Sin

  SUBROUTINE CheckOrtho_Basis(Basis,nderiv)
  USE UtilLib_m

    TYPE(Basis_t),           intent(in)     :: Basis
    integer,                 intent(in)     :: nderiv

    integer                      :: ib
    real(kind=Rk), ALLOCATABLE   :: S(:,:)
    real(kind=Rk), ALLOCATABLE   :: d0bgw(:,:)
    real(kind=Rk)                :: Sii,Sij

    IF (Basis_IS_allocated(Basis)) THEN
      d0bgw = transpose(Basis%d0gb)
      DO ib=1,Basis%nb
        d0bgw(ib,:) = d0bgw(ib,:) * Basis%w(:)
      END DO

      S = matmul(d0bgw,Basis%d0gb)
      IF (nderiv > -1) CALL Write_RMat(S,out_unitp,5,name_info='S')
      Sii = ZERO
      Sij = ZERO
      DO ib=1,Basis%nb
        IF (abs(S(ib,ib)-ONE) > Sii) Sii = abs(S(ib,ib)-ONE)
        S(ib,ib) = ZERO
      END DO
      Sij = maxval(S)
      write(out_unitp,*) 'Sii,Sij',Sii,Sij

      IF (nderiv > 0) THEN
        write(out_unitp,*)
        S = matmul(d0bgw,Basis%d1gb(:,:,1))
        !CALL Write_RMat(S,out_unitp,5,name_info='<d0b|d1b>',Rformat='e13.4')
        CALL Write_RMat(S,out_unitp,5,name_info='<d0b|d1b>')
      END IF

      IF (nderiv > 1) THEN
        write(out_unitp,*)
        S = matmul(d0bgw,Basis%d2gb(:,:,1,1))
        !CALL Write_RMat(S,out_unitp,5,name_info='<d0b|d2b>',Rformat='e13.4')
        CALL Write_RMat(S,out_unitp,5,name_info='<d0b|d1b>')
      END IF

    ELSE
      write(out_unitp,*) ' WARNNING in CheckOrtho_Basis'
      write(out_unitp,*) ' the basis is not allocated.'
    END IF

  END SUBROUTINE CheckOrtho_Basis
  SUBROUTINE Scale_Basis(Basis,x0,sx)
  USE UtilLib_m

    TYPE(Basis_t),       intent(inout)  :: Basis
    real(kind=Rk),       intent(in)     :: x0,sx

    IF (abs(sx) > ONETENTH**6 .AND. Basis_IS_allocated(Basis)) THEN

      Basis%x(:) = x0 + Basis%x(:) / sx
      Basis%w(:) =      Basis%w(:) / sx

      Basis%d0gb(:,:)     = Basis%d0gb(:,:)     * sqrt(sx)
      Basis%d1gb(:,:,:)   = Basis%d1gb(:,:,:)   * sqrt(sx)*sx
      Basis%d2gb(:,:,:,:) = Basis%d2gb(:,:,:,:) * sqrt(sx)*sx*sx
    ELSE
      write(out_unitp,*) ' ERROR in Scale_Basis'
      write(out_unitp,*) ' sx is too small  or ...'
      write(out_unitp,*) ' the basis is not allocated.'
      STOP 'ERROR in Scale_Basis'
    END IF

  END SUBROUTINE Scale_Basis

END MODULE Basis_m


module FiniteElementMod

  type,public :: FEAsolver
     real :: zeta=1,omega=1
     real :: xi(3),dxi
    !  real,allocatable :: IEN(:,:) ! element node array, how the elements are linked to the nodes.
    !  real,allocatable :: ID(:)    ! destination array, links the global node number to the global equation number in the final linear system
   contains
     procedure,public :: init,update
  end type

 contains

  subroutine init(a,xi0,zeta,omega)
    class(FEAsolver),intent(inout) :: a
    real,intent(in)          :: xi0
    real,intent(in),optional :: zeta,omega
    a%xi = (/xi0,xi0,xi0/)
    if(present( zeta)) a%zeta = zeta
    if(present(omega)) a%omega= omega
  end subroutine init

  subroutine update(a,q,dt)
    class(FEAsolver),intent(inout) :: a
    real,intent(in) :: q,dt
    real :: xi,xi_1,xi_2
    xi=a%xi(1); xi_1=a%xi(2); xi_2=a%xi(3)
! -- update in time using second order forward difference
    xi_n = (q + (5+4*a%zeta*a%omega*dt)*xi &
               -(4+a%zeta*a%omega*dt)*xi_1+xi_2) &
               /(2+3*a%zeta*a%omega*dt+a%omega**2*dt**2)
! -- prepare next time step
    a%xi = (/xi_n, xi, xi_1/)
    a%dxi = xi_n-xi
  end subroutine update
!
! -- test on a oscillator, this writes to a file
  subroutine FEAsolver_test
    implicit none
    type(FEAsolver) :: FEsolver
    real,allocatable :: xi(:),ts(:),dxi(:)
    real :: dt,time=0,stop=10,x0(3)
    integer :: i = 1
    call FEsolver%init(xi0=1.,zeta=sqrt(10.)/40,omega=sqrt(10.))
    dt = 0.001
    allocate(xi(int(stop/dt)),ts(int(stop/dt)),dxi(int(stop/dt)))
    do while(time<stop)
      call FEsolver%update(q=0.,dt=dt)
      time = time+dt
      xi(i) = FEsolver%xi(1)
      ts(i) = time
      dxi(i) = FEsolver%dxi
      i=i+1
    end do
    open(14,file='out.csv')
    write(14,*) ts
    write(14,*) xi
    write(14,*) dxi
    close(14)
  end subroutine FEAsolver_test

end module FiniteElementMod
program test
  use FiniteElementMod
  call FEAsolver_test
end program test


      SUBROUTINE sla_DVN (V, UV, VM)
*+
*     - - - -
*      D V N
*     - - - -
*
*  Normalizes a 3-vector also giving the modulus (double precision)
*
*  Given:
*     V       d(3)      vector
*
*  Returned:
*     UV      d(3)      unit vector in direction of V
*     VM      d         modulus of V
*
*  Notes:
*
*  1  If the modulus of V is zero, UV is set to zero as well.
*
*  2  To comply with the ANSI Fortran 77 standard, V and UV must be
*     different arrays.  However, the routine is coded so as to work
*     properly on most platforms even if this rule is violated.
*
*  Last revision:   22 July 2004
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*-

      IMPLICIT NONE

      DOUBLE PRECISION V(3),UV(3),VM

      INTEGER I
      DOUBLE PRECISION W1,W2

*  Modulus.
      W1 = 0D0
      DO I=1,3
         W2 = V(I)
         W1 = W1+W2*W2
      END DO
      W1 = SQRT(W1)
      VM = W1

*  Normalize the vector.
      IF (W1.LE.0D0) W1 = 1D0
      DO I=1,3
         UV(I) = V(I)/W1
      END DO

      END


      subroutine compute_b(A,Nx,B)
         implicit none
         integer Nx
         real*8 A(Nx)
         real*8 B(Nx)
         integer i
         do i=1,Nx,1
           B(i) = 1.0D0/dsqrt(A(i))
         end do
      END


**********************************************************************
* This file contains general evaluation routines for FEM-functions
* as well as routines for producing cutlines through the mesh.
**********************************************************************

**********************************************************************
* Scalar evaluation of FEM function on quadrilaterals
*
* Evaluates a scalar FEM-function in a given point. The return value
* is the value in this point as well as the X- and Y-derivative.
*
* In:
*  NEQ    - length of FEM solution vector
*  DSOL   - array [1..NEQ] of double
*           FEM solution vector describing the continuous FEM
*           function. The function is assumed to be scalar!
*  ELE    - Element that is used for the discretisation
*  BNONPR - TRUE if ELEM is a nonparametric element,
*           FALSE otherwise
*  DXPOS,
*  DYPOS  - the point where to evaluate
*  IELEM  - The element containing the point (DX,DY), or:
*           -1 = determine the element containing (DX,DY) automatically
*            0 = determine the element containing (DX,DY) automatically
*                and return the element number in IELEM
*  TRIA  - array [1..SZTRIA] of integer
*          Triangulation structure
*  DCORVG,
*  KVERT
*  KMID  - Usual geometry information; must correspond to TRIA!
*
*
* Out:
*  DVAL   - Value of the function in (DX,DY)
*  DGRX   - X-derivative in this point
*  DGRY   - Y-derivative in this point
*
* if IELEM=0 on call:
*  IELEM  - element containing (DX,DY)
*
* If the point is not on the element (or if no element was found),
* IER is set to -1 and the calculation is aborted.
**********************************************************************

      SUBROUTINE SCEVLQ (NEQ,DSOL,ELE,BNONPR,DXPOS,DYPOS,IELEM,
     *                   TRIA,DCORVG,KVERT,KMID,
     *                   DVAL, DGRX, DGRY)

      IMPLICIT NONE

      INCLUDE 'cerr.inc'
      INCLUDE 'cout.inc'

      INCLUDE 'cbasictria.inc'
      INCLUDE 'cbasicelem.inc'
      INCLUDE 'celem.inc'

      INCLUDE 'stria.inc'

C parameters

      INTEGER NEQ,IELEM,KVERT(NNVE,*),KMID(NNVE,*),TRIA(SZTRIA)
      DOUBLE PRECISION DSOL(NEQ),DXPOS,DYPOS,DVAL, DGRX, DGRY
      DOUBLE PRECISION DCORVG(2,*),DJF(2,2)
      LOGICAL BNONPR
      EXTERNAL ELE

C local variables

      INTEGER IEL1,I,IVE,JP,IELTYP,NEL,NVE
      DOUBLE PRECISION X,Y,DCOORD(2,4)
      INTEGER KDFG(NNBAS),KDFL(NNBAS),IDFL

      LOGICAL ISINEL
      INTEGER NDFL
      EXTERNAL ISINEL,NDFL

C     Fetch some general information to local variables

      NEL = TRIA(ONEL)
      NVE = TRIA(ONVE)

C Do we have an element given?

      IF (IELEM.GT.0) THEN
        IEL1=IELEM
      ELSE

C No, we have to search for it. Basic linear search method.

        DO IEL1=1,NEL
          IF (ISINEL (DXPOS,DYPOS,IEL1,DCORVG,KVERT)) THEN
            IF (IELEM.EQ.0) IELEM = IEL1
            GOTO 10
          END IF
        END DO
10      CONTINUE

      END IF

C Quick save-test to be sure that element contains our point

      IF ((IEL1.GT.NEL).OR.
     *    (.NOT.ISINEL (DXPOS,DYPOS,IEL1,DCORVG,KVERT))) THEN
        IF (MT.GE.3) THEN
          WRITE (*,'(A,2D24.12,A)')
     *     'WARNING: Found no element containing node (',DXPOS,DYPOS,')'
        END IF
        IER = -1
        GOTO 99999
      END IF

C On parametric elements we have to transform the point back to the
C reference element

      IF (.NOT.BNONPR) THEN

C Build the structure defining the element:

        DO IVE = 1,NVE
          JP=KVERT(IVE,IEL1)
          DCOORD (1,IVE) = DCORVG(1,JP)
          DCOORD (2,IVE) = DCORVG(2,JP)
        END DO

C Back-transformation

        CALL QBTRAF (DCOORD, X, Y, DXPOS, DYPOS)

      ELSE

C Otherwise we can evaluate directly

        X = DXPOS
        Y = DYPOS

      END IF

C Ask the element about its type:

      IELTYP=-1
      CALL ELE(0D0,0D0,IELTYP)

C how many basis functions=DOF's do we have on each element?

      IDFL=NDFL(IELTYP)

C Calculate the local and global DOF's on our current element.
C We later have to loop about them...

      CALL NDFGLX(TRIA,IEL1,1,IELTYP,KVERT,KMID, KDFG,KDFL)
      IF (IER.LT.0) GOTO 99999

C     Calculate auxiliary Jacobian factors of the transformation

      CALL QINIJF (DCOORD,DJF)

C     Calculate Jacobian matrix of transformation and its
C     determinant. This is necessary for the element routine ELE
C     to properly calculate derivatives. The result is directly
C     written into the element COMMON block variables DJAC and DETJ.

      CALL QTRDET (DCOORD,DJF,DJAC,DETJ,X,Y)

C From the element we want to have weights for function values
C as well as derivatives:

      DO  I = 1,NNDER
        BDER(I)=.FALSE.
      ENDDO

      BDER(1)=.TRUE.
      BDER(2)=.TRUE.
      BDER(3)=.TRUE.

C Initialise the COMMON block of the element to inform the it
C about our current quadrilateral:

      DO IVE = 1, NVE
        JP=KVERT(IVE,IEL1)
        KVE(IVE)=JP
        DX(IVE)=DCORVG(1,JP)
        DY(IVE)=DCORVG(2,JP)
      END DO

C Call the element routine to calculate the weights of the basis
C functions in the current point:

      CALL ELE (X,Y,0)

C Is there at all something to do, or is the solution vector empty?!?

      IF (NEQ.EQ.0) GOTO 99999

C Loop about the local DOF's and sum up the values there together with
C the just calculated weights to obtain the function value in (X,Y):

      DVAL = 0D0
      DGRX = 0D0
      DGRY = 0D0

      DO I=1,IDFL
        JP=KDFG(I)
        DVAL=DVAL+DSOL(JP)*DBAS(KDFL(I),1)
        DGRX=DGRX+DSOL(JP)*DBAS(KDFL(I),2)
        DGRY=DGRY+DSOL(JP)*DBAS(KDFL(I),3)
      END DO

99999 END

**********************************************************************
* Scalar evaluation of FEM function on quadrilaterals
* with reconstructed gradients
*
* Evaluates a scalar FEM-function in a given point. The return value
* is the value in this point as well as the X- and Y-derivative.
* In contrast to SCEVLQ, this routine accepts two additional
* arrays DGRADX, DGRADY containing for each node the X- and Y-
* gradient of the function. These arrays can e.g. be calculated with
* reconstructed gradient routines. The routine then returns the
* gradient of the function based on these arrays rather than on the
* original gradient of the FEM-function.
*
* In:
*  NEQ    - length of FEM solution vector
*  DSOL   - array [1..NEQ] of double
*           FEM solution vector describing the continuous FEM
*           function. The function is assumed to be scalar!
*  DGRADX - array [1..NEQ] of double
*  DGRADX - array [1..NEQ] of double
*           FEM solution vector describing the gradient of the
*           continuous FEM function DSOL.
*  ELE    - Element that is used for the discretisation
*  BNONPR - TRUE if ELEM is a nonparametric element,
*           FALSE otherwise
*  DXPOS,
*  DYPOS  - the point where to evaluate
*  IELEM  - The element containing the point (DX,DY), or:
*           -1 = determine the element containing (DX,DY) automatically
*            0 = determine the element containing (DX,DY) automatically
*                and return the element number in IELEM
*  TRIA  - array [1..SZTRIA] of integer
*          Triangulation structure
*  DCORVG,
*  KVERT
*  KMID  - Usual geometry information; must correspond to TRIA!
*
*
* Out:
*  DVAL   - Value of the function in (DX,DY)
*  DGRX   - X-derivative in this point
*  DGRY   - Y-derivative in this point
*
* if IELEM=0 on call:
*  IELEM  - element containing (DX,DY)
*
* If the point is not on the element (or if no element was found),
* IER is set to -1 and the calculation is aborted.
**********************************************************************

      SUBROUTINE SCEVQR (NEQ,DSOL,DGRADX,DGRADY,ELE,BNONPR,
     *                   DXPOS,DYPOS,IELEM,
     *                   TRIA,DCORVG,KVERT,KMID,
     *                   DVAL, DGRX, DGRY)

      IMPLICIT NONE

      INCLUDE 'cerr.inc'
      INCLUDE 'cout.inc'

      INCLUDE 'cbasictria.inc'
      INCLUDE 'cbasicelem.inc'
      INCLUDE 'celem.inc'

      INCLUDE 'stria.inc'

C parameters

      INTEGER NEQ,IELEM,KVERT(NNVE,*),KMID(NNVE,*),TRIA(SZTRIA)
      DOUBLE PRECISION DSOL(NEQ),DGRADX(NEQ), DGRADY(NEQ)
      DOUBLE PRECISION DXPOS,DYPOS,DVAL, DGRX, DGRY
      DOUBLE PRECISION DCORVG(2,*)
      LOGICAL BNONPR
      EXTERNAL ELE

C local variables

      INTEGER IEL1,I,IVE,JP,IELTYP,NEL,NVE
      DOUBLE PRECISION X,Y,DCOORD(2,4)
      INTEGER KDFG(NNBAS),KDFL(NNBAS),IDFL

      LOGICAL ISINEL
      INTEGER NDFL
      EXTERNAL ISINEL,NDFL

C     Fetch some general information to local variables

      NEL = TRIA(ONEL)
      NVE = TRIA(ONVE)

C Do we have an element given?

      IF (IELEM.GT.0) THEN
        IEL1=IELEM
      ELSE

C No, we have to search for it. Basic linear search method.

        DO IEL1=1,NEL
          IF (ISINEL (DXPOS,DYPOS,IEL1,DCORVG,KVERT)) THEN
            IF (IELEM.EQ.0) IELEM = IEL1
            GOTO 10
          END IF
        END DO
10      CONTINUE

      END IF

C Quick save-test to be sure that element contains our point

      IF ((IEL1.GT.NEL).OR.
     *    (.NOT.ISINEL (DXPOS,DYPOS,IEL1,DCORVG,KVERT))) THEN
        IF (MT.GE.3) THEN
          WRITE (*,'(A,2D24.12,A)')
     *     'WARNING: Found no element containing node (',DXPOS,DYPOS,')'
        END IF
        IER = -1
        GOTO 99999
      END IF

C On parametric elements we have to transform the point back to the
C reference element

      IF (.NOT.BNONPR) THEN

C Build the structure defining the element:

        DO IVE = 1,NVE
          JP=KVERT(IVE,IEL1)
          DCOORD (1,IVE) = DCORVG(1,JP)
          DCOORD (2,IVE) = DCORVG(2,JP)
        END DO

C Back-transformation

        CALL QBTRAF (DCOORD, X, Y, DXPOS, DYPOS)

      ELSE

C Otherwise we can evaluate directly

        X = DXPOS
        Y = DYPOS

      END IF

C Ask the element about its type:

      IELTYP=-1
      CALL ELE(0D0,0D0,IELTYP)

C how many basis functions=DOF's do we have on each element?

      IDFL=NDFL(IELTYP)

C Calculate the local and global DOF's on our current element.
C We later have to loop about them...

      CALL NDFGLX(TRIA,IEL1,1,IELTYP,KVERT,KMID, KDFG,KDFL)
      IF (IER.LT.0) GOTO 99999

C From the element we want to have weights for function values.
C The values of the derivatice we don't need, as we can calculate
C the derivatives from DGRADX/DGRADY.

      DO  I = 1,NNDER
        BDER(I)=.FALSE.
      ENDDO

      BDER(1)=.TRUE.

C ---
C In standard evaluation of elements at this point we have to calculate
C the Jacobian and its determinant. But this is only necessary for the
C evaluation of derivatives. So as the derivatives are calculated with
C reconstructed gradients only by evaluation of functionals, we can
C skip the calculation of the Jacobian with QINIJF / QTRDET here.
C ---

C Initialise the COMMON block of the element to inform the it
C about our current quadrilateral:

      DO IVE = 1, NVE
        JP=KVERT(IVE,IEL1)
        KVE(IVE)=JP
        DX(IVE)=DCORVG(1,JP)
        DY(IVE)=DCORVG(2,JP)
      END DO

C Call the element routine to calculate the weights of the basis
C functions in the current point:

      CALL ELE (X,Y,0)

C Is there at all something to do, or is the solution vector empty?!?

      IF (NEQ.EQ.0) GOTO 99999

C Loop about the local DOF's and sum up the values there together with
C the just calculated weights to obtain the function value in (X,Y):

      DVAL = 0D0
      DGRX = 0D0
      DGRY = 0D0

      DO I=1,IDFL
        JP=KDFG(I)
        DVAL=DVAL+DSOL(JP)*DBAS(KDFL(I),1)
        DGRX=DGRX+DGRADX(JP)*DBAS(KDFL(I),1)
        DGRY=DGRY+DGRADY(JP)*DBAS(KDFL(I),1)
      END DO

99999 END

**********************************************************************
* Multiple scalar evaluations of FEM function on quadrilaterals
*
* Evaluates a set of scalar FEM-functions in a given point. This helps
* to save computational time if more than one function is to evaluate.
* The FEM-functions are given as a set of handles into the DWORK-
* array. The caller can decide whether to calculate function value or
* gradient of every function. The subroutine returns the value
* of the appropriate function and/or derivatives in three arrays
* with each element of the array corresponding to a function.
*
* This routine can also be used to calculate the gradient of a
* function using recovered gradients. In this case the two arrays
* containing X- and Y-derivative of a function have to be given
* as a standard function.
*
* In:
*  NSOL   - Number of solutions
*  NEQ    - Length of each FEM solution vector.
*           It's assumed that all solution vectors correspond to the
*           same element type and have the same length.
*  LSOL   - array [1..NSOL] of integer
*           Array of handles to all the NSOL solution vectors
*  FCLC   - array [1..NSOL] of integer
*           For every solution vector: Bitfield. FCLC(I) determines
*           what to calculate for that specific solution LSOL(I):
*             Bit 0: Calculate the function value into DVAL(I)
*             Bit 1: Calculate the X-derivative into DGRADY(I)
*             Bit 2: Calculate the Y-derivative into DGRADY(I)
*  ELE    - Element that is used for the discretisation
*  BNONPR - TRUE if ELEM is a nonparametric element,
*           FALSE otherwise
*  DXPOS,
*  DYPOS  - the point where to evaluate
*  IELEM  - The element containing the point (DX,DY), or:
*           -1 = determine the element containing (DX,DY) automatically
*            0 = determine the element containing (DX,DY) automatically
*                and return the element number in IELEM
*  TRIA  - array [1..SZTRIA] of integer
*          Triangulation structure
*  DCORVG,
*  KVERT
*  KMID  - Usual geometry information; must correspond to TRIA!
*
* Out:
*  DVAL   - array [1..NSOL] of double
*           DVAL(I) contains the value of each function LSOL(I)
*           in the point (DX,DY)
*  DGRX   - array [1..NSOL] of double
*           X-derivative in this point for every function, if to be
*           calculated
*  DGRY   - array [1..NSOL] of double
*           Y-derivative in this point for every function, if to be
*           calculated
*
* if IELEM=0 on call:
*  IELEM  - element containing (DX,DY)
*
* If the point is not on the element (or if no element was found),
* IER is set to -1 and the calculation is aborted.
**********************************************************************

      SUBROUTINE MSCVQR (NSOL,NEQ,LSOL,FCLC,ELE,BNONPR,
     *                   DXPOS,DYPOS,IELEM,
     *                   TRIA,DCORVG,KVERT,KMID,
     *                   DVAL, DGRX, DGRY)

      IMPLICIT NONE

      INCLUDE 'cerr.inc'
      INCLUDE 'cout.inc'
      INCLUDE 'cmem.inc'

      INCLUDE 'cbasictria.inc'
      INCLUDE 'cbasicelem.inc'
      INCLUDE 'celem.inc'

      INCLUDE 'stria.inc'

C parameters

      INTEGER NSOL,NEQ,IELEM,KVERT(NNVE,*),KMID(NNVE,*),TRIA(SZTRIA)
      INTEGER LSOL(NEQ),FCLC(NSOL)
      DOUBLE PRECISION DXPOS,DYPOS,DVAL(NSOL),DGRX(NSOL),DGRY(NSOL)
      DOUBLE PRECISION DCORVG(2,*)
      LOGICAL BNONPR
      EXTERNAL ELE

C local variables

      INTEGER IEL1,I,J,IVE,JP,IELTYP,NEL,NVE
      DOUBLE PRECISION X,Y,DCOORD(2,4),BAS,BASX,BASY,SOL,DJF(2,2)
      INTEGER KDFG(NNBAS),KDFL(NNBAS),IDFL

      LOGICAL ISINEL
      INTEGER NDFL
      EXTERNAL ISINEL,NDFL

C     Fetch some general information to local variables

      NEL = TRIA(ONEL)
      NVE = TRIA(ONVE)

C Do we have an element given?

      IF (IELEM.GT.0) THEN
        IEL1=IELEM
      ELSE

C No, we have to search for it. Basic linear search method.

        DO IEL1=1,NEL
          IF (ISINEL (DXPOS,DYPOS,IEL1,DCORVG,KVERT)) THEN
            IF (IELEM.EQ.0) IELEM = IEL1
            GOTO 10
          END IF
        END DO
10      CONTINUE

      END IF

C Quick save-test to be sure that element contains our point

      IF ((IEL1.GT.NEL).OR.
     *    (.NOT.ISINEL (DXPOS,DYPOS,IEL1,DCORVG,KVERT))) THEN
        IF (MT.GE.3) THEN
          WRITE (*,'(A,2D24.12,A)')
     *     'WARNING: Found no element containing node (',DXPOS,DYPOS,')'
        END IF
        IER = -1
        GOTO 99999
      END IF

C On parametric elements we have to transform the point back to the
C reference element

      IF (.NOT.BNONPR) THEN

C Build the structure defining the element:

        DO IVE = 1,NVE
          JP=KVERT(IVE,IEL1)
          DCOORD (1,IVE) = DCORVG(1,JP)
          DCOORD (2,IVE) = DCORVG(2,JP)
        END DO

C Back-transformation

        CALL QBTRAF (DCOORD, X, Y, DXPOS, DYPOS)

      ELSE

C Otherwise we can evaluate directly

        X = DXPOS
        Y = DYPOS

      END IF

C Ask the element about its type:

      IELTYP=-1
      CALL ELE(0D0,0D0,IELTYP)

C how many basis functions=DOF's do we have on each element?

      IDFL=NDFL(IELTYP)

C Calculate the local and global DOF's on our current element.
C We later have to loop about them...

      CALL NDFGLX(TRIA,IEL1,1,IELTYP,KVERT,KMID, KDFG,KDFL)
      IF (IER.LT.0) GOTO 99999

C From the element we want to have weights for function values.
C The values of the derivatice we don't need, as we can calculate
C the derivatives from DGRADX/DGRADY.

      DO I = 1,NNDER
        BDER(I)=.FALSE.
      ENDDO

      DO I=1,NSOL
        IF (IAND(FCLC(I),1).NE.0) BDER(1)=.TRUE.
        IF (IAND(FCLC(I),2).NE.0) BDER(2)=.TRUE.
        IF (IAND(FCLC(I),4).NE.0) BDER(3)=.TRUE.
      END DO

C     If derivatives are to be calculated, we need the Jacibian
C     matrix and determinant of the mapping to/from the reference
C     element. If derivatives are not used, we can skip this,
C     as elements don't need information about the Jacobian
C     only for calculating the values of the function.

      IF (BDER(2).OR.BDER(3)) THEN

C       Calculate auxiliary Jacobian factors of the transformation

        CALL QINIJF (DCOORD,DJF)

C       Calculate Jacobian matrix of transformation and its
C       determinant. This is necessary for the element routine ELE
C       to properly calculate derivatives. The result is directly
C       written into the element COMMON block variables DJAC and DETJ.

        CALL QTRDET (DCOORD,DJF,DJAC,DETJ,X,Y)

      END IF

C Initialise the COMMON block of the element to inform the it
C about our current quadrilateral:

      DO IVE = 1, NVE
        JP=KVERT(IVE,IEL1)
        KVE(IVE)=JP
        DX(IVE)=DCORVG(1,JP)
        DY(IVE)=DCORVG(2,JP)
      END DO

C Call the element routine to calculate the weights of the basis
C functions in the current point:

      CALL ELE (X,Y,0)

C Is there at all something to do, or is the solution vector empty?!?

      IF (NEQ.EQ.0) GOTO 99999

C Clear the return vectors

      DO I=1,NSOL
        DVAL(I) = 0D0
        DGRX(I) = 0D0
        DGRY(I) = 0D0
      END DO

C Loop about the local DOF's and sum up the values there together with
C the just calculated weights to obtain the function value in (X,Y):

      DO I=1,IDFL
        JP=KDFG(I)
        BAS = DBAS(KDFL(I),1)
        BASX = DBAS(KDFL(I),2)
        BASY = DBAS(KDFL(I),3)

C       Loop over all functions, build together function value
C       and derivative

        DO J=1,NSOL
          SOL = DWORK(L(LSOL(J))+JP-1)

          IF (IAND(FCLC(J),1).NE.0) THEN
            DVAL(J) = DVAL(J) + SOL*BAS
          END IF

          IF (IAND(FCLC(J),2).NE.0) THEN
            DGRX(J) = DGRX(J) + SOL*BASX
          END IF

          IF (IAND(FCLC(J),4).NE.0) THEN
            DGRY(J) = DGRY(J) + SOL*BASY
          END IF
        END DO

      END DO

99999 END

**********************************************************************
* Scalar evaluation of FEM function on triangles
*
* Evaluates a scalar FEM-function in a given point. The return value
* is the value in this point as well as the X- and Y-derivative.
*
* In:
*  NEQ    - length of FEM solution vector
*  DSOL   - array [1..NEQ] of double
*           FEM solution vector describing the continuous FEM
*           function. The function is assumed to be scalar!
*  ELE    - Element that is used for the discretisation
*  BNONPR - TRUE if ELEM is a nonparametric element,
*           FALSE otherwise
*  DXPOS,
*  DYPOS  - the point where to evaluate
*  IELEM  - The element containing the point (DX,DY), or:
*           -1 = determine the element containing (DX,DY) automatically
*            0 = determine the element containing (DX,DY) automatically
*                and return the element number in IELEM
*  TRIA   - array [1..SZTRIA] of integer
*           Triangulation structure
*  DCORVG,
*  KVERT
*  KMID   - Usual geometry information; must correspond to TRIA!
*
*
* Out:
*  DVAL   - Value of the function in (DX,DY)
*  DGRX   - X-derivative in this point
*  DGRY   - Y-derivative in this point
*
* if IELEM=0 on call:
*  IELEM  - element containing (DX,DY)
*
* If the point is not on the element (or if no element was found),
* IER is set to -1 and the calculation is aborted.
**********************************************************************

      SUBROUTINE SCEVLT (NEQ,DSOL,ELE,BNONPR,DXPOS,DYPOS,IELEM,
     *                   TRIA,DCORVG,KVERT,KMID,
     *                   DVAL, DGRX, DGRY)

      IMPLICIT NONE

      INCLUDE 'cerr.inc'
      INCLUDE 'cout.inc'

      INCLUDE 'cbasictria.inc'
      INCLUDE 'cbasicelem.inc'
      INCLUDE 'celem.inc'

      INCLUDE 'stria.inc'

C parameters

      INTEGER NEQ,IELEM,KVERT(NNVE,*),KMID(NNVE,*),TRIA(SZTRIA)
      DOUBLE PRECISION DSOL(NEQ),DXPOS,DYPOS,DVAL, DGRX, DGRY
      DOUBLE PRECISION DCORVG(2,*)
      LOGICAL BNONPR
      EXTERNAL ELE

C local variables

      INTEGER IEL1,I,J,IVE,JP,IELTYP, IV, NEL,NVE
      DOUBLE PRECISION X1,X2,X3
      INTEGER KDFG(NNBAS),KDFL(NNBAS),IDFL
      DOUBLE PRECISION DCOORD (2,3)

      INTEGER NDFL
      EXTERNAL NDFL

C     Fetch some general information to local variables

      NEL = TRIA(ONEL)
      NVE = TRIA(ONVE)

C Do we have an element given?

      IF (IELEM.GT.0) THEN

        IEL1 = IELEM

C Ok, let's check if the point is really inside of this triangle.
C Calculate the barycentric coordinates:

        DO J=1,3
          IV = KVERT(J,IEL1)
          DCOORD(1,J) = DCORVG(1, IV)
          DCOORD(2,J) = DCORVG(2, IV)
        END DO

        CALL TBTRAF (DCOORD, X1, X2, X3, DETJ, DXPOS, DYPOS)

        IF ((X1.LT.0D0).OR.(X1.GT.1D0).OR.
     *      (X2.LT.0D0).OR.(X2.GT.1D0).OR.
     *      (X3.LT.0D0).OR.(X3.GT.1D0)) THEN

C Oh, not good, the point is not inside here.
C Abort the further calculation. The caller can call this routine again
C to perform a linear search if desired...

          IER = -1
          GOTO 99999

	  ENDIF

      ELSE

C No, we have to search for it. Basic linear search method.

        DO IEL1=1, NEL

C Calculate the barycentric coordinates of the point corresponding to
C the current triangle:

          DO J=1,3
            IV = KVERT(J,IEL1)
            DCOORD(1,J) = DCORVG(1, IV)
            DCOORD(2,J) = DCORVG(2, IV)
          END DO

          CALL TBTRAF (DCOORD, X1, X2, X3, DETJ, DXPOS, DYPOS)

C Then check if the coordinates are all between 0 and 1;
C if yes, we found our element, if no... go on with the search

	    IF ((X1.GE.0D0).AND.(X1.LE.1D0).AND.
     *        (X2.GE.0D0).AND.(X2.LE.1D0).AND.
     *        (X3.GE.0D0).AND.(X3.LE.1D0)) THEN

C Is the caller interested in the element number?

	      IF (IELEM.EQ.0) IELEM=IEL1
	      GOTO 10

	    ENDIF
        END DO
10    END IF

      IF(IEL1.GT.NEL) THEN
        IF (MT.GE.3) THEN
	    WRITE (MTERM,'(A,2D24.12)')
     *          'Warning, found no element containing',DXPOS, DYPOS
          IER=-1
          GOTO 99999
        END IF
      END IF

C Ask the element about its type:

      IELTYP=-1
      CALL ELE(0D0,0D0,0D0,IELTYP)

C how many basis functions=DOF's do we have on each element?

      IDFL=NDFL(IELTYP)

C Calculate the local and global DOF's on our current element.
C We later have to loop about them...

      CALL NDFGLX(TRIA,IEL1,1,IELTYP,KVERT,KMID, KDFG,KDFL)
      IF (IER.LT.0) GOTO 99999

C !!!!!!!!!!!!!!!!
C Perhaps at this point the calculation of the Jacobian and its determinant
C is necessary - although this is not necessary if only function values
C are to be calculated. As the routines has never been tested for the
C evaluation of derivatives of FE-functions on triangles, this might
C be an open bug.
C !!!!!!!!!!!!!!!!

C From the element we want to have weights for function values
C as well as derivatives:

      DO  I = 1,NNDER
        BDER(I)=.FALSE.
      ENDDO

      BDER(1)=.TRUE.
      BDER(2)=.TRUE.
      BDER(3)=.TRUE.

C Initialise the COMMON block of the element to inform the it
C about our current quadrilateral:

      DO IVE = 1, NVE
        JP=KVERT(IVE,IEL1)
        KVE(IVE)=JP
        DX(IVE)=DCORVG(1,JP)
        DY(IVE)=DCORVG(2,JP)
      END DO

C Call the element routine to calculate the weights of the basis
C functions in the current point:

      CALL ELE (X1,X2,X3,0)

C Is there at all something to do, or is the solution vector empty?!?

      IF (NEQ.EQ.0) GOTO 99999

C Loop about the local DOF's and sum up the values there together with
C the just calculated weights to obtain the function value in (X,Y):

      DVAL = 0D0
      DGRX = 0D0
      DGRY = 0D0

      DO I=1,IDFL
        JP=KDFG(I)
        DVAL=DVAL+DSOL(JP)*DBAS(KDFL(I),1)
        DGRX=DGRX+DSOL(JP)*DBAS(KDFL(I),2)
        DGRY=DGRY+DSOL(JP)*DBAS(KDFL(I),3)
      END DO

99999 END

**********************************************************************
* Calculate values of a scalar FEM function on a cutline
*
* Evaluates a scalar FEM-function along a given cutline.
* The cutline is given by start- and endpoint and is evaluated
* in equidistant intervals.
*
* In:
*  NEQ    - length of FEM solution vector
*  DSOL   - array [1..NEQ] of double
*           FEM solution vector describing the continuous FEM
*           function. The function is assumed to be scalar!
*  ELE    - Element that is used for the discretisation
*  BNONPR - TRUE if ELEM is a nonparametric element,
*           FALSE otherwise
*  BTRI   - TRUE if ELEM is a triangular element,
*           FALSE otherwise
*  DX1,
*  DY1    - start point of the cutline
*  DX2,
*  DY2    - end point of the cutline
*  NNDS   - Number of nodes on the cutline where the function
*           should be evaluated.
*
*  TRIA   - array [1..SZTRIA] of integer
*           Triangulation structure
*  DCORVG,
*  KVERT
*  KMID   - Usual geometry information; must correspond to TRIA!
*
*
* Out:
*  DVAL   - array [1..NNDS] of double
*           Receives the function values along the cutline.
*  DGRX   - array [1..NNDS] of double
*           Receives the X-derivatives along the cutline.
*  DGRY   - array [1..NNDS] of double
*           Receives the Y-derivatives values along the cutline.
*  DXPOS  - array [1..NNDS] of double
*           Recevies the X-positions of the points where the
*           function is evaluated
*  DYPOS  - array [1..NNDS] of double
*           Recevies the Y-positions of the points where the
*           function is evaluated
*  IELS   - array [1..NNDS] of integer
*           Recevies the numbers of the elements corresponding to
*           the points in DXPOS/DYPOS
*
* If the point is not on the element (or if no element was found),
* IER is set to -1 and the calculation is aborted.
**********************************************************************

      SUBROUTINE CUTLIN (NEQ,DSOL,ELE,BNONPR, BTRI,
     *                   DX1,DY1, DX2,DY2, NNDS,
     *                   TRIA,DCORVG,KVERT,KMID,
     *                   DVAL, DGRX, DGRY, DXPOS, DYPOS, IELS)

      IMPLICIT NONE

      INCLUDE 'cerr.inc'

      INCLUDE 'cbasictria.inc'

      INCLUDE 'stria.inc'

C parameters

      INTEGER NEQ,NNDS,IELS(NNDS),KVERT(NNVE,*),KMID(NNVE,*)
      INTEGER TRIA(SZTRIA)
      DOUBLE PRECISION DCORVG(2,*), DX1,DY1, DX2,DY2
      DOUBLE PRECISION DSOL(NEQ),DXPOS(NNDS),DYPOS(NNDS)
      DOUBLE PRECISION DVAL(NNDS), DGRX(NNDS), DGRY(NNDS)
      LOGICAL BNONPR, BTRI
      EXTERNAL ELE

C local variables

      INTEGER I

C Cutlines are postprocessing :)
C Therefore we don't care about runtime...

C The cutline is divided into NNDS-1 intervals. The coordinates
C of the interval endpoints we can calculate directly...

      DO I=1,NNDS
        IELS(I) = 0
        DXPOS(I) = ( DX1 * DBLE(NNDS-I) + DX2 * DBLE(I) ) / DBLE(NNDS)
        DYPOS(I) = ( DY1 * DBLE(NNDS-I) + DY2 * DBLE(I) ) / DBLE(NNDS)
      END DO

C Now loop again through these points and evaluate the function there

      DO I=1,NNDS

C First try to evaluate on the same element as before.

        IF (I.GT.1) IELS(I) = IELS(I-1)
        IF (BTRI) THEN
          CALL SCEVLT (NEQ,DSOL,ELE,BNONPR,DXPOS(I),DYPOS(I),IELS(I),
     *               TRIA,DCORVG,KVERT,KMID,
     *               DVAL(I), DGRX(I), DGRY(I))
        ELSE
          CALL SCEVLQ (NEQ,DSOL,ELE,BNONPR,DXPOS(I),DYPOS(I),IELS(I),
     *               TRIA,DCORVG,KVERT,KMID,
     *               DVAL(I), DGRX(I), DGRY(I))
        END IF

C If this doesn't work, search for another element that contains
C the current point.

        IF (IER.LT.0) THEN
          IER = 0
          IELS(I) = 0
          IF (BTRI) THEN
            CALL SCEVLT (NEQ,DSOL,ELE,BNONPR,DXPOS(I),DYPOS(I),IELS(I),
     *               TRIA,DCORVG,KVERT,KMID,
     *               DVAL(I), DGRX(I), DGRY(I))
          ELSE
            CALL SCEVLQ (NEQ,DSOL,ELE,BNONPR,DXPOS(I),DYPOS(I),IELS(I),
     *               TRIA,DCORVG,KVERT,KMID,
     *               DVAL(I), DGRX(I), DGRY(I))
          END IF
        END IF

C In case of an error we take the last calculated value.
C Errors e.g. occur if there are two boundary components, so the
C points in the inner boundary component don't have a corresponding
C element in the grid!

        IF (IER.LT.0) THEN
          IER = 0
          IF (I.GT.0) THEN
            DVAL(I) = DVAL(I-1)
            DGRX(I) = DGRX(I-1)
            DGRY(I) = DGRY(I-1)
          END IF
        END IF

      END DO

      END

***********************************************************************
* Compute a cutline and write it to a file
*
* In:
*  DSOL    - solution vector
*  NEQ     - length of solution vector
*  ELE     - Element function
*  BNONPR  - TRUE if the element is nonparametric
*  BTRI   - TRUE if ELEM is a triangular element,
*           FALSE otherwise
*  X1,
*  Y1      - start of the cutline
*  X2,
*  Y2      - end of the cutline
*  NNDCL   - Number of points in the cutline
*  MUNIT   - File handle where to write the data to.
*            The file must be open already!
*
* This file uses the data in the TRIAx-COMMON blocks for the definition
* of the grid.
***********************************************************************

      SUBROUTINE WCUTLN (DSOL,NEQ,ELE,BNONPR,BTRI,X1,Y1,X2,Y2,NNDCL,
     *                   MUNIT)

      IMPLICIT NONE

      INCLUDE 'cmem.inc'
      INCLUDE 'cerr.inc'
      INCLUDE 'cout.inc'
      INCLUDE 'cbasictria.inc'

      INCLUDE 'stria.inc'

      INTEGER NEQ
      DOUBLE PRECISION X1,Y1,X2,Y2,DSOL(NEQ)

      EXTERNAL ELE

      INTEGER MUNIT,NNDCL,ELE
      LOGICAL BNONPR,BTRI

C Some variables for calculating cutlines in the postprocessing

      INTEGER LVAL, LGRX, LGRY, LXPOS, LYPOS, LIELS, TRIA(SZTRIA)

      INTEGER I

C Reserve memory for the cutline data

      IER = 0

      CALL ZNEW (NNDCL,1,LVAL,'DVAL  ')
      CALL ZNEW (NNDCL,1,LGRX,'DGRY  ')
      CALL ZNEW (NNDCL,1,LGRY,'DGRY  ')
      CALL ZNEW (NNDCL,1,LXPOS,'DXPOS ')
      CALL ZNEW (NNDCL,1,LYPOS,'DYPOS ')
      CALL ZNEW (NNDCL,3,LIELS,'IELS  ')

      IF (IER.NE.0) THEN
        WRITE (MTERM,'(A)') 'WCUTLN: not enough memory for cutline'
        RETURN
      END IF

C Fetch the triangulation structure

      CALL C2TRIA(TRIA)

C Calculate the cutline

      CALL CUTLIN (NEQ,DSOL,ELE,BNONPR,BTRI,
     *               X1,Y1, X2,Y2, NNDCL,
     *               TRIA,DWORK(L(TRIA(OLCORVG))),
     *               KWORK(L(TRIA(OLVERT))),KWORK(L(TRIA(OLMID))),
     *               DWORK(L(LVAL)), DWORK(L(LGRX)), DWORK(L(LGRY)),
     *               DWORK(L(LXPOS)), DWORK(L(LYPOS)), KWORK(L(LIELS)))

C Write it to the file in GNUPlot-format

      WRITE (MUNIT,'(A)') '# X Y Value X-Der. Y-Der. Element-Nr.'

      DO I=1,NNDCL
        WRITE (MUNIT,'(I10,5E24.14,I10)') I,
     *         DWORK(L(LXPOS)+I-1), DWORK(L(LYPOS)+I-1),
     *         DWORK(L(LVAL)+I-1), DWORK(L(LGRX)+I-1),
     *         DWORK(L(LGRY)+I-1),KWORK(L(LIELS)+I-1)

      END DO

      WRITE (MUNIT,'(A)') ''

C Free the memory used

      CALL ZDISP (0,LIELS,'IELS  ')
      CALL ZDISP (0,LYPOS,'DYPOS ')
      CALL ZDISP (0,LXPOS,'DXPOS ')
      CALL ZDISP (0,LGRY,'DGRY  ')
      CALL ZDISP (0,LGRX,'DGRY  ')
      CALL ZDISP (0,LVAL,'DVAL  ')

      END


    Program zpbequ_example

!     ZPBEQU Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: zdscal
      Use lapack_example_aux, Only: nagf_blas_zddscl, &
        nagf_file_print_matrix_complex_band_comp
      Use lapack_interfaces, Only: zpbequ
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: one = 1.0_dp
      Real (Kind=dp), Parameter :: thresh = 0.1_dp
      Integer, Parameter :: nin = 5, nout = 6
      Character (1), Parameter :: uplo = 'U'
!     .. Local Scalars ..
      Real (Kind=dp) :: amax, big, scond, small
      Integer :: i, i0, i1, ifail, ilen, info, j, kd, ldab, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: ab(:, :)
      Real (Kind=dp), Allocatable :: s(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon, max, min, radix, real, tiny
!     .. Executable Statements ..
      Write (nout, *) 'ZPBEQU Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, kd
      ldab = kd + 1
      Allocate (ab(ldab,n), s(n))

!     Read the upper or lower triangular part of the band matrix A
!     from data file

      If (uplo=='U') Then
        Do i = 1, n
          Read (nin, *)(ab(kd+1+i-j,j), j=i, min(n,i+kd))
        End Do
      Else If (uplo=='L') Then
        Do i = 1, n
          Read (nin, *)(ab(1+i-j,j), j=max(1,i-kd), i)
        End Do
      End If

!     Print the matrix A

!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      If (uplo=='U') Then
        Call nagf_file_print_matrix_complex_band_comp(n, n, 0, kd, ab, ldab, &
          'Bracketed', '1P,E10.2', 'Matrix A', 'Integer', rlabs, 'Integer', &
          clabs, 80, 0, ifail)
      Else If (uplo=='L') Then
        Call nagf_file_print_matrix_complex_band_comp(n, n, kd, 0, ab, ldab, &
          'Bracketed', '1P,E10.2', 'Matrix A', 'Integer', rlabs, 'Integer', &
          clabs, 80, 0, ifail)
      End If

      Write (nout, *)

!     Compute diagonal scaling factors

      Call zpbequ(uplo, n, kd, ab, ldab, s, scond, amax, info)

      If (info>0) Then
        Write (nout, 100) 'Diagonal element', info, ' of A is non positive'
      Else

!       Print SCOND, AMAX and the scale factors

        Write (nout, 110) 'SCOND =', scond, ', AMAX =', amax
        Write (nout, *)
        Write (nout, *) 'Diagonal scaling factors'
        Write (nout, 120) s(1:n)
        Write (nout, *)
        Flush (nout)

!       Compute values close to underflow and overflow

        small = tiny(1.0E0_dp)/(epsilon(1.0E0_dp)*real(radix(1.0E0_dp),kind=dp &
          ))
        big = one/small
        If ((scond<thresh) .Or. (amax<small) .Or. (amax>big)) Then

!         Scale A

          If (uplo=='U') Then
            Do j = 1, n
              i0 = max(1, j-kd)
              i1 = 1 + i0 - (j-kd)
              ilen = j - i0 + 1
              Call zdscal(ilen, s(j), ab(i1,j), 1)
              Call nagf_blas_zddscl(ilen, s(i0), 1, ab(i1,j), 1)
            End Do

          Else If (uplo=='L') Then
            Do j = 1, n
              i1 = 1
              ilen = min(n, j+kd) - j + 1
              Call zdscal(ilen, s(j), ab(i1,j), 1)
              Call nagf_blas_zddscl(ilen, s(j), 1, ab(i1,j), 1)
            End Do
          End If

!         Print the scaled matrix

          ifail = 0
          If (uplo=='U') Then
            Call nagf_file_print_matrix_complex_band_comp(n, n, 0, kd, ab, &
              ldab, 'Bracketed', 'F7.4', 'Scaled matrix', 'Integer', rlabs, &
              'Integer', clabs, 80, 0, ifail)
          Else If (uplo=='L') Then
            Call nagf_file_print_matrix_complex_band_comp(n, n, kd, 0, ab, &
              ldab, 'Bracketed', 'F7.4', 'Scaled matrix', 'Integer', rlabs, &
              'Integer', clabs, 80, 0, ifail)
          End If
        End If
      End If

100   Format (1X, A, I4, A)
110   Format (1X, 2(A,1P,E8.1))
120   Format ((1X,1P,7E11.1))
    End Program


program solve_test
  use m_util

  implicit none

  call solve_test1

contains

  subroutine solve_test1
    real(dp) :: actual(3), expected(3)
    real(dp) :: M(3,3), b(3)

    M(1,:) = [ 3.0,  2.0, -1.0]
    M(2,:) = [ 2.0, -2.0,  4.0]
    M(3,:) = [-1.0,  0.5, -1.0]

    b = [1.0, -2.0, 0.0]

    actual = solve(M, b)
    expected = [1.0, -2.0, -2.0]

    if (maxval(abs(actual - expected)) > 1D-10) stop 1
  end subroutine solve_test1
end program solve_test


C$Procedure      TYEAR ( Seconds per tropical year )

      DOUBLE PRECISION FUNCTION TYEAR ()

C$ Abstract
C
C     Return the number of seconds in a tropical year.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C  None.
C
C$ Keywords
C
C      CONSTANTS
C
C$ Declarations
C
C     None.
C
C$ Brief_I/O
C
C      VARIABLE  I/O              DESCRIPTION
C      --------  ---  --------------------------------------------------
C      TYEAR       O   The number of seconds/tropical year
C
C$ Detailed_Input
C
C     None.
C
C$ Detailed_Output
C
C     The function returns the number of seconds per tropical
C     year.  This value is taken from the 1992 Explanatory Supplement
C     to the Astronomical Almanac.
C
C$ Parameters
C
C     None.
C
C$ Particulars
C
C     The tropical year is often used as a fundamental unit
C     of time when dealing with older ephemeris data.  For this
C     reason its value in terms of ephemeris seconds is
C     recorded in this function.
C
C$ Examples
C
C     Suppose you wish to compute the number of tropical centuries
C     that have elapsed since the ephemeris epoch B1950 (beginning
C     of the Besselian year 1950) at a particular ET epoch.  The
C     following line of code will do the trick.
C
C
C        CENTRY = ( ET - UNITIM ( B1950(), 'JED', 'ET' ) )
C       .       / ( 100.0D0 * TYEAR() )
C
C
C$ Restrictions
C
C      None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      W.L. Taber      (JPL)
C
C$ Literature_References
C
C      Explanatory Supplement to the Astronomical Almanac.
C      Page 80. University Science Books, 20 Edgehill Road,
C      Mill Valley, CA 94941
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 13-JUL-1993 (WLT)
C
C-&

C$ Index_Entries
C
C     Number of seconds per tropical year
C
C-&

      TYEAR = 31556925.9747D0
      RETURN
      END


      subroutine shockbubble_setprob(gamma_in,
     &      x0_in,y0_in,r0_in,rhoin_in,pinf_in, idisc_in)

      implicit none
      double precision gamma_in, x0_in, y0_in, r0_in
      double precision rhoin_in, pinf_in
      double precision gamma,x0,y0,r0,rhoin,pinf
      double precision qin(5), qout(5)
      double precision gamma1
      double precision alf, beta
      double precision rinf,vinf,einf
      double precision rhoout, pout, pin
      integer idisc, idisc_in

      common /comic/ qin,qout
      common /cparam/  gamma,gamma1
      common/cdisc/ x0,y0,alf,beta,r0,idisc
      common /cominf/ rinf,vinf,einf
c
c
c      # set idisc for cellave routines (see function fdisc)
       idisc = idisc_in
c

c      # These should be read in as options
       gamma = gamma_in
       gamma1 = gamma - 1.d0

       x0 = x0_in
       y0 = y0_in
       r0 = r0_in
       rhoin = rhoin_in
       pinf = pinf_in

c       x0 = 0.5d0
c       y0 = 0.0d0
c       r0 = 0.2d0
c       rhoin = 0.1d0
c       pinf = 5.d0

c       read(7,*) gamma
c       gamma1 = gamma - 1.d0
c
cc      # read center and radius of bubble:
c       read(7,*) x0,y0,r0
cc      # density in bubble:
c       read(7,*) rhoin
cc      # pressure behind shock:
c       read(7,*) pinf
cc
c      # density outside bubble and pressure ahead of shock are fixed:
       rhoout = 1.d0
       pout   = 1.d0
       pin    = 1.d0

       qin(1) = rhoin
       qin(2) = 0.d0
       qin(3) = 0.d0
       qin(4) = pin/gamma1
       qin(5) = 1.d0

       qout(1) = rhoout
       qout(2) = 0.d0
       qout(3) = 0.d0
       qout(4) = pout/gamma1
       qout(5) = 0.d0
c
c     # Compute density and velocity behind shock from Hugoniot relations:
c     # ------------------------------------------------------------------

      rinf = ( gamma1 + (gamma+1)*pinf )/( (gamma+1) + gamma1*pinf )
      vinf = (1.0d0/sqrt(gamma)) * (pinf - 1.d0)/
     &       sqrt( 0.5d0*((gamma+1)/gamma) * pinf + 0.5d0*gamma1/gamma )
      einf = 0.5d0*rinf*vinf*vinf + pinf/gamma1

      return
      end


module lineclip

use, intrinsic:: iso_c_binding, only: c_int
use, intrinsic:: iso_fortran_env, only : stderr=>error_unit
use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan, ieee_is_nan
use assert, only: wp

implicit none

integer,parameter :: inside=0,left=1,right=2,lower=4,upper=8
private
public:: wp,cohensutherland,Ccohensutherland

contains

subroutine Ccohensutherland(xmin,ymax,xmax,ymin,Np,x1,y1,x2,y2) bind(c)
! for C/C++/f2py that need constant length arrays
!
! INPUTS
! ------
! xmin,ymax,xmax,ymin:  upper left and lower right corners of box (pixel coordinates)
! Np: number of points in vectors (number of elementts)
!
! INOUT
! -----
! x1,y1,x2,y2:
! in - endpoints of line
! out - intersection points with box. If no intersection, all NaN

integer(c_int), intent(in) :: Np
real(wp),intent(in) :: xmin,ymax,xmax,ymin
real(wp),intent(inout), dimension(Np):: x1,y1,x2,y2

call cohensutherland(xmin, ymax, xmax,ymin,x1,y1,x2,y2)

end subroutine Ccohensutherland

elemental subroutine cohensutherland(xmin,ymax,xmax,ymin, &
                                x1, y1, x2, y2)
! INPUTS
! ------
! xmin,ymax,xmax,ymin:  upper left and lower right corners of box (pixel coordinates)
!
! INOUT
! -----
! x1,y1,x2,y2:
! in - endpoints of line
! out - intersection points with box. If no intersection, all NaN

real(wp), intent(in) :: xmin,ymax,xmax,ymin
real(wp), intent(out):: x1,y1,x2,y2
real(wp) :: nan

integer k1, k2, opt ! just plain integers
real(wp) :: x,y

nan = ieee_value(1.,ieee_quiet_nan)
y = nan
x = nan

! check for trivially outside lines
k1 = getclip(x1,y1,xmin,xmax,ymin,ymax)
k2 = getclip(x2,y2,xmin,xmax,ymin,ymax)

do while (ior(k1,k2) /= 0)

  !trivially outside window, Reject
  if (iand(k1,k2) /= 0) then
    x1=nan; y1=nan; x2=nan; y2=nan
    return
  endif

  opt = merge(k1,k2,k1 > 0)
  if (iand(opt,UPPER) > 0) then
    x = x1 + (x2 - x1) * (ymax - y1) / (y2 - y1)
    y = ymax
  elseif (iand(opt,LOWER) > 0) then
    x = x1 + (x2 - x1) * (ymin - y1) / (y2 - y1)
    y = ymin
  elseif (iand(opt,RIGHT) > 0) then
    y = y1 + (y2 - y1) * (xmax - x1) / (x2 - x1)
    x = xmax
  elseif (iand(opt,LEFT) > 0) then
    y = y1 + (y2 - y1) * (xmin - x1) / (x2 - x1)
    x = xmin
  else
    error stop 'undefined clipping state'
  endif

  if (opt == k1) then ! not case select
    x1 = x; y1 = y
    k1 = getclip(x1,y1,xmin,xmax,ymin,ymax)
  elseif (opt == k2) then
    x2 = x; y2 = y
    k2 = getclip(x2,y2,xmin,xmax,ymin,ymax)
  endif

end do

end subroutine cohensutherland

elemental function getclip(xa,ya,xmin,xmax,ymin,ymax) result(p) ! bit patterns
real(wp), intent(in) :: xa,ya,xmin,xmax,ymin,ymax

integer p
p = inside ! default

!consider x
if (xa < xmin) then
  p = ior(p,left)
elseif (xa > xmax) then
  p = ior(p,right)
endif

!consider y
if (ya < ymin) then
  p = ior(p,lower)
elseif (ya > ymax) then
  p = ior(p,upper)
endif

end function getclip

end module lineclip


      SUBROUTINE REGRID(XPOSNS,YPOSNS,ZPOSNS,NPNTS,XLEFT,XRIGHT,
     &                  YLOWER,YUPPER,SURFAS,NPTSX,NPTSY,INTERP)
C
C          ------------------------------------------------
C          ROUTINE NO. ( 128)   VERSION (A8.2)    04:MAR:91
C          ------------------------------------------------
C
C          THIS ESTIMATES THE SURFACE HEIGHTS ON A REGULAR GRID,
C          GIVEN HEIGHTS OF THE SURFACE AT RANDOM COPLANAR POINTS.
C
C
C          THE ARGUMENTS ARE AS FOLLOWS:
C
C          [XPOSNS] THE SET OF X-COORDINATES,
C          [YPOSNS] THE SET OF Y-COORDINATES,
C          [ZPOSNS] THE SET OF Z-COORDINATES,
C                   (ALL OF THESE MUST HAVE AT LEAST <NPNTS> ELEMENTS)
C          <NPNTS>  THE NUMBER OF SURFACE POINTS (THIS MUST BE > 5),
C          <XLEFT>  THE LEFT-HAND EDGE OF THE GRID RECTANGLE,
C          <XRIGHT> THE RIGHT-HAND EDGE OF THE GRID RECTANGLE,
C          <YLOWER> THE LOWER EDGE OF THE GRID RECTANGLE,
C          <YUPPER> THE UPPER EDGE OF THE GRID RECTANGLE,
C          [SURFAS] AN OUTPUT ARRAY OF SIZE <NPTSX> BY <NPTSY>,
C                   WHICH (IF THE ROUTINE IS SUCCESSFUL) CONTAINS
C                   THE ESTIMATED SURFACE HEIGHTS FOR THE GRID.
C                   THE ELEMENT (1,1) CONTAINS THE HEIGHT AT
C                   (<XLEFT>,<YLOWER>) AND THE ELEMENT (<NPTSX>,<NPTSY>)
C                   CONTAINS THE HEIGHT AT (<XRIGHT>,<YUPPER>).
C          <NPTSX>  THE NO. OF GRID INTERVALS IN THE X-DIRECTION,
C          <NPTSY>  THE NO. OF GRID INTERVALS IN THE Y-DIRECTION,
C          <INTERP> IS AN INTERPOLATION ROUTINE WHICH ESTIMATES THE
C                   HEIGHT AT A GIVEN GRID POINT. TWO VERSIONS ARE
C                   SUPPLIED WITH GHOST-80, INTRP1 AND INTRP2. THOSE
C                   WHO WISH TO PROVIDE THEIR OWN VERSION SHOULD REFER
C                   TO THE SPECIFICATION GIVEN AT THE START OF EITHER.
C
C
C          THE SUBROUTINE ESTIMATES SURFACE HEIGHTS ON A REGULAR GRID
C          IN THE RECTANGLE DEFINED BY THE GIVEN X AND Y RANGES. ONLY
C          POINTS WITHIN A CIRCLE OF RADIUS <RADIUS> CENTRED ON A GRID
C          POINT ARE USED IN THE ESTIMATION OF ITS SURFACE HEIGHT.
C          <RADIUS> IS INITIALLY SET SO THAT AN ESTIMATED 30 POINTS LIE
C          INSIDE THE CIRCLE. IF THE SIZE OF <RADIUS> PROVES TOO SMALL,
C          IT IS INCREASED UNTIL A RELIABLE CALCULATION CAN BE MADE.
C
C
      REAL    XPOSNS(NPNTS),YPOSNS(NPNTS),ZPOSNS(NPNTS),
     &        SURFAS(NPTSX,NPTSY)
      LOGICAL ERRON
C
      EXTERNAL INTERP
C
      COMMON /T0TRAC/ IPRINT
      COMMON /T3CONS/ PI
      COMMON /T3ERRS/ ERRON,NUMERR
C
C
      CALL G3INIT(2)
C
      IF (IPRINT.EQ.1) CALL G0MESG(145,0)
C
C          SOME OF THE INPUT ARGUMENTS ARE CHECKED FOR VALIDITY.
C
      IF (NPNTS.LE.5.OR.NPTSX.LT.1.OR.NPTSY.LT.1) GO TO 901
C
      X1= XPOSNS(1)
      X2= XPOSNS(1)
      Y1= YPOSNS(1)
      Y2= YPOSNS(1)
      DO 100 IPT= 2,NPNTS
        TEMPX= XPOSNS(IPT)
        TEMPY= YPOSNS(IPT)
        X1= AMIN1(X1,TEMPX)
        X2= AMAX1(X2,TEMPX)
        Y1= AMIN1(Y1,TEMPY)
        Y2= AMAX1(Y2,TEMPY)
  100 CONTINUE
C
C          THE RECTANGLE ENCLOSING ALL GRID AND DATA POINTS IS FOUND.
C
      X1= AMIN1(X1,XLEFT,XRIGHT)
      X2= AMAX1(X2,XLEFT,XRIGHT)
      Y1= AMIN1(Y1,YLOWER,YUPPER)
      Y2= AMAX1(Y2,YLOWER,YUPPER)
C
C          DATA POINTS WITHIN A RADIUS <RADIUS> OF A GRID POINT ARE
C          TO BE USED TO COMPUTE THE APPROXIMATION. THE RADIUS
C          <RADIUS> IS CALCULATED SO THAT ON AVERAGE THIRTY POINTS LIE
C          INSIDE A CIRCLE OF RADIUS <RADIUS> CENTRED ON A GRID POINT.
C
      XRANGE= X2-X1
      YRANGE= Y2-Y1
      AREA= XRANGE*YRANGE*30.0/FLOAT(NPNTS)
      STARAD= SQRT(AREA/PI)
C
C          IF A DATA POINT IS WITHIN DISTANCE <TOL> OF A GRID POINT,
C          THE SURFACE HEIGHT AT THE DATA POINT IS ACCEPTED AS THE
C          HEIGHT AT THE GRID POINT. THE VALUE OF <TOL> IS SET HERE.
C
      DIAM= SQRT(XRANGE*XRANGE+YRANGE*YRANGE)
      TOL= 0.001*DIAM
      IF (STARAD.LT.TOL) STARAD= TOL
C
C          THE FOLLOWING DOUBLE LOOP CONSTRUCTS THE REGULAR GRID.
C
      XSTEP= (XRIGHT-XLEFT)/FLOAT(NPTSX-1)
      YSTEP= (YUPPER-YLOWER)/FLOAT(NPTSY-1)
      DO 200 IGX= 1,NPTSX
        XPOS= XLEFT+FLOAT(IGX-1)*XSTEP
        DO 300 IGY= 1,NPTSY
          YPOS= YLOWER+FLOAT(IGY-1)*YSTEP
          RADIUS= STARAD
C
C          THE REMEDY FOR AN ERROR IS TO INCREASE <RADIUS>
C          UNTIL THE WHOLE AREA IS COVERED. IF THIS FAILS,
C          THE ATTEMPT IS ABANDONED AND AN ERROR EXIT TAKEN.
C
    2       CALL INTERP(XPOSNS,YPOSNS,ZPOSNS,NPNTS,XPOS,YPOS,RADIUS,TOL,
     &                  VALUE,IREPLY)
            IF (IREPLY.EQ.0) GO TO 3
C
            IF (RADIUS.GT.DIAM) GO TO 902
            RADIUS= 2.0*RADIUS
            GO TO 2
C
    3     SURFAS(IGX,IGY)= VALUE
  300   CONTINUE
  200 CONTINUE
      RETURN
C
  901 NUMERR= 35
      CALL G0ERMS
      RETURN
C
  902 NUMERR= 36
      CALL G0ERMS
C
      RETURN
      END


      SUBROUTINE FIRF16( Y, YPT, NP, DX, ISTAT )

!************************************************************************
!* This routine filters the data in array Y using a finite impulse
!*  response filter.  The passband frequency is the current sampling
!*  frequency divided by 16, the cutoff frequency is 1.36 times the
!*  passband, the stopband frequency is 1.89 times the passband, the
!*  passband ripple is 0.0225 dB, and the stopband gain is -50 dB.  The
!*  array Y will contain the same number of points on output as when
!*  input.  NFILT is the number of filter coefficients.
!*
!* Y(I) = Summation of H(K)*(Y(I-K)+Y(I+K)) for K = 1, NFILT
!*
!* Arguments:
!*  Y     = data to be filtered
!*  YPT   = scratch array (must be dimensioned NP+50)
!*  NP    = number of data points in Y
!*  DX    = time increment between points in Y
!*  ISTAT = status code  [0 = no error, -1 = no filtering]
!*
!* Written By:  M.R.Neale Dec-1980
!*       from HSRI Thoracic Injury Project (DOT-HS-4-00921)
!*
!* Modification History:
!*   Ver/Ed    Date      Modification
!*   ------- ---------  ------------------------------------------------
!*    MRN01  24-Jun-81  Changed filter type to specific code for this
!*    HCG01  10-Jul-87  Converted for use on the HQ VAX 11/780.
!*
!* Language: Fortran
!*
!* Author: M.R.Neale
!*
!* Date: 1999/08/20
!************************************************************************

      ! Arguments ____________________________________________________

      INTEGER NP ! Number of data points

      REAL Y(NP) ! Data array

      REAL YPT(NP+50) ! Scratch array

      REAL DX ! Time step (delta-t) (sec) in time series (>0)

      INTEGER ISTAT ! Status flag returned

      ! Variables ____________________________________________________

      INTEGER NFILT, I, K, NL, NR

      PARAMETER ( NFILT = 25 )

      REAL H(NFILT), PIVOT

      DOUBLE PRECISION HYSUM

      SAVE H

      DATA H /
     & 0.00209983, 0.00129339, 0.00065168,-0.00085462,-0.00290368,
     & -0.00474660,-0.00539656,-0.00400504,-0.00031044, 0.00502427,
     & 0.01036730, 0.01347790, 0.01223700, 0.00555978,-0.00587902,
     & -0.01924700,-0.03001660,-0.03298210,-0.02377640,-0.00039844,
     & 0.03574880, 0.07971110, 0.12385300, 0.15960801, 0.17961000 /

!
!#######################################################################

      ! Check frequency (assumes 100 Hz) vs. sampling rate
      IF ( ( DX .EQ. 0. ) .OR. ( .5/DX .LE. 100. ) ) THEN
        WRITE( *, * )
     &     '*** ERROR - Filter cutoff freq must be < (sample rate) / 2'
        ISTAT = -1
        RETURN
      END IF

      ! Transfer data leaving room for reqd padding at beginning & end
      DO I = 1, NP
        YPT(NFILT+I) = Y(I)
      END DO

      ! Pad beginning
      PIVOT = 2.0 * YPT(NFILT+1)
      DO I = 1, NFILT
        YPT(NFILT+1-I) = PIVOT - YPT(NFILT+I)
      END DO

      ! Pad end
      PIVOT = 2.0 * YPT(NP+NFILT)
      DO I = 1, NFILT
        YPT(NP+NFILT+I) = PIVOT - YPT(NP+NFILT+1-I)
      END DO

      ! Now, do the actual filtering
      DO I = 1, NP
        NL = I - 1
        NR = I + 2 * NFILT
        HYSUM = 0.
        DO K = 1, NFILT
          HYSUM = HYSUM + H(K) * ( YPT(NL+K) + YPT(NR-K) )
        END DO
        Y(I) = REAL( HYSUM )
      END DO
      ISTAT = 0

      RETURN
      END


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
MODULE m_dosef
   !
   !---  >    obtain dos at ei (here: ef)
   !
   USE m_constants
   USE m_types
   USE m_trisrt

   IMPLICIT NONE

   CONTAINS

   SUBROUTINE dosef(ei,nemax,jspins,kpts,sfac,eig)

      INTEGER,       INTENT(IN) :: jspins
      TYPE(t_kpts),  INTENT(IN) :: kpts
      REAL,          INTENT(IN) :: ei,sfac
      INTEGER,       INTENT(IN) :: nemax(:)
      REAL,          INTENT(IN) :: eig(:,:,:) !(neig,nkpt,jspins)

      REAL     :: e1,e2,e21,e3,e31,e32,s
      INTEGER  :: iBand,jspin,k1,k2,k3,itria,neig

      DO jspin = 1,jspins
         neig = nemax(jspin)
         s = 0.0
         DO iBand = 1,neig
            DO itria = 1,kpts%ntet
               !Get the k-points and eigenvalues
               !of the current triangle
               k1 = kpts%ntetra(1,itria)
               k2 = kpts%ntetra(2,itria)
               k3 = kpts%ntetra(3,itria)
               e1 = eig(iBand,k1,jspin)
               e2 = eig(iBand,k2,jspin)
               e3 = eig(iBand,k3,jspin)
               !Sort by ascending eigenvalues
               CALL trisrt(e1,e2,e3,k1,k2,k3)
               IF (e1.LE.-9999.0) cycle !Not all eigenvalues available
               IF ((ei.LT.e1) .OR. (ei.GE.e3)) cycle !triangle not contributing
               IF (ei.GT.e2) THEN
                  !--->  e2<ei<e3
                  e31 = e3 - e1
                  e32 = e3 - e2
                  s = s + 2.0*kpts%voltet(itria)/kpts%ntet &
                         * (e3-ei)/ (e31*e32)
               ELSE
                  !--->  e1<ei<e2
                  e31 = e3 - e1
                  e21 = e2 - e1
                  s = s + 2.0*kpts%voltet(itria)/kpts%ntet &
                         * (ei-e1)/ (e31*e21)
               ENDIF
            ENDDO
         ENDDO
         !gb  s = (2./jspins)*s
         s = sfac * s
         WRITE (oUnit,FMT=8000) ei,jspin,s
8000     FORMAT (/,10x,'density of states at',f12.6,&
                 ' har for spin',i2,'=',e20.8,' states/har')
      ENDDO

   END SUBROUTINE dosef
END MODULE m_dosef


! BUCKLING_PLATE_BARDELL program
!
! The required inputs that should be given are described below
!
! Run control
! -----------
! NUM : integer
!   Number of returned eigenvalues
!
! M : integer
!   Number of terms along x
!
! N : integer
!   Number of terms along x
!
! Geometry
! --------
! a : float
!   The plate length (dimension along x)
! b : float
!   The plate width (dimension along y)
!
! Applied Loads
! -------------
! Nxx : float
!   Nxx stress
! Nyy : float
!   Nyy stress
! Nxy : float
!   Nxy stress
!
! Laminate Constitutive Varibles (matrix D)
! -----------------------------------------
! D11 : float
!   Bending stiffness
! D12 : float
!   Bending-Bending stiffness
! D16 : float
!   Bending-twist stiffness
! D22 : float
!   Bending stiffness
! D26 : float
!   Bending-twist stiffness
! D66 : float
!   Twist (torsion) stiffness
!
! Boundary conditions
! -------------------
! w1tx : float
!   If 1. the edge at x=0 can translate along w
!   If 0. the edge at x=0 cannot translate along w
! w1rx : float
!   If 1. the end at x=0 can rotate
!   If 0. the end at x=0 cannot translate along w
! w2tx : float
!   If 1. the edge at x=a can translate along w
!   If 0. the edge at x=a cannot translate along w
! w2rx : float
!   If 1. the end at x=a can rotate
!   If 0. the end at x=a cannot translate along w
! w1ty : float
!   If 1. the edge at y=0 can translate along w
!   If 0. the edge at y=0 cannot translate along w
! w1ry : float
!   If 1. the end at y=0 can rotate
!   If 0. the end at y=0 cannot translate along w
! w2ty : float
!   If 1. the edge at y=b can translate along w
!   If 0. the edge at y=b cannot translate along w
! w2ry : float
!   If 1. the end at y=b can rotate
!   If 0. the end at y=b cannot translate along w

INCLUDE 'calc_matrices.f90'
INCLUDE '../bardell.f90'

PROGRAM BUCKLING_PLATE_BARDELL
    IMPLICIT NONE
    INTERFACE
        SUBROUTINE integral_ff(i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_ffxi(i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_ffxixi(i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_fxifxi(i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_fxifxixi(i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_fxixifxixi(i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE

        SUBROUTINE CALC_K0(M, N, K, a, b, D11, D12, D16, D22, D26, D66, w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
            INTEGER, INTENT(IN) :: M, N
            REAL*8, INTENT(IN) :: w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry
            REAL*8, INTENT(IN) :: a, b
            REAL*8, INTENT(IN) :: D11, D12, D16, D22, D26, D66
            REAL*8, INTENT(OUT) :: K(M*N, M*N)
        END SUBROUTINE
        SUBROUTINE CALC_KG0(M, N, K, a, b, Nxx, Nyy, Nxy, w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
            INTEGER, INTENT(IN) :: N
            REAL*8, INTENT(IN) :: a, b, Nxx, Nyy, Nxy
            REAL*8, INTENT(IN) :: w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry
            REAL*8, INTENT(OUT) :: K(M*N, M*N)
        END SUBROUTINE
    END INTERFACE

    ! inputs
    CHARACTER BALANC, JOBVL, JOBVR, SENSE
    INTEGER NT, nulls, NUM, M, N
    REAL*8, ALLOCATABLE :: K0(:, :), KG0(:, :), K02(:, :), KG02(:, :)
    REAL*8 D11, D12, D16, D22, D26, D66
    REAL*8 w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry
    REAL*8 a, b, Nxx, Nyy, Nxy
    INTEGER LDA, LDB, LDZ

    ! workspace
    CHARACTER (LEN=100) :: line
    CHARACTER (LEN=400) :: input_file, output_file
    INTEGER stat, i, j, id, jd
    INTEGER LWORK
    INTEGER, ALLOCATABLE :: IWORK(:)
    REAL*8, ALLOCATABLE :: WORK(:)
    INTEGER, ALLOCATABLE :: TMP(:)

    ! outputs
    INTEGER Mout, INFO
    INTEGER, ALLOCATABLE :: IFAIL(:)
    REAL*8, ALLOCATABLE :: EIGVALS(:), EIGVECS(:, :)

    BALANC = 'N'
    JOBVL = 'N'
    JOBVR = 'N'
    SENSE = 'N'

    NUM = 10
    M = 15
    N = 15

    IF (COMMAND_ARGUMENT_COUNT() .NE. 2) THEN
        STOP "This program should be called as: 'buckling_plate_bardell input output'"
    ELSE
        CALL GET_COMMAND_ARGUMENT(1, VALUE=input_file, STATUS=stat)
        CALL GET_COMMAND_ARGUMENT(2, VALUE=output_file, STATUS=stat)
    END IF

    OPEN(10, FILE=input_file)
    DO
        READ(10, *) line
        IF (TRIM(line) == "NUM") READ(10, *) NUM
        IF (TRIM(line) == "M") READ(10, *) M
        IF (TRIM(line) == "N") READ(10, *) N
        IF (TRIM(line) == "a") READ(10, *) a
        IF (TRIM(line) == "b") READ(10, *) b
        IF (TRIM(line) == "Nxx") READ(10, *) Nxx
        IF (TRIM(line) == "Nyy") READ(10, *) Nyy
        IF (TRIM(line) == "Nxy") READ(10, *) Nxy
        IF (TRIM(line) == "D11") READ(10, *) D11
        IF (TRIM(line) == "D12") READ(10, *) D12
        IF (TRIM(line) == "D16") READ(10, *) D16
        IF (TRIM(line) == "D22") READ(10, *) D22
        IF (TRIM(line) == "D26") READ(10, *) D26
        IF (TRIM(line) == "D66") READ(10, *) D66
        IF (TRIM(line) == "w1tx") READ(10, *) w1tx
        IF (TRIM(line) == "w1rx") READ(10, *) w1rx
        IF (TRIM(line) == "w2tx") READ(10, *) w2tx
        IF (TRIM(line) == "w2rx") READ(10, *) w2rx
        IF (TRIM(line) == "w1ty") READ(10, *) w1ty
        IF (TRIM(line) == "w1ry") READ(10, *) w1ry
        IF (TRIM(line) == "w2ty") READ(10, *) w2ty
        IF (TRIM(line) == "w2ry") READ(10, *) w2ry
        IF (TRIM(line) == "END") EXIT
    END DO

    NT = M*N

    ! allocating arrays
    ALLOCATE(K0(NT, NT))
    ALLOCATE(KG0(NT, NT))

    ! constitutive stiffness matrix
    CALL CALC_K0(M, N, K0, a, b, D11, D12, D16, D22, D26, D66, w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)

    ! geometric stiffness matrix
    CALL CALC_KG0(M, N, KG0, a, b, Nxx, Nyy, Nxy, w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)

    ! removing null rows and columns
    ALLOCATE(TMP(NT))
    TMP = 0
    WHERE (ABS(SUM(K0, DIM=1)) <= 0.0000001) TMP = 1
    nulls = SUM(TMP)
    WRITE(*, *) "Number of removed cols:", nulls

    ALLOCATE(K02(NT-nulls, NT-nulls))
    ALLOCATE(KG02(NT-nulls, NT-nulls))

    jd = 0
    DO j=1, NT
        IF (TMP(j) == 1) THEN
            jd = jd+1
            CYCLE
        END IF
        id = 0
        DO i=1, NT
            IF (TMP(i) == 1) THEN
                id = id+1
                CYCLE
            END IF
            K02(i-id, j-jd) = K0(i, j)
            KG02(i-id, j-jd) = KG0(i, j)
        END DO
    END DO
    DEALLOCATE(TMP)

    ! allocating arrays
    ALLOCATE(IWORK((NT-nulls)**2))

    ! allocating output arrays
    ALLOCATE(EIGVALS(NT-nulls))
    ALLOCATE(EIGVECS(NT-nulls, NT-nulls))
    ALLOCATE(IFAIL(NT-nulls))

    LDA = NT-nulls
    LDB = NT-nulls
    LDZ = NT-nulls

    WRITE(*, *) "Eigenvalue analysis starting..."

    ! signature of eigenvalue solver used:
    !
    ! CALL DSYGVX(ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, &
    !             VL, VU, IL, IU, ABSTOL, Mout, W, Z, LDZ, &
    !             WORK, LWORK, IWORK, IFAIL, INFO)

    EIGVALS = EIGVALS*0

    ! Workspace query
    LWORK = -1
    ALLOCATE(WORK(1))
    CALL DSYGVX(1, "N", "A", "U", (NT-nulls), KG02, LDB, K02, LDA, &
                -1.D10, 0, 1, NUM, 0., Mout, EIGVALS, EIGVECS, LDZ, &
                WORK, LWORK, IWORK, IFAIL, INFO)
    LWORK = WORK(1)
    DEALLOCATE(WORK)
    ! Eigensolver query
    ALLOCATE(WORK(LWORK))
    CALL DSYGVX(1, "N", "A", "U", (NT-nulls), KG02, LDB, K02, LDA, &
                -1.D10, 0, 1, NUM, 0., Mout, EIGVALS, EIGVECS, LDZ, &
                WORK, LWORK, IWORK, IFAIL, INFO)
    DEALLOCATE(WORK)

    WHERE(EIGVALS /= 0) EIGVALS = -1/EIGVALS

    WRITE(*, *) "Eigenvalue analysis completed!"

    ! Writing eigenvalues
    OPEN(11, FILE=output_file, ACTION="WRITE", STATUS="REPLACE")
    DO i=1, NUM
        WRITE(11, *) EIGVALS(i)
    END DO

    IF (INFO /= 0) THEN
        WRITE(*, *) 'EIGVALS', EIGVALS(1), EIGVALS(2)
        WRITE(*, *) 'Mout', Mout
        WRITE(*, *) 'INFO', NT-nulls, INFO
        WRITE(*, *) 'IFAIL', IFAIL
        WRITE(*, *) 'MIN(K02), MAX(K02)', MINVAL(K02), MAXVAL(K02)
        WRITE(*, *) 'SUM(K02), SUM(KG02)', SUM(K02), SUM(KG02)
    END IF

    DEALLOCATE(K0)
    DEALLOCATE(KG0)
    DEALLOCATE(K02)
    DEALLOCATE(KG02)
    DEALLOCATE(IWORK)
    DEALLOCATE(EIGVALS)
    DEALLOCATE(EIGVECS)
    DEALLOCATE(IFAIL)

END PROGRAM BUCKLING_PLATE_BARDELL