!*==cgges.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  CGGES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CGGES + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB,
!                         SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK,
!                         LWORK, RWORK, BWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBVSL, JOBVSR, SORT
!       INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM
!       ..
!       .. Array Arguments ..
!       LOGICAL            BWORK( * )
!       REAL               RWORK( * )
!       COMPLEX            A( LDA, * ), ALPHA( * ), B( LDB, * ),
!      $                   BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ),
!      $                   WORK( * )
!       ..
!       .. Function Arguments ..
!       LOGICAL            SELCTG
!       EXTERNAL           SELCTG
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CGGES computes for a pair of N-by-N complex nonsymmetric matrices
!> (A,B), the generalized eigenvalues, the generalized complex Schur
!> form (S, T), and optionally left and/or right Schur vectors (VSL
!> and VSR). This gives the generalized Schur factorization
!>
!>         (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )
!>
!> where (VSR)**H is the conjugate-transpose of VSR.
!>
!> Optionally, it also orders the eigenvalues so that a selected cluster
!> of eigenvalues appears in the leading diagonal blocks of the upper
!> triangular matrix S and the upper triangular matrix T. The leading
!> columns of VSL and VSR then form an unitary basis for the
!> corresponding left and right eigenspaces (deflating subspaces).
!>
!> (If only the generalized eigenvalues are needed, use the driver
!> CGGEV instead, which is faster.)
!>
!> A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
!> or a ratio alpha/beta = w, such that  A - w*B is singular.  It is
!> usually represented as the pair (alpha,beta), as there is a
!> reasonable interpretation for beta=0, and even for both being zero.
!>
!> A pair of matrices (S,T) is in generalized complex Schur form if S
!> and T are upper triangular and, in addition, the diagonal elements
!> of T are non-negative real numbers.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBVSL
!> \verbatim
!>          JOBVSL is CHARACTER*1
!>          = 'N':  do not compute the left Schur vectors;
!>          = 'V':  compute the left Schur vectors.
!> \endverbatim
!>
!> \param[in] JOBVSR
!> \verbatim
!>          JOBVSR is CHARACTER*1
!>          = 'N':  do not compute the right Schur vectors;
!>          = 'V':  compute the right Schur vectors.
!> \endverbatim
!>
!> \param[in] SORT
!> \verbatim
!>          SORT is CHARACTER*1
!>          Specifies whether or not to order the eigenvalues on the
!>          diagonal of the generalized Schur form.
!>          = 'N':  Eigenvalues are not ordered;
!>          = 'S':  Eigenvalues are ordered (see SELCTG).
!> \endverbatim
!>
!> \param[in] SELCTG
!> \verbatim
!>          SELCTG is a LOGICAL FUNCTION of two COMPLEX arguments
!>          SELCTG must be declared EXTERNAL in the calling subroutine.
!>          If SORT = 'N', SELCTG is not referenced.
!>          If SORT = 'S', SELCTG is used to select eigenvalues to sort
!>          to the top left of the Schur form.
!>          An eigenvalue ALPHA(j)/BETA(j) is selected if
!>          SELCTG(ALPHA(j),BETA(j)) is true.
!>
!>          Note that a selected complex eigenvalue may no longer satisfy
!>          SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since
!>          ordering may change the value of complex eigenvalues
!>          (especially if the eigenvalue is ill-conditioned), in this
!>          case INFO is set to N+2 (See INFO below).
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrices A, B, VSL, and VSR.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX array, dimension (LDA, N)
!>          On entry, the first of the pair of matrices.
!>          On exit, A has been overwritten by its generalized Schur
!>          form S.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is COMPLEX array, dimension (LDB, N)
!>          On entry, the second of the pair of matrices.
!>          On exit, B has been overwritten by its generalized Schur
!>          form T.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of B.  LDB >= max(1,N).
!> \endverbatim
!>
!> \param[out] SDIM
!> \verbatim
!>          SDIM is INTEGER
!>          If SORT = 'N', SDIM = 0.
!>          If SORT = 'S', SDIM = number of eigenvalues (after sorting)
!>          for which SELCTG is true.
!> \endverbatim
!>
!> \param[out] ALPHA
!> \verbatim
!>          ALPHA is COMPLEX array, dimension (N)
!> \endverbatim
!>
!> \param[out] BETA
!> \verbatim
!>          BETA is COMPLEX array, dimension (N)
!>          On exit,  ALPHA(j)/BETA(j), j=1,...,N, will be the
!>          generalized eigenvalues.  ALPHA(j), j=1,...,N  and  BETA(j),
!>          j=1,...,N  are the diagonals of the complex Schur form (A,B)
!>          output by CGGES. The  BETA(j) will be non-negative real.
!>
!>          Note: the quotients ALPHA(j)/BETA(j) may easily over- or
!>          underflow, and BETA(j) may even be zero.  Thus, the user
!>          should avoid naively computing the ratio alpha/beta.
!>          However, ALPHA will be always less than and usually
!>          comparable with norm(A) in magnitude, and BETA always less
!>          than and usually comparable with norm(B).
!> \endverbatim
!>
!> \param[out] VSL
!> \verbatim
!>          VSL is COMPLEX array, dimension (LDVSL,N)
!>          If JOBVSL = 'V', VSL will contain the left Schur vectors.
!>          Not referenced if JOBVSL = 'N'.
!> \endverbatim
!>
!> \param[in] LDVSL
!> \verbatim
!>          LDVSL is INTEGER
!>          The leading dimension of the matrix VSL. LDVSL >= 1, and
!>          if JOBVSL = 'V', LDVSL >= N.
!> \endverbatim
!>
!> \param[out] VSR
!> \verbatim
!>          VSR is COMPLEX array, dimension (LDVSR,N)
!>          If JOBVSR = 'V', VSR will contain the right Schur vectors.
!>          Not referenced if JOBVSR = 'N'.
!> \endverbatim
!>
!> \param[in] LDVSR
!> \verbatim
!>          LDVSR is INTEGER
!>          The leading dimension of the matrix VSR. LDVSR >= 1, and
!>          if JOBVSR = 'V', LDVSR >= N.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,2*N).
!>          For good performance, LWORK must generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is REAL array, dimension (8*N)
!> \endverbatim
!>
!> \param[out] BWORK
!> \verbatim
!>          BWORK is LOGICAL array, dimension (N)
!>          Not referenced if SORT = 'N'.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          =1,...,N:
!>                The QZ iteration failed.  (A,B) are not in Schur
!>                form, but ALPHA(j) and BETA(j) should be correct for
!>                j=INFO+1,...,N.
!>          > N:  =N+1: other than QZ iteration failed in CHGEQZ
!>                =N+2: after reordering, roundoff changed values of
!>                      some complex eigenvalues so that leading
!>                      eigenvalues in the Generalized Schur form no
!>                      longer satisfy SELCTG=.TRUE.  This could also
!>                      be caused due to scaling.
!>                =N+3: reordering failed in CTGSEN.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexGEeigen
!
!  =====================================================================
      SUBROUTINE CGGES(Jobvsl,Jobvsr,Sort,SELCTG,N,A,Lda,B,Ldb,Sdim,    &
     &                 Alpha,Beta,Vsl,Ldvsl,Vsr,Ldvsr,Work,Lwork,Rwork, &
     &                 Bwork,Info)
      IMPLICIT NONE
!*--CGGES274
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Jobvsl , Jobvsr , Sort
      INTEGER Info , Lda , Ldb , Ldvsl , Ldvsr , Lwork , N , Sdim
!     ..
!     .. Array Arguments ..
      LOGICAL Bwork(*)
      REAL Rwork(*)
      COMPLEX A(Lda,*) , Alpha(*) , B(Ldb,*) , Beta(*) , Vsl(Ldvsl,*) , &
     &        Vsr(Ldvsr,*) , Work(*)
!     ..
!     .. Function Arguments ..
      LOGICAL SELCTG
      EXTERNAL SELCTG
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE
      PARAMETER (ZERO=0.0E0,ONE=1.0E0)
      COMPLEX CZERO , CONE
      PARAMETER (CZERO=(0.0E0,0.0E0),CONE=(1.0E0,0.0E0))
!     ..
!     .. Local Scalars ..
      LOGICAL cursl , ilascl , ilbscl , ilvsl , ilvsr , lastsl ,        &
     &        lquery , wantst
      INTEGER i , icols , ierr , ihi , ijobvl , ijobvr , ileft , ilo ,  &
     &        iright , irows , irwrk , itau , iwrk , lwkmin , lwkopt
      REAL anrm , anrmto , bignum , bnrm , bnrmto , eps , pvsl , pvsr , &
     &     smlnum
!     ..
!     .. Local Arrays ..
      INTEGER idum(1)
      REAL dif(2)
!     ..
!     .. External Subroutines ..
      EXTERNAL CGEQRF , CGGBAK , CGGBAL , CGGHRD , CHGEQZ , CLACPY ,    &
     &         CLASCL , CLASET , CTGSEN , CUNGQR , CUNMQR , SLABAD ,    &
     &         XERBLA
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV
      REAL CLANGE , SLAMCH
      EXTERNAL LSAME , ILAENV , CLANGE , SLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , SQRT
!     ..
!     .. Executable Statements ..
!
!     Decode the input arguments
!
      IF ( LSAME(Jobvsl,'N') ) THEN
         ijobvl = 1
         ilvsl = .FALSE.
      ELSEIF ( LSAME(Jobvsl,'V') ) THEN
         ijobvl = 2
         ilvsl = .TRUE.
      ELSE
         ijobvl = -1
         ilvsl = .FALSE.
      ENDIF
!
      IF ( LSAME(Jobvsr,'N') ) THEN
         ijobvr = 1
         ilvsr = .FALSE.
      ELSEIF ( LSAME(Jobvsr,'V') ) THEN
         ijobvr = 2
         ilvsr = .TRUE.
      ELSE
         ijobvr = -1
         ilvsr = .FALSE.
      ENDIF
!
      wantst = LSAME(Sort,'S')
!
!     Test the input arguments
!
      Info = 0
      lquery = (Lwork==-1)
      IF ( ijobvl<=0 ) THEN
         Info = -1
      ELSEIF ( ijobvr<=0 ) THEN
         Info = -2
      ELSEIF ( (.NOT.wantst) .AND. (.NOT.LSAME(Sort,'N')) ) THEN
         Info = -3
      ELSEIF ( N<0 ) THEN
         Info = -5
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -7
      ELSEIF ( Ldb<MAX(1,N) ) THEN
         Info = -9
      ELSEIF ( Ldvsl<1 .OR. (ilvsl .AND. Ldvsl<N) ) THEN
         Info = -14
      ELSEIF ( Ldvsr<1 .OR. (ilvsr .AND. Ldvsr<N) ) THEN
         Info = -16
      ENDIF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV.)
