*DECK DHESL
      SUBROUTINE DHESL (A, LDA, N, IPVT, B)
      INTEGER LDA, N, IPVT(*)
      DOUBLE PRECISION A(LDA,*), B(*)
C-----------------------------------------------------------------------
C This is essentially the LINPACK routine DGESL except for changes
C due to the fact that A is an upper Hessenberg matrix.
C-----------------------------------------------------------------------
C     DHESL solves the real system A * x = b
C     using the factors computed by DHEFA.
C
C     On entry
C
C        A       DOUBLE PRECISION(LDA, N)
C                the output from DHEFA.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        IPVT    INTEGER(N)
C                the pivot vector from DHEFA.
C
C        B       DOUBLE PRECISION(N)
C                the right hand side vector.
C
C     On return
C
C        B       the solution vector  x .
C
C     Modification of LINPACK, by Peter Brown, LLNL.
C     Written 7/20/83.  This version dated 6/20/01.
C
C     BLAS called: DAXPY
C-----------------------------------------------------------------------
      INTEGER K, KB, L, NM1
      DOUBLE PRECISION T
C
      NM1 = N - 1
C
C        Solve  A * x = b
C        First solve  L*y = b
C
         IF (NM1 .LT. 1) GO TO 30
         DO 20 K = 1, NM1
            L = IPVT(K)
            T = B(L)
            IF (L .EQ. K) GO TO 10
               B(L) = B(K)
               B(K) = T
   10       CONTINUE
            B(K+1) = B(K+1) + T*A(K+1,K)
   20    CONTINUE
   30    CONTINUE
C
C        Now solve  U*x = y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/A(K,K)
            T = -B(K)
            CALL DAXPY (K-1, T, A(1,K), 1, B(1), 1)
   40    CONTINUE
      RETURN
C----------------------- End of Subroutine DHESL -----------------------
      END


      subroutine rsg(nm,n,a,b,w,matz,z,fv1,fv2,ierr)
c
      integer n,nm,ierr,matz
      double precision a(nm,n),b(nm,n),w(n),z(nm,n),fv1(n),fv2(n)
c
c     this subroutine calls the recommended sequence of
c     subroutines from the eigensystem subroutine package (eispack)
c     to find the eigenvalues and eigenvectors (if desired)
c     for the real symmetric generalized eigenproblem  ax = (lambda)bx.
c
c     on input
c
c        nm  must be set to the row dimension of the two-dimensional
c        array parameters as declared in the calling program
c        dimension statement.
c
c        n  is the order of the matrices  a  and  b.
c
c        a  contains a real symmetric matrix.
c
c        b  contains a positive definite real symmetric matrix.
c
c        matz  is an integer variable set equal to zero if
c        only eigenvalues are desired.  otherwise it is set to
c        any non-zero integer for both eigenvalues and eigenvectors.
c
c     on output
c
c        w  contains the eigenvalues in ascending order.
c
c        z  contains the eigenvectors if matz is not zero.
c
c        ierr  is an integer output variable set equal to an error
c           completion code described in the documentation for tqlrat
c           and tql2.  the normal completion code is zero.
c
c        fv1  and  fv2  are temporary storage arrays.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      if (n .le. nm) go to 10
      ierr = 10 * n
      go to 50
c
   10 call  reduc(nm,n,a,b,fv2,ierr)
      if (ierr .ne. 0) go to 50
      if (matz .ne. 0) go to 20
c     .......... find eigenvalues only ..........
      call  tred1(nm,n,a,w,fv1,fv2)
      call  tqlrat(n,w,fv2,ierr)
      go to 50
c     .......... find both eigenvalues and eigenvectors ..........
   20 call  tred2(nm,n,a,w,fv1,z)
      call  tql2(nm,n,w,fv1,z,ierr)
      if (ierr .ne. 0) go to 50
      call  rebak(nm,n,b,fv2,n,z)
   50 return
      end


      program rilut
c-----------------------------------------------------------------------
c     test program for ilut preconditioned gmres.
c     this program generates a sparse matrix using
c     matgen and then solves a linear system with an
c     artificial rhs.
c-----------------------------------------------------------------------
      implicit none
c
      integer nmax, nzmax
      parameter (nmax=5000,nzmax=100000)
      integer ia(nmax),ja(nzmax),jau(nzmax),ju(nzmax),iw(nmax*3),
     &     iperm(nmax*2),ipar(16), levs(nzmax)
      real*8  a(nzmax),x(nmax),y(nmax),au(nzmax),vv(nmax,20),
     *     xran(nmax),rhs(nmax),al(nmax),fpar(16)
c     real t(2), t1, etime
c
      integer nx,ny,nz,n,j,k,ierr,meth,lfil,nwk,im,maxits,iout
      real*8 tol,permtol,eps,alph,gammax,gammay,alpha
      external gmres
c
      common /func/ gammax, gammay, alpha
c-----------------------------------------------------------------------
c     pde to be discretized is :
c---------------------------
c
c     -Lap u + gammax exp (xy)delx u + gammay exp (-xy) dely u +alpha u
c
c     where Lap = 2-D laplacean, delx = part. der. wrt x,
c     dely = part. der. wrt y.
c     gammax, gammay, and alpha are passed via the commun func.
c
c-----------------------------------------------------------------------
c
c     data for PDE:
c
      nx = 30
      ny = 30
      nz = 1
      alpha = -50.0
      gammax = 10.0
      gammay = 10.0
c
c     data for preconditioner
c
      nwk = nzmax
c
c     data for GMRES
c
      im   = 10
      eps  = 1.0D-07
      maxits = 100
      iout = 6
      permtol = 1.0
      ipar(2) = 2
      ipar(3) = 2
      ipar(4) = 20*nmax
      ipar(5) = im
      ipar(6) = maxits
      fpar(1) = eps
      fpar(2) = 2.22D-16
c
c     same initial guess for gmres
c
c--------------------------------------------------------------
c     call gen57 to generate matrix in compressed sparse row format
c--------------------------------------------------------------
c
c     define part of the boundary condition here
c
      al(1) = 0.0
      al(2) = 1.0
      al(3) = 0.0
      al(4) = 0.0
      al(5) = 0.0
      al(6) = 0.0
      call gen57pt(nx,ny,nz,al,0,n,a,ja,ia,ju,rhs)
c
c     zero initial guess to the iterative solvers
c
      do j=1, n
         xran(j) = 0.d0
      enddo
      print *, 'RILUT:  generated a finite difference matrix'
      print *, '        grid size = ', nx, ' X ', ny, ' X ', nz
      print *, '        matrix size = ', n
c--------------------------------------------------------------
c     gnerate right han side = A * (1,1,1,...,1)**T
c--------------------------------------------------------------
      do  k=1,n
         x(k) = 1.0
      enddo
      call amux(n, x, y, a, ja, ia)
c--------------------------------------------------------------
c     test all different methods available:
c     ILU0, MILU0, ILUT and with different values of tol and lfil
c     ( from cheaper to more expensive preconditioners)
c     The more accurate the preconditioner the fewer iterations
c     are required in pgmres, in general.
c
c--------------------------------------------------------------
      do 200 meth = 1, 15
         goto (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15) meth
 1       continue
         write (iout,*) ' +++++ ILU(0) Preconditioner ++++ '
c        t1 = etime(t)
         call ilu0 (n, a, ja, ia, au, jau, ju, iw, ierr)
c        t1 = etime(t) - t1
         goto 100
 2       continue
         write (iout,*) ' +++++ MILU(0) Preconditioner ++++ '
c        t1 = etime(t)
         call milu0 (n, a, ja, ia, au, jau, ju, iw, ierr)
c        t1 = etime(t) - t1
         goto 100
 3       continue
         write (iout,*) ' +++++ ILUT Preconditioner ++++ '
         write (iout,*) ' +++++ tol = 0.0001, lfil=5 ++++ '
         tol  = 0.0001
         lfil = 5
c
c        t1 = etime(t)
         call ilut (n,a,ja,ia,lfil,tol,au,jau,ju,nwk,vv,iw,ierr)
c         t1 = etime(t) - t1
         goto 100
 4       continue
         write (iout,*) ' +++++ ILUT Preconditioner ++++ '
         write (iout,*) ' +++++ tol = 0.0001, lfil=10 ++++ '
         tol = 0.0001
         lfil = 10
c
c        t1 = etime(t)
         call ilut (n,a,ja,ia,lfil,tol,au,jau,ju,nwk,vv,iw,ierr)

c        t1 = etime(t) - t1
         goto 100
 5       continue
         write (iout,*) ' +++++ ILUT Preconditioner ++++ '
         write (iout,*) ' +++++ tol = .0001, lfil=15 ++++ '
         tol = 0.0001
         lfil = 15
c
c        t1 = etime(t)
         call ilut (n,a,ja,ia,lfil,tol,au,jau,ju,nwk,vv,iw,ierr)
c        t1 = etime(t) - t1
         goto 100
 6       continue
         write (iout,*) ' +++++ ILUTP Preconditioner ++++ '
         write (iout,*) ' +++++ tol = 0.0001, lfil=5 ++++ '
         tol  = 0.0001
         lfil = 5
c
c        t1 = etime(t)
         call ilutp(n,a,ja,ia,lfil,tol,permtol,n,au,jau,ju,nwk,
     *        vv,iw,iperm,ierr)
c        t1 = etime(t) - t1
         goto 100
 7       continue
         write (iout,*) ' +++++ ILUTP Preconditioner ++++ '
         write (iout,*) ' +++++ tol = 0.0001, lfil=10 ++++ '
         tol = 0.0001
         lfil = 10
c
c        t1 = etime(t)
         call ilutp(n,a,ja,ia,lfil,tol,permtol,n,au,jau,ju,nwk,
     *        vv,iw,iperm,ierr)
c        t1 = etime(t) - t1
         goto 100
c-----------------------------------------------------------------------------
 8       continue
         write (iout,*) ' +++++ ILUTP Preconditioner ++++ '
         write (iout,*) ' +++++ tol = .0001, lfil=15 ++++ '
         tol = 0.0001
         lfil = 15
c
c        t1 = etime(t)
         call ilutp(n,a,ja,ia,lfil,tol,permtol,n,au,jau,ju,nwk,
     *        vv,iw,iperm,ierr)
c        t1 = etime(t) - t1
         goto 100
 9      continue
         write (iout,*) ' +++++ ILUK Preconditioner ++++ '
         write (iout,*) ' +++++       lfil=0        ++++ '
         lfil = 0
c        t1 = etime(t)
         call iluk(n,a,ja,ia,lfil,au,jau,ju,levs,nwk,vv,iw,ierr)
         print *, ' nnz for a =', ia(n+1) - ia(1)
         print *, ' nnz for ilu =', jau(n+1) -jau(1) + n
c        t1 = etime(t) - t1
         goto 100
c
 10      continue
         write (iout,*) ' +++++ ILUK Preconditioner ++++ '
         write (iout,*) ' +++++       lfil=1        ++++ '
         lfil = 1
c        t1 = etime(t)
         call iluk(n,a,ja,ia,lfil,au,jau,ju,levs,nwk,vv,iw,ierr)
         print *, ' nnz for a =', ia(n+1) - ia(1)
         print *, ' nnz for ilu =', jau(n+1) -jau(1) + n
c        t1 = etime(t) - t1
         goto 100
c
 11      continue
         write (iout,*) ' +++++ ILUK Preconditioner ++++ '
         write (iout,*) ' +++++       lfil=3        ++++ '
         lfil = 3
c        t1 = etime(t)
         call iluk(n,a,ja,ia,lfil,au,jau,ju,levs,nwk,vv,iw,ierr)
         print *, ' nnz for a =', ia(n+1) - ia(1)
         print *, ' nnz for ilu =', jau(n+1) -jau(1) + n
c        t1 = etime(t) - t1
         goto 100
c
 12      continue
         write (iout,*) ' +++++ ILUK Preconditioner ++++ '
         write (iout,*) ' +++++       lfil=6        ++++ '
         lfil = 6
c        t1 = etime(t)
         call iluk(n,a,ja,ia,lfil,au,jau,ju,levs,nwk,vv,iw,ierr)
         print *, ' nnz for a =', ia(n+1) - ia(1)
         print *, ' nnz for ilu =', jau(n+1) -jau(1) + n
c        t1 = etime(t) - t1
         goto 100
c
 13      continue
c-----------------------------------------------------------------------
        write (iout,*) ' +++++ ILUD Preconditioner ++++ '
        write (iout,*) ' +++++ tol=0.075, alpha=0.0 ++++ '
        tol = 0.075
        alph= 0.0
c        t1 = etime(t)
        call ilud(n,a,ja,ia,alph,tol,au,jau,ju,nwk,vv,iw,ierr)
c
        print *, ' nnz for a =', ia(n+1) - ia(1)
        print *, ' nnz for ilu =', jau(n+1) -jau(1) + n
c        t1 = etime(t) - t1
        goto 100
c
 14      continue
        write (iout,*) ' +++++ ILUD Preconditioner ++++ '
        write (iout,*) ' +++++ tol=0.075, alpha=1.0 ++++ '
        tol = 0.075
        alph=1.0
c        t1 = etime(t)
        call ilud(n,a,ja,ia,alph,tol,au,jau,ju,nwk,vv,iw,ierr)
        print *, ' nnz for a =', ia(n+1) - ia(1)
        print *, ' nnz for ilu =', jau(n+1) -jau(1) + n
c        t1 = etime(t) - t1
        goto 100

 15      continue
        write (iout,*) ' +++++ ILUD Preconditioner ++++ '
        write (iout,*) ' +++++ tol=0.01, alpha=1.0 ++++ '
        tol = 0.01
c        t1 = etime(t)
        call ilud(n,a,ja,ia,alph,tol,au,jau,ju,nwk,vv,iw,ierr)
        print *, ' nnz for a =', ia(n+1) - ia(1)
        print *, ' nnz for ilu =', jau(n+1) -jau(1) + n
c        t1 = etime(t) - t1
c        goto 100
c
 100     continue
c
c     check that return was succesful
c
c        print *, ' ILU factorization time ', t1
         print *, ' Precon set-up returned with ierr ', ierr
         if (ierr .ne. 0) goto 200
c--------------------------------------------------------------
c     call GMRES
c--------------------------------------------------------------
         call runrc(n,y,x,ipar,fpar,vv,xran,a,ja,ia,au,jau,ju,
     +        gmres)
         print *, 'GMRES return status = ', ipar(1)
         write (iout,*) '     '
 200  continue
c
c----------------------------------------------------------
c
      write (iout,*) ' **** SOLUTION ****  '
      write(iout, 111) (x(k),k=1,n)
 111  format (5d15.5)
      stop
      end


      subroutine eigen(a,r,n,mv)
c
c Computes the eigenvalues and eigenvectors of a real symmetric matrix.
c
c Usage:
c       call eigen(a,r,n,mv)
c
c Description of parameters:
c       "a" - original matrix (symmetric), destroyed in computation.
c             Resultant eigenvalues are developed in diagonal of
c             matrix in descending order.
c       "r" - resultant matrix of eigenvectors (stored columnwise, in
c	      same order as eigenvalues)
c       "n" - order of matrices "a" and "r"
c      "mv" - input code
c             .ne.1  compute egenvalues and eigenvectors
c             .eq.1  compute eigenvalues only ("r" need not be dimensioned
c             but must still appear in calling sequence)
c
c Remarks:
c       Original matrix "a" must be real symmetric (storage mode =1)
c       stored either as the upper triangular part by columns or the
c       lower triangular part by rows (including main diagonal)
c       Matrix "a" cannot be in same location as matrix "r"
c
c Method:
c       Diagonalization method originated by Jacobi and adapted by
c       von Neumann as found in "Mathematical
c       Methods for Digital Computers" edited by Ralston and Wilf,
c       John Wiley and sons, New York, 1962, chapter 7.
c       This program copied from "Cluster Analysis for Applications",
c       by Anderberg, p 242.
c
c ...................................................................
c
      dimension a(1),r(1)
c
c ...................................................................
c
c     If a double precision version of this routine is desired, the
c     c in column 1 should be removed from the double precision
c     statement which follows.
c    double precision a,r,anorm,anrmx,thr,x,y,sinx,sinx2,cosx,cosx2,
c   *                 sincs,range
c
c     The double precision version of this subroutine must also contain
c     double precision fortran functions. sqrt in statements 40,68,75
c     and 78 must be changed to dsqrt. abs in statement 62 must be
c     changed to dabs. The constant in statement 5 should be changed to
c     1.0d-12.
c
c ...................................................................
c
c generate identity matrix
c

	character*130 rcsid
	data rcsid/'$Header$'/

 5    range     = 1.0e-12
      if (mv-1) 10,25,10
 10   iq        = -n
      do 20 j   = 1,n
      iq        = iq + n
      do 20 i   = 1,n
      ij        = iq + i
      r(ij)     = 0.
      if (i-j) 20,15,20
 15   r(ij)     = 1.
 20   continue
c
c compute initial and final norms (anorm and anormx)
c
 25   anorm     = 0.
      do 35 i   = 1,n
      do 35 j   = i,n
      if (i-j) 30,35,30
 30   ia        = i + (j*j-j)/2
      anorm     = anorm + a(ia)*a(ia)
 35   continue
      if (anorm) 165,165,40
 40   anorm     = 1.414e0*sqrt(anorm)
      anrmx     = anorm*range/float(n)
c
c initialize indicators and compute threshold thr
c
      ind       = 0
      thr       = anorm
 45   thr       = thr/float(n)
 50   l         = 1
 55   m         = l + 1
c
c compute sin and cos
c
 60   mq        = (m*m-m)/2
      lq        = (l*l-l)/2
      lm        = l + mq
 62   if (abs(a(lm))-thr) 130,65,65
 65   ind       = 1
      ll        = l + lq
      mm        = m + mq
      x         = .5*(a(ll) - a(mm))
 68   y         = -a(lm)/sqrt(a(lm)*a(lm)+x*x)
      if (x) 70,75,75
 70   y         = -y
 75   sinx      = y/sqrt(2.*(1.+(sqrt(1.-y*y))))
      sinx2     = sinx*sinx
 78   cosx      = sqrt(1.-sinx2)
      cosx2     = cosx*cosx
      sincs     = sinx*cosx
c
c rotate l and m columns
c
      ilq       = n*(l-1)
      imq       = n*(m-1)
      do 125 i  = 1,n
      iq        = (i*i-i)/2
      if (i-l) 80,115,80
 80   if (i-m) 85,115,90
 85   im        = i + mq
      go to 95
 90   im        = m + iq
 95   if (i-l) 100,105,105
 100  il        = i + lq
      go to 110
 105  il        = l + iq
 110  x         = a(il)*cosx - a(im)*sinx
      a(im)     = a(il)*sinx + a(im)*cosx
      a(il)     = x
 115  if (mv-1) 120,125,120
 120  ilr       = ilq + i
      imr       = imq + i
      x = r(ilr)*cosx - r(imr)*sinx
      r(imr)    = r(ilr)*sinx + r(imr)*cosx
      r(ilr)    = x
 125  continue
      x         = 2.*a(lm)*sincs
      y         = a(ll)*cosx2 + a(mm)*sinx2 - x
      x         = a(ll)*sinx2 + a(mm)*cosx2 + x
      a(lm)     = (a(ll)-a(mm))*sincs + a(lm)*(cosx2-sinx2)
      a(ll)     = y
      a(mm)     = x
c
c tests for completion
c
c test for m = last column
c
 130  if (m-n) 135,140,135
 135  m         = m + 1
      go to 60
c
c test for l = second from last column
c
 140  if (l-(n-1))  145,150,145
 145  l         = l + 1
      go to 55
 150  if (ind-1)  160,155,160
 155  ind       = 0
      go to 50
c
c compare threshold with final norm
c
 160  if (thr-anrmx)  165,165,45
c
c sort eigenvalues and eigenvectors
c
 165  iq        = -n
      do 185 i  = 1,n
      iq        = iq + n
      ll        = i + (i*i-i)/2
      jq        = n*(i-2)
      do 185 j  = i,n
      jq        = jq + n
      mm        = j + (j*j-j)/2
      if (a(ll)-a(mm))  170,185,185
 170  x         = a(ll)
      a(ll)     = a(mm)
      a(mm)     = x
      if (mv-1) 175,185,175
 175  do 180 k  = 1,n
      ilr       = iq + k
      imr       = jq + k
      x         = r(ilr)
      r(ilr)    = r(imr)
 180  r(imr)    = x
 185  continue
c
      return
      end

c $Id$


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

      double precision eps
      double complex eye,zk
      integer i,j,k
      double precision hkrand

      data eye/(0.0d0,1.0d0)/

c
cc      initialize printing routine
c
      call prini(6,13)
      write(*,*)
      write(*,*)
      write(*,*) "================================="
      call prin2("This code is an example fortran driver*",i,0)
      call prin2("On output, the code prints sample pot,grad*",i,0)
      write(*,*)
      write(*,*)

      zk = 2.2d0
      zk = 3.1418

      ns = 30000

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

      eps = 0.5d-9

      write(*,*) "=========================================="

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

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

        charge(i) = hkrand(0) + eye*hkrand(0)

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

      call hfmm3d_s_c_g(eps,zk,ns,source,charge,
     1      pot,grad)
      call prin2("pot at sources=*",pot,12)
      call prin2("grad at sources=*",grad,12)

      stop
      end
c----------------------------------------------------------
c
cc
c
c


      SUBROUTINE EROX (ROTANG, XFRMT)

      REAL XFRMT (4,4), SN, CS, ROTANG

      CALL IDMAT (4, XFRMT)
      SN = SIN(ROTANG)
      CS = COS(ROTANG)
      XFRMT (2,2) =  CS
      XFRMT (3,3) =  CS
      XFRMT (2,3) = -SN
      XFRMT (3,2) =  SN

      END


!
!     ------------------------------------------------------------------
!              Q U A D S
!     ------------------------------------------------------------------
!
!
!                                       kk
!       Evaluates the integral of  (1/r)   YK(r) P (r) P (r)  with
!                                                 i     j
!   respect to r.
!
!
      DOUBLE PRECISION FUNCTION QUADS (I, J, KK)
      use param_C
      use radial_C
      use nel_C
!
!
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
!...Translated by Pacific-Sierra Research 77to90  4.3E  00:41:52  11/16/01
!...Switches:
!      PARAMETER(NOD=220)
!      COMMON/PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID
!     :   ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS
!      COMMON/RADIAL/R(NOD),RR(NOD),R2(NOD),YK(NOD),YR(NOD),X(NOD)
!      POINTER(IQP,P(NOD,1)),(IQN,N(1)),(IQL,L(1)),(IQAZ,AZ(1)),
!     :       (IQMAX,MAX_(1))
!      COMMON/NEL/IQP,IQN,IQL,IQAZ,IQMAX,IQ(7)
      DIMENSION :: G(NOD)
!
      DEN = L(I) + L(J) + 3
      K = 2 - KK
      CD = D1 + Z*R(1)*(DEN - D1)/((DEN + D1)*((L(I)+1)*(L(J)+1)))
      D = YK(1)*P(1,I)*P(1,J)*R(1)**K*(CD/(DEN*H1) + D5)
      DD = D0
      MX = MIN0(MAX_(I),MAX_(J))
      DO M = 2, MX
         G(M) = YK(M)*P(M,I)*P(M,J)*R(M)**K
      END DO
      DO M = 2, MX - 1, 2
         DD = DD + G(M)
         D = D + G(M+1)
      END DO
      QUADS = H1*(D + D2*DD)
      RETURN
      END FUNCTION QUADS


      SUBROUTINE real_unit
      USE global
      IMPLICIT NONE
      DX = DXR
      DT = DTR

      NI   = NI/dx
      NCE  = NCE/dx
      NHE  = NHE/dx

      VXI  = VXI/(dt/(2*dx))
      VXCE = VXCE/(dt/(2*dx))
      VXHE = VXHE/(dt/(2*dx))

      PI   = PI/((dt**4)/(16*dx))
      PCE  = PCE/((dt**4)/(16*dx))
      PHE  = PHE/((dt**4)/(16*dx))

      EX    = EX/((dt**2)/(4*dx))
      PH  = PH*((dt**2)/(4*dx**2))

      ME   = ME/((dt**4)/(4*dx))
      MI   = MI/((dt**4)/(4*dx))

      ZE   = ZE/((dt**4)/(4*dx))
      ZI   = ZI/((dt**4)/(4*dx))

      END SUBROUTINE real_unit


module mod_rans_efficient
#include <messenger.h>
    use mod_constants,          only: ZERO, ONE, TWO, THREE, HALF
    use mod_fluid,              only: Rgas, Pr, cp, gam
    use mod_spalart_allmaras,   only: SA_c_v1, SA_Pr_t
    use DNAD_D
    implicit none

    character(1000) :: turbulence_model = 'Spalart Allmaras'
    character(1000) :: viscosity_model  = 'Sutherlands Law'
    character(1000) :: state_equation   = 'Ideal Gas'

    namelist /fluid/ turbulence_model, viscosity_model, state_equation