!
      IF ( Info==0 ) THEN
         lwkmin = MAX(1,2*N)
         lwkopt = MAX(1,N+N*ILAENV(1,'CGEQRF',' ',N,1,N,0))
         lwkopt = MAX(lwkopt,N+N*ILAENV(1,'CUNMQR',' ',N,1,N,-1))
         IF ( ilvsl ) lwkopt = MAX(lwkopt,N+N*ILAENV(1,'CUNGQR',' ',N,1,&
     &                         N,-1))
         Work(1) = lwkopt
!
         IF ( Lwork<lwkmin .AND. .NOT.lquery ) Info = -18
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('CGGES ',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) THEN
         Sdim = 0
         RETURN
      ENDIF
!
!     Get machine constants
!
      eps = SLAMCH('P')
      smlnum = SLAMCH('S')
      bignum = ONE/smlnum
      CALL SLABAD(smlnum,bignum)
      smlnum = SQRT(smlnum)/eps
      bignum = ONE/smlnum
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      anrm = CLANGE('M',N,N,A,Lda,Rwork)
      ilascl = .FALSE.
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
         anrmto = smlnum
         ilascl = .TRUE.
      ELSEIF ( anrm>bignum ) THEN
         anrmto = bignum
         ilascl = .TRUE.
      ENDIF
!
      IF ( ilascl ) CALL CLASCL('G',0,0,anrm,anrmto,N,N,A,Lda,ierr)
!
!     Scale B if max element outside range [SMLNUM,BIGNUM]
!
      bnrm = CLANGE('M',N,N,B,Ldb,Rwork)
      ilbscl = .FALSE.
      IF ( bnrm>ZERO .AND. bnrm<smlnum ) THEN
         bnrmto = smlnum
         ilbscl = .TRUE.
      ELSEIF ( bnrm>bignum ) THEN
         bnrmto = bignum
         ilbscl = .TRUE.
      ENDIF
!
      IF ( ilbscl ) CALL CLASCL('G',0,0,bnrm,bnrmto,N,N,B,Ldb,ierr)
!
!     Permute the matrix to make it more nearly triangular
!     (Real Workspace: need 6*N)
!
      ileft = 1
      iright = N + 1
      irwrk = iright + N
      CALL CGGBAL('P',N,A,Lda,B,Ldb,ilo,ihi,Rwork(ileft),Rwork(iright), &
     &            Rwork(irwrk),ierr)
!
!     Reduce B to triangular form (QR decomposition of B)
!     (Complex Workspace: need N, prefer N*NB)
!
      irows = ihi + 1 - ilo
      icols = N + 1 - ilo
      itau = 1
      iwrk = itau + irows
      CALL CGEQRF(irows,icols,B(ilo,ilo),Ldb,Work(itau),Work(iwrk),     &
     &            Lwork+1-iwrk,ierr)
!
!     Apply the orthogonal transformation to matrix A
!     (Complex Workspace: need N, prefer N*NB)
!
      CALL CUNMQR('L','C',irows,icols,irows,B(ilo,ilo),Ldb,Work(itau),  &
     &            A(ilo,ilo),Lda,Work(iwrk),Lwork+1-iwrk,ierr)
!
!     Initialize VSL
!     (Complex Workspace: need N, prefer N*NB)
!
      IF ( ilvsl ) THEN
         CALL CLASET('Full',N,N,CZERO,CONE,Vsl,Ldvsl)
         IF ( irows>1 ) CALL CLACPY('L',irows-1,irows-1,B(ilo+1,ilo),   &
     &                              Ldb,Vsl(ilo+1,ilo),Ldvsl)
         CALL CUNGQR(irows,irows,irows,Vsl(ilo,ilo),Ldvsl,Work(itau),   &
     &               Work(iwrk),Lwork+1-iwrk,ierr)
      ENDIF
!
!     Initialize VSR
!
      IF ( ilvsr ) CALL CLASET('Full',N,N,CZERO,CONE,Vsr,Ldvsr)
!
!     Reduce to generalized Hessenberg form
!     (Workspace: none needed)
!
      CALL CGGHRD(Jobvsl,Jobvsr,N,ilo,ihi,A,Lda,B,Ldb,Vsl,Ldvsl,Vsr,    &
     &            Ldvsr,ierr)
!
      Sdim = 0
!
!     Perform QZ algorithm, computing Schur vectors if desired
!     (Complex Workspace: need N)
!     (Real Workspace: need N)
!
      iwrk = itau
      CALL CHGEQZ('S',Jobvsl,Jobvsr,N,ilo,ihi,A,Lda,B,Ldb,Alpha,Beta,   &
     &            Vsl,Ldvsl,Vsr,Ldvsr,Work(iwrk),Lwork+1-iwrk,          &
     &            Rwork(irwrk),ierr)
      IF ( ierr/=0 ) THEN
         IF ( ierr>0 .AND. ierr<=N ) THEN
            Info = ierr
         ELSEIF ( ierr>N .AND. ierr<=2*N ) THEN
            Info = ierr - N
         ELSE
            Info = N + 1
         ENDIF
         GOTO 100
      ENDIF
!
!     Sort eigenvalues ALPHA/BETA if desired
!     (Workspace: none needed)
!
      IF ( wantst ) THEN
!
!        Undo scaling on eigenvalues before selecting
!
         IF ( ilascl ) CALL CLASCL('G',0,0,anrm,anrmto,N,1,Alpha,N,ierr)
         IF ( ilbscl ) CALL CLASCL('G',0,0,bnrm,bnrmto,N,1,Beta,N,ierr)
!
!        Select eigenvalues
!
         DO i = 1 , N
            Bwork(i) = SELCTG(Alpha(i),Beta(i))
         ENDDO
!
         CALL CTGSEN(0,ilvsl,ilvsr,Bwork,N,A,Lda,B,Ldb,Alpha,Beta,Vsl,  &
     &               Ldvsl,Vsr,Ldvsr,Sdim,pvsl,pvsr,dif,Work(iwrk),     &
     &               Lwork-iwrk+1,idum,1,ierr)
         IF ( ierr==1 ) Info = N + 3
!
      ENDIF
!
!     Apply back-permutation to VSL and VSR
!     (Workspace: none needed)
!
      IF ( ilvsl ) CALL CGGBAK('P','L',N,ilo,ihi,Rwork(ileft),          &
     &                         Rwork(iright),N,Vsl,Ldvsl,ierr)
      IF ( ilvsr ) CALL CGGBAK('P','R',N,ilo,ihi,Rwork(ileft),          &
     &                         Rwork(iright),N,Vsr,Ldvsr,ierr)
!
!     Undo scaling
!
      IF ( ilascl ) THEN
         CALL CLASCL('U',0,0,anrmto,anrm,N,N,A,Lda,ierr)
         CALL CLASCL('G',0,0,anrmto,anrm,N,1,Alpha,N,ierr)
      ENDIF
!
      IF ( ilbscl ) THEN
         CALL CLASCL('U',0,0,bnrmto,bnrm,N,N,B,Ldb,ierr)
         CALL CLASCL('G',0,0,bnrmto,bnrm,N,1,Beta,N,ierr)
      ENDIF
!
      IF ( wantst ) THEN
!
!        Check if reordering is correct
!
         lastsl = .TRUE.
         Sdim = 0
         DO i = 1 , N
            cursl = SELCTG(Alpha(i),Beta(i))
            IF ( cursl ) Sdim = Sdim + 1
            IF ( cursl .AND. .NOT.lastsl ) Info = N + 2
            lastsl = cursl
         ENDDO
!
      ENDIF
!
!
 100  Work(1) = lwkopt
!
!
!     End of CGGES
!
      END SUBROUTINE CGGES


      COMPLEX FUNCTION SUMPHI(IXR,IYR,ND1,NDN,CAPPHI,DSS,N,M,ASYM)
C
C     FUNCTION TO COMPUTE SUM OF CAPPHI-DELTA SOURCE STENGTH PRODUCT
C
      LOGICAL ASYM
      DIMENSION ND1(1),NDN(1)
      COMPLEX  CAPPHI(1),DSS(N,M)
C
      SUMPHI  =  ( 0.0 , 0.0 )
      IF ( IXR .EQ. 0 )   RETURN
      DO   400   I = 1 , IXR
      IXS  =  I - 1
      IP  =  IXR - IXS
      LTOT  =  2 * IP + 1
      IPHI  =  ( IP * ( IP + 1 ) ) / 2
      IYS  =  IYR - IXR + IXS
      DO   300   L = 1 , LTOT
      IF ( ASYM .AND. IYS .EQ. 0 )   GO TO  200
      J  =  IABS ( IYS ) + 1
      IF ( .NOT. ( I .GE. (ND1(J)) .AND. I .LE. NDN(J) ) )   GO TO 200
      S  =  1.0
      IF ( ASYM .AND. IYS .LT. 0 )   S  =  -S
      IJPHI  =  IPHI + 1 + IABS ( IYR - IYS )
      SUMPHI  =  SUMPHI + S * CAPPHI(IJPHI) * DSS(I,J)
 200  IYS  =  IYS + 1
 300  CONTINUE
 400  CONTINUE
      RETURN
      END


program hmipt_matsuara
  USE DMFT_IPT
  USE IOTOOLS
  USE ERROR
  implicit none
  logical                :: converged,check
  real(8)                :: n,z,de,e
  integer                :: i,iloop
  complex(8)             :: zeta
  complex(8),allocatable :: fg(:),fg0(:),sigma(:)
  real(8),allocatable    :: wm(:),epsi(:),dos(:)

  call read_input("inputIPT.in")

  !allocate functions:
  allocate(fg(L))
  allocate(sigma(L))
  allocate(fg0(L))

  !build freq. array
  allocate(wm(L))
  wm(:)  = pi/beta*real(2*arange(1,L)-1,8)

  allocate(dos(Nx),epsi(Nx))
  D=sqrt(2.d0)*ts
  epsi = linspace(-5.d0*D,5.d0*D,Nx,mesh=de)
  do i=1,Nx
     dos(i) = dens_hyperc(epsi(i),D)
  enddo
  call splot("DOShyperc.ipt",epsi,dos)
  print*,trapz(de,dos)

  !get or read first sigma
  call  get_inital_sigma(Sigma,"Sigma.restart")

  !dmft loop:
  iloop=0 ; converged=.false.
  do while(.not.converged.AND.iloop<nloop)
     iloop=iloop+1
     write(*,"(A,i5)",advance="no")"DMFT-loop",iloop
     !SELF-CONSISTENCY:
     fg=zero
     do i=1,L
        zeta = xi*wm(i) - sigma(i)
        fg(i) = sum_overk_zeta(zeta,epsi,dos)*de
     enddo
     n   = get_local_density(fg,beta)
     fg0 = one/(one/fg + sigma)
     !
     !IMPURITY SOLVER
     sigma= solve_ipt_matsubara(fg0)
     sigma=xi*dimag(sigma)
     converged=check_convergence(fg0,dmft_error,nsuccess,nloop)
     !GET OBSERVABLES
     z=1.d0 - dimag(sigma(1))/wm(1);z=1.d0/z
     call splot("observables_all.ipt",dble(iloop),u,z,beta,append=.true.)
  enddo
  call splot("G_iw.ipt",wm,fg)
  call splot("G0_iw.ipt",wm,fg0)
  call splot("Sigma_iw.ipt",wm,sigma)
  call splot("observables.ipt",u,beta,n,z)