contains

    !>
    !!
    !!
    !!
    !-----------------------------------------------------------------
    subroutine compute_pressure_temperature(density,mom1,mom2,mom3,energy,pressure,temperature)
        type(AD_D),                 intent(in)      :: density(:)
        type(AD_D),                 intent(in)      :: mom1(:)
        type(AD_D),                 intent(in)      :: mom2(:)
        type(AD_D),                 intent(in)      :: mom3(:)
        type(AD_D),                 intent(in)      :: energy(:)
        type(AD_D), allocatable,    intent(inout)   :: pressure(:)
        type(AD_D), allocatable,    intent(inout)   :: temperature(:)

        pressure = (gam-ONE)*(energy - HALF*( (mom1*mom1) + (mom2*mom2) + (mom3*mom3) )/density )
        temperature = pressure/(density*Rgas)

    end subroutine compute_pressure_temperature
    !*****************************************************************

    !>
    !!
    !!
    !!
    !------------------------------------------------------------------
    subroutine compute_viscosity(density,temperature,density_nutilde,mu_l,mu_t,lambda_l,lambda_t)
        type(AD_D),                 intent(in)      :: density(:)
        type(AD_D),                 intent(in)      :: temperature(:)
        type(AD_D),                 intent(in)      :: density_nutilde(:)
        type(AD_D), allocatable,    intent(inout)   :: mu_l(:)
        type(AD_D), allocatable,    intent(inout)   :: mu_t(:)
        type(AD_D), allocatable,    intent(inout)   :: lambda_l(:)
        type(AD_D), allocatable,    intent(inout)   :: lambda_t(:)

        real(rk) :: mu0 = 1.7894e-5_rk  ! [kg/(m*s)]
        real(rk) :: T0  = 273.11_rk     ! [K]
        real(rk) :: S   = 110.56_rk     ! [K]

        type(AD_D), allocatable :: chi(:), f_v1(:), nutilde(:), nu_l(:), chi3(:)

        !
        ! Sutherlands Law for Laminar Viscosity
        !
        mu_l = mu0*((temperature/T0)**(THREE/TWO))*(T0+S)/(temperature+S)
        lambda_l = -(TWO/THREE)*mu_l

        !
        ! Get viscosity: compute nu, nutilde
        !
        nu_l   = mu_l/density
        nutilde = density_nutilde/density

        !
        ! Compute chi, f_v1
        !
        chi = nutilde/nu_l
        chi3 = chi*chi*chi
        f_v1 = chi3/(chi3 + SA_c_v1*SA_c_v1*SA_c_v1)

        !
        ! Initialize derivatives, compute mu_t
        !
        mu_t = density
        where (nutilde >= 0)
            mu_t = density * nutilde * f_v1
        else where
            mu_t = ZERO
        end where
        lambda_t = (-TWO/THREE)*mu_t

    end subroutine compute_viscosity
    !*********************************************************************

    !>
    !!
    !!
    !!
    !!
    !----------------------------------------------------------------------
    subroutine compute_thermal_conductivity(mu_l,mu_t,k_l,k_t)
        type(AD_D),                 intent(in)      :: mu_l(:)
        type(AD_D),                 intent(in)      :: mu_t(:)
        type(AD_D), allocatable,    intent(inout)   :: k_l(:)
        type(AD_D), allocatable,    intent(inout)   :: k_t(:)

        k_l = cp * mu_l / Pr
        k_t = cp * mu_t / SA_Pr_t

    end subroutine compute_thermal_conductivity
    !**********************************************************************

    !>
    !!
    !!
    !!
    !!
    !-----------------------------------------------------------------------
    subroutine compute_temperature_gradient(density,u,v,w,p,                            &
                                            grad1_density,grad2_density,grad3_density,  &
                                            grad1_mom1,   grad2_mom1,   grad3_mom1,     &
                                            grad1_mom2,   grad2_mom2,   grad3_mom2,     &
                                            grad1_mom3,   grad2_mom3,   grad3_mom3,     &
                                            grad1_energy, grad2_energy, grad3_energy,   &
                                            grad1_T, grad2_T, grad3_T)
        type(AD_D),                 intent(in)  :: density(:)
        type(AD_D),                 intent(in)  :: u(:)
        type(AD_D),                 intent(in)  :: v(:)
        type(AD_D),                 intent(in)  :: w(:)
        type(AD_D),                 intent(in)  :: p(:)
        type(AD_D),                 intent(in)  :: grad1_density(:)
        type(AD_D),                 intent(in)  :: grad2_density(:)
        type(AD_D),                 intent(in)  :: grad3_density(:)
        type(AD_D),                 intent(in)  :: grad1_mom1(:)
        type(AD_D),                 intent(in)  :: grad2_mom1(:)
        type(AD_D),                 intent(in)  :: grad3_mom1(:)
        type(AD_D),                 intent(in)  :: grad1_mom2(:)
        type(AD_D),                 intent(in)  :: grad2_mom2(:)
        type(AD_D),                 intent(in)  :: grad3_mom2(:)
        type(AD_D),                 intent(in)  :: grad1_mom3(:)
        type(AD_D),                 intent(in)  :: grad2_mom3(:)
        type(AD_D),                 intent(in)  :: grad3_mom3(:)
        type(AD_D),                 intent(in)  :: grad1_energy(:)
        type(AD_D),                 intent(in)  :: grad2_energy(:)
        type(AD_D),                 intent(in)  :: grad3_energy(:)
        type(AD_D), allocatable,    intent(inout)  :: grad1_T(:)
        type(AD_D), allocatable,    intent(inout)  :: grad2_T(:)
        type(AD_D), allocatable,    intent(inout)  :: grad3_T(:)

        type(AD_D), allocatable, dimension(:)   ::                  &
            invdensity,                                             &
            dke_ddensity, dke_dmom1, dke_dmom2, dke_dmom3,          &
            dp_ddensity, dp_dmom1, dp_dmom2, dp_dmom3, dp_denergy,  &
            dT_ddensity, dT_dmom1, dT_dmom2, dT_dmom3, dT_denergy

        real(rk)    :: const

        ! Precompute density inverse
        invdensity = ONE/density

        ! Compute Kinetic Energy Jacobians
        dke_ddensity = -HALF*(u*u + v*v + w*w)
        dke_dmom1    = u
        dke_dmom2    = v
        dke_dmom3    = w

        ! Compute Pressure Jacobians
        dp_ddensity = -(gam-ONE)*dke_ddensity
        dp_dmom1    = -(gam-ONE)*dke_dmom1
        dp_dmom2    = -(gam-ONE)*dke_dmom2
        dp_dmom3    = -(gam-ONE)*dke_dmom3
        dp_denergy  =  dp_dmom3    ! Initialize derivatives
        dp_denergy  =  (gam-ONE)   ! No negative sign

        ! Compute Temperature Jacobians
        const = ONE/Rgas
        dT_ddensity = const*invdensity*dp_ddensity  -  const*invdensity*invdensity*p
        dT_dmom1    = const*invdensity*dp_dmom1
        dT_dmom2    = const*invdensity*dp_dmom2
        dT_dmom3    = const*invdensity*dp_dmom3
        dT_denergy  = const*invdensity*dp_denergy

        ! Compute temperature gradient
        grad1_T = dT_ddensity*grad1_density + dT_dmom1*grad1_mom1 + dT_dmom2*grad1_mom2 + dT_dmom3*grad1_mom3 + dT_denergy*grad1_energy
        grad2_T = dT_ddensity*grad2_density + dT_dmom1*grad2_mom1 + dT_dmom2*grad2_mom2 + dT_dmom3*grad2_mom3 + dT_denergy*grad2_energy
        grad3_T = dT_ddensity*grad3_density + dT_dmom1*grad3_mom1 + dT_dmom2*grad3_mom2 + dT_dmom3*grad3_mom3 + dT_denergy*grad3_energy

    end subroutine compute_temperature_gradient
    !***********************************************************************

    !>
    !!
    !!
    !!
    !!
    !------------------------------------------------------------------------
    subroutine compute_shear_stress(coordinate_system,r,                                &
                                    density,grad1_density,grad2_density,grad3_density,  &
                                    mom1,   grad1_mom1,   grad2_mom1,   grad3_mom1,     &
                                    mom2,   grad1_mom2,   grad2_mom2,   grad3_mom2,     &
                                    mom3,   grad1_mom3,   grad2_mom3,   grad3_mom3,     &
                                    energy, grad1_energy, grad2_energy, grad3_energy,   &
                                    mu, lambda,                                         &
                                    shear_11,shear_22,shear_33,shear_12,shear_13,shear_23)
        character(*),               intent(in)      :: coordinate_system
        type(AD_D),                 intent(in)      :: r(:)
        type(AD_D),                 intent(in)      :: density(:)
        type(AD_D),                 intent(in)      :: grad1_density(:)
        type(AD_D),                 intent(in)      :: grad2_density(:)
        type(AD_D),                 intent(in)      :: grad3_density(:)
        type(AD_D),                 intent(in)      :: mom1(:)
        type(AD_D),                 intent(in)      :: grad1_mom1(:)
        type(AD_D),                 intent(in)      :: grad2_mom1(:)
        type(AD_D),                 intent(in)      :: grad3_mom1(:)
        type(AD_D),                 intent(in)      :: mom2(:)
        type(AD_D),                 intent(in)      :: grad1_mom2(:)
        type(AD_D),                 intent(in)      :: grad2_mom2(:)
        type(AD_D),                 intent(in)      :: grad3_mom2(:)
        type(AD_D),                 intent(in)      :: mom3(:)
        type(AD_D),                 intent(in)      :: grad1_mom3(:)
        type(AD_D),                 intent(in)      :: grad2_mom3(:)
        type(AD_D),                 intent(in)      :: grad3_mom3(:)
        type(AD_D),                 intent(in)      :: energy(:)
        type(AD_D),                 intent(in)      :: grad1_energy(:)
        type(AD_D),                 intent(in)      :: grad2_energy(:)
        type(AD_D),                 intent(in)      :: grad3_energy(:)
        type(AD_D),                 intent(in)      :: mu(:)
        type(AD_D),                 intent(in)      :: lambda(:)
        type(AD_D), allocatable,    intent(inout)   :: shear_11(:)
        type(AD_D), allocatable,    intent(inout)   :: shear_22(:)
        type(AD_D), allocatable,    intent(inout)   :: shear_33(:)
        type(AD_D), allocatable,    intent(inout)   :: shear_12(:)
        type(AD_D), allocatable,    intent(inout)   :: shear_13(:)
        type(AD_D), allocatable,    intent(inout)   :: shear_23(:)

        type(AD_D), allocatable, dimension(:)   ::  &
            grad1_u, grad2_u, grad3_u,              &
            grad1_v, grad2_v, grad3_v,              &
            grad1_w, grad2_w, grad3_w,              &
            invdensity, invdensity2, div_velocity, u, v

!        !
!        ! compute velocity jacobians
!        !
!        invdensity = ONE/density
!        du_ddensity  = -invdensity*invdensity*mom1
!        dv_ddensity  = -invdensity*invdensity*mom2
!        dw_ddensity  = -invdensity*invdensity*mom3
!
!        du_dmom1 = invdensity
!        dv_dmom2 = invdensity
!        dw_dmom3 = invdensity
!
!
!
!        !
!        ! compute velocity gradients via chain rule:
!        !
!        !   u = f(rho,rhou)
!        !
!        !   grad(u) = dudrho * grad(rho)  +  dudrhou * grad(rhou)
!        !
!        grad1_u = du_ddensity*grad1_density  +  du_dmom1*grad1_mom1
!        grad2_u = du_ddensity*grad2_density  +  du_dmom1*grad2_mom1
!        grad3_u = du_ddensity*grad3_density  +  du_dmom1*grad3_mom1
!
!        grad1_v = dv_ddensity*grad1_density  +  dv_dmom2*grad1_mom2
!        grad2_v = dv_ddensity*grad2_density  +  dv_dmom2*grad2_mom2
!        grad3_v = dv_ddensity*grad3_density  +  dv_dmom2*grad3_mom2
!
!        grad1_w = dw_ddensity*grad1_density  +  dw_dmom3*grad1_mom3
!        grad2_w = dw_ddensity*grad2_density  +  dw_dmom3*grad2_mom3
!        grad3_w = dw_ddensity*grad3_density  +  dw_dmom3*grad3_mom3

        !
        ! compute velocity jacobians
        !
        invdensity = ONE/density
        invdensity2 = -invdensity*invdensity
!        du_ddensity  = -invdensity*invdensity*mom1
!        dv_ddensity  = -invdensity*invdensity*mom2
!        dw_ddensity  = -invdensity*invdensity*mom3
!
!        du_dmom1 = invdensity
!        dv_dmom2 = invdensity
!        dw_dmom3 = invdensity

        !
        ! compute velocity gradients via chain rule:
        !
        !   u = f(rho,rhou)
        !
        !   grad(u) = dudrho * grad(rho)  +  dudrhou * grad(rhou)
        !
        grad1_u = invdensity2*mom1*grad1_density  +  invdensity*grad1_mom1
        grad2_u = invdensity2*mom1*grad2_density  +  invdensity*grad2_mom1
        grad3_u = invdensity2*mom1*grad3_density  +  invdensity*grad3_mom1

        grad1_v = invdensity2*mom2*grad1_density  +  invdensity*grad1_mom2
        grad2_v = invdensity2*mom2*grad2_density  +  invdensity*grad2_mom2
        grad3_v = invdensity2*mom2*grad3_density  +  invdensity*grad3_mom2

        grad1_w = invdensity2*mom3*grad1_density  +  invdensity*grad1_mom3
        grad2_w = invdensity2*mom3*grad2_density  +  invdensity*grad2_mom3
        grad3_w = invdensity2*mom3*grad3_density  +  invdensity*grad3_mom3

        !----------------------------------------------------------
        !
        !                        Cartesian
        !
        !----------------------------------------------------------
        !if (worker%coordinate_system() == 'Cartesian') then
        if (coordinate_system == 'Cartesian') then

            !
            ! Compute divergence of velocity vector
            !
            !   U = [u_x, u_y, u_z] = [u,v,w]
            !
            !   div(V) = dudx + dvdy + dwdz
            !
            div_velocity = grad1_u + grad2_v + grad3_w

            !
            ! Compute shear stress components
            !
            shear_11 = TWO*mu*grad1_u  +  lambda*(div_velocity)
            shear_22 = TWO*mu*grad2_v  +  lambda*(div_velocity)
            shear_33 = TWO*mu*grad3_w  +  lambda*(div_velocity)

            shear_12 = mu*(grad2_u + grad1_v)
            shear_13 = mu*(grad3_u + grad1_w)
            shear_23 = mu*(grad2_w + grad3_v)

        else if (coordinate_system == 'Cylindrical') then

            !
            ! Compute divergence of velocity vector
            !
            !   U = [u_r, u_theta, u_z] = [u,v,w]
            !
            !   div(U) = (1/r)d(r*u)dr   + (1/r)dv/dtheta + dw/dz
            !          = (du/dr + u/r) + (1/r)dv/dtheta + dw/dz
            !
            !   Note:
            !       grad1_u = du/dr
            !       grad2_v = (1/r)dv/dtheta
            !       grad3_w = dw/dz
            !
            u = mom1/density
            v = mom2/density
            div_velocity = (grad1_u + u/r) + grad2_v + grad3_w

            !
            ! Compute shear stress components
            !
            shear_11 = TWO*mu*(grad1_u        )  +  lambda*(div_velocity)
            shear_22 = TWO*mu*(grad2_v + (u/r))  +  lambda*(div_velocity)
            shear_33 = TWO*mu*(grad3_w        )  +  lambda*(div_velocity)

            shear_12 = mu*(grad2_u + grad1_v  - (v/r))
            shear_13 = mu*(grad3_u + grad1_w         )
            shear_23 = mu*(grad2_w + grad3_v         )

        end if

    end subroutine compute_shear_stress
    !*************************************************************************

    !>
    !!
    !!
    !!
    !!
    !------------------------------------------------------------------------
    subroutine compute_vorticity(coordinate_system,r,                                &
                                 density,grad1_density,grad2_density,grad3_density,  &
                                 mom1,   grad1_mom1,   grad2_mom1,   grad3_mom1,     &
                                 mom2,   grad1_mom2,   grad2_mom2,   grad3_mom2,     &
                                 mom3,   grad1_mom3,   grad2_mom3,   grad3_mom3,     &
                                 vorticity_1, vorticity_2, vorticity_3)
        character(*),               intent(in)      :: coordinate_system
        type(AD_D),                 intent(in)      :: r(:)
        type(AD_D),                 intent(in)      :: density(:)
        type(AD_D),                 intent(in)      :: grad1_density(:)
        type(AD_D),                 intent(in)      :: grad2_density(:)
        type(AD_D),                 intent(in)      :: grad3_density(:)
        type(AD_D),                 intent(in)      :: mom1(:)
        type(AD_D),                 intent(in)      :: grad1_mom1(:)
        type(AD_D),                 intent(in)      :: grad2_mom1(:)
        type(AD_D),                 intent(in)      :: grad3_mom1(:)
        type(AD_D),                 intent(in)      :: mom2(:)
        type(AD_D),                 intent(in)      :: grad1_mom2(:)
        type(AD_D),                 intent(in)      :: grad2_mom2(:)
        type(AD_D),                 intent(in)      :: grad3_mom2(:)
        type(AD_D),                 intent(in)      :: mom3(:)
        type(AD_D),                 intent(in)      :: grad1_mom3(:)
        type(AD_D),                 intent(in)      :: grad2_mom3(:)
        type(AD_D),                 intent(in)      :: grad3_mom3(:)
        type(AD_D), allocatable,    intent(inout)   :: vorticity_1(:)
        type(AD_D), allocatable,    intent(inout)   :: vorticity_2(:)
        type(AD_D), allocatable,    intent(inout)   :: vorticity_3(:)

        type(AD_D), allocatable, dimension(:)   ::  &
            invdensity, du_ddensity, dv_ddensity, dw_ddensity,  &
            du_dmom1, dv_dmom2, dw_dmom3,                       &
            grad1_u, grad2_u, grad3_u,                          &
            grad1_v, grad2_v, grad3_v,                          &
            grad1_w, grad2_w, grad3_w, v

        !
        ! compute velocity jacobians
        !
        invdensity  = ONE/density
        du_ddensity = -invdensity*invdensity*mom1
        dv_ddensity = -invdensity*invdensity*mom2
        dw_ddensity = -invdensity*invdensity*mom3

        du_dmom1 = invdensity
        dv_dmom2 = invdensity
        dw_dmom3 = invdensity

        !
        ! compute velocity gradients via chain rule:
        !
        !   u = f(rho,rhou)
        !
        !   grad(u) = dudrho * grad(rho)  +  dudrhou * grad(rhou)
        !
        grad1_u = du_ddensity*grad1_density  +  du_dmom1*grad1_mom1
        grad2_u = du_ddensity*grad2_density  +  du_dmom1*grad2_mom1
        grad3_u = du_ddensity*grad3_density  +  du_dmom1*grad3_mom1

        grad1_v = dv_ddensity*grad1_density  +  dv_dmom2*grad1_mom2
        grad2_v = dv_ddensity*grad2_density  +  dv_dmom2*grad2_mom2
        grad3_v = dv_ddensity*grad3_density  +  dv_dmom2*grad3_mom2

        grad1_w = dw_ddensity*grad1_density  +  dw_dmom3*grad1_mom3
        grad2_w = dw_ddensity*grad2_density  +  dw_dmom3*grad2_mom3
        grad3_w = dw_ddensity*grad3_density  +  dw_dmom3*grad3_mom3

        !----------------------------------------------------------
        !
        !                        Cartesian
        !
        !----------------------------------------------------------
        if (trim(coordinate_system) == 'Cartesian') then
            !
            ! Compute vorticity:
            !
            !   vorticity = Curl(U)
            !
            !   U = [u_x, u_y, u_z] = [u,v,w]
            !
            !   curl(U) = (dwdx - dvdz)i  +  (dudz - dwdx)j  +  (dvdx - dudy)k
            !
            vorticity_1 =  (grad2_w - grad3_v)
            vorticity_2 =  (grad3_u - grad1_w)
            vorticity_3 =  (grad1_v - grad2_u)

        else if (trim(coordinate_system) == 'Cylindrical') then
            !
            ! Compute divergence of velocity vector
            !
            !   U = [u_r, u_theta, u_z] = [u,v,w]
            !
            !   curl(U) = ((1/r)dwdtheta - dvdz)i  +  (dudz - dwdr)j  +  (1/r)(d(rv)dr - dudtheta)k
            !           = ((1/r)dwdtheta - dvdz)i  +  (dudz - dwdr)j  +  ( dvdr - (1/r)dudtheta  + (v/r) )k
            !           = (grad2_w - grad3_v)i  +  (grad3_u - grad1_w)j  +  ( grad1_v - grad2_u  + (v/r) )k
            !
            !   Note:
            !       grad1_ = d/dr
            !       grad2_ = (1/r)d/dtheta
            !       grad3_ = d/dz
            !
            v = mom2/density

            vorticity_1 =  (grad2_w - grad3_v)
            vorticity_2 =  (grad3_u - grad1_w)
            vorticity_3 =  (grad1_v - grad2_u + (v/r))

        end if

    end subroutine compute_vorticity