contains

  subroutine get_inital_sigma(self,file)
    complex(8),dimension(:) :: self
    real(8),dimension(size(self)) :: wm
    character(len=*)        :: file
    logical                 :: check
    inquire(file=file,exist=check)
    if(check)then
       print*,'Reading sigma'
       call sread(file,wm,self)
    else
       print*,"Using Hartree-Fock self-energy"
       print*,"===================================="
       self=zero !U*(n-1/2)
    endif
  end subroutine get_inital_sigma

end program hmipt_matsuara


      FUNCTION FF100(I,A,B,M,N,X)
      DIMENSION  X(1)
      F100 = 0.0
      CAPX = A + B * X(I)
      XX = X(I)
      N1 = M + N - 2
      N2 = M - 1
      N3 = N1 + 1
      AN1 = N1
      AN2 = N2
      NFAC = N1
      ASSIGN 5 TO IRET
      GO TO 1000
    5 AMN2F = IFAC
      AN1P1 = AN1 + 1.0
      IS = 0
      S = 0.0
      SF = 1.0
      AMN2SF = AMN2F
      GO TO 50
   10 IS = IS + 1
      S = IS
      SF = SF * S
      AMN2SF = AMN2SF / (AN1P1 - S)
   50 CONTINUE
      N4 = N2 - IS
      IF (N4 .EQ. 0) GO TO 100
      F100 = F100 + AMN2F * (CAPX ** N4) *((-B)** IS) / (AMN2SF * SF
     1            * (AN2 - S) * (XX ** N4))
      GO TO 200
  100 CONTINUE
      NFAC = N2
      ASSIGN 110 TO IRET
      GO TO 1000
  110 AM1F = IFAC
      NFAC = N-1
      ASSIGN 120 TO IRET
      GO TO 1000
  120 AN1F = IFAC
      F100 = F100 + AMN2F *((-B)** N2) * ALOG(ABS(CAPX/XX))
     1            / (AM1F * AN1F)
  200 CONTINUE
      IF (IS .LT. N1) GO TO 10
      F100 =  -F100 / (A ** N3)
       FF100  = F100
      RETURN
 1000 IFAC = 1
      IF(NFAC.LT.2) GO TO 1020
      DO 1010 LFAC=2,NFAC
      IFAC=IFAC*LFAC
 1010 CONTINUE
 1020 GO TO IRET,(5,110,120)
      END


module damage_deriv
	! contains routines for computation of the derivatives of the damage variables
	! with respect to the strain vector

	! load additional modules
	use constants
	use derived_types

    implicit none

contains

	function comp_DomegaDalpha_d(alpha_d, l_char)
		! computes derivative of scalar damage variable omega
		! with respect to internal strain-like damage variable alpha_d
		! domega/dalpha_d
		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), intent(in) :: alpha_d							! internal strain type damage variable
		real(kind=dbl), intent(in) :: l_char							! characteristic element length

		! return variable
		real(kind=dbl) :: comp_DomegaDalpha_d					! domega/dalpha_d

		! internal variable
		! --------------------------------------------------------------------------

		! computation of domega/dalpha_d
		! .
		! .
		! .
		! comp_DomegaDalpha_d = ...

	end function comp_DomegaDalpha_d

end module damage_deriv


* auxCD.F
* auxiliary functions used by the three- and four-point integrals
* these functions are adapted from Ansgar Denner's bcanew.f
* to the conventions of LoopTools;
* they are used for double-checking the results of FF
* last modified 25 Oct 05 th

      double complex function ln(x, isig)
      implicit none
      include 'qlconstants.f'
      double precision x, isig
      if( x .gt. 0 ) then
        ln = DCMPLX(log(x),0d0)
      else
       ln = dcmplx(log(-x)) + DCMPLX(0D0, sign(pi, isig))
      endif
      end

************************************************************************

      double complex function cln(z, isig)
      implicit none
      include 'qlconstants.f'
      double complex z
      double precision isig

      if( DIMAG(z) .eq. 0d0 .and. DBLE(z) .le. 0d0 ) then
         cln = log(-z) + DCMPLX(0D0, sign(pi, isig))
      else
         cln = log(z)
      endif
      end

************************************************************************

      double complex function denspence(z, isig)
      implicit none
      double complex z
      double precision isig

      include 'qlconstants.f'
      include 'qlonshellcutoff.f'

      double complex z1
      double precision az1,acc

      double complex li2series, cln
      external li2series, cln
      acc=qlonshellcutoff

      z1 = cone - z
      az1 = abs(z1)

      if( isig .eq. 0d0 .and.
     &    DIMAG(z) .eq. 0d0 .and. abs(DBLE(z1)) .lt. acc )
     &    print *, "denspence: argument on cut"

      if( az1 .lt. 1D-15 ) then
        denspence = dcmplx(pisqo6)
      else if( DBLE(z) .lt. .5D0 ) then
        if( abs(z) .lt. 1d0 ) then
          denspence = li2series(z, isig)
        else
          denspence = -dcmplx(pisqo6) -
     &        .5D0*cln(-z, -isig)**2 - li2series(1d0/z, -isig)
        endif
      else
        if( az1 .lt. 1d0 ) then
          denspence = dcmplx(pisqo6) -
     &        cln(z, isig)*cln(z1, -isig) - li2series(z1, -isig)
        else
          denspence = 2d0*dcmplx(pisqo6) +
     &        .5D0*cln(-z1, -isig)**2 - cln(z, isig)*cln(z1, -isig) +
     &        li2series(1d0/z1, isig)
        endif
      endif
      end

************************************************************************

      double complex function li2series(z, isig)
      implicit none
      include 'qlconstants.f'
      double complex z
      double precision isig

      double complex xm, x2, new
      integer j

      double complex cln
      external cln

* these are the even-n Bernoulli numbers, already divided by (n + 1)!
* as in Table[BernoulliB[n]/(n + 1)!, {n, 2, 50, 2}]
      double precision b(25)
      data b /
     &    0.02777777777777777777777777777777777777777778774D0,
     &    -0.000277777777777777777777777777777777777777777778D0,
     &    4.72411186696900982615268329554043839758125472D-6,
     &    -9.18577307466196355085243974132863021751910641D-8,
     &    1.89788699889709990720091730192740293750394761D-9,
     &    -4.06476164514422552680590938629196667454705711D-11,
     &    8.92169102045645255521798731675274885151428361D-13,
     &    -1.993929586072107568723644347793789705630694749D-14,
     &    4.51898002961991819165047655285559322839681901D-16,
     &    -1.035651761218124701448341154221865666596091238D-17,
     &    2.39521862102618674574028374300098038167894899D-19,
     &    -5.58178587432500933628307450562541990556705462D-21,
     &    1.309150755418321285812307399186592301749849833D-22,
     &    -3.087419802426740293242279764866462431595565203D-24,
     &    7.31597565270220342035790560925214859103339899D-26,
     &    -1.740845657234000740989055147759702545340841422D-27,
     &    4.15763564461389971961789962077522667348825413D-29,
     &    -9.96214848828462210319400670245583884985485196D-31,
     &    2.394034424896165300521167987893749562934279156D-32,
     &    -5.76834735536739008429179316187765424407233225D-34,
     &    1.393179479647007977827886603911548331732410612D-35,
     &    -3.372121965485089470468473635254930958979742891D-37,
     &    8.17820877756210262176477721487283426787618937D-39,
     &    -1.987010831152385925564820669234786567541858996D-40,
     &    4.83577851804055089628705937311537820769430091D-42 /

      xm = -cln(cone - z, -isig)
      x2 = xm**2
      li2series = xm - x2/4D0
      do j = 1, 25
        xm = xm*x2
        new = li2series + xm*b(j)
        if( new .eq. li2series ) return
        li2series = new
      enddo
      print *, "li2series: bad convergence"
      end


      SUBROUTINE BILIN11L( M, N, P, IX, AX, V, Y )

        !!***********************************************************************
        !! Version "$Id: bilin.f 1 2017-06-10 18:05:20Z coats $"
        !! EDSS/Models-3 I/O API.
        !! Copyright (C) 1992-2002 MCNC and Carlie J. Coats, Jr.,
        !! (C) 2003-2010 Baron Advanced Meteorological Systems, and
        !! (C) 2014 UNC Institute for the Environment.
        !! Distributed under the GNU LESSER GENERAL PUBLIC LICENSE version 2.1
        !! See file "LGPL.txt" for conditions of use.
        !!.........................................................................
        !!  subroutine body BILIN11L starts at line  88:  layered-vector inputs and outputs
        !!  subroutine body BILIN12L starts at line 142:  layered-vector input, 3-D grid output
        !!  subroutine body BILIN21L starts at line 225:  layered-vector input, 3-D grid output
        !!  subroutine body BILIN22L starts at line 300:  layered-vector input, 3-D grid output
        !!  subroutine body BILIN11  starts at line 380:  non-layered vector inputs and outputs
        !!  subroutine body BILIN12  starts at line 430:  non-layered vector input, 2D grid output
        !!  subroutine body BILIN21  starts at line 483:  2-D grid inputs and output
        !!  subroutine body BILIN22  starts at line 531:  2-D grid inputs and output
        !!  subroutine body BILIN    starts at line 582:  fall-back for non-"USE M3UTILIO"
        !!
        !!  FUNCTION:  apply a 4-band sparse matrix to an array ("layered vector")
        !!
        !!  NOTE:  Maintains I/O subscript order V( M,P )
        !!
        !!       For Bilinear interpolation of gridded data having dimension NC,NR
        !!       to a list of locations having grid-normal coordinates <X(S),Y(S)>:
        !!       let Y(S) and R(S) be INT( X(S) ) and INT( Y(S) ), P(S) and Q(S)
        !!       be AMOD( X(S), 1.0 ) and AMOD( Y(S), 1.0 ).  Then IX has the
        !!	single-indexing subscripts into the grid for the cell=corners
        !!       surrounding the <X(S),Y(S)>
        !!           IX(1,S) = C + NC * ( R - 1 ) + 1
        !!           IX(2,S) = C + NC * ( R - 1 )
        !!           IX(3,S) = C + NC *   R
        !!           IX(4,S) = C + NC *   R       + 1
        !!       and AX has the BILIN1ear-interpolation coefficients:
        !!           AX(1,S) = ( 1.0 - P( S ) )*( 1.0 - Q( S ) )
        !!           AX(2,S) =         P( S )  *( 1.0 - Q( S ) )
        !!           AX(3,S) = ( 1.0 - P( S ) )*        Q( S )
        !!           AX(4,S) =         P( S )  *        Q( S )
        !!
        !!    MODULE M3UTILIO contains a generic BILIN interface that selects
        !!    among the BILIN*
        !!
        !!  SEE ALSO:
        !!       UNGRIDB() which produces such matrices
        !!       BMATVEY() which performs combined interpolate-and-transpose,
        !!                 e.g., for SMOKE program LAYPOINT
        !!
        !!  PRECONDITIONS REQUIRED:
        !!       Number of layers same for input and output.
        !!       Index and coefficients set up so that the equation for
        !!       the multiplication (at each row R and layer L) is
        !!
        !!       Y(L,R) = SUM_{ J=1...4 }  A( J,R ) * V( I( J,R ),L )
        !!
        !!  SUBROUTINES AND FUNCTIONS CALLED:  none
        !!
        !!  REVISION  HISTORY:
        !!       prototype 8/1999 by CJC
        !!       Version   9/2014 by CJC:  modifications for OpenMP parallel
        !!    Version  12/2014 by CJC for I/O API v3.2:  multiple versions
        !!        with M3UTILIO generic interface BILIN()
        !!***********************************************************************

        IMPLICIT NONE

        !!...........   ARGUMENTS and their descriptions:

        INTEGER, INTENT(IN   ) :: M               ! length of input  vector
        INTEGER, INTENT(IN   ) :: N               ! length of output vector
        INTEGER, INTENT(IN   ) :: P               ! number of layers
        INTEGER, INTENT(IN   ) :: IX( 4,N )       ! index array
        REAL   , INTENT(IN   ) :: AX( 4,N )       ! 4-band coeff matrix
        REAL   , INTENT(IN   ) :: V( M,P )        ! P-layered input  vector
        REAL   , INTENT(  OUT) :: Y( N,P )        ! P-layered output vector

        !!...........   SCRATCH LOCAL VARIABLES and their descriptions:

        INTEGER         R, L, J1, J2, J3, J4

        !!***********************************************************************
        !!   begin body of subroutine  BILIN1

        IF ( L .EQ. 1 ) THEN        !! parallelize on R