end module mod_rans_efficient


      SUBROUTINE precal
      USE vparams, ONLY: zero, one, epstan
      USE vacmod
      IMPLICIT NONE
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: p25 = p5*p5, bigno = 1.e50_dp
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: kp, ku, kuminus, kv, kvminus, i, m, n, mn,
     1   imn, jmn, kmn, l, istat1, smn, nuv_tan
      REAL(rprec), DIMENSION(0:mf + nf,0:mf,0:nf) :: cmn
      REAL(rprec) :: argu, argv, argp, dn1, f1, f2, f3, alp_per
C-----------------------------------------------
!
!     THIS ROUTINE COMPUTES INITIAL CONSTANTS AND ARRAYS
!
      pi2 = 8*ATAN(one)
      pi3 = p5*pi2**3
      pi4 = 2*pi2
      onp = one/nfper
      onp2 = onp*onp
      alu = pi2/nu
      alv = pi2/nv
      alp = pi2*onp
      alvp = onp*alv

!
!     ALLOCATE PERSISTENT ARRAYS. DEALLOCATED IN FILEOUT ROUTINE
!
      IF (nv == 1) THEN         !(AXISYMMETRIC CASE: DO FP SUM TO INTEGRATE IN V)
         nvper = 64
         nuv_tan = 2*nu*nvper
      ELSE
         nvper = nfper
         nuv_tan = 2*nuv
      END IF

      alp_per = pi2/nvper
      nvp = nv*nvper

      ALLOCATE (tanu(nuv_tan), tanv(nuv_tan),
     1     sinper(nvper), cosper(nvper), sinuv(nuv), cosuv(nuv),
     2     sinu(0:mf,nu), cosu(0:mf,nu), sinv(-nf:nf,nv),
     3     cosv(-nf:nf,nv), sinui(0:mf,nu2), cosui(0:mf,nu2),
     4     cmns(0:(mf+nf),0:mf,0:nf), csign(-nf:nf),
     5     sinu1(nuv2,0:mf), cosu1(nuv2,0:mf),
     6     sinv1(nuv2,0:nf), cosv1(nuv2,0:nf), imirr(nuv),
     7     xmpot(mnpd), xnpot(mnpd), stat=istat1)
      IF (istat1.ne.0) STOP 'allocation error in precal'

!
!     IMIRR(I) GIVES THE INDEX OF THE POINT TWOPI-THETA(I),TWOPI-ZETA(I)
!
      DO kp = 1, nvper
         cosper(kp) = COS(alp_per*(kp - 1))
         sinper(kp) = SIN(alp_per*(kp - 1))
      END DO

      DO ku = 1, nu
         kuminus = MOD(nu + 1 - ku,nu) + 1
         DO kv = 1, nv
            kvminus = MOD(nv + 1 - kv,nv) + 1
            i = kv + nv*(ku - 1)
            imirr(i) = kvminus + nv*(kuminus - 1)
            cosuv(i) = COS(alvp*(kv - 1))
            sinuv(i) = SIN(alvp*(kv - 1))
         END DO
      END DO

!
!     NOTE: ANGLE DIFFERENCE IS PI2*{[NUV + (KUP-1)] - (KU-1)}
!           THIS DIFFERENCE IS ACCOUNTED FOR BY THE OFFSET IUOFF IN GREENF ROUTINE
!
!           THE KP SUM BELOW IS USED ONLY FOR NV == 1. IT PERFORMS THE V-INTEGRAL
!           IN AN AXISYMMETRIC PLASMA
!
      i = 0
      DO kp = 1, nvper
         IF (kp.gt.1 .and. nv.ne.1) EXIT
         argp = p5*alp_per*(kp-1)
         DO ku = 1, 2*nu
            argu = p5*alu*(ku - 1)
            DO kv = 1, nv
               i = i + 1
               argv = p5*alv*(kv - 1) + argp
               IF (ABS(argu - p25*pi2)<epstan .or.
     1         ABS(argu - 0.75_dp*pi2) < epstan) THEN
                  tanu(i) = bigno
               ELSE
                  tanu(i) = 2*TAN(argu)
               ENDIF
               IF (ABS(argv - p25*pi2) < epstan) THEN
                  tanv(i) = bigno
               ELSE
                  tanv(i) = 2*TAN(argv)
               ENDIF
            END DO
         END DO
      END DO

      DO m = 0, mf
         l40: DO ku = 1, nu
            cosu(m,ku) = COS(alu*(m*(ku - 1)))
            sinu(m,ku) = SIN(alu*(m*(ku - 1)))
            DO kv = 1, nv
               i = kv + nv*(ku - 1)
               IF (i > nuv2) CYCLE  l40
               cosu1(i,m) = cosu(m,ku)
               sinu1(i,m) = sinu(m,ku)
            END DO
         END DO l40
         DO ku = 1, nu2
            cosui(m,ku) = cosu(m,ku)*alu*alv*2
            sinui(m,ku) = sinu(m,ku)*alu*alv*2
            IF (ku.eq.1 .or. ku.eq.nu2) cosui(m,ku) = p5*cosui(m,ku)
         END DO
      END DO
      DO n = -nf, nf
         dn1 = alvp*(n*nfper)
         csign(n) = SIGN(one,dn1)
         l50: DO ku = 1, nu
            DO kv = 1, nv
               i = kv + nv*(ku - 1)
               cosv(n,kv) = COS(dn1*(kv - 1))
               sinv(n,kv) = SIN(dn1*(kv - 1))
               IF (i.gt.nuv2 .or. n.lt.0) CYCLE  l50
               cosv1(i,n) = cosv(n,kv)
               sinv1(i,n) = sinv(n,kv)
            END DO
         END DO l50
      END DO
      mn = 0
      DO n = -nf, nf
         DO m = 0, mf
            mn = mn + 1
            xmpot(mn) = m
            xnpot(mn) = n*nfper
         END DO
      END DO