!$OMP       PARALLEL DO
!$OMP&        DEFAULT( NONE ),
!$OMP&         SHARED( P, N, IX, AX, V, Y ),
!$OMP&        PRIVATE( R, J1, J2, J3, J4 )

            DO  R = 1, N

                J1 = IX( 1,R )
                J2 = IX( 2,R )
                J3 = IX( 3,R )
                J4 = IX( 4,R )

                Y( R,1 ) = AX( 1,R ) * V( J1,1 )  +
     &                     AX( 2,R ) * V( J2,1 )  +
     &                     AX( 3,R ) * V( J3,1 )  +
     &                     AX( 4,R ) * V( J4,1 )

            END DO

        ELSE        !!  L > 1:  parallelize on L

!$OMP       PARALLEL DO
!$OMP&        DEFAULT( NONE ),
!$OMP&         SHARED( P, N, IX, AX, V, Y ),
!$OMP&        PRIVATE( L, R, J1, J2, J3, J4 )

            DO  L = 1, P
            DO  R = 1, N

                J1 = IX( 1,R )
                J2 = IX( 2,R )
                J3 = IX( 3,R )
                J4 = IX( 4,R )

                Y( R,L ) = AX( 1,R ) * V( J1,L )  +
     &                     AX( 2,R ) * V( J2,L )  +
     &                     AX( 3,R ) * V( J3,L )  +
     &                     AX( 4,R ) * V( J4,L )

            END DO
            END DO

        END IF

        RETURN

      END SUBROUTINE BILIN11L

!!-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

      SUBROUTINE BILIN12L( M, NC, NR, P, IX, AX, V, Y )

        IMPLICIT NONE

        !!...........   ARGUMENTS and their descriptions:

        INTEGER, INTENT(IN   ) :: M                 ! length of input  vector
        INTEGER, INTENT(IN   ) :: NC, NR            ! dims of output grid
        INTEGER, INTENT(IN   ) :: P                 ! number of layers
        INTEGER, INTENT(IN   ) :: IX( 4,NC*NR )     ! index array
        REAL   , INTENT(IN   ) :: AX( 4,NC*NR )     ! 4-band coeff matrix
        REAL   , INTENT(IN   ) :: V( M,P )          ! P-layered input  vector
        REAL   , INTENT(  OUT) :: Y( NC,NR,P )      ! P-layered output vector

        !!...........   SCRATCH LOCAL VARIABLES and their descriptions:

        INTEGER         C, R, CC, RR, S, K, L, J1, J2, J3, J4

        !!***********************************************************************
        !!   begin body of subroutine  BILIN1

        IF ( L .EQ. 1 ) THEN        !! parallelize on R

!$OMP       PARALLEL DO
!$OMP&        DEFAULT( NONE ),
!$OMP&         SHARED( P, NC, NR, IX, AX, V, Y ),
!$OMP&        PRIVATE( C, R, S, J1, J2, J3, J4 )

            DO  R = 1, NR
            DO  C = 1, NC

                S = ( R  - 1 ) * NC  +  C
                J1 = IX( 1,S )
                J2 = IX( 2,S )
                J3 = IX( 3,S )
                J4 = IX( 4,S )

                Y( C,R,1 ) = AX( 1,S ) * V( J1,1 )  +
     &                       AX( 2,S ) * V( J2,1 )  +
     &                       AX( 3,S ) * V( J3,1 )  +
     &                       AX( 4,S ) * V( J4,1 )

            END DO
            END DO

        ELSE        !!  L > 1:  parallelize on L

!$OMP       PARALLEL DO
!$OMP&        DEFAULT( NONE ),
!$OMP&         SHARED( P, NC, NR, IX, AX, V, Y ),
!$OMP&        PRIVATE( L, C, R, S, J1, J2, J3, J4 )

            DO  L = 1, P
            DO  R = 1, NR
            DO  C = 1, NC

                S = ( R  - 1 ) * NC  +  C
                J1 = IX( 1,S )
                J2 = IX( 2,S )
                J3 = IX( 3,S )
                J4 = IX( 4,S )

                Y( C,R,L ) = AX( 1,S ) * V( J1,L )  +
     &                       AX( 2,S ) * V( J2,L )  +
     &                       AX( 3,S ) * V( J3,L )  +
     &                       AX( 4,S ) * V( J4,L )

            END DO
            END DO
            END DO

        END IF

        RETURN

      END SUBROUTINE BILIN12L

!!-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

      SUBROUTINE BILIN21L( MC, MR, N, P, IX, AX, V, Y )

        IMPLICIT NONE

        !!...........   ARGUMENTS and their descriptions:

        INTEGER, INTENT(IN   ) :: MC, MR          ! dims of input  grid
        INTEGER, INTENT(IN   ) :: N               ! dims of output grid
        INTEGER, INTENT(IN   ) :: P               ! number of layers
        INTEGER, INTENT(IN   ) :: IX( 4,N )       ! index array
        REAL   , INTENT(IN   ) :: AX( 4,N )       ! 4-band coeff matrix
        REAL   , INTENT(IN   ) ::  V( MC,MR,P )   ! P-layered input  vector
        REAL   , INTENT(  OUT) ::  Y( N,P )       ! P-layered output vector

        !!...........   SCRATCH LOCAL VARIABLES and their descriptions:

        INTEGER         C, R, K, L, S, CC, RR

        !!***********************************************************************
        !!   begin body of subroutine  BILIN1

        IF ( L .EQ. 1 ) THEN        !! parallelize on R

!$OMP       PARALLEL DO
!$OMP&        DEFAULT( NONE ),
!$OMP&         SHARED( P, MC, MR, N, IX, AX, V, Y ),
!$OMP&        PRIVATE( S, K, CC, RR )

            DO  S = 1, N

                K  = IX( 1,S )
                CC = MOD( K, MC )
                RR = 1 + K / MC

                Y( S,1 ) = AX( 1,S ) * V( CC  ,RR  ,1 )  +
     &                     AX( 2,S ) * V( CC+1,RR  ,1 )  +
     &                     AX( 3,S ) * V( CC  ,RR+1,1 )  +
     &                     AX( 4,S ) * V( CC+1,RR+1,1 )

            END DO

        ELSE        !!  L > 1:  parallelize on L

!$OMP       PARALLEL DO
!$OMP&        DEFAULT( NONE ),
!$OMP&         SHARED( P, MC, MR, N, IX, AX, V, Y ),
!$OMP&        PRIVATE( L,S, K, CC, RR )

            DO  L = 1, P
            DO  S = 1, N

                K  = IX( 1,S )
                CC = MOD( K, MC )
                RR = 1 + K / MC

                Y( S,L ) = AX( 1,S ) * V( CC  ,RR  ,L )  +
     &                     AX( 2,S ) * V( CC+1,RR  ,L )  +
     &                     AX( 3,S ) * V( CC  ,RR+1,L )  +
     &                     AX( 4,S ) * V( CC+1,RR+1,L )

            END DO
            END DO

        END IF

        RETURN

      END SUBROUTINE BILIN21L

!!-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

      SUBROUTINE BILIN22L( MC, MR, NC, NR, P, IX, AX, V, Y )

        IMPLICIT NONE

        !!...........   ARGUMENTS and their descriptions:

        INTEGER, INTENT(IN   ) :: MC, MR          ! dims of input  grid
        INTEGER, INTENT(IN   ) :: NC, NR          ! dims of output grid
        INTEGER, INTENT(IN   ) :: P               ! number of layers
        INTEGER, INTENT(IN   ) :: IX( 4,NC*NR )   ! index array
        REAL   , INTENT(IN   ) :: AX( 4,NC*NR )   ! 4-band coeff matrix
        REAL   , INTENT(IN   ) ::  V( MC,MR,P )   ! P-layered input  vector
        REAL   , INTENT(  OUT) ::  Y( NC,NR,P )   ! P-layered output vector

        !!...........   SCRATCH LOCAL VARIABLES and their descriptions:

        INTEGER         C, R, K, L, S, CC, RR

        !!***********************************************************************
        !!   begin body of subroutine  BILIN1

        IF ( L .EQ. 1 ) THEN        !! parallelize on R

!$OMP       PARALLEL DO
!$OMP&        DEFAULT( NONE ),
!$OMP&         SHARED( P, MC, MR, NC, NR, IX, AX, V, Y ),
!$OMP&        PRIVATE( C, R, S, K, CC, RR )

            DO  R = 1, NR
            DO  C = 1, NC

                S  = ( R  - 1 ) * NC  +  C
                K  = IX( 1,S )
                CC = MOD( K, MC )
                RR = 1 + K / MC

                Y( C,R,1 ) = AX( 1,S ) * V( CC  ,RR  ,1 )  +
     &                       AX( 2,S ) * V( CC+1,RR  ,1 )  +
     &                       AX( 3,S ) * V( CC  ,RR+1,1 )  +
     &                       AX( 4,S ) * V( CC+1,RR+1,1 )

            END DO
            END DO

        ELSE        !!  L > 1:  parallelize on L