!
!     COMPUTE CMNS AND THE COEFFICIENTS OF T+- IN EQ (A14 AND A13) IN J.COMP.PHYS PAPER (PKM)
!     NOTE: HERE, THE INDEX L IN THE LOOP BELOW IS THE SUBSCRIPT OF T+-. THEREFORE,
!     L = 2L' + Kmn (L' = INDEX IN EQ. A14, Kmn = |m-n|), WITH LMIN = K AND LMAX = Jmn == m+n.
!
!     THE FOLLOWING DEFINITIONS PERTAIN (NOTE: kmn <= L <= jmn):
!
!     F1 = [(L + jmn)/2]! / [(jmn - L)/2]! == [(jmn + kmn)/2 + L']!/[(jmn - kmn)/2 + L']!
!
!     F2 = [(L + kmn)/2]!  == (L' + kmn)!
!
!     F3 = [(L - kmn)/2]!  == (L')!
!
      DO m = 0, mf
         DO n = 0, nf
            jmn = m + n
            imn = m - n
            kmn = ABS(imn)
            smn = (jmn + kmn)/2                  !!Integer: J+K always even
            f1 = 1
            f2 = 1
            f3 = 1
            DO i = 1, kmn
               f1 = f1*(smn + 1 - i)
               f2 = f2*i
            END DO
            cmn(0:mf+nf,m,n) = 0
            DO l = kmn, jmn, 2
               cmn(l,m,n) = f1/(f2*f3)*((-1)**((l - imn)/2))
               f1 = f1*p25*((jmn + l + 2)*(jmn - l))
               f2 = f2*p5*(l + 2 + kmn)
               f3 = f3*p5*(l + 2 - kmn)
            END DO
         END DO
      END DO
!
!     Now combine these into a single coefficient (cmns), Eq. A13).
!     NOTE:  The ALP=2*pi/nfper factor is needed to normalize integral over field periods
!
      DO m = 1,mf
         DO n = 1,nf
            cmns(0:mf+nf,m,n) = p5*alp*(cmn(0:mf+nf,m,n) +
     1      cmn(0:mf+nf,m-1,n) + cmn(0:mf+nf,m,n-1) +
     2      cmn(0:mf+nf,m-1,n-1))
         END DO
      END DO
      cmns(0:mf+nf,1:mf,0) = (p5*alp)*(cmn(0:mf+nf,1:mf,0)
     1                     +           cmn(0:mf+nf,:mf-1,0))
      cmns(0:mf+nf,0,1:nf) = (p5*alp)*(cmn(0:mf+nf,0,1:nf)
     1                     +           cmn(0:mf+nf,0,:nf-1))
      cmns(0:mf+nf,0,0)    = (p5*alp)*(cmn(0:mf+nf,0,0)
     1                     +           cmn(0:mf+nf,0,0))

      END SUBROUTINE precal


      SUBROUTINE PHO_SASBEH(Kf,X,Q2,P2,Pm2,Xpbh)
      IMPLICIT NONE
      REAL aem2pi , beta , beta2 , chsq , P2 , Pm2 , Q2 , rmq , rpbe ,
     &     rpbesn , rpq , sigbh , w2 , X , xbi , xbl , Xpbh
      INTEGER Kf
C...Purpose: to evaluate the Bethe-Heitler cross section for
C...heavy flavour production.
      SAVE
      DATA aem2pi/0.0011614/

C...Reset output.
      Xpbh = 0.
      sigbh = 0.

C...Check kinematics limits.
      IF ( X.GE.Q2/(4.*Pm2+Q2+P2) ) RETURN
      w2 = Q2*(1.-X)/X - P2
      beta2 = 1. - 4.*Pm2/w2
      IF ( beta2.LT.1E-10 ) RETURN
      beta = SQRT(beta2)
      rmq = 4.*Pm2/Q2

C...Simple case: P2 = 0.
      IF ( P2.LT.1E-4 ) THEN
         IF ( beta.LT.0.99 ) THEN
            xbl = LOG((1.+beta)/(1.-beta))
         ELSE
            xbl = LOG((1.+beta)**2*w2/(4.*Pm2))
         END IF
         sigbh = beta*(8.*X*(1.-X)-1.-rmq*X*(1.-X))
     &           + xbl*(X**2+(1.-X)**2+rmq*X*(1.-3.*X)-0.5*rmq**2*X**2)

C...Complicated case: P2 > 0, based on approximation of
C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
      ELSE
         rpq = 1. - 4.*X**2*P2/Q2
         IF ( rpq.GT.1E-10 ) THEN
            rpbe = SQRT(rpq*beta2)
            IF ( rpbe.LT.0.99 ) THEN
               xbl = LOG((1.+rpbe)/(1.-rpbe))
               xbi = 2.*rpbe/(1.-rpbe**2)
            ELSE
               rpbesn = 4.*Pm2/w2 + (4.*X**2*P2/Q2)*beta2
               xbl = LOG((1.+rpbe)**2/rpbesn)
               xbi = 2.*rpbe/rpbesn
            END IF
            sigbh = beta*(6.*X*(1.-X)-1.)
     &              + xbl*(X**2+(1.-X)**2+rmq*X*(1.-3.*X)
     &              -0.5*rmq**2*X**2) + xbi*(2.*X/Q2)
     &              *(Pm2*X*(2.-rmq)-P2*X)
         END IF
      END IF

C...Multiply by charge-squared etc. to get parton distribution.
      chsq = 1./9.
      IF ( ABS(Kf).EQ.2 .OR. ABS(Kf).EQ.4 ) chsq = 4./9.
      Xpbh = 3.*chsq*aem2pi*X*sigbh

      END SUBROUTINE


#version 130

in vec3 pass_Position;
in vec4 pass_Color;
in vec2 pass_TextureCoord;
in vec3 pass_Normal;
in vec3 pass_LightPosition;

uniform float lightIntensity;
uniform float materialAmbientReflectivity;
uniform float materialDiffuseReflectivity;
uniform float materialSpecularReflectivity;
uniform int   materialSpecularHardness;

uniform sampler2D tex;

out vec4 out_Color;

float diffuseComponent(vec3 light, vec3 normal) {
	return max(dot(light, normal), 0);
}

float specularComponent(vec3 reflection, vec3 camera, float hardness) {
	return pow(max(dot(reflection, camera), 0), hardness);
}

vec3 lightVector(vec3 lightSource, vec3 position) {
	return normalize(lightSource - position);
}

float intensity(vec3 light, vec3 normal, float lightIntensity) {
    vec3 reflection = normalize(-reflect(light, normal));
	vec3 camera     = normalize(-pass_Position);

    float ambient  = materialAmbientReflectivity;
	float diffuse  = lightIntensity * materialDiffuseReflectivity  * diffuseComponent(light, normal);
	float specular = lightIntensity * materialSpecularReflectivity * specularComponent(reflection, camera, materialSpecularHardness);

	float intensity = ambient + diffuse + specular;
	return clamp(intensity, 0, 1);
}

// https://www.opengl.org/sdk/docs/tutorials/ClockworkCoders/lighting.php
void main(void) {
    vec3 L = lightVector(pass_LightPosition, pass_Position);
	out_Color = texture(tex, pass_TextureCoord) * intensity(L, pass_Normal, lightIntensity);
}


! Learn_dg - A quick and dirty project to deploy a working DG solver
! Copyright (c) 2017, Chris Coutinho
! All rights reserved.
!
! Licensed under the BSD-2 clause license. See LICENSE for details.

module mod_legendre
    use, intrinsic  :: iso_fortran_env, only: wp=>real64
    implicit none

    private

    public :: basis_1D
    interface basis_1D
        pure module function basis_1D(x, alpha, dx) result(y)
            ! Input/output variables
            integer,  intent(in)                            :: dx
            real(wp), intent(in), dimension(:)              :: x
            real(wp), intent(in), dimension(:)              :: alpha
            real(wp),             dimension(:), allocatable :: y
        end function basis_1D
    end interface basis_1D

    public :: getXY
    interface getXY
        pure module function getXY_2D(N) result(xy)
            integer,  intent(in)          :: N
            real(wp), dimension(N,2)      :: xy
        end function getXY_2D
    end interface getXY

    public :: pascal_single_row
    interface pascal_single_row
        pure module function pascal_row_2D(N, x, y) result(row)
            integer,  intent(in)      :: N
            real(wp), intent(in)      :: x
            real(wp), intent(in)      :: y
            real(wp), dimension(N+1)  :: row
        end function pascal_row_2D
    end interface pascal_single_row

    public :: pascal_row
    interface pascal_row
        pure module function pascal_1D_line(N, x) result(row)
            integer,  intent(in)          :: N
            real(wp), intent(in)          :: x
            real(wp), dimension(N+1)      :: row
        end function pascal_1D_line

        pure module function pascal_2D_quad(N, x, y) result(row)
            integer,  intent(in)          :: N
            real(wp), intent(in)          :: x
            real(wp), intent(in)          :: y
            real(wp), dimension((N+1)**2) :: row
        end function pascal_2D_quad
    end interface pascal_row

    public :: getArow
    interface getArow
        pure module function getArow1D(N, xi) result(row)
            integer, intent(in)     :: N
            real(wp), intent(in)    :: xi
            real(wp), dimension(N)  :: row
        end function getArow1D
        pure module function getArow2D(N, xi, eta) result(row)
            integer, intent(in)     :: N
            real(wp), intent(in)    :: xi, eta
            real(wp), dimension(N)  :: row
        end function getArow2D
    end interface getArow

    public :: getAlpha2D
    interface getAlpha2D
        module function getAlpha2D(N) result(alpha)
            integer, intent(in)       :: N
            real(wp), dimension(N,N)  :: alpha
        end function getAlpha2D
    end interface getAlpha2D

    public :: getAlpha1D
    interface getAlpha1D
        module function getAlpha1D(N) result(alpha)
            integer, intent(in)       :: N
            real(wp), dimension(N,N)  :: alpha
        end function getAlpha1D
    end interface getAlpha1D

    public :: getJacobian
    interface getJacobian
        module function getJacobian_2D(N, xi, eta, xy, alpha) result(J)
            integer,                  intent(in)  :: N
            real(wp),                 intent(in)  :: xi
            real(wp),                 intent(in)  :: eta
            real(wp), dimension(N,2), intent(in)  :: xy
            real(wp), dimension(N,N), intent(in)  :: alpha
            real(wp), dimension(2,2)              :: J
        end function getJacobian_2D
    end interface getJacobian

end module mod_legendre


c     Program DRDPOLZ2
c>> 2009-10-28 DRZPOLZ2 Krogh Mods to get comples used in single prec.
c>> 1996-07-03 DRDPOLZ2 Krogh Set for deriving single precision C vers.
c>> 1995-05-28 DRDPOLZ2 Krogh Moved formats up.
c>> 1994-08-09 DRDPOLZ2 WVS Removed '0' in format
c>> 1991-11-20 DRDPOLZ2 CLL Editing for Fortran 90.
c>> 1987-12-09 DRDPOLZ2 Lawson  Initial Code.
c Conversion should only be done from "D" to "S" for processing to C.
c--D replaces "?": DR?POLZ2, ?POLZ2
c     Demonstration driver for DPOLZ2.
c
      double precision  DC(3,3)
c++ CODE for .D. | .C. is active
      double precision Z(2,2)
c++ CODE for .S. & ~.C. is inactive
c      complex Z(2)
c++ END

      integer  I, J, K, N
c
      data (DC(I,1),I=1,3) / 1.D0, 1.D0, -1.D0 /
      data (DC(I,2),I=1,3) / 2.D0, -12.D0, 26.D0 /
      data (DC(I,3),I=1,3) / 1.D0, -4.D0, 4.D0 /
      data N / 2 /
c
  100 format(' ','Degree =',I2/' ',
     *       'Coefficients =',6X,3(F10.4,1X))
  200 format(' ','Roots ='/(2(1X:'(',1X,F8.5,',',1X,F8.5,2X,')',2X)))
  300 format(//' ')
c
      do 40 J = 1,3
         print 100, N, (DC(I, J),I=1,3)
        call DPOLZ2(DC(1,J),Z)
c++ CODE for .D. & ~.C. is active
        print '('' Roots =''/(2(1X:''('',1X,F8.5,'','',1X,F8.5,2X,
     *    '')'',2X)))', (Z(1,K),Z(2,K),K=1,2)
c++ CODE for .S. & ~.C. is inactive
c        print '('' Roots =''/(2(1X:''('',1X,F8.5,'','',1X,F8.5,2X,
c     *    '')'',2X)))', (Z(K),K=1,2)
c++ CODE for .C. is inactive
c%%        printf( "\n Roots =\n  ( %8.5f, %8.5f )  ( %8.5f, %8.5f ) ",
c%%           z[0][0], z[0][1], z[1][0], z[1][1] );
c++ End
        print 300
   40 continue
      end


program problem_10

!! What is the first number that does not have this property?

use aoc_utilities, only: read_file_to_integer_array, sort_ascending
use iso_fortran_env

implicit none

integer,dimension(:),allocatable :: output_joltage
integer :: i, j, k, n, highest_rated, device_adapter_voltage, diff, diff2, diff_1v, diff_3v
integer :: total_valid, istart, iend, n_valid
logical,dimension(:),allocatable :: removable

type :: sequence
    integer,dimension(:),allocatable :: i
    integer :: n_valid = 0
end type sequence
type(sequence),allocatable,dimension(:) :: sequences

output_joltage = read_file_to_integer_array('input.txt')
highest_rated = maxval(output_joltage)
device_adapter_voltage = highest_rated + 3
output_joltage = [0, output_joltage, device_adapter_voltage]
call sort_ascending(output_joltage)
n = size(output_joltage)

do i=1,n
    write(*,*) output_joltage(i)
end do
write(*,*) ''
write(*,*) n, 'elements'
write(*,*) ''

diff_1v = 0
diff_3v = 0

do i = 2, n
    diff = output_joltage(i) - output_joltage(i-1)
    if (.not. any(diff==[1,2,3])) error stop 'error'  ! verify
    select case(diff)
    case(1); diff_1v = diff_1v + 1
    case(3); diff_3v = diff_3v + 1
    end select
end do

write(*,*) '1 v diffs: ', diff_1v
write(*,*) '3 v diffs: ', diff_3v
write(*,*) 'product  : ', diff_1v * diff_3v

write(*,*) ''
write(*,*) '=========================='
write(*,*) '         Part 2'
write(*,*) '=========================='
write(*,*) ''

! identify candidates for removal:
allocate(removable(n))
removable = .false.
do i = 2, n-1
    diff = output_joltage(i+1) - output_joltage(i-1)
    if (any(diff==[1,2,3])) then
        removable(i) = .true. ! this one could be removed
        !write(*,'(A,1X,I3,1X,A,I2,A)') 'index ', i, '(', output_joltage(i),') is removable'
    end if
end do
! write(*,*) count(removable), 'are removable'

! write(*,*) ''
! write(*,*) 'removable: ', removable
! write(*,*) ''

! get consecutive sequences...these are the ones that have to be checked:
allocate(sequences(0))
istart = 0
iend = 2
do i = 2, n-1

    if (removable(i)) then
        if (istart==0) then
            istart = i  ! first one
        end if
        iend = i  ! add another one
    else
        if (istart /= 0) then
            ! write(*,*) 'sequence: ', [(j, j = istart, iend)]
            sequences = [ sequences, sequence([(j, j = istart, iend)]) ]
        end if
        istart = 0
        iend = 0
    end if

end do

! write(*,*) '....sequences:'
! do i=1, size(sequences)
!     write(*,*) sequences(i)%i
! end do

! 1     -> 1
! 1,2   -> 1, 2,    12,                 2^2-1
! 1,2,3 -> 1, 2, 3, 12, 13, 23, 123     2^3-1
!
!... only have to check the conseq ones, the single ones are valid
! .. so, have to check 12, 13, 23, 123

! write(*,*) ''
! write(*,*) '----- get combos -----'
! write(*,*) ''

do i=1, size(sequences)
    !write(*,*) sequences(i)%i
    ! do j = 1, size(sequences(i)%i)
    !     write(*,*) sequences(i)%i(j)
    ! end do
    sequences(i)%n_valid = sequences(i)%n_valid + size(sequences(i)%i)  ! we can also remove them individually
    select case (size(sequences(i)%i))
    case(1)
        ! already counted this
    case(2)
        ! can we remove both at the same time?
        diff = output_joltage(sequences(i)%i(2)+1) - output_joltage(sequences(i)%i(1)-1)
        if (any(diff==[1,2,3])) then
            n_valid = n_valid + 1
            !write(*,*) sequences(i)%i(1), sequences(i)%i(2)
            sequences(i)%n_valid = sequences(i)%n_valid + 1
        end if
    case(3)
        ! remove 1-2
        diff = output_joltage(sequences(i)%i(2)+1) - output_joltage(sequences(i)%i(1)-1)
        if (any(diff==[1,2,3])) then
            n_valid = n_valid + 1
            !write(*,*) sequences(i)%i(1), sequences(i)%i(2)
            sequences(i)%n_valid = sequences(i)%n_valid + 1
        end if
        ! remove 1-3
        diff = output_joltage(sequences(i)%i(2))   - output_joltage(sequences(i)%i(1)-1)
        diff2 = output_joltage(sequences(i)%i(3)+1) - output_joltage(sequences(i)%i(2))
        if (any(diff==[1,2,3]) .and. any(diff2==[1,2,3])) then
            n_valid = n_valid + 1
            !write(*,*) sequences(i)%i(1), sequences(i)%i(3)
            sequences(i)%n_valid = sequences(i)%n_valid + 1
        end if
        ! remove 2-3
        diff = output_joltage(sequences(i)%i(3)+1) - output_joltage(sequences(i)%i(2)-1)
        if (any(diff==[1,2,3])) then
            n_valid = n_valid + 1
            !write(*,*) sequences(i)%i(2), sequences(i)%i(3)
            sequences(i)%n_valid = sequences(i)%n_valid + 1
        end if
        ! remove 1-2-3     !---> can never happen ...
        diff = output_joltage(sequences(i)%i(3)+1) - output_joltage(sequences(i)%i(1)-1)
        if (any(diff==[1,2,3])) then
            n_valid = n_valid + 1
           !write(*,*) sequences(i)%i(1), sequences(i)%i(2), sequences(i)%i(3)
            sequences(i)%n_valid = sequences(i)%n_valid + 1
        end if

    case default
        error stop 'oops have not accounted for this'
    end select
end do

write(*,*) ''
write(*,*) 'number of distinct ways: ', product(int(sequences%n_valid+1,int64))
write(*,*) ''

end program problem_10


program problem29
  implicit none
  integer, parameter                    :: a_limit=100,b_limit=100
  integer, parameter                    :: power=floor(log(dble(a_limit))/log(dble(2)))
  integer                               :: i,j,k,answer
  double precision                      :: temp
  logical, dimension(a_limit,b_limit*6) :: found

  do i=1,a_limit
     do j=1,b_limit*power
        found(i,j) = .false.
     end do
  end do

  do i=2,a_limit
     ! Filter out powers of earlier numbers
     do j=2,i-1
        temp=log(dble(i))/log(dble(j))
        if (mod(temp,1.0_8) == 0.0_8) then
           go to 1
        end if
     end do

     ! Mark found numbers
     do j=2,b_limit
        ! Largest exponent of this number that is less than the largest a
        do k=1,floor(log(dble(a_limit))/log(dble(i)))
           found(i,j*k) = .true.
        end do
     end do
1 end do

  answer=0
  do i=1,a_limit
     do j=1,power*b_limit
        if (found(i,j)) then
           answer=answer+1
        end if
     end do
  end do

  print *, answer

end program problem29


       function tr_2(T)
        implicit none

        type(Tensor2) :: T
        real(kind=8) :: tr_2

        tr_2 = T%ab(1,1)+T%ab(2,2)+T%ab(3,3)

       end function tr_2

       function tr_2s(T)
        implicit none

        type(Tensor2s) :: T
        real(kind=8) :: tr_2s

        tr_2s = T%a6(1)+T%a6(2)+T%a6(3)

       end function tr_2s


*DECK DPCHIM
      SUBROUTINE DPCHIM (N, X, F, D, INCFD, IERR)
C***BEGIN PROLOGUE  DPCHIM
C***PURPOSE  Set derivatives needed to determine a monotone piecewise
C            cubic Hermite interpolant to given data.  Boundary values
C            are provided which are compatible with monotonicity.  The
C            interpolant will have an extremum at each point where mono-
C            tonicity switches direction.  (See DPCHIC if user control
C            is desired over boundary or switch conditions.)
C***LIBRARY   SLATEC (PCHIP)
C***CATEGORY  E1A
C***TYPE      DOUBLE PRECISION (PCHIM-S, DPCHIM-D)
C***KEYWORDS  CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION,
C             PCHIP, PIECEWISE CUBIC INTERPOLATION
C***AUTHOR  Fritsch, F. N., (LLNL)
C             Lawrence Livermore National Laboratory
C             P.O. Box 808  (L-316)
C             Livermore, CA  94550
C             FTS 532-4275, (510) 422-4275
C***DESCRIPTION
C
C          DPCHIM:  Piecewise Cubic Hermite Interpolation to
C                  Monotone data.
C
C     Sets derivatives needed to determine a monotone piecewise cubic
C     Hermite interpolant to the data given in X and F.
C
C     Default boundary conditions are provided which are compatible
C     with monotonicity.  (See DPCHIC if user control of boundary con-
C     ditions is desired.)
C
C     If the data are only piecewise monotonic, the interpolant will
C     have an extremum at each point where monotonicity switches direc-
C     tion.  (See DPCHIC if user control is desired in such cases.)
C
C     To facilitate two-dimensional applications, includes an increment
C     between successive values of the F- and D-arrays.
C
C     The resulting piecewise cubic Hermite function may be evaluated
C     by DPCHFE or DPCHFD.
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        PARAMETER  (INCFD = ...)
C        INTEGER  N, IERR
C        DOUBLE PRECISION  X(N), F(INCFD,N), D(INCFD,N)
C
C        CALL  DPCHIM (N, X, F, D, INCFD, IERR)
C
C   Parameters:
C
C     N -- (input) number of data points.  (Error return if N.LT.2 .)
C           If N=2, simply does linear interpolation.
C
C     X -- (input) real*8 array of independent variable values.  The
C           elements of X must be strictly increasing:
C                X(I-1) .LT. X(I),  I = 2(1)N.
C           (Error return if not.)
C
C     F -- (input) real*8 array of dependent variable values to be
C           interpolated.  F(1+(I-1)*INCFD) is value corresponding to
C           X(I).  DPCHIM is designed for monotonic data, but it will
C           work for any F-array.  It will force extrema at points where
C           monotonicity switches direction.  If some other treatment of
C           switch points is desired, DPCHIC should be used instead.
C                                     -----
C     D -- (output) real*8 array of derivative values at the data
C           points.  If the data are monotonic, these values will
C           determine a monotone cubic Hermite function.
C           The value corresponding to X(I) is stored in
C                D(1+(I-1)*INCFD),  I=1(1)N.
C           No other entries in D are changed.
C
C     INCFD -- (input) increment between successive values in F and D.
C           This argument is provided primarily for 2-D applications.
C           (Error return if  INCFD.LT.1 .)
C
C     IERR -- (output) error flag.
C           Normal return:
C              IERR = 0  (no errors).
C           Warning error:
C              IERR.GT.0  means that IERR switches in the direction
C                 of monotonicity were detected.
C           "Recoverable" errors:
C              IERR = -1  if N.LT.2 .
C              IERR = -2  if INCFD.LT.1 .
C              IERR = -3  if the X-array is not strictly increasing.
C             (The D-array has not been changed in any of these cases.)
C               NOTE:  The above errors are checked in the order listed,
C                   and following arguments have **NOT** been validated.
C
C***REFERENCES  1. F. N. Fritsch and J. Butland, A method for construc-
C                 ting local monotone piecewise cubic interpolants, SIAM
C                 Journal on Scientific and Statistical Computing 5, 2
C                 (June 1984), pp. 300-304.
C               2. F. N. Fritsch and R. E. Carlson, Monotone piecewise
C                 cubic interpolation, SIAM Journal on Numerical Ana-
C                 lysis 17, 2 (April 1980), pp. 238-246.
C***ROUTINES CALLED  DPCHST, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   811103  DATE WRITTEN
C   820201  1. Introduced  DPCHST  to reduce possible over/under-
C             flow problems.
C           2. Rearranged derivative formula for same reason.
C   820602  1. Modified end conditions to be continuous functions
C             of data when monotonicity switches in next interval.
C           2. Modified formulas so end conditions are less prone
C             of over/underflow problems.
C   820803  Minor cosmetic changes for release 1.
C   870707  Corrected XERROR calls for d.p. name(s).
C   870813  Updated Reference 1.
C   890206  Corrected XERROR calls.
C   890411  Added SAVE statements (Vers. 3.2).
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890703  Corrected category record.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920429  Revised format and order of references.  (WRB,FNF)
C***END PROLOGUE  DPCHIM
C  Programming notes:
C
C     1. The function  DPCHST(ARG1,ARG2)  is assumed to return zero if
C        either argument is zero, +1 if they are of the same sign, and
C        -1 if they are of opposite sign.
C     2. To produce a single precision version, simply:
C        a. Change DPCHIM to PCHIM wherever it occurs,
C        b. Change DPCHST to PCHST wherever it occurs,
C        c. Change all references to the Fortran intrinsics to their
C           single precision equivalents,
C        d. Change the double precision declarations to real, and
C        e. Change the constants ZERO and THREE to single precision.
C
C  DECLARE ARGUMENTS.
C
      INTEGER  N, INCFD, IERR
      DOUBLE PRECISION  X(*), F(INCFD,*), D(INCFD,*)
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER  I, NLESS1
      DOUBLE PRECISION  DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, DSAVE,
     *      H1, H2, HSUM, HSUMT3, THREE, W1, W2, ZERO
      SAVE ZERO, THREE
      DOUBLE PRECISION  DPCHST
      DATA  ZERO /0.D0/, THREE/3.D0/
C
C  VALIDITY-CHECK ARGUMENTS.
C
C***FIRST EXECUTABLE STATEMENT  DPCHIM
      IF ( N.LT.2 )  GO TO 5001
      IF ( INCFD.LT.1 )  GO TO 5002
      DO 1  I = 2, N
         IF ( X(I).LE.X(I-1) )  GO TO 5003
    1 CONTINUE
C
C  FUNCTION DEFINITION IS OK, GO ON.
C
      IERR = 0
      NLESS1 = N - 1
      H1 = X(2) - X(1)
      DEL1 = (F(1,2) - F(1,1))/H1
      DSAVE = DEL1
C
C  SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION.
C
      IF (NLESS1 .GT. 1)  GO TO 10
      D(1,1) = DEL1
      D(1,N) = DEL1
      GO TO 5000
C
C  NORMAL CASE  (N .GE. 3).
C
   10 CONTINUE
      H2 = X(3) - X(2)
      DEL2 = (F(1,3) - F(1,2))/H2
C
C  SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE
C     SHAPE-PRESERVING.
C
      HSUM = H1 + H2
      W1 = (H1 + HSUM)/HSUM
      W2 = -H1/HSUM
      D(1,1) = W1*DEL1 + W2*DEL2
      IF ( DPCHST(D(1,1),DEL1) .LE. ZERO)  THEN
         D(1,1) = ZERO
      ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO)  THEN
C        NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES.
         DMAX = THREE*DEL1
         IF (ABS(D(1,1)) .GT. ABS(DMAX))  D(1,1) = DMAX
      ENDIF
C
C  LOOP THROUGH INTERIOR POINTS.
C
      DO 50  I = 2, NLESS1
         IF (I .EQ. 2)  GO TO 40
C
         H1 = H2
         H2 = X(I+1) - X(I)
         HSUM = H1 + H2
         DEL1 = DEL2
         DEL2 = (F(1,I+1) - F(1,I))/H2
   40    CONTINUE
C
C        SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC.
C
         D(1,I) = ZERO
         IF ( DPCHST(DEL1,DEL2) )  42, 41, 45
C
C        COUNT NUMBER OF CHANGES IN DIRECTION OF MONOTONICITY.
C
   41    CONTINUE
         IF (DEL2 .EQ. ZERO)  GO TO 50
         IF ( DPCHST(DSAVE,DEL2) .LT. ZERO)  IERR = IERR + 1
         DSAVE = DEL2
         GO TO 50
C
   42    CONTINUE
         IERR = IERR + 1
         DSAVE = DEL2
         GO TO 50
C
C        USE BRODLIE MODIFICATION OF BUTLAND FORMULA.
C
   45    CONTINUE
         HSUMT3 = HSUM+HSUM+HSUM
         W1 = (HSUM + H1)/HSUMT3
         W2 = (HSUM + H2)/HSUMT3
         DMAX = MAX( ABS(DEL1), ABS(DEL2) )
         DMIN = MIN( ABS(DEL1), ABS(DEL2) )
         DRAT1 = DEL1/DMAX
         DRAT2 = DEL2/DMAX
         D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2)
C
   50 CONTINUE
C
C  SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE
C     SHAPE-PRESERVING.
C
      W1 = -H2/HSUM
      W2 = (H2 + HSUM)/HSUM
      D(1,N) = W1*DEL1 + W2*DEL2
      IF ( DPCHST(D(1,N),DEL2) .LE. ZERO)  THEN
         D(1,N) = ZERO
      ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO)  THEN
C        NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES.
         DMAX = THREE*DEL2
         IF (ABS(D(1,N)) .GT. ABS(DMAX))  D(1,N) = DMAX
      ENDIF
C
C  NORMAL RETURN.
C
 5000 CONTINUE
      RETURN
C
C  ERROR RETURNS.
C
 5001 CONTINUE