!$OMP       PARALLEL DO
!$OMP&        DEFAULT( NONE ),
!$OMP&         SHARED( P, MC, MR, NC, NR, IX, AX, V, Y ),
!$OMP&        PRIVATE( L, C, R, S, K, CC, RR )

            DO  L = 1, P
            DO  R = 1, NR
            DO  C = 1, NC

                S  = ( R  - 1 ) * NC  +  C
                K  = IX( 1,S )
                CC = MOD( K, MC )
                RR = 1 + K / MC

                Y( C,R,L ) = AX( 1,S ) * V( CC  ,RR  ,L )  +
     &                       AX( 2,S ) * V( CC+1,RR  ,L )  +
     &                       AX( 3,S ) * V( CC  ,RR+1,L )  +
     &                       AX( 4,S ) * V( CC+1,RR+1,L )

            END DO
            END DO
            END DO

        END IF

        RETURN

      END SUBROUTINE BILIN22L

!!-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

      SUBROUTINE BILIN11( M, N, IX, AX, V, Y )

        IMPLICIT NONE

        !!...........   ARGUMENTS and their descriptions:

        INTEGER, INTENT(IN   ) :: M               ! length of input  vector
        INTEGER, INTENT(IN   ) :: N               ! length of output vector
        INTEGER, INTENT(IN   ) :: IX( 4,N )       ! index array
        REAL   , INTENT(IN   ) :: AX( 4,N )       ! 4-band coeff matrix
        REAL   , INTENT(IN   ) :: V( M )          ! 1-layered input  vector
        REAL   , INTENT(  OUT) :: Y( N )          ! 1-layered output vector

        !!...........   SCRATCH LOCAL VARIABLES and their descriptions:

        INTEGER         R, L, J1, J2, J3, J4

        !!***********************************************************************
        !!   begin body of subroutine  BILIN11

!$OMP       PARALLEL DO
!$OMP&        DEFAULT( NONE ),
!$OMP&         SHARED( N, IX, AX, V, Y ),
!$OMP&        PRIVATE( R, J1, J2, J3, J4 )

        DO  R = 1, N

            J1 = IX( 1,R )
            J2 = IX( 2,R )
            J3 = IX( 3,R )
            J4 = IX( 4,R )

            Y( R ) = AX( 1,R ) * V( J1 )  +
     &               AX( 2,R ) * V( J2 )  +
     &               AX( 3,R ) * V( J3 )  +
     &               AX( 4,R ) * V( J4 )

        END DO

        RETURN

      END SUBROUTINE BILIN11

!!-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

      SUBROUTINE BILIN12( M, NC, NR, IX, AX, V, Y )

        IMPLICIT NONE

        !!...........   ARGUMENTS and their descriptions:

        INTEGER, INTENT(IN   ) :: M                 ! length of input  vector
        INTEGER, INTENT(IN   ) :: NC, NR            ! dims of output grid
        INTEGER, INTENT(IN   ) :: IX( 4,NC*NR )     ! index array
        REAL   , INTENT(IN   ) :: AX( 4,NC*NR )     ! 4-band coeff matrix
        REAL   , INTENT(IN   ) :: V( M )            ! 1-layered input  vector
        REAL   , INTENT(  OUT) :: Y( NC,NR )        ! 1-layered output vector

        !!...........   SCRATCH LOCAL VARIABLES and their descriptions:

        INTEGER         C, R, CC, RR, S, K, L, J1, J2, J3, J4

        !!***********************************************************************
        !!   begin body of subroutine  BILIN11

!$OMP       PARALLEL DO
!$OMP&        DEFAULT( NONE ),
!$OMP&         SHARED( NC, NR, IX, AX, V, Y ),
!$OMP&        PRIVATE( C, R, S, J1, J2, J3, J4 )

        DO  R = 1, NR
        DO  C = 1, NC

            S = ( R  - 1 ) * NC  +  C
            J1 = IX( 1,S )
            J2 = IX( 2,S )
            J3 = IX( 3,S )
            J4 = IX( 4,S )

            Y( C,R ) = AX( 1,S ) * V( J1 )  +
     &                 AX( 2,S ) * V( J2 )  +
     &                 AX( 3,S ) * V( J3 )  +
     &                 AX( 4,S ) * V( J4 )

        END DO
        END DO

        RETURN

      END SUBROUTINE BILIN12

!!-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

      SUBROUTINE BILIN21( MC, MR, N, IX, AX, V, Y )

        IMPLICIT NONE

        !!...........   ARGUMENTS and their descriptions:

        INTEGER, INTENT(IN   ) :: MC, MR          ! dims of input  grid
        INTEGER, INTENT(IN   ) :: N               ! dims of output grid
        INTEGER, INTENT(IN   ) :: IX( 4,N )       ! index array
        REAL   , INTENT(IN   ) :: AX( 4,N )       ! 4-band coeff matrix
        REAL   , INTENT(IN   ) ::  V( MC,MR )     ! nonlayered input  vector
        REAL   , INTENT(  OUT) ::  Y( N )         ! nonlayered output vector

        !!...........   SCRATCH LOCAL VARIABLES and their descriptions:

        INTEGER         C, R, K, L, S, CC, RR

        !!***********************************************************************
        !!   begin body of subroutine  BILIN11

!$OMP       PARALLEL DO
!$OMP&        DEFAULT( NONE ),
!$OMP&         SHARED( MC, MR, N, IX, AX, V, Y ),
!$OMP&        PRIVATE( C, R, S, K, CC, RR )

        DO  S = 1, N

            K  = IX( 1,S )
            CC = MOD( K, MC )
            RR = 1 + K / MC

            Y( S ) = AX( 1,S ) * V( CC  ,RR   )  +
     &               AX( 2,S ) * V( CC+1,RR   )  +
     &               AX( 3,S ) * V( CC  ,RR+1 )  +
     &               AX( 4,S ) * V( CC+1,RR+1 )

        END DO

        RETURN

      END SUBROUTINE BILIN21

!!-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

      SUBROUTINE BILIN22( MC, MR, NC, NR, IX, AX, V, Y )

        IMPLICIT NONE

        !!...........   ARGUMENTS and their descriptions:

        INTEGER, INTENT(IN   ) :: MC, MR          ! dims of input  grid
        INTEGER, INTENT(IN   ) :: NC, NR          ! dims of output grid
        INTEGER, INTENT(IN   ) :: IX( 4,NC*NR )   ! index array
        REAL   , INTENT(IN   ) :: AX( 4,NC*NR )   ! 4-band coeff matrix
        REAL   , INTENT(IN   ) ::  V( MC,MR )     ! P-layered input  vector
        REAL   , INTENT(  OUT) ::  Y( NC,NR )     ! P-layered output vector

        !!...........   SCRATCH LOCAL VARIABLES and their descriptions:

        INTEGER         C, R, K, L, S, CC, RR

        !!***********************************************************************
        !!   begin body of subroutine  BILIN11

!$OMP       PARALLEL DO
!$OMP&        DEFAULT( NONE ),
!$OMP&         SHARED( MC, MR, NC, NR, IX, AX, V, Y ),
!$OMP&        PRIVATE( C, R, S, K, CC, RR )

        DO  R = 1, NR
        DO  C = 1, NC

            S  = ( R  - 1 ) * NC  +  C
            K  = IX( 1,S )
            CC = MOD( K, MC )
            RR = 1 + K / MC

            Y( C,R ) = AX( 1,S ) * V( CC  ,RR   )  +
     &                 AX( 2,S ) * V( CC+1,RR   )  +
     &                 AX( 3,S ) * V( CC  ,RR+1 )  +
     &                 AX( 4,S ) * V( CC+1,RR+1 )

        END DO
        END DO

        RETURN

      END SUBROUTINE BILIN22

!!-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

      SUBROUTINE BILIN( M, N, P, IX, AX, V, Y )

        IMPLICIT NONE

C...........   ARGUMENTS and their descriptions:

        INTEGER, INTENT(IN   ) :: M               ! length of input  vector
        INTEGER, INTENT(IN   ) :: N               ! length of output vector
        INTEGER, INTENT(IN   ) :: P               ! number of layers
        INTEGER, INTENT(IN   ) :: IX( 4,N )       ! index array
        REAL   , INTENT(IN   ) :: AX( 4,N )       ! 4-band coeff matrix
        REAL   , INTENT(IN   ) :: V( M,P )        ! P-layered input  vector
        REAL   , INTENT(  OUT) :: Y( N,P )        ! P-layered output vector

        CALL BILIN11L( M, N, P, IX, AX, V, Y )

        RETURN

      END SUBROUTINE BILIN