C     N.LT.2 RETURN.
      IERR = -1
      CALL XERMSG ('SLATEC', 'DPCHIM',
     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
      RETURN
C
 5002 CONTINUE
C     INCFD.LT.1 RETURN.
      IERR = -2
      CALL XERMSG ('SLATEC', 'DPCHIM', 'INCREMENT LESS THAN ONE', IERR,
     +   1)
      RETURN
C
 5003 CONTINUE
C     X-ARRAY NOT STRICTLY INCREASING.
      IERR = -3
      CALL XERMSG ('SLATEC', 'DPCHIM',
     +   'X-ARRAY NOT STRICTLY INCREASING', IERR, 1)
      RETURN
C------------- LAST LINE OF DPCHIM FOLLOWS -----------------------------
      END


module mod_debug
  use mpi
  use mod_common_mpi, only: myid,ierr
  use mod_param     , only: dims
  use mod_types
  implicit none
  private
  public chk_mean,chk_helmholtz
  contains
  subroutine chk_mean(n,grid_vol_ratio,p,mean)
    !
    ! compute the mean value of an observable over the entire domain
    !
    implicit none
    integer , intent(in), dimension(3) :: n
    real(rp), intent(in), dimension(0:) :: grid_vol_ratio
    real(rp), intent(in), dimension(0:,0:,0:) :: p
    real(rp), intent(out) :: mean
    integer :: i,j,k
    mean = 0.
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP SHARED(n,p,grid_vol_ratio) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP REDUCTION(+:mean)
    do k=1,n(3)
      do j=1,n(2)
        do i=1,n(1)
          mean = mean + p(i,j,k)*grid_vol_ratio(k)
        end do
      end do
    end do
    !$OMP END PARALLEL DO
    call mpi_allreduce(MPI_IN_PLACE,mean,1,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
  end subroutine chk_mean
  !
  subroutine chk_helmholtz(lo,hi,dli,dzci,dzfi,alpha,fp,fpp,bc,is_bound,c_or_f,diffmax)
    !
    ! this subroutine checks if the implementation of implicit diffusion is
    ! correct under sanity.f90
    !
    implicit none
    integer , intent(in), dimension(3) :: lo,hi
    real(rp), intent(in), dimension(2) :: dli
    real(rp), intent(in) :: alpha
    real(rp), intent(in), dimension(lo(3)-1:) :: dzfi,dzci
    real(rp), intent(in), dimension(lo(1)-1:,lo(2)-1:,lo(3)-1:) :: fp,fpp
    character(len=1), intent(in), dimension(0:1,3) :: bc
    character(len=1), intent(in), dimension(3) :: c_or_f
    logical         , intent(in), dimension(0:1,3) :: is_bound
    real(rp), intent(out) :: diffmax
    real(rp) :: val
    integer :: i,j,k
    integer :: idir
    integer, dimension(3) :: q
    q(:) = 0
    do idir = 1,3
      if(bc(1,idir).ne.'P'.and.c_or_f(idir) == 'f'.and.is_bound(1,idir)) q(idir) = 1
    end do
    select case(c_or_f(3))
    case('c')
      diffmax = 0.
      do k=lo(3),hi(3)-q(3)
        do j=lo(2),hi(2)-q(2)
          do i=lo(1),hi(1)-q(1)
            val =  fpp(i,j,k)+(1./alpha)*( &
                  (fpp(i+1,j,k)-2.*fpp(i,j,k)+fpp(i-1,j,k))*(dli(1)**2) + &
                  (fpp(i,j+1,k)-2.*fpp(i,j,k)+fpp(i,j-1,k))*(dli(2)**2) + &
                 ((fpp(i,j,k+1)-fpp(i,j,k  ))*dzci(k ) - &
                  (fpp(i,j,k  )-fpp(i,j,k-1))*dzci(k-1))*dzfi(k) )
            val = val*alpha
            diffmax = max(diffmax,abs(val-fp(i,j,k)))
            !if(abs(val-fp(i,j,k)) > 1.e-8) print*, 'Large difference : ', val-fp(i,j,k),i,j,k
          end do
        end do
      end do
    case('f')
      diffmax = 0.
      do k=lo(3),hi(3)-q(3)
        do j=lo(2),hi(2)-q(2)
          do i=lo(1),hi(1)-q(1)
            val =  fpp(i,j,k)+(1./alpha)*( &
                  (fpp(i+1,j,k)-2.*fpp(i,j,k)+fpp(i-1,j,k))*(dli(1)**2) + &
                  (fpp(i,j+1,k)-2.*fpp(i,j,k)+fpp(i,j-1,k))*(dli(2)**2) + &
                 ((fpp(i,j,k+1)-fpp(i,j,k  ))*dzfi(k+1) - &
                  (fpp(i,j,k  )-fpp(i,j,k-1))*dzfi(k ))*dzci(k) )
            val = val*alpha
            diffmax = max(diffmax,abs(val-fp(i,j,k)))
            !if(abs(val-fp(i,j,k)) > 1.e-8) print*, 'Large difference : ', val,fp(i,j,k),i,j,k
          end do
        end do
      end do
    end select
    call mpi_allreduce(MPI_IN_PLACE,diffmax,1,MPI_REAL_RP,MPI_MAX,MPI_COMM_WORLD,ierr)
  end subroutine chk_helmholtz
end module mod_debug


module nodal_smoothers_module

  use bl_constants_module
  use bc_functions_module
  use nodal_stencil_module

  implicit none

contains

  subroutine nodal_line_solve_1d(ss, uu, ff, mm, lo, ng)

    use tridiag_module, only: tridiag

    integer        , intent(in   ) :: lo(:),ng
    real(kind=dp_t), intent(in   ) :: ff(lo(1)-1:)
    real(kind=dp_t), intent(inout) :: uu(lo(1)-ng:)
    real(kind=dp_t), intent(in   ) :: ss(0:,lo(1):)
    integer        , intent(in   ) :: mm(lo(1):)

!   real(kind=dp_t)              :: dd
    real(kind=dp_t), allocatable :: a_ls(:), b_ls(:), c_ls(:), r_ls(:), u_ls(:)
    integer                      :: is, ie, ilen, i, hi(size(lo))

    hi = ubound(uu)-ng

    if (.not. bc_dirichlet(mm(lo(1)),1,0)) then
       is = lo(1)
    else
       is = lo(1)+1
    end if
    if (.not. bc_dirichlet(mm(hi(1)),1,0)) then
       ie = hi(1)
    else
       ie = hi(1)-1
    end if

    ilen = ie-is+1

    allocate(a_ls(0:ilen-1))
    allocate(b_ls(0:ilen-1))
    allocate(c_ls(0:ilen-1))
    allocate(r_ls(0:ilen-1))
    allocate(u_ls(0:ilen-1))

    do i = is,ie
      a_ls(i-is) = ss(2,i)
      b_ls(i-is) = ss(0,i)
      c_ls(i-is) = ss(1,i)
      r_ls(i-is) = ff(i)
    end do

    ! Adjust low end for Neumann boundary condition
    if (bc_neumann(mm(is),1,-1)) then
      c_ls(0) = 2.d0*c_ls(0)
    end if

    ! Adjust high end for Neumann boundary condition
    if (bc_neumann(mm(ie),1,1)) then
      a_ls(0) = 2.d0*a_ls(0)
    end if

    r_ls(0)      = r_ls(0)      - ss(2,is) * uu(is-1)
    r_ls(ilen-1) = r_ls(ilen-1) - ss(1,ie) * uu(ie+1)

    call tridiag(a_ls,b_ls,c_ls,r_ls,u_ls,ilen)

    do i = is, ie
       uu(i) = u_ls(i-is)
    end do

!   TESTING ONLY
!   i = lo(1)
!   if (.not. bc_dirichlet(mm(i),1,0)) then
!      dd = ss(0,i)*uu(i) + ss(1,i)*uu(i+1)
!      print *,'RES AT ',i, ff(i) - dd
!   end if

!   do i = lo(1)+1,hi(1)-1
!      dd = ss(0,i)*uu(i) + ss(1,i)*uu(i+1) + ss(2,i)*uu(i-1)
!      print *,'RES AT ',i, ff(i) - dd
!   end do

!   i = hi(1)
!   if (.not. bc_dirichlet(mm(i),1,0)) then
!      dd = ss(0,i)*uu(i) + ss(1,i)*uu(i+1) + ss(2,i)*uu(i-1)
!      print *,'RES AT ',i, ff(i) - dd
!   end if

    deallocate(a_ls,b_ls,c_ls,r_ls,u_ls)

  end subroutine nodal_line_solve_1d

  subroutine nodal_smoother_1d(ss, uu, ff, mm, lo, ng, red_black)
    integer, intent(in) :: lo(:)
    integer, intent(in) :: ng, red_black

    real (kind = dp_t), intent(in)    :: ff(lo(1)-1:)
    real (kind = dp_t), intent(inout) :: uu(lo(1)-ng:)
    real (kind = dp_t), intent(in)    :: ss(0:,lo(1):)
    integer            ,intent(in)    :: mm(lo(1):)
    real (kind = dp_t) :: dd
    integer :: i, hi(size(lo))

    real (kind = dp_t), parameter :: omega = 1.33_dp_t

    hi = ubound(uu)-ng

    ! Red/black
    do i = lo(1)+red_black,hi(1),2
       if ( .not. bc_dirichlet(mm(i),1,0) ) then
          dd = ss(0,i)*uu(i) + ss(1,i)*uu(i+1) + ss(2,i)*uu(i-1)
          uu(i) = uu(i) + (omega/ss(0,i)) * (ff(i) - dd)
       end if
    end do

  end subroutine nodal_smoother_1d

  subroutine nodal_smoother_2d(ss, uu, ff, mm, lo, ng, pmask, stencil_type, red_black)

    use bl_prof_module
    use impose_neumann_bcs_module

    integer, intent(in) :: ng
    integer, intent(in) :: lo(:)
    logical, intent(in) :: pmask(:)
    real (kind = dp_t), intent(in) :: ff(lo(1)-1:, lo(2)-1:)
    real (kind = dp_t), intent(inout) :: uu(lo(1)-ng:, lo(2)-ng:)
    real (kind = dp_t), intent(in) :: ss(0:,lo(1):,lo(2):)
    integer            ,intent(in) :: mm(lo(1):,lo(2):)
    integer            ,intent(in) :: stencil_type
    integer            ,intent(in) :: red_black

    integer            :: j, i, ipar, hi(size(lo))
    real (kind = dp_t) :: dd
    type(bl_prof_timer), save :: bpt

    call build(bpt, "nodal_smoother_2d")

    hi = ubound(uu)-ng

    call impose_neumann_bcs_2d(uu,mm,lo,ng)

    if ( stencil_type .eq. ND_DENSE_STENCIL ) then

       do j = lo(2),hi(2)
          do i = lo(1),hi(1)
             if ( .not. bc_dirichlet(mm(i,j),1,0) ) then
                dd =   ss(0,i,j) * uu(i  ,j  ) &
                     + ss(1,i,j) * uu(i-1,j-1) &
                     + ss(2,i,j) * uu(i  ,j-1) &
                     + ss(3,i,j) * uu(i+1,j-1) &
                     + ss(4,i,j) * uu(i-1,j  ) &
                     + ss(5,i,j) * uu(i+1,j  ) &
                     + ss(6,i,j) * uu(i-1,j+1) &
                     + ss(7,i,j) * uu(i  ,j+1) &
                     + ss(8,i,j) * uu(i+1,j+1)
                uu(i,j) = uu(i,j) + (one/ss(0,i,j)) * (ff(i,j) - dd)
             end if
          end do
       end do

    else if ( stencil_type .eq. ND_CROSS_STENCIL ) then

       ipar = 1-red_black
       do j = lo(2),hi(2)
          ipar = 1 - ipar
          do i = lo(1)+ipar,hi(1),2
             if ( .not. bc_dirichlet(mm(i,j),1,0) ) then
                dd =   ss(0,i,j) * uu(i  ,j ) &
                     + ss(2,i,j) * uu(i-1,j  ) + ss(1,i,j) * uu(i+1,j  ) &
                     + ss(4,i,j) * uu(i  ,j-1) + ss(3,i,j) * uu(i  ,j+1)
                uu(i,j) = uu(i,j) + (one/ss(0,i,j)) * (ff(i,j) - dd)
             end if
          end do
       end do

    else
      call bl_error('BAD STENCIL_TYPE IN NODAL_SMOOTHER ',stencil_type)
    end if

    call destroy(bpt)

  end subroutine nodal_smoother_2d

  subroutine nodal_smoother_3d(ss, uu, ff, mm, lo, ng, uniform_dh, pmask, stencil_type, red_black)

    use bl_prof_module
    use impose_neumann_bcs_module

    integer,            intent(in   ) :: ng
    integer,            intent(in   ) :: lo(:)
    logical,            intent(in   ) :: pmask(:)
    real (kind = dp_t), intent(in   ) :: ff(lo(1)-1:,lo(2)-1:,lo(3)-1:)
    real (kind = dp_t), intent(inout) :: uu(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:)
    real (kind = dp_t), intent(in   ) :: ss(0:,lo(1):,lo(2):,lo(3):)
    integer,            intent(in   ) :: mm(lo(1):,lo(2):,lo(3):)
    logical,            intent(in   ) :: uniform_dh
    integer            ,intent(in   ) :: stencil_type
    integer,            intent(in   ) :: red_black

    integer            :: i, j, k, ipar, hi(size(lo))
    logical            :: jface, kface, doit
    real (kind = dp_t) :: dd
    type(bl_prof_timer), save :: bpt

    call build(bpt, "nodal_smoother_3d")

    hi(1) = lo(1) + size(mm,dim=1)-1
    hi(2) = lo(2) + size(mm,dim=2)-1
    hi(3) = lo(3) + size(mm,dim=3)-1

    call impose_neumann_bcs_3d(uu,mm,lo,ng)

    if ( stencil_type .eq. ND_CROSS_STENCIL ) then

       !$OMP PARALLEL DO PRIVATE(k,ipar,j,i,dd,jface,kface,doit)
       do k = lo(3),hi(3)
          kface = .false. ; if ( (k.eq.lo(3)) .or. (k.eq.hi(3)) ) kface = .true.

          do j = lo(2),hi(2)
             jface = .false. ; if ( (j.eq.lo(2)) .or. (j.eq.hi(2)) ) jface = .true.

             ipar = MOD(j + k + red_black,2)

             do i = lo(1)+ipar,hi(1),2

                doit = .true.

                if ( jface .or. kface .or. (i.eq.lo(1)) .or. (i.eq.hi(1)) ) then
                   if ( bc_dirichlet(mm(i,j,k),1,0) ) doit = .false.
                end if

                if (doit) then
                   dd =   ss(0,i,j,k) * uu(i  ,j  ,k  ) &
                        + ss(2,i,j,k) * uu(i-1,j  ,k  ) + ss(1,i,j,k) * uu(i+1,j  ,k  ) &
                        + ss(4,i,j,k) * uu(i  ,j-1,k  ) + ss(3,i,j,k) * uu(i  ,j+1,k  ) &
                        + ss(6,i,j,k) * uu(i  ,j  ,k-1) + ss(5,i,j,k) * uu(i  ,j  ,k+1)

                   uu(i,j,k) = uu(i,j,k) + (one/ss(0,i,j,k)) * (ff(i,j,k) - dd)
                end if
             end do
          end do
       end do
     !$OMP END PARALLEL DO

    else if ( stencil_type .eq. ND_DENSE_STENCIL ) then
       !
       ! Gauss-Seidel.
       !
       do k = lo(3),hi(3)
          kface = .false. ; if ( (k.eq.lo(3)) .or. (k.eq.hi(3)) ) kface = .true.

          do j = lo(2),hi(2)
             jface = .false. ; if ( (j.eq.lo(2)) .or. (j.eq.hi(2)) ) jface = .true.

             do i = lo(1),hi(1)

                doit = .true.

                if ( jface .or. kface .or. (i.eq.lo(1)) .or. (i.eq.hi(1)) ) then
                   if ( bc_dirichlet(mm(i,j,k),1,0) ) doit = .false.
                end if

                if ( doit ) then
                   dd = ss(0,i,j,k)*uu(i,j,k) &
                        + ss( 1,i,j,k) * uu(i-1,j-1,k-1) + ss( 2,i,j,k) * uu(i  ,j-1,k-1) &
                        + ss( 3,i,j,k) * uu(i+1,j-1,k-1) + ss( 4,i,j,k) * uu(i-1,j  ,k-1) &
                        + ss( 5,i,j,k) * uu(i+1,j  ,k-1) + ss( 6,i,j,k) * uu(i-1,j+1,k-1) &
                        + ss( 7,i,j,k) * uu(i  ,j+1,k-1) + ss( 8,i,j,k) * uu(i+1,j+1,k-1) &
                        + ss( 9,i,j,k) * uu(i-1,j-1,k  ) + ss(10,i,j,k) * uu(i+1,j-1,k  ) &
                        + ss(11,i,j,k) * uu(i-1,j+1,k  ) + ss(12,i,j,k) * uu(i+1,j+1,k  ) &
                        + ss(13,i,j,k) * uu(i-1,j-1,k+1) + ss(14,i,j,k) * uu(i  ,j-1,k+1) &
                        + ss(15,i,j,k) * uu(i+1,j-1,k+1) + ss(16,i,j,k) * uu(i-1,j  ,k+1) &
                        + ss(17,i,j,k) * uu(i+1,j  ,k+1) + ss(18,i,j,k) * uu(i-1,j+1,k+1) &
                        + ss(19,i,j,k) * uu(i  ,j+1,k+1) + ss(20,i,j,k) * uu(i+1,j+1,k+1)

                   if ( (size(ss,dim=1) .eq. 27) .and. (.not. uniform_dh) ) then
                      !
                      ! Add faces (only non-zero for non-uniform dx)
                      !
                      dd = dd + &
                           ss(21,i,j,k) * uu(i-1,j  ,k  ) + ss(22,i,j,k) * uu(i+1,j  ,k  ) &
                           + ss(23,i,j,k) * uu(i  ,j-1,k  ) + ss(24,i,j,k) * uu(i  ,j+1,k  ) &
                           + ss(25,i,j,k) * uu(i  ,j  ,k-1) + ss(26,i,j,k) * uu(i  ,j  ,k+1)
                   end if

                   uu(i,j,k) = uu(i,j,k) + (one/ss(0,i,j,k)) * (ff(i,j,k) - dd)
                end if
             end do
          end do
       end do

    else
      call bl_error('BAD STENCIL_TYPE IN NODAL_SMOOTHER ',stencil_type)
    end if

    call destroy(bpt)

  end subroutine nodal_smoother_3d

  subroutine nodal_smoother_3d_opt(ss, uu, ff, mm, lo, ng, uniform_dh, pmask, &
                                   stencil_type, dx)

    use bl_prof_module
    use impose_neumann_bcs_module

    integer,            intent(in   ) :: ng
    integer,            intent(in   ) :: lo(:)
    logical,            intent(in   ) :: pmask(:)
    real (kind = dp_t), intent(in   ) :: ff(lo(1)-1:,lo(2)-1:,lo(3)-1:)
    real (kind = dp_t), intent(inout) :: uu(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:)
    real (kind = dp_t), intent(in   ) :: ss(0:,lo(1):,lo(2):,lo(3):)
    integer,            intent(in   ) :: mm(lo(1):,lo(2):,lo(3):)
    logical,            intent(in   ) :: uniform_dh
    integer            ,intent(in   ) :: stencil_type
    real (kind = dp_t), intent(in   ) :: dx(:)

    integer            :: i, j, k, hi(size(lo))
    logical            :: jface, kface, doit
    real (kind = dp_t) :: dd
    type(bl_prof_timer), save :: bpt

    call build(bpt, "nodal_smoother_3d")

    hi(1) = lo(1) + size(mm,dim=1)-1
    hi(2) = lo(2) + size(mm,dim=2)-1
    hi(3) = lo(3) + size(mm,dim=3)-1

    print *,'In nodal_smoother_3d_opt with dx ', dx(1)

    call impose_neumann_bcs_3d(uu,mm,lo,ng)

    if ( stencil_type .ne. ND_DENSE_STENCIL ) then
      call bl_error('Bad stencil_type in nodal_smoother_3d_opt: ',stencil_type)
    end if

    if ( .not. uniform_dh) then
      call bl_error('Want uniform_dh = true in nodal_smoother_3d_opt: ')
    end if

    !
    ! Gauss-Seidel.
    !
    do k = lo(3),hi(3)
       kface = .false. ; if ( (k.eq.lo(3)) .or. (k.eq.hi(3)) ) kface = .true.

       do j = lo(2),hi(2)
          jface = .false. ; if ( (j.eq.lo(2)) .or. (j.eq.hi(2)) ) jface = .true.

          do i = lo(1),hi(1)

             doit = .true.

             if ( jface .or. kface .or. (i.eq.lo(1)) .or. (i.eq.hi(1)) ) then
                if ( bc_dirichlet(mm(i,j,k),1,0) ) doit = .false.
             end if

                if ( doit ) then
                   dd = ss(0,i,j,k)*uu(i,j,k) &
                        + ss( 1,i,j,k) * uu(i-1,j-1,k-1) + ss( 2,i,j,k) * uu(i  ,j-1,k-1) &
                        + ss( 3,i,j,k) * uu(i+1,j-1,k-1) + ss( 4,i,j,k) * uu(i-1,j  ,k-1) &
                        + ss( 5,i,j,k) * uu(i+1,j  ,k-1) + ss( 6,i,j,k) * uu(i-1,j+1,k-1) &
                        + ss( 7,i,j,k) * uu(i  ,j+1,k-1) + ss( 8,i,j,k) * uu(i+1,j+1,k-1) &
                        + ss( 9,i,j,k) * uu(i-1,j-1,k  ) + ss(10,i,j,k) * uu(i+1,j-1,k  ) &
                        + ss(11,i,j,k) * uu(i-1,j+1,k  ) + ss(12,i,j,k) * uu(i+1,j+1,k  ) &
                        + ss(13,i,j,k) * uu(i-1,j-1,k+1) + ss(14,i,j,k) * uu(i  ,j-1,k+1) &
                        + ss(15,i,j,k) * uu(i+1,j-1,k+1) + ss(16,i,j,k) * uu(i-1,j  ,k+1) &
                        + ss(17,i,j,k) * uu(i+1,j  ,k+1) + ss(18,i,j,k) * uu(i-1,j+1,k+1) &
                        + ss(19,i,j,k) * uu(i  ,j+1,k+1) + ss(20,i,j,k) * uu(i+1,j+1,k+1)

                   uu(i,j,k) = uu(i,j,k) + (one/ss(0,i,j,k)) * (ff(i,j,k) - dd)
                end if
          end do
       end do
    end do

    call destroy(bpt)

  end subroutine nodal_smoother_3d_opt

end module nodal_smoothers_module


module laplacian
  use mpi
  use rokko
  use, intrinsic :: iso_c_binding
  implicit none
  integer :: comm
  integer :: private, nprocs, myrank
  integer(c_int), private :: dim, local_offset, num_local_rows
  integer(c_int), private :: start_row, end_row
  integer(c_int), private :: start_k, end_k
  logical, private :: is_first_proc, is_last_proc
  double precision, private :: buf_p = 0, buf_m = 0
  integer, private :: status_m(mpi_status_size), status_p(mpi_status_size)
contains
  subroutine initialize (mat, dim_in)
    type(rokko_distributed_mfree), intent(inout) :: mat
    integer(c_int), intent(in) :: dim_in
    integer :: ierr
    integer :: tmp, rem

    comm = mpi_comm_world
    call mpi_comm_rank(comm, myrank, ierr)
    call mpi_comm_size(comm, nprocs, ierr)
    dim = dim_in
    tmp = dim / nprocs
    rem = mod(dim, nprocs)
    num_local_rows = (dim + nprocs - myrank - 1) / nprocs
    start_row = tmp * myrank + min(rem, myrank) + 1  ! extra plus 1
    end_row = start_row + num_local_rows - 1 ! extra plus 1

    if (start_row == 1) then
       is_first_proc = .true.
    else
       is_first_proc = .false.
    endif

    if (end_row == dim) then
       is_last_proc = .true.
    else
       is_last_proc = .false.
    endif

    end_k = num_local_rows
    !print*, "myrank=", myrank, "start_row=", start_row, "end_row=", end_row,&
    !     "is_first_proc", is_first_proc, " is_last_proc", is_last_proc
    !print*, "myrank=", myrank, "num_local_rows=", num_local_rows
    call rokko_distributed_mfree_construct(mat, multiply, dim, num_local_rows)
  end subroutine initialize

  integer function get_num_local_rows ()
    get_num_local_rows = num_local_rows
  end function get_num_local_rows

  ! subroutine passed to c function.
  ! it must be interoperable!
  subroutine multiply (n, x, y) bind(c)
    implicit none
    integer(c_int), intent(in), value :: n
    double precision, intent(in) :: x(n)
    double precision, intent(out) :: y(n)
    integer :: ierr
    integer :: k

    if (num_local_rows == 0) then
       return
    endif

    if (.not.(is_first_proc) .and. (nprocs /= 1)) then
       !print*, "recv myrank=", myrank
       call mpi_send(x(1), 1, mpi_double_precision, myrank-1, 0, comm, ierr)
       call mpi_recv(buf_m, 1, mpi_double_precision, myrank-1, 0, comm, status_m, ierr)
    endif

    if (.not.(is_last_proc) .and. (nprocs /= 1)) then
       !print*, "send myrank=", myrank
       call mpi_recv(buf_p, 1, mpi_double_precision, myrank+1, 0, comm, status_p, ierr)
       call mpi_send(x(end_k), 1, mpi_double_precision, myrank+1, 0, comm, ierr)
    endif

    if (is_first_proc) then
       if (num_local_rows /= 1) then
          y(1) = x(1) - x(2)
          if (nprocs /= 1) then
             y(end_k) = - x(end_k - 1) + 2 * x(end_k) - buf_p
          endif
       else
          y(1) = x(1) - buf_p
       endif
    endif

    if (is_last_proc) then
       if (num_local_rows /= 1) then
          if (nprocs /= 1) then
             y(1) = - buf_m + 2 * x(1) - x(2)
          endif
          y(end_k) = 2 * x(end_k) - x(end_k - 1)
       else
          y(end_k) = 2 * x(end_k) - buf_m
       endif
    endif
    if (.not.(is_first_proc .or. is_last_proc)) then ! neither first or last process
       if (num_local_rows /= 1) then
          y(1) = - buf_m + 2 * x(1) - x(2)
          y(end_k) = - x(end_k - 1) + 2 * x(end_k) - buf_p
       else
          y(1) = - buf_m + 2 * x(1) - buf_p
       endif
    endif

    ! from 2 to end
    do k=2, end_k-1
       y(k) = - x(k-1) + 2 * x(k) - x(k+1)
    enddo
  end subroutine multiply
end module laplacian

program main
  use mpi
  use rokko
  use laplacian
  implicit none
  integer :: provided, ierr

  double precision :: eig_val
  double precision, allocatable, dimension(:) :: eig_vec

  type(rokko_parallel_sparse_solver) :: solver
  character(len=100) :: solver_name, tmp_str
  integer arg_len, status
  type(rokko_distributed_mfree) :: mat
  integer :: dim, i
  integer :: num_evals, block_size, max_iters
  integer :: num_local_rows, num_conv
  double precision :: tol
  double precision :: x(10), y(10)

  call mpi_init_thread(mpi_thread_multiple, provided, ierr)
  call mpi_comm_rank(comm, myrank, ierr)
  call mpi_comm_size(comm, nprocs, ierr)

  solver_name = "anasazi"  ! default
  dim = 10
  if (command_argument_count().ge.1) then
     call get_command_argument(1, tmp_str, arg_len, status)
     solver_name = trim(tmp_str)
  endif

  if (command_argument_count().eq.2) then
     call get_command_argument(2, tmp_str, arg_len, status)
     read(tmp_str, *) dim
  endif

  if (myrank == 0) then
     write(*,*) "solver name = ", trim(solver_name)
     write(*,*) "matrix dimension = ", dim
  endif

  call rokko_parallel_sparse_solver_construct(solver, solver_name)
  call initialize(mat, dim)

  num_evals = 3
  block_size = 5
  max_iters = 500
  tol = 1.0e-3
  !num_local_rows = get_num_local_rows()
  !do i=1, num_local_rows
  !   x = 0
  !   x(i) = 1
  !   call multiply(num_local_rows, x, y);
  !   print*, "y=", y
  !enddo
  call rokko_parallel_sparse_solver_diagonalize_distributed_mfree(solver, mat, num_evals, block_size, max_iters, tol)

  num_conv = rokko_parallel_sparse_solver_num_conv(solver)
  eig_val = rokko_parallel_sparse_solver_eigenvalue(solver, 0)
  num_local_rows = rokko_distributed_mfree_num_local_rows(mat)
  if (myrank == 0) then
     print*, "eigval=", eig_val
  endif
  call rokko_distributed_mfree_destruct(mat)
  call rokko_parallel_sparse_solver_destruct(solver)

  call mpi_finalize(ierr)
end program main


program main
    implicit none

    integer :: seed

    interface
        function get_seed(year_, mon_, day_, hour_, min_, sec_)
            implicit none

            integer, intent(in), optional :: year_, mon_, day_, hour_, min_, sec_
            integer :: get_seed
        end function get_seed
    end interface

    seed = get_seed()
    write(*,*) "Current seed value = ", seed
end program main

function get_seed(year_, mon_, day_, hour_, min_, sec_)
    implicit none

    integer, intent(in), optional :: year_, mon_, day_, hour_, min_, sec_
    integer :: get_seed

    character(10) :: b(3)
    integer :: date_time(8)
    integer :: i_y, i_m, i_d, i_h, i_n, i_s

    if ((present(year_)) .and. (present(mon_)) .and. (present(day_)) .and.&
        (present(hour_)) .and. (present(min_)) .and. (present(sec_))) then
        i_y = mod(year_, 100)
        i_m = mon_
        i_d = day_
        i_h = hour_
        i_n = min_
        i_s = sec_
    else
        call date_and_time(b(1), b(2), b(3), date_time)
        i_y = mod(date_time(1), 100)
        i_m = date_time(2)
        i_d = date_time(3)
        i_h = date_time(5)
        i_n = date_time(6)
        i_s = date_time(7)
    end if

    get_seed = i_y + 70 * (i_m + 12 * (i_d + 31 * (i_h + 23 * (i_n + 59 * i_s))))
    if (get_seed < 0) then
        get_seed = get_seed + 2**31
    end if
end function get_seed


      PROGRAM xeclazz
C     driver for routine eclazz
      LOGICAL equiv
      INTEGER N
      PARAMETER(N=15)
      INTEGER i,j,k,lclas,nclass,nf(N),nflag(N),nsav(N)
      EXTERNAL equiv
      call eclazz(nf,N,equiv)
      do 11 i=1,N
        nflag(i)=1
11    continue
      write(*,'(/1x,a)') 'Numbers from 1-15 divided according to'
      write(*,'(1x,a/)') 'their value modulo 4:'
      lclas=0
      do 13 i=1,N
        nclass=nf(i)
        if (nflag(nclass).ne.0) then
          nflag(nclass)=0
          lclas=lclas+1
          k=0
          do 12 j=i,N
            if (nf(j).eq.nf(i)) then
              k=k+1
              nsav(k)=j
            endif
12        continue
          write(*,'(1x,a,i2,a,3x,5i3)') 'Class',
     *         lclas,':',(nsav(j),j=1,k)
        endif
13    continue
      END
      LOGICAL FUNCTION equiv(i,j)
      INTEGER i,j
      equiv=.false.
      if (mod(i,4).eq.mod(j,4)) equiv=.true.
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xeclazz.for