*> \brief \b DPTT02
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DPTT02( N, NRHS, D, E, X, LDX, B, LDB, RESID )
*
*       .. Scalar Arguments ..
*       INTEGER            LDB, LDX, N, NRHS
*       DOUBLE PRECISION   RESID
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   B( LDB, * ), D( * ), E( * ), X( LDX, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DPTT02 computes the residual for the solution to a symmetric
*> tridiagonal system of equations:
*>    RESID = norm(B - A*X) / (norm(A) * norm(X) * EPS),
*> where EPS is the machine epsilon.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGTER
*>          The order of the matrix A.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrices B and X.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is DOUBLE PRECISION array, dimension (N)
*>          The n diagonal elements of the tridiagonal matrix A.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*>          E is DOUBLE PRECISION array, dimension (N-1)
*>          The (n-1) subdiagonal elements of the tridiagonal matrix A.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*>          X is DOUBLE PRECISION array, dimension (LDX,NRHS)
*>          The n by nrhs matrix of solution vectors X.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*>          LDX is INTEGER
*>          The leading dimension of the array X.  LDX >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
*>          On entry, the n by nrhs matrix of right hand side vectors B.
*>          On exit, B is overwritten with the difference B - A*X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] RESID
*> \verbatim
*>          RESID is DOUBLE PRECISION
*>          norm(B - A*X) / (norm(A) * norm(X) * EPS)
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_lin
*
*  =====================================================================
      SUBROUTINE DPTT02( N, NRHS, D, E, X, LDX, B, LDB, RESID )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            LDB, LDX, N, NRHS
      DOUBLE PRECISION   RESID
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), D( * ), E( * ), X( LDX, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            J
      DOUBLE PRECISION   ANORM, BNORM, EPS, XNORM
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DASUM, DLAMCH, DLANST
      EXTERNAL           DASUM, DLAMCH, DLANST
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLAPTM
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( N.LE.0 ) THEN
         RESID = ZERO
         RETURN
      END IF
*
*     Compute the 1-norm of the tridiagonal matrix A.
*
      ANORM = DLANST( '1', N, D, E )
*
*     Exit with RESID = 1/EPS if ANORM = 0.
*
      EPS = DLAMCH( 'Epsilon' )
      IF( ANORM.LE.ZERO ) THEN
         RESID = ONE / EPS
         RETURN
      END IF
*
*     Compute B - A*X.
*
      CALL DLAPTM( N, NRHS, -ONE, D, E, X, LDX, ONE, B, LDB )
*
*     Compute the maximum over the number of right hand sides of
*        norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
*
      RESID = ZERO
      DO 10 J = 1, NRHS
         BNORM = DASUM( N, B( 1, J ), 1 )
         XNORM = DASUM( N, X( 1, J ), 1 )
         IF( XNORM.LE.ZERO ) THEN
            RESID = ONE / EPS
         ELSE
            RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
         END IF
   10 CONTINUE
*
      RETURN
*
*     End of DPTT02
*
      END


  submodule (m_array1D) m_Array_d1D
    !! Routines for double precision arrays

  implicit none

  contains
  !====================================================================!
  module procedure arange_d1D
    !! Interfaced with [[arange]]
  !====================================================================!
  !module function arange_d1D(start,stp,_step) result(this)
  !real(r64) :: start !! Start from here
  !real(r64) :: stp !! Stop here
  !real(r64) :: step !! Step size
  !real(r64), allocatable :: res(:)
  integer(i32) :: i
  integer(i32) :: N
  real(r64) :: step_
  step_=1.d0
  if (present(step)) step_ = step
  N=int((stp-start)/step_)+1
  if (size(res) /= N) call eMsg('arange_d1D:1D Array must be size '//str(N))
  if (step_ == 1.d0) then
      do i = 1, N
          res(i) = start + real(i-1, kind=r64)
      enddo
  else
      do i = 1, N
          res(i) = start + real(i-1, kind=r64)*step_
      enddo
  endif
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure diff_d1D
    !! Interfaced [[diff]]
  !====================================================================!
!  real(r64), intent(in) :: this(:) !! 1D array
!  real(r64) :: res(size(this)-1) !! Difference along array
  integer(i32) :: i
  integer(i32) :: N
  N=size(this)
  if (size(res) /= N-1) call eMsg('diff_d1D:Result must be size '//str(N-1))
  do i=1,N-1
    res(i) = this(i+1) - this(i)
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure isSorted_d1D
    !! Interfaced with [[isSorted]]
  !====================================================================!
  !module function isSorted_d1D(this) result(yes)
  !real(r64):: this(:) !! 1D array
  !logical :: yes !! isSorted
  integer :: i,N
  N=size(this)
  yes=.true.
  do i=2,N
    if (this(i) < this(i-1)) then
      yes=.false.
      return
    end if
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure isSorted_d1Di1D
    !! Interfaced with [[isSorted]]
  !====================================================================!
  !module function isSorted_d1D(this) result(yes)
  !real(r64):: this(:) !! 1D array
  !integer(i32) :: indx(:)
  !logical :: yes !! isSorted
  integer :: i,N
  N=size(this)
  yes=.true.
  do i=2,N
    if (this(indx(i)) < this(indx(i-1))) then
      yes=.false.
      return
    end if
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure repeat_d1D
    !! Interfaced with [[repeat]]
  !====================================================================!
!  real(r64) :: this(:) !! 1D array
!  integer(i32) :: nRepeats !! Number of times each element should be repeated
!  real(r64) :: res(size(this)*nRepeats)
  integer(i32) :: i,k,N,nTmp
  N = size(this)
  nTmp = N * nRepeats
  call allocate(res, nTmp)
  !if (size(res) /= nTmp) call eMsg('repeat_d1D:Result must be size '//str(nTmp))
  k = 1
  do i = 1, N
    res(k:k + nRepeats - 1) = this(i) ! Repeat the element
    k = k + nRepeats
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure shuffle_d1D
    !! Interfaced with [[shuffle]]
  !====================================================================!
  !module subroutine shuffle_d1D(this)
  !real(r64) :: this(:)
  integer(i32) :: i
  integer(i32) :: N
  integer(i32) :: r
  N=size(this)
  do i = 2, N
    call rngInteger(r, 1, i)
    call swap(this(i), this(r))
  end do
  end procedure
  !====================================================================!
!  !====================================================================!
!  function calcInternalAngle_Vector(this,that) result(theta)
!  !====================================================================!
!  real(r64) :: this(:),that(:)
!  real(r64) :: theta
!  theta=dacos(dot_product(this,that)/(magnitude_Vector(this)*magnitude_Vector(that)))
!  end function
!  !====================================================================!
!  !====================================================================!
!  function outerproduct(a,b) result(c)
!  !====================================================================!
!  real(r64) :: a(:),b(:)
!  integer :: nB
!  real(r64) :: c(size(a),size(b))
!  integer :: i
!  nB=size(b)
!  do i=1,nB
!    c(:,i)=a*b(i)
!  enddo
!  end function
!  !====================================================================!
!  !====================================================================!
!  function normalize_Vector(this) result(that)
!  !====================================================================!
!  real(r64) :: this(:)
!  real(r64) :: that(size(this))
!  real(r64) :: magnitude
!
!  that=this
!  magnitude=magnitude_Vector(this)
!  if (magnitude /= 0.d0) that=that/magnitude
!
!  end function
!  !====================================================================!
!  !====================================================================!
!  function ContraharmonicMean(this,order) result(that)
!  !====================================================================!
!  ! Input
!  real(r64) :: this(:)
!  real(r64) :: order
!  ! Output
!  real(r64) :: that
!  ! Specific
!  real(r64) :: tmp
!  !====================================================================!
!  ! Compute the Contraharmonic mean of a vector
!  ! Digital Image Processing|Gonzalez and Woods|2011|3rd Edition
!  !====================================================================!
!  tmp=sum(this)
!  that=tmp**(order+1.d0)
!  that=that/(tmp**order)
!  return
!  end function
!  !====================================================================!
!  !====================================================================!
!  function HarmonicMean(this) result(that)
!  !====================================================================!
!  real(r64) :: this(:)
!  real(r64) :: that
!  real(r64) :: N
!  !====================================================================!
!  ! Compute the Harmonic mean of a vector
!  ! Digital Image Processing|Gonzalez and Woods|2011|3rd Edition
!  !====================================================================!
!  N=dble(size(this))
!  that=N/(sum(1.d0/this))
!  return
!  end function
!  !====================================================================!

!  !====================================================================!
!  function isConstant_DV(this) result(yes)
!  !====================================================================!
!  ! Checks whether a vector contains the same value throughout
!  real(r64) :: this(:)
!  logical :: yes
!  real(r64) :: tmp
!  yes=.true.
!  tmp=this(1)
!  if (any(this/=tmp)) yes=.false.
!  end function
!  !====================================================================!
!  !====================================================================!
!  function isConstantIncrement_DV(this,val) result(yes)
!  !====================================================================!
!  ! Checks whether a vector contains the same value throughout
!  real(r64) :: this(:)
!  real(r64) :: val
!  logical :: yes
!  integer :: i,N
!  N=size(this)
!  yes=.true.
!  do i=2,N
!    if ((this(i)-this(i-1))/=val) then
!      yes=.false.
!      return
!    endif
!  enddo
!  end function
!  !====================================================================!
!  !====================================================================!
!  function isInside1D_I1(this,x0,sortme) result(yes)
!  !====================================================================!
!  integer :: this(:)
!  integer :: x0
!  integer :: n
!  logical :: sortme
!  logical :: yes
!  !====================================================================!
!  ! Determine if x0 is within this
!  !====================================================================!
!  n=size(this)
!  if (sortme) call sort(this)
!
!  yes=.true.
!  if (x0 < this(1)) yes=.false.
!  if (x0 > this(n)) yes=.false.
!
!  end function
!  !====================================================================!
!  !====================================================================!
!  function isFactor2Vector(this) result(yes)
!  !====================================================================!
!  real(r64) :: this(:)
!  logical :: yes
!  integer :: ii,N
!  real(r64) :: tmp1,tmp2
!  N=size(this)
!  yes=.true.
!  tmp1=dabs(this(2)-this(1))
!  do ii=3,N
!    tmp2=dabs(this(ii)-this(ii-1))
!    if (tmp2==tmp1) cycle
!    if (tmp2 /= 2.d0*tmp1 .and. tmp2/=0.5d0*tmp1) then
!      yes=.false.
!      return
!    endif
!    tmp1=tmp2
!  enddo
!  end function
!  !====================================================================!
!  !====================================================================!
!  function getBin1D_I1(this,x0,sortme) result(i)
!  !====================================================================!
!  integer :: this(:)
!  integer :: x0
!  integer :: x1,x2,x3
!  logical :: sortme
!  integer :: i
!  integer :: i1,i2,i3,n
!  !====================================================================!
!  ! Determine the bin in this containing x0 using bisection
!  ! Forces the return index to lie within the vector "this"
!  !====================================================================!
!  n=size(this)
!  if (sortme) call sort(this)
!
!  if (x0.le.this(2)  ) then
!    i=1
!    return
!  endif
!  if (x0.gt.this(n-1)) then
!    i=n-1
!    return
!  endif
!
!  i1=2;
!  x1=this(i1)  ! Left value
!  i3=n-2;
!  x3=this(i3)  ! Right value
!  i2=(i3+i1)/2;
!  x2=this(i2)  ! Central value
!
!  do while ( (i3-i1) /= 1)
!    if     (x0 <= x2) then;
!      i3=i2;
!      x3=x2
!    elseif (x0 >  x2) then;
!      i1=i2;
!      x1=x2;
!    endif
!    i2=(i3+i1)/2;
!    x2=this(i2)  ! Central value
!  enddo
!  i=i1
!  end function
!  !====================================================================!
!  !====================================================================!
!  function isInside1D_D1(this,x0,sortme) result(yes)
!  !====================================================================!
!  real(r64) :: this(:)
!  real(r64) :: x0
!  integer :: n
!  logical :: sortme
!  logical :: yes
!  !====================================================================!
!  ! Determine if x0 is within this
!  !====================================================================!
!  n=size(this)
!  if (sortme) call sort(this)
!
!  yes=.true.
!  if (x0 < this(1)) yes=.false.
!  if (x0 > this(n)) yes=.false.
!
!  end function
!  !====================================================================!
!  !====================================================================!
!  function getBin1D_D1(this,x0,sortme) result(i)
!  !====================================================================!
!  real(r64) :: this(:)
!  real(r64) :: x0
!  real(r64) :: x1,x2,x3
!  logical :: sortme
!  integer :: i
!  integer :: i1,i2,i3,n
!  !====================================================================!
!  ! Determine the bin in this containing x0 using bisection
!  ! Forces the return index to lie within the vector "this"
!  ! Do NOT use an unsorted vector!
!  !====================================================================!
!  n=size(this)
!  if (sortme) call sort(this)
!
!  if (x0 <= this(2)) then
!    i=1
!    return
!  endif
!  if (x0 > this(n-1)) then
!    i=n-1;
!    return;
!  endif
!
!  i1=2;
!  x1=this(i1)  ! Left value
!  i3=n-2;
!  x3=this(i3)  ! Right value
!  i2=(i3+i1)/2;
!  x2=this(i2)  ! Central value
!  ! Bisection Method to obtain the bin
!  do while ( (i3-i1) /= 1)
!    if     (x0 <= x2) then;
!      i3=i2;
!      x3=x2
!    elseif (x0 >  x2) then;
!      i1=i2;
!      x1=x2;
!    endif
!    i2=(i3+i1)/2;
!    x2=this(i2)  ! Central value
!  enddo
!  i=i1
!  end function
!  !====================================================================!
!  !====================================================================!
!  function getSmallestIncrement(this) result(inc)
!  !====================================================================!
!  real(r64) :: this(:)
!  real(r64) :: inc
!  integer :: ii,N
!  real(r64) :: tmp1
!  N=size(this)
!  tmp1=dabs(this(2)-this(1))
!  inc=tmp1
!  do ii=2,N
!    tmp1=dabs(this(ii+1)-this(ii))
!    if (tmp1 < inc) inc=tmp1
!  enddo
!  end function
!  !====================================================================!
!  !====================================================================!
!  subroutine unitize_1D(this)
!  !====================================================================!
!  real(r64) :: this(:)
!  ! Normalize the input vector
!  this=this-minval(this)
!  this=this/maxval(this)
!  end subroutine
!  !====================================================================!
!  !====================================================================!
!  subroutine scaleVector(this,xmin,xmax)
!  !====================================================================!
!  ! Scales a vector to [xmin xmax]
!  real(r64) :: this(:),xmin,xmax
!  ! Normalize the input vector
!  call unitize(this)
!  ! Map to new limits
!  this=(this*(xmax-xmin))+xmin
!  end subroutine
!  !====================================================================!
!  !====================================================================!
!  subroutine integerizeVector(this,x0,inc)
!  !====================================================================!
!  ! Takes a vector and maps it to integer increments for easy nearest neighbour
!  ! operations for grids, e.g. if x0=10, inc=5 then
!  ! (-50,-12.5,5,24.3) = (-11,-3.5,0,3.86) Only the 4th point is inside a grid.
!  real(r64) :: this(:),inc,x0
!  this=((this-x0)/inc)+1.d0
!  end subroutine
!  !====================================================================!
!  !====================================================================!
!  subroutine deintegerizeVector(this,x0,inc)
!  !====================================================================!
!  ! Takes an integerized vector and maps it to non-integerized format.
!  real(r64) :: this(:),inc,x0
!  this=((this-1.d0)*inc)+x0
!  end subroutine
!  !====================================================================!
!  !====================================================================!
!  subroutine removeItem(this,i)
!  !====================================================================!
!  real(r64) :: this(:)
!  integer :: i,j
!  integer :: N
!  N=size(this)
!  if (i < 1 .or. i > N) call Emsg('removeItem','index is outside the array')
!  do j=i,N-1
!    this(j)=this(j+1)
!  enddo
!  this(N)=tiny(0.d0)
!  end subroutine
!  !====================================================================!
!  !====================================================================!
!  subroutine insertItem(this,i,val)
!  !====================================================================!
!  real(r64) :: this(:)
!  integer :: i,j
!  real(r64) :: val
!  integer :: N
!  N=size(this)
!  if (i < 1 .or. i > N) call Emsg('insertItem','index is outside the array')
!  do j=N,i+1,-1
!    this(j)=this(j-1)
!  enddo
!  this(i)=val
!  end subroutine
!  !====================================================================!
!  !====================================================================!
!  subroutine writeToFile_D1D(this,fname)
!  !====================================================================!
!  real(r64) :: this(:)
!  character(len=*) :: fname
!  integer :: i,istat,iunit,N
!  N=size(this)
!  call openFile(fname,iunit,'unknown',istat)
!  do i=1,N
!    write(iunit,'(a)') str(this(i),7)
!  enddo
!  call closeFile(fname,iunit,'unknown',istat)
!  end subroutine
!  !====================================================================!
end submodule


!-------------------------------------------------------------------------
!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: setup_grid: setup regriding field
!
! !INTERFACE:
!
   subroutine setup_grid(im,jm,im2,jm2,dphi,dlam,lons,lats)

! !REVISION HISTORY:
!
!  01Feb2001 Cruz     Created
!
!EOP
!-------------------------------------------------------------------------

   implicit none
   integer :: i,j,im,jm,im2,jm2,loc
   real :: lats(im2*jm2), dphi(jm), dphi2, dlpin
   real :: lons(im2*jm2), dlam(im), dlam2, dlin, dpin
   real :: lon,lat
   real :: pi

   pi = 4.0*atan(1.0)
   dlin = 2*pi/im
   dpin = pi/(jm-1)
   dlam(:) = dlin
   dphi(:) = dpin

   dlam2   = 2.*pi/ im2
   dphi2   = pi/(jm2-1)

   loc=0
   do j=1,jm2
     do i=1,im2
       loc = loc + 1
       lon = -pi + (i-1)*dlam2
       lons(loc) = lon
     enddo
   enddo
   loc = 0
   do j=1,jm2
     lat = -pi/2.0 + (j-1)*dphi2
     do i=1,im2
       loc = loc + 1
       lats(loc) = lat
     enddo
   enddo

   end subroutine

!-------------------------------------------------------------------------
!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: comput_gaus: compute guassian latitudes and
!           create output lons and lats
!
! !INTERFACE:
!
   subroutine comput_gaus(im,jm,im2,jm2,dphi,dlam,lons,lats,flip)

! !REVISION HISTORY:
!
!  01Feb2001 Cruz     Created
!  30Jul2004 Todling  Added flip option
!
!EOP
!-------------------------------------------------------------------------

   implicit none
   integer :: i,j,im,jm,im2,jm2,loc
   real :: lats(im2*jm2), dphi(jm)
   real :: lons(im2*jm2), dlam(im)
   logical :: flip
   integer :: lon,lat,n,m
   real :: dl,dp,pi
   real :: glat(jm2) ! automatic

   pi = 4.0*atan(1.0)
   dl = 2.0*pi/im
   dp = pi/( jm-1 )
   dlam(:) = dl  ! Uniform grid input
   dphi(:) = dp  ! Uniform grid input

   call gauss_lat_nmc (glat,jm2)
   dl = 2.0*pi/im2
   if (flip) glat(:) = glat(jm2:1:-1)

   loc = 0
   do j=1,jm2
     do i=1,im2
       loc = loc + 1
       lons (loc) = -pi + (i-1)*dl
     enddo
   enddo

   loc = 0
   do j=1,jm2
     do i=1,im2
       loc = loc + 1
       lats (loc) = glat(j)*pi/180.0
     enddo
   enddo

   end subroutine


      SUBROUTINE slCADJ (IY, IM, ID, DJM, J)
*+
*     - - - - - -
*      C A D J
*     - - - - - -
*
*  Gregorian Calendar to Modified Julian Date
*
*  (Includes century default feature:  use slCLDJ for years
*   before 100AD.)
*
*  Given:
*     IY,IM,ID     int    year, month, day in Gregorian calendar
*
*  Returned:
*     DJM          dp     modified Julian Date (JD-2400000.5) for 0 hrs
*     J            int    status:
*                           0 = OK
*                           1 = bad year   (MJD not computed)
*                           2 = bad month  (MJD not computed)
*                           3 = bad day    (MJD computed)
*
*  Acceptable years are 00-49, interpreted as 2000-2049,
*                       50-99,     "       "  1950-1999,
*                       100 upwards, interpreted literally.
*
*  Called:  slCLDJ
*
*  P.T.Wallace   Starlink   November 1985
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  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
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      INTEGER IY,IM,ID
      DOUBLE PRECISION DJM
      INTEGER J

      INTEGER NY

*  Default century if appropriate
      IF (IY.GE.0.AND.IY.LE.49) THEN
         NY=IY+2000
      ELSE IF (IY.GE.50.AND.IY.LE.99) THEN
         NY=IY+1900
      ELSE
         NY=IY
      END IF

*  Modified Julian Date
      CALL slCLDJ(NY,IM,ID,DJM,J)

      END


subroutine xy_geog(x,y,z,fi,tet,h)

common/pi/pi,per
common/povorot/fi0,tet0,orient,sinal,cosal
rz=6371.

xx = x*cosal+y*sinal
yy =-x*sinal+y*cosal
zz = rz-z

X1 =  xx
Y1 = -yy*SIN(tet0*PER) + zz*COS(tet0*PER)
Z1 =  yy*COS(tet0*PER) + zz*SIN(tet0*PER)

if(x1.eq.0.) then
	fi=fi0
else
	IF(X1.GT.0..AND.Y1.GT.0.)PA=0.
	IF(X1.LT.0.)PA=-PI
	IF(X1.GT.0..AND.Y1.LT.0.)PA=2.*PI
	ff=atan(y1/x1)/per
	FI=fi0-(ff+PA/PER)+90.
end if

if(abs(fi+360-fi0).lt.abs(fi-fi0))fi=fi+360
if(abs(fi-360-fi0).lt.abs(fi-fi0))fi=fi-360

r=sqrt(x1*x1+y1*y1+z1*z1)
tet=ASIN(Z1/r)/PER
h=rz-r

return
end


module module_parameters

REAL(8),PARAMETER :: ALPHA=0.0 !Alpha decides how to stretch the grid i.e. alpha=0 means homogenous grid
INTEGER,PARAMETER :: N= 11 	!NUMBER OF NODE POINTS IN FVM
REAL(8),PARAMETER ::RHO=1.225			!kg/m^3
REAL(8),PARAMETER ::DYN_VIS=1.802*1E-5 		!kg/m.s Dynamic Viscosity of Air
REAL(8),PARAMETER ::KIN_VIS=1.4725*1E-5		!m^2/s Kinematic Viscosity of Air
REAL(8),PARAMETER:: CONV_CRIT=1E-10             !convergence criteria ( max permissible error)

!case wise data
REAL(8),PARAMETER ::VW=12.84, H=66E-3,  PGF=0.0d0		!CASE 1

end module module_parameters


!> Command-line tool to calculate the Fibonacci number of a given
!! integer.

!! Copyright 2014 The University of Edinburgh.
!!
!! Licensed under the Apache License, Version 2.0 (the "License");
!! you may not use this file except in compliance with the License.
!! You may obtain a copy of the License at
!!
!!   http://www.apache.org/licenses/LICENSE-2.0
!!
!! Unless required by applicable law or agreed to in writing, software
!! distributed under the License is distributed on an "AS IS" BASIS,
!! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
!! implied. See the License for the specific language governing
!! permissions and limitations under the License.

program fibonacci_program

  use fibonacci_module

  implicit none

  integer       :: num_arguments, n, fib
  character(60) :: argument

  num_arguments=command_argument_count()
  if (num_arguments == 0) then
    call print_usage()
    stop 1
  end if
  call get_command_argument(1, argument)
  read(argument,*) n
  if (n < 0) then
    call print_usage()
    stop 2
  end if
  fib = fibonacci(n)
  write(*,*) 'fibonacci(',n,') = ',fib

contains

  subroutine print_usage()
    write(*,*) 'Usage: ./fibonacci N'
    write(*,*) '  where N >= 0'
  end subroutine print_usage

end program fibonacci_program


! { dg-do compile }
! { dg-require-effective-target pthread }
! { dg-options "-Ofast -ftree-parallelize-loops=4" }

SUBROUTINE wsm32D(t, &
   w, &
   den, &
   p, &
   delz, &
                     its,&
   ite, &
   kts, &
   kte  &
                      )
  REAL, DIMENSION( its:ite , kts:kte ),                           &
        INTENT(INOUT) ::                                          &
                                                               t
  REAL, DIMENSION( ims:ime , kms:kme ),                           &
        INTENT(IN   ) ::                                       w, &
                                                             den, &
                                                               p, &
                                                            delz
  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
        qs, &
        xl, &
        work1, &
        work2, &
        qs0, &
        n0sfac
      diffus(x,y) = 8.794e-5*x**1.81/y
      diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b))
      venfac(a,b,c) = (viscos(b,c)/diffus(b,a))**(.3333333)       &
             /viscos(b,c)**(.5)*(den0/c)**0.25
      do loop = 1,loops
      xa=-dldt/rv
      do k = kts, kte
        do i = its, ite
          tr=ttp/t(i,k)
          if(t(i,k).lt.ttp) then
            qs(i,k) =psat*(tr**xa)*exp(xb*(1.-tr))
          endif
          qs0(i,k)  =psat*(tr**xa)*exp(xb*(1.-tr))
        enddo
        do i = its, ite
          if(t(i,k).ge.t0c) then
            work1(i,k) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qs(i,k))
          endif
          work2(i,k) = venfac(p(i,k),t(i,k),den(i,k))
        enddo
      enddo
      enddo                  ! big loops
END SUBROUTINE wsm32D


! Copyright (c) 2019 Etienne Descamps
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation and/or
!    other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!    used to endorse or promote products derived from this software without specific prior
!    written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
! INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Program test_beta
  Use ieee_arithmetic
  Use iso_c_binding
  Use mlf_utils
  Use mlf_gamma_dist
  Use mlf_beta_dist
  Use mlf_histogram
  Use mlf_hdf5
  Use mlf_intf
  integer :: info
  type(mlf_hdf5_file) :: h5f
  real(8) :: x
  info = mlf_init()
  CALL BetaTestMaxLL(1d0, 0.5d0, 0.4d0)
  CALL BetaTestMaxLL(1d0, 0.4999d0, 0.4999d0)
  CALL BetaTestMaxLL(1d0, 0.2d0, 0.1d0)
  CALL BetaTestMaxLL(2d0, 0.3d0, 0.2d0)
  CALL test_betaPriorConst(1d0, 0.5d0, 0.4d0)
  CALL test_betaPriorConst(1d0, 0.2d0, 0.1d0)
  CALL test_betaPriorConst(2d0, 0.3d0, 0.2d0)
  x = QuantileBeta(0.5d0, 0.7d0, 0.98d0)
  info = h5f%createFile("test_beta.h5")
  CALL test_incompleteIntervalBeta(h5f, 'a2b2', 2d0, 2d0)
  CALL test_incompleteIntervalBeta(h5f, "a0.2b1.2", 0.2d0, 1.2d0)
  CALL test_incompleteIntervalBeta(h5f, "a0.5b0.7", 0.5d0, 0.7d0)
  !CALL test_incompleteBeta(h5f, 'a2b2', 2d0, 2d0)
  !CALL test_incompleteBeta(h5f, "a0.2b1.2", 0.2d0, 1.2d0)
  !CALL test_incompleteBeta(h5f, "a0.5b0.7", 0.5d0, 0.7d0)
  !CALL test_random(h5f, "a2b2", 2d0, 2d0, 1024, 1024)
  !CALL test_random(h5f, "a0.2b1.2", 0.2d0, 1.2d0, 1024, 1024)
  !CALL test_random(h5f, "a0.5b0.7", 0.5d0, 0.7d0, 1024, 1024)
  CALL h5f%finalize()
  !CALL test_likelihood(10000000, 2d0, 2d0)
  !CALL test_likelihood(10000000, 5d0, 1.5d0)
  !CALL test_likelihood(10000000, 2d0, 0.5d0)
  !CALL test_likelihood(10000000, 0.3d0, 0.6d0)
  !CALL test_likelihood(10000000, 60d0, 50d0)
  info = mlf_quit()
Contains
  Subroutine BetaTestMaxLL(lambda, x0, y0)
    real(c_double), intent(in) :: lambda, x0, y0
    real(c_double) :: alpha, beta
    CALL BetaPriorMaxLL(lambda, x0, y0, alpha, beta)
    PRINT *, "MaxLL: lambda,x0,y0 = ", lambda, x0, y0, "alpha,beta = ", alpha, beta
  End Subroutine BetaTestMaxLL
  Subroutine BetaPriorTest(lambda, x0, y0, N)
    real(c_double), intent(in) :: lambda, x0, y0
    integer, intent(in) :: N
    real :: x
    x = BetaPriorConst(lambda, x0, y0, N)
    PRINT *, "1: N = ", N, " ", x
  End Subroutine BetaPriorTest
  Subroutine test_betaPriorConst(lambda, x0, y0)
    real(c_double), intent(in) :: lambda, x0, y0
    PRINT *, "******Test betaPriorConst******"
    PRINT *, "lamdba: ", lambda, " x0: ", x0, " y0: ", y0
    CALL BetaPriorTest(lambda, x0, y0, 10)
    CALL BetaPriorTest(lambda, x0, y0, 50)
    CALL BetaPriorTest(lambda, x0, y0, 100)
    CALL BetaPriorTest(lambda, x0, y0, 500)
    CALL BetaPriorTest(lambda, x0, y0, 1000)
    CALL BetaPriorTest(lambda, x0, y0, 5000)
    CALL BetaPriorTest(lambda, x0, y0, 10000)
    CALL BetaPriorTest(lambda, x0, y0, 50000)
    PRINT *, "****End Test betaPriorConst****"
  End Subroutine test_betaPriorConst

  Subroutine test_incompleteBeta(h5f, rname, alpha, beta)
    class(mlf_hdf5_file), intent(inout) :: h5f
    character(len=*), intent(in) :: rname
    real(c_double), intent(in) :: alpha, beta
    real(c_double), allocatable :: points(:,:)
    integer, parameter :: N = 1000
    integer :: i
    ALLOCATE(points(3, N))
    FORALL(i=1:N) points(1, i) = REAL(i-1,8)/REAL(N-1,8)
    points(2, :) = IncompleteBeta(alpha, beta, points(1, :))
    Do i = 1,N
      points(3, i) = QuantileBeta(alpha, beta, points(2, i))
    End Do
    info = h5f%pushData(points, rname)
  End Subroutine test_incompleteBeta

  Subroutine test_incompleteIntervalBeta(h5f, rname, alpha, beta)
    class(mlf_hdf5_file), intent(inout) :: h5f
    character(len=*), intent(in) :: rname
    real(c_double), intent(in) :: alpha, beta
    real(c_double), allocatable :: points(:,:)
    integer, parameter :: N = 1000
    integer :: i
    ALLOCATE(points(2, N))
    CALL QuantileTableBeta(alpha, beta, points(1,:))
    points(2, :) = IncompleteBeta(alpha, beta, points(1, :))
    info = h5f%pushData(points, rname)
  End Subroutine test_incompleteIntervalBeta

  Subroutine test_likelihood(N, alpha, beta)
    real(c_double), intent(in) :: alpha, beta
    integer, intent(in) :: N
    real(c_double), allocatable :: X(:), W(:)
    real(c_double) :: a0, b0
    integer :: i, info
    ALLOCATE(X(N), W(N))
    Do i = 1, N
      Do
        X(i) = RandomBeta(alpha,beta)
        If(X(i) /= 0d0 .AND. X(i) /= 1d0) EXIT
      End Do
    End Do
    CALL RANDOM_NUMBER(W)
    W = 1-W
    info = MaxLikelihoodBeta(X, a0, b0, W)
    PRINT *, alpha, a0, beta, b0
  End Subroutine test_likelihood

  Subroutine test_random(h5f, rname, a, b, k, N)
    class(mlf_hdf5_file), intent(inout) :: h5f
    character(len=*), intent(in) :: rname
    real(c_double), intent(in) :: a, b
    integer, intent(in) :: k, N
    real(c_double), allocatable :: X(:), points(:,:), betaV(:,:)
    integer, allocatable :: idx(:)
    type(mlf_histogram_int) :: hist
    integer :: info, i, j
    integer, parameter :: sizeX = 16384
    info = hist%init(0d0, 1d0, k)
    ALLOCATE(X(sizeX), idx(sizeX), points(2,k+1), betaV(2, 64*k))
    Do j = 1, N
      Do i = 1, sizeX
        X(i) = RandomBeta(a, b)
      End Do
      CALL QSortIdx(X, idx)
      X = X(idx)
      CALL hist%addVectSorted(X)
    End Do
    info = hist%get(points(2,:), points(1,:))
    points(2,:) = REAL(k-1, 8)*points(2,:)
    info = h5f%pushData(points, rname)
    FORALL(i=1:64*k) betaV(1,i) = REAL(i-1,8)/REAL(64*k-1,8)
    betaV(2,:) = BetaDensity(a, b, betaV(1,:))
    info = h5f%pushData(betaV, rname//"_real")
  End Subroutine test_random
End


PROGRAM RiemannProblem1D_CylindricalSymmetry

  USE KindModule, ONLY: &
    DP, Pi
  USE ProgramInitializationModule, ONLY: &
    InitializeProgram, &
    FinalizeProgram
  USE RiemannProblemInitializationModule, ONLY: &
    InitializeRiemannProblem1D
  USE TimeSteppingModule, ONLY: &
    EvolveFields, &
    SSP_RK

  IMPLICIT NONE

  CALL InitializeProgram &
         ( ProgramName_Option &
            = 'RiemannProblem1D_CylindricalSymmetry', &
           nX_Option &
             = [ 2048, 1, 1 ], &
           swX_Option &
             = [ 1, 0, 0 ], &
           bcX_Option &
             = [ 2, 0, 0 ], &
           xL_Option &
             = [ 0.0_DP, 0.0_DP, 0.0_DP ], &
           xR_Option &
             = [ 1.0_DP, 2 * Pi, 1.0_DP ], &
           nNodes_Option &
             = 1, &
           CoordinateSystem_Option &
             = 'CYLINDRICAL', &
           EquationOfState_Option &
             = 'IDEAL', &
           Gamma_IDEAL_Option &
             = 1.4_DP, &
           FluidSolver_Option &
             = 'Euler_DG', &
           FluidRiemannSolver_Option &
             = 'HLLC', &
           EvolveFluid_Option &
             = .TRUE., &
           nStages_SSP_RK_Option &
             = 1 )

  CALL InitializeRiemannProblem1D &
         ( D_L = 0.00_DP, V_L = [ 0.0_DP, 0.0_DP, 0.0_DP ], P_L = 0.00_DP, &
           D_R = 1.00_DP, V_R = [ -1.0_DP, 0.0_DP, 0.0_DP ], P_R = 1.0D-6, X_D_Option = 0.0_DP )

  CALL EvolveFields &
         ( t_begin = 0.0_DP, t_end = 1.0_DP, dt_write = 0.01_DP, &
           UpdateFields = SSP_RK )

  CALL FinalizeProgram

END PROGRAM RiemannProblem1D_CylindricalSymmetry