module initial

implicit none

real :: pi, gam0

integer :: nr, nproc, nray=6
integer, private :: i, j, k

logical :: gauss = .true.

contains

subroutine lecture( nstep, imov, xp, yp, op, delta, idm, dt, nbpart )

namelist/donnees/nstep, dt, imov, amach, nray, delta

integer, parameter :: ix=0, jx=200, iy=0, jy=200
integer :: nstep, imov, idm, nbpart

real :: xp( idm ), yp( idm ), op( idm )
real :: rf( idm ), zf( idm ), gam( idm )

real :: circ, al, ur, tau, aom, u0, r0
real :: amach, gomeg, delta, dt

nstep = 1
dt    = 0.01
imov  = 1
amach = 0.1
nproc = 1
nray  = 6
delta = 0.01

open(10, file = "input" )
read(10,donnees)
close(10)

pi = 4. * atan(1.)
r0 = 0.5
u0 = amach

gam0   = u0 * 2.0 * pi / 0.7 * r0	!gaussienne
!gam0   = 2. * pi * r0 * u0		!constant
!gam0   = 2. * pi / 10.0

aom    = gam0 / ( pi * r0**2 )	!Amplitude du vortex
tau    = 8.0 * pi**2 / gam0	!Periode de co-rotation
gomeg  = gam0/ (4.0*pi)		!Vitesse angulaire
ur     = gomeg 			!Vitesse tangentielle du vortex
al     = 0.5 * tau 	 	!Longeur d'onde

write(*,*) " iterations : ", nstep
write(*,*) " pas de temps : ", dt
write(*,*) " animation : ", imov, " steps "
write(*,*) " aom = ", aom
write(*,*) " r0 = ", r0
write(*,*) " Circulation = ", gam0
write(*,*) " Vitesse de rotation gomeg = ", gomeg
write(*,*) " ur = ", ur
write(*,*) " periode de corotation = ", tau
write(*,*) " --------------------------------------------- "

call distrib( rf, zf, gam, r0, idm )

do k = 1, nr
   xp( k    ) = rf( k )
   yp( k    ) = zf( k ) + 1.
   op( k    ) = gam( k )
   xp( k+nr ) = rf( k )
   yp( k+nr ) = zf( k ) - 1.
   op( k+nr ) = gam( k )
end do
nbpart = 2 * nr

!Calcul de la vitesse de propagation du systeme

circ = sum(op(1:nr))

write(*,*) ' Nombre total de particules =',nbpart

end subroutine lecture

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

subroutine distrib(rf, zf, cir, ray, idm )

integer :: kd, nsec, nsec0, idm

real :: rf( * ), zf( * ), cir( * ), ds( idm )
real :: ssurf, q, sigma, teta, dss, r1, r2, s1, s2, eps
real :: gamt, sgam, dteta, surf, ray, dray, r, dr

pi    = 4.0 * atan( 1.0 )
nsec  = 6

!     rf,zf : position de la particule
!     ds    : taille de l'element de surface
!     cir   : circulation de la particule
!     dr    : pas d'espace dans la direction radiale
!     nray  : nb de pts ds la direction radiale.
!     dray  : rayon de la particule placee au centre
!     ray   : rayon de la section
!     gam0  : circulation totale
!     surf  : surface de la section
!     nsec  : nombre de points dans la premiere couronne

dr      = ray / ( nray + 0.5 )
dray    = 0.5 * dr	!rayon de la section centrale
surf    = pi * ray * ray
dteta   = 2.0 * pi / float( nsec)
gamt    = gam0 / ( 1. - exp( -1.0 ) ) ! total strength of gaussian vortex

k       = 1
rf(  1) = 0.0
zf(  1) = 0.0
ds(  1) = pi * dray * dray

if ( gauss ) then
   cir( 1) = gamt * ( 1.-exp(-(dray/ray)**2)) !gauss
else
   cir( 1) = gam0 * ds( 1 ) / surf   !uniforme
end if
sgam    = cir( 1 )

r1    = dray
s1    = pi * r1**2
nsec0 = nsec
nsec  = 0

!cpn   *** parametre de l'ellipse ***
!c      eps = 0.01		! 0.0 --> disque
      eps = 0.0
!cpn   ******************************

do i = 1, nray

   nsec  = nsec + nsec0
   dteta = 2.0 * pi / float(nsec)
   r     = float( i ) * dr

   r2  = r + 0.5 * dr
   s2  = pi * r2**2
   dss = s2 - s1
   s1  = s2

   do j = 1, nsec

      k = k + 1
      if( k .gt. idm ) stop ' !! idm < Nr !! '

      teta    = float( j ) * dteta
      sigma   = r * ( 1.0 + eps * cos( 2.0*teta ) )
      rf( k ) = sigma * cos( teta )
      zf( k ) = sigma * sin( teta )

      ds(  k ) = dss / float( nsec )

      if ( gauss ) then
         q       = 0.5 * (exp(-(r1/ray)**2)-exp(-(r2/ray)**2) )
         cir( k ) = gamt * dteta / pi * q	! gauss
      else
         cir( k ) = gam0 * ds( k ) / surf	! uniforme
      end if

      sgam     = sgam + cir( k )

    end do

    r1  = r2

    kd = k - nsec + 1

end do

nr = k

ssurf = 0.0
do i = 1, nr
   ssurf = ssurf + ds(i)
end do

write(*,*) 'Nb de pts sur la section :', nr,'(',idm,' max )'
write(*,*) 'surface theorique - pratique :', (surf),' - ',(ssurf)
if (gauss) then
   write(*,*) 'circulation theorique - pratique :',(gam0),' ; ',(sgam)
else
   write(*,*) 'circulation theorique - pratique :',(gam0),' ; ',(sgam)
end if

1000  format( F11.5, 2X, F11.5, 2X, F11.5, 1X, F11.5 )

end subroutine distrib

end module initial


c
c      read plane wave quadratures from file
c

      subroutine lreadall(eps,zk,nquad,cxs,cws,nfour,nphys,lw,ier)
c
cc        this subroutine computes lambda quadrature nodes and weights
c         for given helmholtz parameter and the number of terms
c         per lambda required in fourier and physical domains
c
c         input:
c         eps:   precision requested
c                  min precision possible is 0.5d-12
c
c
c         zk -      Helmholtz parameter
c                   currently code works for zk in
c                    [0.02,pi/2]+[0,0.02]i
c
c         lw -      length of various arrays sent to the routine
c
c         OUTPUT
c         nquad -    number of discretization nodes for lambda
c                    quadrature
c
c         cxs(nquad) -  complex *16, lambda quadrature nodes,
c                       cxs actually stores \sqrt(\lambda^2 - k^2)
c
c         cws(nquad) - complex *16, lambda quadrature weights
c
c         nfour(nquad) - integer, number of fourier modes required
c                        per lambda
c
c         nphys(nquad) - integer, number of physical modes required
c                        per lambda
c
c         ier - error code
c               ier = 0, no error, successful return of all parameters
c               ier = 16 if lw<nquad
c
c

        implicit real *8 (a-h,o-z)
        complex *16 cxs(*),cws(*),zk
        real *8 cx(100),cy(100),eps
        integer nfour(*),nphys(*)

        done = 1
        pi = atan(done)*4

c
        nnx=11
        nny=11
c
        cx(1)=0.00d0
        cx(2)=0.02d0
        cx(3)=0.04d0
        cx(4)=0.10d0
        cx(5)=0.20d0
        cx(6)=0.40d0
        cx(7)=1.00d0
        cx(8)=pi/2
        cx(9)=pi
        cx(10)=2*pi
        cx(11)=3*pi
        cx(12)=4*pi
        cx(13)=5*pi
        cx(14)=6*pi
        cx(15)=7*pi
        cx(16)=8*pi
        cx(17)=9*pi
        cx(18)=10*pi
        cx(19)=11*pi
        cx(20)=12*pi
        cx(21)=13*pi
        cx(22)=14*pi
        cx(23)=15*pi
        cx(24)=16*pi
c
        cy(1)=0.00d0
        cy(2)=0.02d0
        cy(3)=0.04d0
        cy(4)=0.10d0
        cy(5)=0.20d0
        cy(6)=0.40d0
        cy(7)=1.00d0
        cy(8)=pi/2
        cy(9)=pi
        cy(10)=2*pi
        cy(11)=3*pi
        cy(12)=4*pi
        cy(13)=5*pi
        cy(14)=6*pi
        cy(15)=7*pi
        cy(16)=8*pi
        cy(17)=9*pi
        cy(18)=10*pi
        cy(19)=11*pi
        cy(20)=12*pi
        cy(21)=13*pi
        cy(22)=14*pi
        cy(23)=15*pi
        cy(24)=16*pi

        ier = 0

        call hwts3getd(ier,zk,nnx,nny,cx,cy,iquad,ix,iy)

        iprec = 1
        if(eps.lt.0.5d-3) iprec = 2
        if(eps.lt.0.5d-6) iprec = 3
        if(eps.lt.0.5d-9) iprec = 4

        call hwts3(ier,iprec,zk,cxs,cws,nquad)

        if(nquad.gt.lw) then

        ier = 16
        call prin2('not enough memory for quad nodes=*',ier,1)
        stop

        endif

        call numphysfour(iprec,iquad,nquad,nphys,nfour)

        return
        end


      subroutine GSMCAMRPOP(
     &           phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,rhs
     &           ,irhslo0,irhslo1,irhslo2
     &           ,irhshi0,irhshi1,irhshi2
     &           ,icoloredboxlo0,icoloredboxlo1,icoloredboxlo2
     &           ,icoloredboxhi0,icoloredboxhi1,icoloredboxhi2
     &           ,dx
     &           ,alpha
     &           ,beta
     &           )
      implicit none
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2)
      integer irhslo0,irhslo1,irhslo2
      integer irhshi0,irhshi1,irhshi2
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           irhslo2:irhshi2)
      integer icoloredboxlo0,icoloredboxlo1,icoloredboxlo2
      integer icoloredboxhi0,icoloredboxhi1,icoloredboxhi2
      REAL*8 dx
      REAL*8 alpha
      REAL*8 beta
      REAL*8 lambda, dxinv, sum_b, lphi
      integer i,j,k
      integer idir
      dxinv = (1.0d0)/(dx*dx)
      sum_b = 0.0
      do idir = 0, 3 -1
         sum_b = sum_b + (2.0d0)*dxinv
      enddo
      lambda = (1.0d0)/(alpha - beta*sum_b)
      do k = icoloredBoxlo2,icoloredBoxhi2,2
      do j = icoloredBoxlo1,icoloredBoxhi1,2
      do i = icoloredBoxlo0,icoloredBoxhi0,2
        lphi =
     &     (    phi(i+1,j  ,k  )
     &     +    phi(i-1,j  ,k  )
     $     -(2.0d0)*phi(i  ,j  ,k  ))
     $     +(   phi(i  ,j+1,k  )
     &     +    phi(i  ,j-1,k  )
     $     -(2.0d0)*phi(i  ,j  ,k  ))
     $     +(   phi(i  ,j  ,k+1)
     &     +    phi(i  ,j  ,k-1)
     $     -(2.0d0)*phi(i  ,j  ,k  ))
        lphi = lphi*dxinv
        phi(i,j,k) =
     $       phi(   i,j,k) +
     &       lambda*(   rhs(   i,j,k) - lphi)
      enddo
      enddo
      enddo
      return
      end
      subroutine GSRBHELMHOLTZ(
     &           phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1,irhslo2
     &           ,irhshi0,irhshi1,irhshi2
     &           ,nrhscomp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,dx
     &           ,alpha
     &           ,beta
     &           ,redBlack
     &           )
      implicit none
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1,irhslo2
      integer irhshi0,irhshi1,irhshi2
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           irhslo2:irhshi2,
     &           0:nrhscomp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      REAL*8 dx
      REAL*8 alpha
      REAL*8 beta
      integer redBlack
      REAL*8 lambda, dxinv, sum_b, lphi, helmop
      integer i,j,k
      integer n,ncomp,idir,indtot,imin,imax
      dxinv = (1.0d0)/(dx*dx)
      sum_b = 0.0
      do idir = 0, 3 -1
         sum_b = sum_b + (2.0d0)*dxinv
      enddo
      lambda = -(1.0d0)/(alpha - beta*sum_b)
      ncomp = nphicomp
      if (ncomp .ne. nrhscomp) then
         call MAYDAYERROR()
      endif
      do n = 0, ncomp - 1
        do k=iregionlo2, iregionhi2
          do j=iregionlo1, iregionhi1
            imin = iregionlo0
            indtot = imin + j  + k
            imin = imin + abs(mod(indtot + redBlack, 2))
            imax = iregionhi0
            do i = imin, imax, 2
              lphi =   (phi(i+1,j,k,n)
     &             +    phi(i-1,j,k,n)
     &             +    phi(i,j+1,k,n)
     &             +    phi(i,j-1,k,n)
     &             +    phi(i,j,k+1,n)
     &             +    phi(i,j,k-1,n)
     &             -(2.0d0)*3*phi(i,j,k,n))*dxinv
              helmop = alpha*phi(i,j,k,n) + beta*lphi
              phi(i,j,k,n) = phi(i,j,k,n) +
     &             lambda*(helmop - rhs(i,j,k,n))
            enddo
          enddo
        enddo
      enddo
      return
      end
      subroutine GSRBLAPLACIAN(
     &           phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1,irhslo2
     &           ,irhshi0,irhshi1,irhshi2
     &           ,nrhscomp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,dx
     &           ,redBlack
     &           )
      implicit none
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1,irhslo2
      integer irhshi0,irhshi1,irhshi2
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           irhslo2:irhshi2,
     &           0:nrhscomp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      REAL*8 dx
      integer redBlack
      REAL*8 lambda, dxinv, sum_b, lphi, lap
      integer i,j,k
      integer n,ncomp,idir,indtot,imin,imax
      dxinv = (1.0d0)/(dx*dx)
      sum_b = 0.0
      do idir = 0, 3 -1
         sum_b = sum_b + (2.0d0)*dxinv
      enddo
      lambda = -(1.0d0)/sum_b
      ncomp = nphicomp
      if (ncomp .ne. nrhscomp) then
         call MAYDAYERROR()
      endif
      do n = 0, ncomp - 1
        do k=iregionlo2, iregionhi2
          do j=iregionlo1, iregionhi1
            imin = iregionlo0
            indtot = imin + j  + k
            imin = imin + abs(mod(indtot + redBlack, 2))
            imax = iregionhi0
            do i = imin, imax, 2
              lphi = (
     &                  phi(i+1,j,k,n)
     &             +    phi(i-1,j,k,n)
     &             +    phi(i,j+1,k,n)
     &             +    phi(i,j-1,k,n)
     &             +    phi(i,j,k+1,n)
     &             +    phi(i,j,k-1,n)
     &             ) * dxinv
              phi(i,j,k,n) = lambda*(rhs(i,j,k,n)-lphi)
            enddo
          enddo
        enddo
      enddo
      return
      end
      subroutine GSRBLAZY(
     &           phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,lphi
     &           ,ilphilo0,ilphilo1,ilphilo2
     &           ,ilphihi0,ilphihi1,ilphihi2
     &           ,rhs
     &           ,irhslo0,irhslo1,irhslo2
     &           ,irhshi0,irhshi1,irhshi2
     &           ,icoloredboxlo0,icoloredboxlo1,icoloredboxlo2
     &           ,icoloredboxhi0,icoloredboxhi1,icoloredboxhi2
     &           ,alpha
     &           ,beta
     &           ,dx
     &           )
      implicit none
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2)
      integer ilphilo0,ilphilo1,ilphilo2
      integer ilphihi0,ilphihi1,ilphihi2
      REAL*8 lphi(
     &           ilphilo0:ilphihi0,
     &           ilphilo1:ilphihi1,
     &           ilphilo2:ilphihi2)
      integer irhslo0,irhslo1,irhslo2
      integer irhshi0,irhshi1,irhshi2
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           irhslo2:irhshi2)
      integer icoloredboxlo0,icoloredboxlo1,icoloredboxlo2
      integer icoloredboxhi0,icoloredboxhi1,icoloredboxhi2
      REAL*8 alpha
      REAL*8 beta
      REAL*8 dx
      integer i,j,k, idir
      REAL*8 dxinv, sum_b, lambda
      dxinv = (1.0d0)/(dx*dx)
      sum_b = 0.0
      do idir = 0, 3 -1
         sum_b = sum_b + (2.0d0)*dxinv
      enddo
      lambda = -(1.0d0)/(alpha - beta*sum_b)
      do k = icoloredBoxlo2,icoloredBoxhi2,2
      do j = icoloredBoxlo1,icoloredBoxhi1,2
      do i = icoloredBoxlo0,icoloredBoxhi0,2
      phi(i,j,k) =
     $     phi(   i,j,k) -
     &     lambda*(
     $     rhs(   i,j,k) -
     $     lphi(  i,j,k))
      enddo
      enddo
      enddo
      return
      end
      subroutine AMRPMULTICOLOR(
     &           phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,rhs
     &           ,irhslo0,irhslo1,irhslo2
     &           ,irhshi0,irhshi1,irhshi2
     &           ,weight
     &           ,alpha
     &           ,beta
     &           ,dx
     &           ,icoloredboxlo0,icoloredboxlo1,icoloredboxlo2
     &           ,icoloredboxhi0,icoloredboxhi1,icoloredboxhi2
     &           )
      implicit none
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2)
      integer irhslo0,irhslo1,irhslo2
      integer irhshi0,irhshi1,irhshi2
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           irhslo2:irhshi2)
      REAL*8 weight
      REAL*8 alpha
      REAL*8 beta
      REAL*8 dx(0:2)
      integer icoloredboxlo0,icoloredboxlo1,icoloredboxlo2
      integer icoloredboxhi0,icoloredboxhi1,icoloredboxhi2
      integer i,j,k
      REAL*8 laplphi, dx0,dx1,dx2
      dx0 = beta/(dx(0) * dx(0))
                dx1 = beta/(dx(1) * dx(1))
                dx2 = beta/(dx(2) * dx(2))
      do k = icoloredBoxlo2,icoloredBoxhi2,2
      do j = icoloredBoxlo1,icoloredBoxhi1,2
      do i = icoloredBoxlo0,icoloredBoxhi0,2
        laplphi =
     &     (    phi(i+1,j  ,k  )
     &     +    phi(i-1,j  ,k  )
     $     -(2.0d0)*phi(i  ,j  ,k  ))*dx0
     $     +(   phi(i  ,j+1,k  )
     &     +    phi(i  ,j-1,k  )
     $     -(2.0d0)*phi(i  ,j  ,k  ))*dx1
     $     +(   phi(i  ,j  ,k+1)
     &     +    phi(i  ,j  ,k-1)
     $     -(2.0d0)*phi(i  ,j  ,k  ))*dx2
        laplphi = laplphi + alpha * phi(i,j,k)
        phi(i,j,k) = phi(i,j,k) +
     &     weight*(rhs(i,j,k) - laplphi)
      enddo
      enddo
      enddo
      return
      end
      subroutine OPERATORLAP(
     &           lofphi
     &           ,ilofphilo0,ilofphilo1,ilofphilo2
     &           ,ilofphihi0,ilofphihi1,ilofphihi2
     &           ,nlofphicomp
     &           ,phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,dx
     &           ,alpha
     &           ,beta
     &           )
      implicit none
      integer nlofphicomp
      integer ilofphilo0,ilofphilo1,ilofphilo2
      integer ilofphihi0,ilofphihi1,ilofphihi2
      REAL*8 lofphi(
     &           ilofphilo0:ilofphihi0,
     &           ilofphilo1:ilofphihi1,
     &           ilofphilo2:ilofphihi2,
     &           0:nlofphicomp-1)
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      REAL*8 dx
      REAL*8 alpha
      REAL*8 beta
      REAL*8 dxinv, lap
      integer n,ncomp
      integer i,j,k
      ncomp = nphicomp
      if (ncomp .ne. nlofphicomp) then
         call MAYDAYERROR()
      endif
      dxinv = (1.0d0)/(dx*dx)
      do n = 0, ncomp-1
      do k = iregionlo2,iregionhi2
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
          lap = (  phi(i+1,j  ,k  ,n)
     &                     + phi(i-1,j  ,k  ,n)
     &                     + phi(i  ,j+1,k  ,n)
     &                     + phi(i  ,j-1,k  ,n)
     &                     + phi(i  ,j  ,k+1,n)
     &                     + phi(i  ,j  ,k-1,n)
     &                     -(2*3)*phi(i,j,k,n) )
     &       * dxinv
          lofphi(i,j,k,n) = alpha*phi(i,j,k,n)+beta*lap
      enddo
      enddo
      enddo
      enddo
      return
      end
      subroutine OPERATORLAPRES(
     &           r
     &           ,irlo0,irlo1,irlo2
     &           ,irhi0,irhi1,irhi2
     &           ,nrcomp
     &           ,phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1,irhslo2
     &           ,irhshi0,irhshi1,irhshi2
     &           ,nrhscomp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,dx
     &           ,alpha
     &           ,beta
     &           )
      implicit none
      integer nrcomp
      integer irlo0,irlo1,irlo2
      integer irhi0,irhi1,irhi2
      REAL*8 r(
     &           irlo0:irhi0,
     &           irlo1:irhi1,
     &           irlo2:irhi2,
     &           0:nrcomp-1)
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1,irhslo2
      integer irhshi0,irhshi1,irhshi2
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           irhslo2:irhshi2,
     &           0:nrhscomp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      REAL*8 dx
      REAL*8 alpha
      REAL*8 beta
      REAL*8 dxinv, lap
      integer n,ncomp
      integer i,j,k
      ncomp = nphicomp
      dxinv = (1.0d0)/(dx*dx)
      do n = 0, ncomp-1
      do k = iregionlo2,iregionhi2
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
          lap = (  phi(i+1,j  ,k  ,n)
     &                     + phi(i-1,j  ,k  ,n)
     &                     + phi(i  ,j+1,k  ,n)
     &                     + phi(i  ,j-1,k  ,n)
     &                     + phi(i  ,j  ,k+1,n)
     &                     + phi(i  ,j  ,k-1,n)
     &                     -(2*3)*phi(i,j,k,n) )
     &       * dxinv
         r(i,j,k,n) = -alpha*phi(i,j,k,n) -beta*lap +
     &       rhs(i,j,k,n)
      enddo
      enddo
      enddo
      enddo
      return
      end
      subroutine RESTRICTRES(
     &           res
     &           ,ireslo0,ireslo1,ireslo2
     &           ,ireshi0,ireshi1,ireshi2
     &           ,nrescomp
     &           ,phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1,irhslo2
     &           ,irhshi0,irhshi1,irhshi2
     &           ,nrhscomp
     &           ,alpha
     &           ,beta
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,dx
     &           )
      implicit none
      integer nrescomp
      integer ireslo0,ireslo1,ireslo2
      integer ireshi0,ireshi1,ireshi2
      REAL*8 res(
     &           ireslo0:ireshi0,
     &           ireslo1:ireshi1,
     &           ireslo2:ireshi2,
     &           0:nrescomp-1)
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1,irhslo2
      integer irhshi0,irhshi1,irhshi2
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           irhslo2:irhshi2,
     &           0:nrhscomp-1)
      REAL*8 alpha
      REAL*8 beta
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      REAL*8 dx
      REAL*8 denom,dxinv,lofphi
      integer n,ncomp
      integer i,j,k
      integer ii,jj,kk
      ncomp = nphicomp
      dxinv = (1.0d0) / (dx*dx)
      denom = 2  *2  *2
      do n = 0, ncomp-1
      do k = iregionlo2,iregionhi2
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
          ii = i/2
          jj = j/2
          kk = k/2
          lofphi = alpha * phi(i,j,k,n)
     &           + beta  *
     &              ( phi(i+1,j  ,k  ,n)
     &                        + phi(i-1,j  ,k  ,n)
     &                        + phi(i  ,j+1,k  ,n)
     &                        + phi(i  ,j-1,k  ,n)
     &                        + phi(i  ,j  ,k+1,n)
     &                        + phi(i  ,j  ,k-1,n)
     &                        - phi(i  ,j  ,k  ,n) * 2 * 3
     &              ) * dxinv
          res(ii,jj,kk,n) = res(ii,jj,kk,n)
     &                            + (rhs(i,j,k,n) - lofphi) / denom
      enddo
      enddo
      enddo
      enddo
      return
      end
      subroutine PROLONG(
     &           phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,coarse
     &           ,icoarselo0,icoarselo1,icoarselo2
     &           ,icoarsehi0,icoarsehi1,icoarsehi2
     &           ,ncoarsecomp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,m
     &           )
      implicit none
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer ncoarsecomp
      integer icoarselo0,icoarselo1,icoarselo2
      integer icoarsehi0,icoarsehi1,icoarsehi2
      REAL*8 coarse(
     &           icoarselo0:icoarsehi0,
     &           icoarselo1:icoarsehi1,
     &           icoarselo2:icoarsehi2,
     &           0:ncoarsecomp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      integer m
      INTEGER ncomp, n
      integer i,j,k
      integer ii,jj,kk
      ncomp = nphicomp
      do n = 0, ncomp-1
      do k = iregionlo2,iregionhi2
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
          ii = i/m
          jj = j/m
          kk = k/m
          phi(i,j,k,n) =  phi(i,j,k,n) +
     &        coarse(ii,jj,kk,n)
      enddo
      enddo
      enddo
      enddo
      return
      end
      subroutine PROLONG_2(
     &           phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,coarse
     &           ,icoarselo0,icoarselo1,icoarselo2
     &           ,icoarsehi0,icoarsehi1,icoarsehi2
     &           ,ncoarsecomp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,m
     &           )
      implicit none
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer ncoarsecomp
      integer icoarselo0,icoarselo1,icoarselo2
      integer icoarsehi0,icoarsehi1,icoarsehi2
      REAL*8 coarse(
     &           icoarselo0:icoarsehi0,
     &           icoarselo1:icoarsehi1,
     &           icoarselo2:icoarsehi2,
     &           0:ncoarsecomp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      integer m
      INTEGER ncomp, n
      integer i,j,k
      integer offs(3)
      integer ic,jc,kc
      REAL*8 f0, den, fx(3)
      den = (1.0d0)/(4**3)
      fx(1) = (3.0d0)*den
      fx(2) = (3.0d0)**2*den
      fx(3) = (3.0d0)**3*den
      f0 = (1.0d0)*den
      ncomp = nphicomp
      do k = iregionlo2,iregionhi2
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
        ic = i/m
        jc = j/m
        kc = k/m
        offs(1) = 2*mod(i,2) - 1
        offs(2) = 2*mod(j,2) - 1
        offs(3) = 2*mod(k,2) - 1
        do n = 0, ncomp-1
          phi(i,j,k,n) = phi(i,j,k,n)
     $      + fx(3)*
     $        coarse(ic,jc,kc,n)
     $      + f0*coarse(ic+offs(1),jc+offs(2),kc+offs(3),n)
          phi(i,j,k,n) = phi(i,j,k,n)
     $      + fx(3 -1)*
     $        (
     $         coarse(ic+offs(1),jc,kc,n)
     $       + coarse(ic,jc+offs(2),kc,n)
     $       + coarse(ic,jc,kc+offs(3),n)  )
          phi(i,j,k,n) = phi(i,j,k,n)
     $      + fx(3 -2)*
     $        (
     $         coarse(ic+offs(1),jc+offs(2),kc,n)
     $       + coarse(ic,jc+offs(2),kc+offs(3),n)
     $       + coarse(ic+offs(1),jc,kc+offs(3),n)  )
        enddo
      enddo
      enddo
      enddo
      return
      end
      subroutine NEWGETFLUX(
     &           flux
     &           ,ifluxlo0,ifluxlo1,ifluxlo2
     &           ,ifluxhi0,ifluxhi1,ifluxhi2
     &           ,nfluxcomp
     &           ,phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,iboxlo0,iboxlo1,iboxlo2
     &           ,iboxhi0,iboxhi1,iboxhi2
     &           ,beta_dx
     &           ,a_idir
     &           )
      implicit none
      integer CHF_ID(0:5,0:5)
      data CHF_ID/ 1,0,0,0,0,0 ,0,1,0,0,0,0 ,0,0,1,0,0,0 ,0,0,0,1,0,0 ,0
     &,0,0,0,1,0 ,0,0,0,0,0,1 /
      integer nfluxcomp
      integer ifluxlo0,ifluxlo1,ifluxlo2
      integer ifluxhi0,ifluxhi1,ifluxhi2
      REAL*8 flux(
     &           ifluxlo0:ifluxhi0,
     &           ifluxlo1:ifluxhi1,
     &           ifluxlo2:ifluxhi2,
     &           0:nfluxcomp-1)
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer iboxlo0,iboxlo1,iboxlo2
      integer iboxhi0,iboxhi1,iboxhi2
      REAL*8 beta_dx
      integer a_idir
      INTEGER ncomp,n
      integer ii, jj, kk
      integer i , j , k
      ncomp = nphicomp
      ii = CHF_ID(a_idir, 0)
      jj = CHF_ID(a_idir, 1)
      kk = CHF_ID(a_idir, 2)
      do n = 0, ncomp-1
      do k = iboxlo2,iboxhi2
      do j = iboxlo1,iboxhi1
      do i = iboxlo0,iboxhi0
          flux(i,j,k,n) =
     &        (phi(i,j,k,n)-
     &         phi(i-ii,j-jj,k-kk,n))*beta_dx
      enddo
      enddo
      enddo
      enddo
      return
      end


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_pair_cover_cv( n, c1, gg1, c2, gg2, c, gg )

!  Given a pair of ellipsoids, E1 and E2, determine a third ellipsoid
!  E which covers E1 and E2.
!  E is defined by:  (x-c)^T * G * G^T * (x-c) <= 1, where the array gg
!  contains G in packed format.  Similarly for E1 and E2.
!  A = G * G^T, A1 = G1 * G1^T, A2 = G2 * G2^T

!  Method: c = (c1+c2)/2,  A = a * ( A1^{-1} + A2^{-1} + (c1-c2) * (c1-c2)^T /4 )^{-1},
!                          where a is as small as possible.

!  Note: this is a heuristic: E does not have minimal volume.

!  S.B. Pope  6/13/04,  5/14/07 (cv_max added)

implicit none

integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: c1(n), gg1((n*(n+1))/2), c2(n), gg2((n*(n+1))/2)
real(k_dp), intent(out) :: c(n),  gg((n*(n+1))/2)

real(k_dp), parameter   :: cv_add = 1.d-10  !  frac. amount to add to diag. of CV to avoid num. sing.
integer    :: i, j, k, info
real(k_dp) :: g1(n,n), g2(n,n), cv1(n,n), cv2(n,n), dc(n), &
              orig(n), c3(n), xf(n), rsq1, rsq2, cv_max

c    = 0.5d0 * ( c1 + c2 )
dc   = 0.5d0 * ( c1 - c2 )
orig = 0.d0

! unpack gg1 and gg2 into g1 and g2
k  = 0
g1 = 0.d0
g2 = 0.d0
do j = 1, n
   do i = j, n
      k = k + 1
	  g1(i,j) = gg1(k)
	  g2(i,j) = gg2(k)
   end do
end do

cv1 = g1
cv2 = g2

!  form covariances CV1 = (G1 * G1^T)^{-1}  and CV2
call dpotri( 'L', n, cv1, n, info )

if( info /= 0 ) then
   write(0,*)'ell_pair_cover_cv(1) dpotri failed for cv1: info = ', info
   stop
endif

call dpotri( 'L', n, cv2, n, info )

if( info /= 0 ) then
   write(0,*)'ell_pair_cover_cv(2) dpotri failed for cv2: info = ', info
   stop
endif

!  form CV = CV1 + CV2 + dc * dc^T

cv_max = 0.d0
do j = 1, n
   do i = j, n
      cv1(i,j) = cv1(i,j) + cv2(i,j) + dc(i) * dc(j)
   end do
   cv_max = max( cv1(j,j), cv_max )
end do

cv_max = cv_max * cv_add  !  amount to add to diagonal to avoid numerical singularity
do j = 1, n
   cv1(j,j) = cv1(j,j) + cv_max
end do

!  Cholesky decomp of CV
call dpotrf( 'L', n, cv1, n, info )

if( info /= 0 ) then
   write(0,*)'ell_pair_cover_cv(3) dpotrf failed for cv: info = ', info
   stop
endif

!  Inverse of CV
call dpotri( 'L', n, cv1, n, info )

if( info /= 0 ) then
   write(0,*)'ell_pair_cover_cv(4) dpotri failed: info = ', info
   stop
endif

!  G:  CV^{-1) = G * G^T
call dpotrf( 'L', n, cv1, n, info )

if( info /= 0 ) then
   write(0,*)'ell_pair_cover_cv(5) dpotrf failed for CV^{-1}: info = ', info
   stop
endif

!  Transform so that E is the unit ball, and find the furthest point on E1
c3 = c1 - c   ! c3 = G^T (c1 - c )
call dtrmv( 'L', 'T', 'N', n, cv1, n, c3, 1 )

! g1 = G^{-1} * G1
call dtrsm( 'L', 'L', 'N', 'N', n, n, 1.d0, cv1, n, g1, n )

call ellu_pt_near_far( 2, n, c3, g1, orig, xf )  !  xf is furthest point
rsq1 = sum( xf*xf )

!  Transform so that E is the unit ball, and find the furthest point on E2
c3 = c2 - c   ! c3 = G^T (c2 - c )
call dtrmv( 'L', 'T', 'N', n, cv1, n, c3, 1 )

! g2 = G^{-1} * G2
call dtrsm( 'L', 'L', 'N', 'N', n, n, 1.d0, cv1, n, g2, n )

call ellu_pt_near_far( 2, n, c3, g2, orig, xf )

rsq2 = sum( xf*xf )

rsq1 = max(rsq1,rsq2)
if( rsq1 > 0.d0 ) rsq1 = 1.d0 / sqrt( rsq1 )
k  = 0  !  pack re-scaled G into gg
do j = 1, n
   do i = j, n
      k = k + 1
	  gg(k) = rsq1 * cv1(i,j)
   end do
end do

return
end subroutine ell_pair_cover_cv


module netlib
!$$$  module documentation block
!
! module: netlib                       Compute eigenvalues and eigenvectors
!                                      of real symmetric matrix
!
! prgmmr: ota              org: np22                   date: 2011-06-03
!
! abstract: Compute eigenvalues and eigenvectors of real symmetric matrix.
!  Basic algorithm and source code are imported from netlib.org libraries
!  and transcripted to f90.
!
! program history log:
!   2011-06-03  Created from netlib.org
!
! attributes:
!   language: f95
!
!$$$

  use kinds,only: i_kind,r_double

  implicit none

  private
  public :: rs

contains

  real(r_double) function pythag(a,b)
    implicit none
    real(r_double) :: a,b
!
!     finds dsqrt(a**2+b**2) without overflow or destructive underflow
!
    real(r_double) :: p,r,s,t,u
    p = dmax1(dabs(a),dabs(b))
    if (p /= 0._r_double) then
       r = (dmin1(dabs(a),dabs(b))/p)**2
       do
          t = 4._r_double + r
          if (t == 4._r_double) exit
          s = r/t
          u = 1._r_double + 2._r_double*s
          p = u*p
          r = (s/u)**2 * r
       end do
    end if
    pythag = p
    return
  end function pythag

  subroutine rs(nm,n,a,w,matz,z,fv1,fv2,ierr)
    implicit none
    integer(i_kind),intent(in) :: n,nm,matz
    real(r_double),intent(inout) :: a(nm,n)
    integer(i_kind),intent(out) :: ierr
    real(r_double),intent(out) :: w(n),z(nm,n),fv1(n),fv2(n)
!
!     this subroutine calls the recommended sequence of
!     subroutines from the eigensystem subroutine package (eispack)
!     to find the eigenvalues and eigenvectors (if desired)
!     of a real symmetric matrix.
!
!     on input
!
!        nm  must be set to the row dimension of the two-dimensional
!        array parameters as declared in the calling program
!        dimension statement.
!
!        n  is the order of the matrix  a.
!
!        a  contains the real symmetric matrix.
!
!        matz  is an integer variable set equal to zero if
!        only eigenvalues are desired.  otherwise it is set to
!        any non-zero integer for both eigenvalues and eigenvectors.
!
!     on output
!
!        w  contains the eigenvalues in ascending order.
!
!        z  contains the eigenvectors if matz is not zero.
!
!        ierr  is an integer output variable set equal to an error
!           completion code described in the documentation for tqlrat
!           and tql2.  the normal completion code is zero.
!
!        fv1  and  fv2  are temporary storage arrays.
!
!     questions and comments should be directed to burton s. garbow,
!     mathematics and computer science div, argonne national laboratory
!
!     this version dated august 1983.
!
!     ------------------------------------------------------------------
!
    if (n > nm) then
       ierr = 10 * n
       return
    end if
!     .......... find both eigenvalues and eigenvectors ..........
    call  tred2(nm,n,a,w,fv1,z)
    call  tql2(nm,n,w,fv1,z,ierr)
    return
  end subroutine rs

  subroutine tql2(nm,n,d,e,z,ierr)
    implicit none
    integer(i_kind),intent(in) :: nm,n
    real(r_double),intent(inout) :: d(n),e(n),z(nm,n)
    integer(i_kind),intent(out) :: ierr
    real(r_double) :: c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2
    integer(i_kind) :: i,j,k,l,m,ii,l1,l2,mml
!
!     this subroutine is a translation of the algol procedure tql2,
!     num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and
!     wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 227-240(1971).
!
!     this subroutine finds the eigenvalues and eigenvectors
!     of a symmetric tridiagonal matrix by the ql method.
!     the eigenvectors of a full symmetric matrix can also
!     be found if  tred2  has been used to reduce this
!     full matrix to tridiagonal form.
!
!     on input
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement.
!
!        n is the order of the matrix.
!
!        d contains the diagonal elements of the input matrix.
!
!        e contains the subdiagonal elements of the input matrix
!          in its last n-1 positions.  e(1) is arbitrary.
!
!        z contains the transformation matrix produced in the
!          reduction by  tred2, if performed.  if the eigenvectors
!          of the tridiagonal matrix are desired, z must contain
!          the identity matrix.
!
!      on output
!
!        d contains the eigenvalues in ascending order.  if an
!          error exit is made, the eigenvalues are correct but
!          unordered for indices 1,2,...,ierr-1.
!
!        e has been destroyed.
!
!        z contains orthonormal eigenvectors of the symmetric
!          tridiagonal (or full) matrix.  if an error exit is made,
!          z contains the eigenvectors associated with the stored
!          eigenvalues.
!
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 30 iterations.
!
!     calls pythag for  dsqrt(a*a + b*b) .
!
!     questions and comments should be directed to burton s. garbow,
!     mathematics and computer science div, argonne national laboratory
!
!     this version dated august 1983.
!
!     ------------------------------------------------------------------
!
    ierr = 0
    if (n == 1) return
!
    do i = 2, n
       e(i-1) = e(i)
    end do
!
    f = 0._r_double
    tst1 = 0._r_double
    e(n) = 0._r_double
!
    do l = 1, n
       j = 0
       h = dabs(d(l)) + dabs(e(l))
       if (tst1 < h) tst1 = h
!     .......... look for small sub-diagonal element ..........
       do m = l, n
          tst2 = tst1 + dabs(e(m))
          if (tst2 == tst1) exit
!     .......... e(n) is always zero, so there is no exit
!                through the bottom of the loop ..........
       end do
!
       if (m /= l) then
          if (j == 30) then
             ierr = l
             return
          end if
          j = j + 1
!     .......... form shift ..........
          l1 = l + 1
          l2 = l1 + 1
          g = d(l)
          p = (d(l1) - g) / (2._r_double * e(l))
          r = pythag(p,1._r_double)
          d(l) = e(l) / (p + dsign(r,p))
          d(l1) = e(l) * (p + dsign(r,p))
          dl1 = d(l1)
          h = g - d(l)
          if (l2 <= n) then
!
             do i = l2, n
                d(i) = d(i) - h
             end do
          end if
!
          f = f + h
!     .......... ql transformation ..........
          p = d(m)
          c = 1._r_double
          c2 = c
          el1 = e(l1)
          s = 0._r_double
          mml = m - l
!     .......... for i=m-1 step -1 until l do -- ..........
          do ii = 1, mml
             c3 = c2
             c2 = c
             s2 = s
             i = m - ii
             g = c * e(i)
             h = c * p
             r = pythag(p,e(i))
             e(i+1) = s * r
             s = e(i) / r
             c = p / r
             p = c * d(i) - s * g
             d(i+1) = h + s * (c * g + s * d(i))
!     .......... form vector ..........
             do k = 1, n
                h = z(k,i+1)
                z(k,i+1) = s * z(k,i) + c * h
                z(k,i) = c * z(k,i) - s * h
             end do
!
          end do
!
          p = -s * s2 * c3 * el1 * e(l) / dl1
          e(l) = s * p
          d(l) = c * p
          tst2 = tst1 + dabs(e(l))
          if (tst2 > tst1) then
             if (j == 30) then
                ierr = l
                return
             end if
          end if
       end if
       d(l) = d(l) + f
    end do
!     .......... order eigenvalues and eigenvectors ..........
    do ii = 2, n
       i = ii - 1
       k = i
       p = d(i)
!
       do j = ii, n
          if (d(j) >= p) exit
          k = j
          p = d(j)
       end do
!
       if (k == i) exit
       d(k) = d(i)
       d(i) = p
!
       do j = 1, n
          p = z(j,i)
          z(j,i) = z(j,k)
          z(j,k) = p
       end do
!
    end do
!     .......... set error -- no convergence to an
!                eigenvalue after 30 iterations ..........
    return
  end subroutine tql2

  subroutine tred2(nm,n,a,d,e,z)
    implicit none
    integer(i_kind),intent(in) :: nm,n
    real(r_double),intent(inout) :: a(nm,n)
    real(r_double),intent(out) :: d(n),e(n),z(nm,n)
    real(r_double) :: f,g,h,hh,scale
    integer(i_kind) :: i,j,k,l,ii,jp1
!
!     this subroutine is a translation of the algol procedure tred2,
!     num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 212-226(1971).
!
!     this subroutine reduces a real symmetric matrix to a
!     symmetric tridiagonal matrix using and accumulating
!     orthogonal similarity transformations.
!
!     on input
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement.
!
!        n is the order of the matrix.
!
!        a contains the real symmetric input matrix.  only the
!          lower triangle of the matrix need be supplied.
!
!     on output
!
!        d contains the diagonal elements of the tridiagonal matrix.
!
!        e contains the subdiagonal elements of the tridiagonal
!          matrix in its last n-1 positions.  e(1) is set to zero.
!
!        z contains the orthogonal transformation matrix
!          produced in the reduction.
!
!        a and z may coincide.  if distinct, a is unaltered.
!
!     questions and comments should be directed to burton s. garbow,
!     mathematics and computer science div, argonne national laboratory
!
!     this version dated august 1983.
!
!     ------------------------------------------------------------------
!
    do i = 1, n
!
       do j = i, n
          z(j,i) = a(j,i)
       end do
!
       d(i) = a(n,i)
    end do
!
    if (n /= 1) then
!     .......... for i=n step -1 until 2 do -- ..........
       do ii = 2, n
          i = n + 2 - ii
          l = i - 1
          h = 0._r_double
          scale = 0._r_double
          if (l < 2) go to 130
!     .......... scale row (algol tol then not needed) ..........
          do k = 1, l
             scale = scale + dabs(d(k))
          end do
!
          if (scale /= 0._r_double) go to 140
130       e(i) = d(l)
!
          do j = 1, l
             d(j) = z(l,j)
             z(i,j) = 0._r_double
             z(j,i) = 0._r_double
          end do
!
          go to 290
!
140       do k = 1, l
             d(k) = d(k) / scale
             h = h + d(k) * d(k)
          end do
!
          f = d(l)
          g = -dsign(dsqrt(h),f)
          e(i) = scale * g
          h = h - f * g
          d(l) = f - g
!     .......... form a*u ..........
          do j = 1, l
             e(j) = 0._r_double
          end do
!
          do j = 1, l
             f = d(j)
             z(j,i) = f
             g = e(j) + z(j,j) * f
             jp1 = j + 1
             if (l >= jp1) then
!
                do k = jp1, l
                   g = g + z(k,j) * d(k)
                   e(k) = e(k) + z(k,j) * f
                end do
             end if
!
             e(j) = g
          end do
!     .......... form p ..........
          f = 0._r_double
!
          do j = 1, l
             e(j) = e(j) / h
             f = f + e(j) * d(j)
          end do
!
          hh = f / (h + h)
!     .......... form q ..........
          do j = 1, l
             e(j) = e(j) - hh * d(j)
          end do
!     .......... form reduced a ..........
          do j = 1, l
             f = d(j)
             g = e(j)
!
             do k = j, l
                z(k,j) = z(k,j) - f * e(k) - g * d(k)
             end do
!
             d(j) = z(l,j)
             z(i,j) = 0._r_double
          end do
!
290       d(i) = h
       end do
!     .......... accumulation of transformation matrices ..........
       do i = 2, n
          l = i - 1
          z(n,l) = z(l,l)
          z(l,l) = 1._r_double
          h = d(i)
          if (h /= 0._r_double) then
!
             do k = 1, l
                d(k) = z(k,i) / h
             end do
!
             do j = 1, l
                g = 0._r_double
!
                do k = 1, l
                   g = g + z(k,i) * z(k,j)
                end do
!
                do k = 1, l
                   z(k,j) = z(k,j) - g * d(k)
                end do
             end do
!
          end if
          do k = 1, l
             z(k,i) = 0._r_double
          end do
!
       end do
    end if
!
    do i = 1, n
       d(i) = z(n,i)
       z(n,i) = 0._r_double
    end do
!
    z(n,n) = 1._r_double
    e(1) = 0._r_double
    return
  end subroutine tred2
end module netlib


program middelperiode
implicit none
real  hs, tp, gamma, omega, b,s,a, omegap,f, k, integral
integer n
real, parameter :: pi=3.1415

hs = 12
tp = 10
gamma = 3
b = 3
n = 100
S = 0
a = 0
omegap = 2.0*pi / tp
f = 0
k = calk(pi, hs, tp, gamma)
write(*,*)'k fra program  er:', k
call fcal(omegap,k,a,b,n,f)
write(*,*)'f fra program  er:', f
tz = tc(a,b,hs,f,pi,n)
write(*,*) 'Tz fra programmet er: ', tz

end program


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE PLANE3 (COORD, NUMNP, DIST, DISTR, NDIM, P1, P2, TOLER,
     *   NODEL, SORTYP, MAP, SORUP, INUM, OPT, SELECT)
      DIMENSION COORD (NUMNP,*), DIST(*), DISTR(*), P1(*), P2(*),
     *   TOLER(*), MAP(*)
      CHARACTER*(*) NODEL, SORTYP, OPT
      LOGICAL SORUP, SELECT(*), ISABRT
      include 'nu_io.blk'

      CALL LOCOUT ('PLANE', NDIM, NODEL, TOLER, SORTYP, P1, P2, ' ')

      A = P2(1)
      B = P2(2)
      C = P2(3)
      D = A * P1(1) + B * P1(2) + C * P1(3)

      TEMP = TOLER(1)
      TOLER(1) = MAX(0.0, TEMP - TOLER(2))
      TOLER(2) = MAX(0.0, TEMP + TOLER(2))

      DO 10 I=1, NUMNP
         IF (SELECT(I)) THEN
            X0 = COORD(I,1)
            Y0 = COORD(I,2)
            Z0 = COORD(I,3)
            DIST(I) = ABS(A * X0 + B * Y0 + C * Z0 - D) /
     *         SQRT(A**2 + B**2 + C**2)
            DISTR(I)=(X0 - P1(1))**2 + (Y0 - P1(2))**2 + (Z0 - P1(3))**2
         END IF
   10 CONTINUE

      INUM = 0
      DISMIN = 1.0E30
      DO 20 I=1, NUMNP
         IF (SELECT(I)) THEN
            DISMIN = MIN(DIST(I), ABS(DISMIN-TEMP))
            IF (DIST(I) .GE. TOLER(1) .AND. DIST(I) .LE. TOLER(2)) THEN
               INUM = INUM + 1
               MAP(INUM) = I
            END IF
         END IF
   20 CONTINUE

      IF      (SORTYP .EQ. 'X') THEN
         CALL INDEXX (COORD(1,1), MAP, INUM, .FALSE.)
      ELSE IF (SORTYP .EQ. 'Y') THEN
         CALL INDEXX (COORD(1,2), MAP, INUM, .FALSE.)
      ELSE IF (SORTYP .EQ. 'Z') THEN
         CALL INDEXX (COORD(1,3), MAP, INUM, .FALSE.)
      ELSE IF (SORTYP .EQ. 'RADIAL') THEN
         CALL INDEXX (DISTR,      MAP, INUM, .FALSE.)
      ELSE IF (SORTYP .EQ. 'DISTANCE') THEN
         CALL INDEXX (DIST,       MAP, INUM, .FALSE.)
      END IF

      IF (SORUP) THEN
         IBEG = 1
         IEND = INUM
         IINC = 1
      ELSE
         IBEG = INUM
         IEND = 1
         IINC = -1
      END IF

      IF (OPT .EQ. '*' .OR. INDEX(OPT, 'P') .GT. 0) THEN
         DO 30 IO=IOMIN, IOMAX
            WRITE (IO, 40) NODEL
   30    CONTINUE
   40    FORMAT (/,T50,'DISTANCE',/2X,A8,T16,'X',T26,'Y',T36,'Z',
     *      T45,'NORMAL',T57,'RADIAL',/)
         DO 60 IN = IBEG, IEND, IINC
            IF (ISABRT()) RETURN
            I = MAP(IN)
            DO 50 IO=IOMIN, IOMAX
               WRITE (IO, 90) I, (COORD(I,J),J=1,3), DIST(I),
     *            SQRT(DISTR(I))
   50       CONTINUE
   60    CONTINUE
         IF (INUM .EQ. 0) THEN
            DO 70 IO=IOMIN, IOMAX
               WRITE (IO, 80) DISMIN
   70       CONTINUE
         END IF
      END IF
   80 FORMAT (/' None found within tolerance, minimum distance = ',
     *   1PE12.3,/)
   90 FORMAT (I10, 3(F10.4), 2(1PE12.3))
      RETURN
      END


! =====================================================
subroutine rpn2(ixy,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,fwave,s,amdq,apdq)
! =====================================================
!     # Adjoint Riemann solver for the acoustics equations in 2d, with varying
!     # material properties rho and kappa

!     waves: 2
!     equations: 3
!     aux fields: 2

!     Conserved quantities:
!       1 pressure
!       2 x_momentum
!       3 y_momentum

!     Auxiliary variables:
!         1  density
!         2  sound_speed

!     # Note that although there are 3 eigenvectors, the second eigenvalue
!     # is always zero and so we only need to compute 2 waves.
!     #
!     # solve Riemann problems along one slice of data.

!     # On input, ql contains the state vector at the left edge of each cell
!     #           qr contains the state vector at the right edge of each cell

!     # Here it is assumed that auxl=auxr gives the cell values.

!     # This data is along a slice in the x-direction if ixy=1
!     #                            or the y-direction if ixy=2.
!     # On output, wave contains the waves,
!     #            s the speeds,
!     #            amdq the  left-going flux difference  A^- \Delta q
!     #            apdq the right-going flux difference  A^+ \Delta q

!     # Note that the i'th Riemann problem has left state qr(i-1,:)
!     #                                    and right state ql(i,:)
!     # From the basic clawpack routines, this routine is called with ql = qr

    implicit double precision (a-h,o-z)

    dimension fwave(meqn, mwaves, 1-mbc:maxm+mbc)
    dimension    s(mwaves, 1-mbc:maxm+mbc)
    dimension   ql(meqn, 1-mbc:maxm+mbc)
    dimension   qr(meqn, 1-mbc:maxm+mbc)
    dimension apdq(meqn, 1-mbc:maxm+mbc)
    dimension amdq(meqn, 1-mbc:maxm+mbc)
    dimension auxl(maux, 1-mbc:maxm+mbc)
    dimension auxr(maux, 1-mbc:maxm+mbc)

!     local arrays
!     ------------
    dimension delta(3)

!     # set mu to point to  the component of the system that corresponds
!     # to velocity in the direction of this slice, mv to the orthogonal
!     # velocity:

    if (ixy == 1) then
        mu = 2
        mv = 3
    else
        mu = 3
        mv = 2
    endif

!     # note that notation for u and v reflects assumption that the
!     # Riemann problems are in the x-direction with u in the normal
!     # direciton and v in the orthogonal direcion, but with the above
!     # definitions of mu and mv the routine also works with ixy=2
!     # in which case waves come from the
!     # Riemann problems u_t + g(u)_y = 0 in the y-direction.

!     # split the jump in f(q) at each interface into waves
!     # The jump is split into a leftgoing wave traveling at speed -c
!     # relative to the material properties to the left of the interface,
!     # and a rightgoing wave traveling at speed +c
!     # relative to the material properties to the right of the interface,

!     # find b1 and b2, the coefficients of the 2 eigenvectors:
    do 20 i = 2-mbc, mx+mbc
!       # material properties

!        # impedances:
        zi = auxl(1,i)*auxl(2,i)
        zim = auxr(1,i-1)*auxr(2,i-1)

!       # sound speed
        ci = auxl(2,i)
        cim = auxr(2,i-1)

!       # density
        rhoi = auxl(1,i)
        rhoim = auxr(1,i-1)

!       # bulk modulus
        bulki = rhoi*ci**2
        bulkim = rhoim*cim**2

!       # f-wave splitting
        delta(1) = -(ql(mu,i)/rhoi - qr(mu,i-1)/rhoim)
        delta(2) = -(bulki*ql(1,i) - bulkim*qr(1,i-1))

        beta1 = (zi*delta(1) + delta(2)) / (zi+zim)
        beta2 = (zim*delta(1) - delta(2)) / (zi+zim)

!       # Compute the waves. Eigenvectors switched for adjoint:

        fwave(1,1,i) = beta1
        fwave(mu,1,i) = beta1*zim
        fwave(mv,1,i) = 0.d0
        s(1,i) = -cim

        fwave(1,2,i) = beta2
        fwave(mu,2,i) = -beta2*zi
        fwave(mv,2,i) = 0.d0
        s(2,i) = ci

    20 END DO

!     # compute the leftgoing and rightgoing flux differences:
!     # Note s(i,1) < 0   and   s(i,2) > 0.

!   # f-wave splitting, so do not multiply by wave speeds:
    forall (m=1:meqn,  i=2-mbc: mx+mbc)
    amdq(m,i) = fwave(m,1,i)
    apdq(m,i) = fwave(m,2,i)
    end forall

    return
    end subroutine rpn2


subroutine mv(m,nc,irp,ja,val,x,ldx,y,ldy,acc)
  use iso_fortran_env
  implicit none

  integer, parameter  :: ipk_ = int32
  integer, parameter  :: spk_   = real32
  complex(spk_), parameter   :: czero=(0.0_spk_,0.0_spk_)

  integer(ipk_), intent(in)      :: m,ldx,ldy,nc,irp(*),ja(*)
  complex(spk_), intent(in)      :: x(ldx,*),val(*)
  complex(spk_), intent(inout)   :: y(ldy,*)
  complex(spk_), intent(inout)   :: acc(*)
  integer(ipk_) :: i,j,k, ir, jc

  do i=1,m
    acc(1:nc)  = czero
    do j=irp(i), irp(i+1)-1
      acc(1:nc)  = acc(1:nc) + val(j) * x(ja(j),1:nc)
    enddo
    y(i,1:nc) = -acc(1:nc)
  end do

end subroutine mv


SUBROUTINE SEDI_FLUX(DIR,HH2,PP1,PP2,SXP,QQ1,SXQ)
    USE TEST
    USE FLOATPRECISION
    USE PARAMETERS
    USE DEPTH
    USE ARRAYSIZE
    IMPLICIT NONE
    CHARACTER*1                         :: DIR
    REAL(FP) , DIMENSION(:,:) , POINTER :: HH2 , PP1 , PP2 , SXP , QQ1 , SXQ
    INTEGER                             :: I , J , I1 , I2 , J1 , J2
    REAL(FP)                            :: H0 , H1, P0 , Q0 , POW1 , MAN3

    POW1 = 11.D0/2.D0
    MAN3 = MANNING**3

    IF(DIR=='X') THEN

        DO I = ML+1 , MU-1
            LPJ1:DO J = NL , NU-1
                P0 = 0.5D0*(PP1(I,J)+PP2(I,J))
                IF(    P0>0.D0) THEN
                    H0 = HH2(I,J)
                    H1 = HH2(I,J+1)
                ELSEIF(P0<0.D0) THEN
                    H0 = HH2(I,J+1)
                    H1 = HH2(I,J)
                ELSEIF(P0==0.D0)THEN
                    SXP(I,J) = 0.D0
                    CYCLE LPJ1
                END IF
                IF(H0>=DCRI.AND.H1>=DCRI) THEN
                    SXP(I,J) = 0.05D0*P0**5/SQRT(GRA)/MAN3/H0**POW1/REDY**2/D50
                ELSEIF(H0<DCRI.OR.H1<DCRI) THEN
                    SXP(I,J) = 0.D0
                ELSE
                    WRITE(*,*) 'ERROR FROM SEDIMENT_FLUX SUBROUTINE'
                    PAUSE
                END IF
                IF(DABS(SXP(I,J))>100.D0) THEN
                    WRITE(*,*) 'p' , I , J
                    WRITE(*,*) CD2
                    WRITE(*,*) P0 , H0
                    WRITE(*,*) CD2
                    WRITE(*,*) DIR
                    EVOGO = .FALSE.
                    CALL OUTPUT('CRI_','.DEP',CD2,DEP0,ML,MU,1,NL,NU,1)
                    PAUSE
                END IF
            END DO LPJ1
        END DO
        ! 136906
        DO J = NL+1 , NU-1
            LPJ2:DO I = ML , MU-1
                Q0 = QQ1(I,J)
                IF(    Q0>0.D0) THEN
                    H0 = HH2(I,J)
                    H1 = HH2(I+1,J)
                ELSEIF(Q0<0.D0) THEN
                    H0 = HH2(I+1,J)
                    H1 = HH2(I,J)
                ELSEIF(Q0==0.D0)THEN
                    SXQ(I,J) = 0.D0
                    CYCLE LPJ2
                END IF
                IF(H0>=DCRI.AND.H1>=DCRI) THEN
                    SXQ(I,J) = 0.05D0*Q0**5/SQRT(GRA)/MAN3/H0**POW1/REDY**2/D50
                ELSEIF(H0<DCRI.OR.H1<DCRI) THEN
                    SXQ(I,J) = 0.D0
                ELSE
                    WRITE(*,*) 'ERROR FROM SEDIMENT_FLUX SUBROUTINE'
                    PAUSE
                END IF
                IF(DABS(SXQ(I,J))>100.D0) THEN
                    WRITE(*,*) 'q',I , J
                    WRITE(*,*) CD2
                    WRITE(*,*) Q0 , H0
                    WRITE(*,*) CD2
                    WRITE(*,*) DIR
                    EVOGO = .FALSE.
                    CALL OUTPUT('CRI_','.DEP',CD2,DEP0,ML,MU,1,NL,NU,1)
                    PAUSE
                END IF
            END DO LPJ2
        END DO

    ELSEIF(DIR=='Y') THEN

        DO I = ML+1 , MU-1
            LPJ3:DO J = NL , NU-1
                Q0 = QQ1(I,J)
                IF(    Q0>0.D0) THEN
                    H0 = HH2(I,J)
                    H1 = HH2(I,J+1)
                ELSEIF(Q0<0.D0) THEN
                    H0 = HH2(I,J+1)
                    H1 = HH2(I,J)
                ELSEIF(Q0==0.D0)THEN
                    SXQ(I,J) = 0.D0
                    CYCLE LPJ3
                END IF
                IF(H0>=DCRI.AND.H1>=DCRI) THEN
                    SXQ(I,J) = 0.05D0*Q0**5/SQRT(GRA)/MAN3/H0**POW1/REDY**2/D50
                ELSEIF(H0<DCRI.OR.H1<DCRI) THEN
                    SXQ(I,J) = 0.D0
                ELSE
                    WRITE(*,*) 'ERROR FROM SEDIMENT_FLUX SUBROUTINE'
                    PAUSE
                END IF
                IF(DABS(SXQ(I,J))>100.D0) THEN
                    WRITE(*,*) 'p' , I , J
                    WRITE(*,*) CD2
                    WRITE(*,*) Q0 , H0
                    WRITE(*,*) CD2
                    WRITE(*,*) DIR
                    EVOGO = .FALSE.
                    CALL OUTPUT('CRI_','.DEP',CD2,DEP0,ML,MU,1,NL,NU,1)
                    PAUSE
                END IF
            END DO LPJ3
        END DO

        DO J = NL+1 , NU-1
            LPJ4:DO I = ML , MU-1
                P0 = 0.5D0*(PP2(I,J)+PP1(I,J))
                IF(    P0>0.D0) THEN
                    H0 = HH2(I,J)
                    H1 = HH2(I+1,J)
                ELSEIF(P0<0.D0) THEN
                    H0 = HH2(I+1,J)
                    H1 = HH2(I,J)
                ELSEIF(P0==0.D0)THEN
                    SXP(I,J) = 0.D0
                    CYCLE LPJ4
                END IF
                IF(H0>=DCRI.AND.H1>=DCRI) THEN
                    SXP(I,J) = 0.05D0*P0**5/SQRT(GRA)/MAN3/H0**POW1/REDY**2/D50
                ELSEIF(H0<DCRI.OR.H1<DCRI) THEN
                    SXP(I,J) = 0.D0
                ELSE
                    WRITE(*,*) 'ERROR FROM SEDIMENT_FLUX SUBROUTINE'
                    PAUSE
                END IF
               IF(DABS(SXP(I,J))>100.D0) THEN
                    WRITE(*,*) 'q', I , J
                    WRITE(*,*) CD2
                    WRITE(*,*) P0 , H0
                    WRITE(*,*) CD2
                    WRITE(*,*) DIR
                    EVOGO = .FALSE.
                    CALL OUTPUT('CRI_','.DEP',CD2,DEP0,ML,MU,1,NL,NU,1)
                    PAUSE
                END IF
            END DO LPJ4
        END DO

    END IF

END SUBROUTINE SEDI_FLUX


      subroutine ch_rtmusk

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine routes a daily flow through a reach using the
!!    Muskingum method

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ch_d(:)     |m             |average depth of main channel
!!    ch_n(2,:)   |none          |Manning"s "n" value for the main channel
!!    ch_s(2,:)   |m/m           |average slope of main channel
!!    chside(:)   |none          |change in horizontal distance per unit
!!                               |change in vertical distance on channel side
!!                               |slopes; always set to 2 (slope=1/2)
!!    flwin(:)    |m^3 H2O       |flow into reach on previous day
!!    flwout(:)   |m^3 H2O       |flow out of reach on previous day
!!    i           |none          |current day of simulation
!!    pet_day     |mm H2O        |potential evapotranspiration
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    flwin(:)    |m^3 H2O       |flow into reach on current day
!!    flwout(:)   |m^3 H2O       |flow out of reach on current day
!!    rcharea     |m^2           |cross-sectional area of flow
!!    rchdep      |m             |depth of flow on day
!!    rtevp       |m^3 H2O       |evaporation from reach on day
!!    rttime      |hr            |reach travel time
!!    rttlc       |m^3 H2O       |transmission losses from reach on day
!!    rtwtr       |m^3 H2O       |water leaving reach on day
!!    sdti        |m^3/s         |average flow on day in reach
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    c           |none          |inverse of channel side slope
!!    c1          |
!!    c2          |
!!    c3          |
!!    c4          |m^3 H2O       |
!!    det         |hr            |time step (24 hours)
!!    jrch        |none          |reach number
!!    nn          |              |number of subdaily computation points for stable
!!                               |routing in the muskingum routing method
!!    p           |m             |wetted perimeter
!!    rh          |m             |hydraulic radius
!!    tbase       |none          |flow duration (fraction of 24 hr)
!!    topw        |m             |top width of main channel
!!    vol         |m^3 H2O       |volume of water in reach at beginning of
!!                               |day
!!    wtrin       |m^3 H2O       |water entering reach on day
!!    xkm         |hr            |storage time constant for the reach on
!!                               |current day
!!    yy          |none          |variable to hold intermediate calculation
!!                               |value
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Sqrt
!!    SWAT: Qman

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

!!    code provided by Dr. Valentina Krysanova, Pottsdam Institute for
!!    Climate Impact Research, Germany
!!    Modified by Balaji Narasimhan
!!    Spatial Sciences Laboratory, Texas A&M University

      use basin_module
      use channel_data_module
      use channel_module
      use hydrograph_module, only : ob, icmd, jrch
      use time_module
      use channel_velocity_module

      implicit none

      integer :: nn        !none              |number of subdaily computation points for stable
                           !                  |routing in the muskingum routing method
      integer :: ii        !none              |counter
      integer :: i         !none              |current day of simulation
      real :: xkm          !hr                |storage time constant for the reach on
                           !                  |current day
      real :: det          !hr                |time step (24 hours)
      real :: yy           !none              |variable to hold intermediate calculation
                           !                  |value
      real :: c1           !units             |description
      real :: c2           !units             |description
      real :: c3           !units             |description
      real :: c4           !m^3 H2O           |
      real :: p            !m                 |wetted perimeter
      real :: vol          !m^3 H2O           |volume of water in reach at beginning of
                           !                  |day
      real :: c            !none              |inverse of channel side slope
      real :: rh           !m                 |hydraulic radius
      real :: topw         !m                 |top width of main channel
      real :: msk1         !units             |description
      real :: msk2         !units             |description
      real :: detmax       !units             |description
      real :: detmin       !units             |description
      real :: qinday       !units             |description
      real :: qoutday      !units             |description
	  real :: volrt        !units             |description
      real :: maxrt        !units             |description
      real :: adddep       !units             |description
      real :: addp         !units             |description
      real :: addarea      !units             |description
	  real :: rttlc1       !units             |description
      real :: rttlc2       !units             |description
      real :: rtevp1       !units             |description
      real :: rtevp2       !units             |description
      real :: qman         !m^3/s or m/s      |flow rate or flow velocity
      real :: vc           !m/s               |flow velocity in reach
      real :: aaa          !units             |description
      real :: sum_rttlc    !                  |           !! Van Tam Nguyen 10/2018
      real :: sum_rtevp    !                  |           !! Van Tam Nguyen 10/2018

      qinday = 0; qoutday = 0
      det = 24.
      sum_rttlc = 0.0   !! Van Tam Nguyen 10/2018
      sum_rtevp = 0.0   !! Van Tam Nguyen 10/2018
      ch(jrch)%chfloodvol = 0.

!! Water entering reach on day

!! Compute storage time constant for reach (msk_co1 + msk_co2 = 1.)
	msk1 = bsn_prm%msk_co1 / (bsn_prm%msk_co1 + bsn_prm%msk_co2)
	msk2 = bsn_prm%msk_co2 / (bsn_prm%msk_co1 + bsn_prm%msk_co2)
	bsn_prm%msk_co1 = msk1
	bsn_prm%msk_co2 = msk2
    xkm = ch_vel(jrch)%wid_btm * bsn_prm%msk_co1 + ch_vel(jrch)%stor_dis_1bf * bsn_prm%msk_co1

!! Muskingum numerical stability -Jaehak Jeong, 2011
!! Check numerical stability
      detmax = 2.* xkm * (1.- bsn_prm%msk_x)
      detmin = 2.* xkm * bsn_prm%msk_x

!! Discretize time interval to meet the stability criterion
      if (det>detmax) then
        if (det/2.<=detmax) then
            det = 12; nn = 2
        elseif (det/4.<=detmax) then
            det = 6; nn = 4
        else
            det = 1; nn = 24
        endif
      else
        det = 24; nn = 1
      end if

 !! Inflow during a subdaily time interval
      wtrin = wtrin / nn

!! Iterate for the day
      do ii=1,nn

 !! calculate volume of water in reach
         vol = wtrin + ch(jrch)%rchstor

!! Find average flowrate in a subdaily time interval
         volrt = vol / (86400. / nn)

!! Find maximum flow capacity of the channel at bank full
      c = ch_hyd(jhyd)%side
	  p = ch_vel(jrch)%wid_btm + 2. * ch_hyd(jhyd)%d * Sqrt(1. + c * c)
	  rh = ch_vel(jrch)%area / p
	  maxrt = Qman(ch_vel(jrch)%area, rh, ch_hyd(jhyd)%n, ch_hyd(jhyd)%s)

      sdti = 0.
	rchdep = 0.
	p = 0.
	rh = 0.
	vc = 0.

!! If average flowrate is greater than than the channel capacity at bank full
!! then simulate flood plain flow else simulate the regular channel flow
      if (volrt > maxrt) then
	  rcharea =ch_vel(jrch)%area
	  rchdep = ch_hyd(jhyd)%d
	  p = ch_vel(jrch)%wid_btm + 2. * ch_hyd(jhyd)%d * Sqrt(1. + c * c)
	  rh = ch_vel(jrch)%area / p
	  sdti = maxrt
	  adddep = 0
	!! find the crossectional area and depth for volrt
	!! by iteration method at 1cm interval depth
	!! find the depth until the discharge rate is equal to volrt
	  Do While (sdti < volrt)
          adddep = adddep + 0.01
          addarea = rcharea + ((ch_hyd(jhyd)%w * 5) + 4 * adddep) *      &
                                                         adddep
          addp = p + (ch_hyd(jhyd)%w * 4) + 2. * adddep *                &
                                                     Sqrt(1. + 4 * 4)
	    rh = addarea / addp
          sdti = Qman(addarea, rh, ch_hyd(jhyd)%n, ch_hyd(jhyd)%s)
	  end do
	  rcharea = addarea
	  rchdep = ch_hyd(jhyd)%d + adddep
	  p = addp
	  sdti = volrt
    ! store floodplain water that can be used by riparian HRU"s [Ann van Griensven]
        ch(jrch)%chfloodvol = (volrt - maxrt)* 86400 * rt_delt
	else
	!! find the crossectional area and depth for volrt
	!! by iteration method at 1cm interval depth
	!! find the depth until the discharge rate is equal to volrt
	  Do While (sdti < volrt)
	    rchdep = rchdep + 0.01
	    rcharea = (ch_vel(jrch)%wid_btm + c * rchdep) * rchdep
	    p = ch_vel(jrch)%wid_btm + 2. * rchdep * Sqrt(1. + c * c)
	    rh = rcharea / p
	    sdti = Qman(rcharea, rh, ch_hyd(jhyd)%n, ch_hyd(jhyd)%s)
	  end do
	  sdti = volrt
	end if

!! calculate top width of channel at water level
         if (rchdep <= ch_hyd(jhyd)%d) then
           topw = ch_vel(jrch)%wid_btm + 2. * rchdep * c
         else
           topw = 5 * ch_hyd(jhyd)%w + 2. *(rchdep - ch_hyd(jhyd)%d) * 4.
         end if

      if (sdti > 0) then

!! calculate velocity and travel time
        vc = sdti / rcharea
        ch(jrch)%vel_chan = vc
	    rttime = ch_hyd(jhyd)%l * 1000. / (3600. * vc)

!! Compute coefficients
      yy = 2. * xkm * (1. - bsn_prm%msk_x) + det
      c1 = (det - 2. * xkm * bsn_prm%msk_x) / yy
      c2 = (det + 2. * xkm * bsn_prm%msk_x) / yy
      c3 = (2. * xkm * (1. - bsn_prm%msk_x) - det) / yy
      c4 = 0.

!! Compute water leaving reach on day
	   if (time%yrs == 1 .and. time%day == time%day_start) then
	     ch(jrch)%flwin = ch(jrch)%rchstor
	     ch(jrch)%flwout = ch(jrch)%rchstor
	   end if

       rtwtr = c1 * wtrin + c2 * ch(jrch)%flwin + c3 * ch(jrch)%flwout
	   if (rtwtr < 0.) rtwtr = 0.

	rtwtr = Min(rtwtr, (wtrin + ch(jrch)%rchstor))

!! calculate amount of water in channel at end of day
      ch(jrch)%rchstor = ch(jrch)%rchstor + wtrin - rtwtr
!! Add if statement to keep rchstor from becoming negative
      if (ch(jrch)%rchstor < 0.0) ch(jrch)%rchstor = 0.0

!! transmission and evaporation losses are proportionally taken from the
!! channel storage and from volume flowing out

       !! calculate transmission losses
	  rttlc = 0.

	  if (rtwtr > 0.) then

	!!  Total time in hours to clear the water

      rttlc = det * ch_hyd(jhyd)%k * ch_hyd(jhyd)%l * p
	  rttlc2 = rttlc * ch(jrch)%rchstor / (rtwtr + ch(jrch)%rchstor)

	    if (ch(jrch)%rchstor <= rttlc2) then
	      rttlc2 = min(rttlc2, ch(jrch)%rchstor)
	      ch(jrch)%rchstor = ch(jrch)%rchstor - rttlc2
	      rttlc1 = rttlc - rttlc2
	      if (rtwtr <= rttlc1) then
	        rttlc1 = min(rttlc1, rtwtr)
	        rtwtr = rtwtr - rttlc1
	      else
	        rtwtr = rtwtr - rttlc1
	      end if
	    else
	      ch(jrch)%rchstor = ch(jrch)%rchstor - rttlc2
	      rttlc1 = rttlc - rttlc2
	      if (rtwtr <= rttlc1) then
	        rttlc1 = min(rttlc1, rtwtr)
	        rtwtr = rtwtr - rttlc1
	      else
	        rtwtr = rtwtr - rttlc1
	      end if
	    end if
	  rttlc = rttlc1 + rttlc2

	  sum_rttlc = sum_rttlc + rttlc    !! Van Tam Nguyen 10/2018
        end if

        !! calculate evaporation
	  rtevp = 0.
       if (rtwtr > 0.) then

          aaa = bsn_prm%evrch * pet_ch / (1000. * nn) !! Van Tam Nguyen 10/2018

	      if (rchdep <= ch_hyd(jhyd)%d) then
               rtevp = aaa * ch_hyd(jhyd)%l * 1000. * topw
	      else
		      if (aaa <=  (rchdep - ch_hyd(jhyd)%d)) then
                 rtevp = aaa * ch_hyd(jhyd)%l * 1000. * topw
	         else
	           rtevp = (rchdep - ch_hyd(jhyd)%d)
	           rtevp = rtevp + (aaa - (rchdep - ch_hyd(jhyd)%d))
                 topw = ch_vel(jrch)%wid_btm + 2. * ch_hyd(jhyd)%d * c
	           rtevp = rtevp * ch_hyd(jhyd)%l * 1000. * topw
	         end if
	      end if

	    rtevp2 = rtevp * ch(jrch)%rchstor / (rtwtr + ch(jrch)%rchstor)

	      if (ch(jrch)%rchstor <= rtevp2) then
	         rtevp2 = min(rtevp2, ch(jrch)%rchstor)
	         ch(jrch)%rchstor = ch(jrch)%rchstor - rtevp2
	         rtevp1 = rtevp - rtevp2
	         if (rtwtr <= rtevp1) then
	           rtevp1 = min(rtevp1, rtwtr)
	           rtwtr = rtwtr - rtevp1
	         else
	           rtwtr = rtwtr - rtevp1
	         end if
	      else
	         ch(jrch)%rchstor = ch(jrch)%rchstor - rtevp2
	         rtevp1 = rtevp - rtevp2
	         if (rtwtr <= rtevp1) then
	           rtevp1 = min(rtevp1, rtwtr)
	           rtwtr = rtwtr - rtevp1
	         else
	           rtwtr = rtwtr - rtevp1
	         end if
	      end if
	      rtevp = rtevp1 + rtevp2
         end if
         sum_rtevp = sum_rtevp + rtevp  !! Van Tam Nguyen 10/2018
!! define flow parameters for current iteration
         ch(jrch)%flwin = 0.
         ch(jrch)%flwout = 0.
         ch(jrch)%flwin = wtrin
         ch(jrch)%flwout = rtwtr

!! define flow parameters for current day
         qinday = qinday + wtrin
         qoutday = qoutday + rtwtr

!! total outflow for the day
      rtwtr = qoutday

      else
        rtwtr = 0.
        sdti = 0.
	  ch(jrch)%rchstor = 0.
	  ch(jrch)%vel_chan = 0.
        ch(jrch)%flwin = 0.
        ch(jrch)%flwout = 0.
      end if

      end do

      rttlc = sum_rttlc          !! Van Tam Nguyen 10/2018
      rtevp = sum_rtevp          !! Van Tam Nguyen 10/2018

      if (rtwtr < 0.) rtwtr = 0.
      if (ch(jrch)%rchstor < 0.) ch(jrch)%rchstor = 0.

      if (ch(jrch)%rchstor < 10.) then
        rtwtr = rtwtr + ch(jrch)%rchstor
        ch(jrch)%rchstor = 0.
      end if

      return
      end subroutine ch_rtmusk


      FUNCTION BESSJ(N,X)
      PARAMETER (IACC=40,BIGNO=1.E10,BIGNI=1.E-10)
      IF(N.LT.2)PAUSE 'bad argument N in BESSJ'
      TOX=2./X
      IF(X.GT.FLOAT(N))THEN
        BJM=BESSJ0(X)
        BJ=BESSJ1(X)
        DO 11 J=1,N-1
          BJP=J*TOX*BJ-BJM
          BJM=BJ
          BJ=BJP
11      CONTINUE
        BESSJ=BJ
      ELSE
        M=2*((N+INT(SQRT(FLOAT(IACC*N))))/2)
        BESSJ=0.
        JSUM=0
        SUM=0.
        BJP=0.
        BJ=1.
        DO 12 J=M,1,-1
          BJM=J*TOX*BJ-BJP
          BJP=BJ
          BJ=BJM
          IF(ABS(BJ).GT.BIGNO)THEN
            BJ=BJ*BIGNI
            BJP=BJP*BIGNI
            BESSJ=BESSJ*BIGNI
            SUM=SUM*BIGNI
          ENDIF
          IF(JSUM.NE.0)SUM=SUM+BJ
          JSUM=1-JSUM
          IF(J.EQ.N)BESSJ=BJP
12      CONTINUE
        SUM=2.*SUM-BJ
        BESSJ=BESSJ/SUM
      ENDIF
      RETURN
      END


      DOUBLE PRECISION FUNCTION DT_DENSIT(Na,R,Ra)

      IMPLICIT NONE
      DOUBLE PRECISION fnorm , ONE , pdif , PI , R , r0 , r1 , Ra ,
     &                 TINY10 , TWO , TWOPI , ZERO
      INTEGER Na
      SAVE

      INCLUDE 'inc/dtflka'

      PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
      PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
     &           PI=TWOPI/TWO)

      DIMENSION r0(18) , fnorm(18)
      DATA r0/ZERO , ZERO , ZERO , ZERO , 2.12D0 , 2.56D0 , 2.41D0 ,
     &     2.46D0 , 2.52D0 , 2.45D0 , 2.37D0 , 2.46D0 , 2.44D0 ,
     &     2.54D0 , 2.58D0 , 2.72D0 , 2.66D0 , 2.79D0/
      DATA fnorm/.1000D+01 , .1000D+01 , .1000D+01 , .1000D+01 ,
     &     .1000D+01 , .1000D+01 , .1000D+01 , .1000D+01 , .1000D+01 ,
     &     .1000D+01 , .1012D+01 , .1039D+01 , .1075D+01 , .1118D+01 ,
     &     .1164D+01 , .1214D+01 , .1265D+01 , .1318D+01/
      DATA pdif/0.545D0/

      DT_DENSIT = ZERO
C shell model
      IF ( Na.LE.4 ) THEN
         STOP 'DT_DENSIT-0'
      ELSE IF ( (Na.GT.4) .AND. (Na.LE.18) ) THEN
         r1 = r0(Na)/SQRT(2.5D0-4.0D0/DBLE(Na))
         DT_DENSIT = (ONE+(DBLE(Na)-4.0D0)/6.0D0*(R/r1)**2)
     &               *EXP(-(R/r1)**2)/fnorm(Na)
C Woods-Saxon
      ELSE IF ( Na.GT.18 ) THEN
         DT_DENSIT = ONE/(ONE+EXP((R-Ra)/pdif))
      END IF

      END FUNCTION


      program test1
      INTEGER SIZE,e,f,m,n,p
      PARAMETER (SIZE=10)
      real a(size,size), b(size,size), c(size,size)

      do 100 i = 1, size
         do 200 j = 1, size
            b(i,j) = (i-1)*size+(j-1)
            p = 1
            m = b(p,j)
            c(i,j) = b(i,j)/(size*size)
 200     continue
 100  continue
      end


subroutine add(a)
    real :: a
    b=2*a
    print*, b
    return
end subroutine add

subroutine fcumsum(a, b, n)
    real a(n), b(n)
    integer :: n
    intent(in) :: a
    intent(out) :: b

    b(1)=a(1)

    do 100 i=2, n

    b(i) = b(i-1) + a(i)

    100 continue

    return
end subroutine fcumsum

subroutine matrix(n, m, a,b)
    !real, dimension(3,3) :: a
    integer m,n
    real, intent(in) :: a(m,n)
    real, intent(out) :: b(m,n)

    do i=1, 3
        do j=1, 3
            b(i,j)=a(i,j)*2
        enddo
        enddo

    return

end subroutine matrix

subroutine matrix3(k, l, m, a, b)
    !real, dimension(3,3) :: a
    integer k,l,m,x,y,z
    real a(k, l, m)
    real, intent(out) :: b(k, l, m)
    print*, a
    print*, size(a)

!    do x=1, 3
!        do y=1, 3
!            do z=1, 3
!                b(x,y,z)=a(x,y,z)*2
!                enddo
!        enddo
!    enddo

    return
end

subroutine bitshift()
    implicit none
    integer x,y,z
    x=4
    y=ishft(x,1) !Left bitshift
    z=ishft(x,-1) !Left bitshift
    print*,y,z
end

program main
    call bitshift()
end


c
c
c
c
        subroutine abramns(z,abrams,n,ifexpon)
        implicit real *8 (a-h,o-z)
        complex *16 z,abrams(1)
        external abram0,abram1,abram2
c
c       This subroutine evaluates the first n+1 Abramowitz functions of the
c       argument z. The user also has the option of evaluating the
c       functions J_n(z) scaled by the (complex) coefficient e^{\nu}
c       with \nu=3(z/2)^(2/3).
c       This option is provided via the parameter ifexpon (see below)
c
c
c                      input parameters:
c
c  z - the complex number for which the Abramowitz functions
c        J_0, ..., J_n are to be evaluated
c  n - the highest order of any Abramowitz function to be evaluated
c  ifexpon - the integer parameter telling the subroutine whether
c        to calculate the actual values of the Abramowitz functions,
c        or the values of Abramowitz functions scaled by e^{\nu}.
c        Permitted values: 0 and 1.
c    ifexpon = 1 will cause the subroutine to evaluate the Abramowitz functions
c        honestly
c    ifexpon = 0 will cause the subroutine to scale the Abramowitz functions
c        by e^{\nu}.
c
c                      output parameters:
c
c  abrams - the first n+1 Abramowitz functions of the (complex) argument z.
c        Please note that abrams(1) is the Abramowitz function of order 0,
c        abrams(2) is the Abramowitz function of order 1, ..., abrams(n+1)
c        is the Abramowitz function of order n
c
c       . . . evaluate the functions J_0,J_1, J_2
c
        call abram0(z,abrams(1),ifexpon)
        call abram1(z,abrams(2),ifexpon)
        call abram2(z,abrams(3),ifexpon)
c
c
c       conduct recursion
c
        do 1200 i1=3,n
c
        abrams(i1+1)=((i1-1)*abrams(i1-1)+z*abrams(i1-2))/2
 1200 continue
c
        return
        end
c
c
c
c
c
        subroutine abramn(z,jn,n,ifexpon)
        implicit real *8 (a-h,o-z)
        complex *16 z,jn,jnm1,jnm2,jnm3
        external abram0,abram1,abram2,abramm1
c
c       This subroutine evaluates the Abramowitz function J_n of the
c       argument z. The user also has the option of evaluating the
c       function J_n(z) scaled by the (complex) coefficient e^{\nu}
c       with \nu=3(z/2)^(2/3).
c       This option is provided via the parameter ifexpon (see below)
c
c
c                      input parameters:
c
c  z - the complex number for which the Abramowitz function
c        J_n are to be evaluated
c  n - the order of the Abramowitz function to be evaluated
c  ifexpon - the integer parameter telling the subroutine whether
c        to calculate the actual value of the Abramowitz function,
c        or the value of Abramowitz function scaled by e^{\nu}.
c        Permitted values: 0 and 1.
c    ifexpon = 1 will cause the subroutine to evaluate the Abramowitz function
c        honestly
c    ifexpon = 0 will cause the subroutine to scale the Abramowitz function
c        by e^{\nu}.
c
c                      output parameters:
c
c  jn - the Abramowitz function J_n(z).
c
c       . . . evaluate the functions J_0,J_1, J_2
c
        if (n .eq. -1) then
           call abramm1(z,jn,ifexpon)
           return
        elseif (n .eq. 0) then
           call abram0(z,jn,ifexpon)
           return
        elseif (n .eq. 1) then
           call abram1(z,jn,ifexpon)
           return
        elseif (n .eq. 2) then
           call abram2(z,jn,ifexpon)
           return
        else
           call abram0(z,jnm3,ifexpon)
           call abram1(z,jnm2,ifexpon)
           call abram2(z,jnm1,ifexpon)
c
c
c       conduct recursion
c
           do 1200 k=3,n
c
              jn=((k-1)*jnm2+z*jnm3)/2
              jnm3=jnm2
              jnm2=jnm1
              jnm1=jn
 1200      continue
c
           return
        endif
        end
c
c
c
c
c


program while_02
implicit none
integer :: i, j
i = 0
j = 0
do while (i < 10)
    i = i + 1
    j = j + i
end do
if (j /= 55) error stop
if (i /= 10) error stop

i = 0
j = 0
do while (i < 10)
    i = i + 1
    if (i == 2) exit
    j = j + i
end do
if (j /= 1) error stop
if (i /= 2) error stop

i = 0
j = 0
do while (i < 10)
    i = i + 1
    if (i == 2) cycle
    j = j + i
end do
if (j /= 53) error stop
if (i /= 10) error stop
end


SUBROUTINE DVBES1(FJ,DJ,SM,RI,NT)
  !
  IMPLICIT NONE
  !
  !        Arguments
  !
  INTEGER            NT
  DOUBLE PRECISION   RI, SM
  DOUBLE PRECISION   DJ(NT), FJ(NT)
  !
  !     ..................................................................
  !
  !        calculate the derivatives of the Bessel functions
  !           DJ = DFJ/DX where X = SM*RI
  !                                             D.D.KOELLING
  !
  !     ..................................................................
  !
  !        Local Parameters
  !
  DOUBLE PRECISION   ONE, THIRD, ZUP, ZERO
  PARAMETER          (ONE   = 1.0D+0)
  PARAMETER          (THIRD = 1.0D+0/3.0D+0)
  PARAMETER          (ZERO  = 0.0D+0)
  PARAMETER          (ZUP   = 1.0D-5)
  !
  !        Local Scalars
  !
  INTEGER            L, LM
  DOUBLE PRECISION   Q2, Q3, X
  !
  X = SM*RI
  IF (X .GT. ZUP) THEN
     Q2 = -ONE/X
     Q3 = Q2
     DJ(1) = -FJ(2)
     LM = 1
     DO L = 2, NT
        Q3 = Q3 + Q2
        DJ(L) = FJ(LM) + Q3*FJ(L)
        LM = LM + 1
     ENDDO
  ELSE
     DJ(1) = ZERO
     DJ(2) = THIRD
     DO L = 3, NT
        DJ(L) = ZERO
     ENDDO
  ENDIF
  !
  RETURN
END SUBROUTINE DVBES1


PROGRAM LA_ZGTSV_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => DP
   USE F95_LAPACK, ONLY: LA_GTSV
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
      CHARACTER(LEN=*), PARAMETER :: FMT =                              &
     &                   '(4(1X,1H(,F7.3,1H,,F7.3,1H):))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER :: I, J, IFAIL, N, NRHS
!  .. LOCAL ARRAYS ..
   REAL(WP), ALLOCATABLE :: DDL(:), DD(:), DDU(:), BB(:,:)
   COMPLEX(WP), ALLOCATABLE :: DL(:), D(:), DU(:), B(:,:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'ZGTSV ET_Example Program Results.'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) N, NRHS
   PRINT *, 'N = ', N, ' NRHS = ', NRHS
   ALLOCATE ( DL(N-1), DDL(N-1), D(N), DD(N), DU(N-1), DDU(N-1), B(N,NRHS), BB(N,NRHS) )
!
        READ (NIN, *) DDU(:), DD(:), DDL(:)

      BB(1,:) = DD(1) + DDU(1)
!     BB(2:N-1,:) = DDL(1:N-2) + DD(2:N-1) + DDU(2:N-1)
      DO I = 2, N-1
         BB(I,:) = DDL(I-1) + DD(I) + DDU(I)
      ENDDO
      BB(N,:) = DDL(N-1) + DD(N-1)
      DO I = 1, NRHS
         BB(:,I) = BB(:,I)*I
      ENDDO
!
   DL = DDL; D = DD; DU = DDU; B = BB
      WRITE(NOUT,*) 'The matrix A:'
      WRITE (NOUT,*) 'DU '; WRITE (NOUT,FMT) DU
      WRITE (NOUT,*) 'D  '; WRITE (NOUT,FMT) D
      WRITE (NOUT,*) 'DL '; WRITE (NOUT,FMT) DL
      WRITE(NOUT,*) 'The RHS matrix B:'
      DO J = 1, NRHS
        WRITE (NOUT,*) 'RHS', J; WRITE (NOUT,FMT) B(:,J)
      ENDDO
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_ZGTSV LAPACK Subroutine Results.'
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) ' CALL LA_GTSV(DL, D, DU, B )'
   DL = DDL; D = DD; DU = DDU; B = BB
   CALL LA_GTSV(DL, D, DU, B )
   WRITE(NOUT,*)'   B - the solution vectors computed by LA_GTSV:'
   DO J = 1, NRHS; WRITE (NOUT,FMT) B(:,J); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GTSV(DL, D, DU, B(1:N,1)'
   DL = DDL; D = DD; DU = DDU; B = BB
   CALL LA_GTSV(DL, D, DU, B(1:N,1) )
   WRITE(NOUT,*)'   B - the solution vectors computed by LA_GTSV:'
   WRITE (NOUT,FMT) B(:,1)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GTSV(DL, D, DU, B, INFO=IFAIL )'
   DL = DDL; D = DD; DU = DDU; B = BB
   CALL LA_GTSV(DL, D, DU, B, INFO=IFAIL )
   WRITE(NOUT,*)'   B - the solution vectors computed by LA_GTSV:'
   DO J = 1, NRHS; WRITE (NOUT,FMT) B(:,J); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) ' CALL LA_GTSV(DL, D, DU, B(1:N,1), IFAIL )'
   DL = DDL; D = DD; DU = DDU; B = BB
   CALL LA_GTSV(DL, D, DU, B(1:N,1), IFAIL )
   WRITE(NOUT,*)'   B - the solution vectors computed by LA_GTSV:'
   WRITE (NOUT,FMT) B(1:N,1)
!
END PROGRAM LA_ZGTSV_ET_EXAMPLE


! sum and other array functions have an optional dim argument
program main
implicit none
integer :: v(2,3)   ! declare 2x3 matrix
v(1,:) = [1,2,3]    ! set 1st row
v(2,:) = 10*v(1,:)  ! set 2nd row to [10,20,30]
print*,sum(v)       ! sum all elements: 66
print*,sum(v,dim=1) ! sum each row: 6 60
print*,sum(v,dim=2) ! sum each col: 11 22 33
end program main


***********************************************************************
* This file provides filtering routines for pure Neumann problems.
***********************************************************************

***********************************************************************
* Calculate the integral mean value of the given vector
***********************************************************************

      DOUBLE PRECISION FUNCTION DCLIMV (DX,NEQ)

      IMPLICIT NONE

C parameters

      INTEGER NEQ
      DOUBLE PRECISION DX(NEQ)

C local variables

      DOUBLE PRECISION SM
      INTEGER I

C Sum up the coefficients, divide by NEQ to get the mean value.
C For piecewise constant functions this is exactly the integral
C mean value (because of midpoint rule). For non-constant
C functions this is an approximation to the mean value of
C 2nd order.

      SM=0D0
      DO I=1,NEQ
        SM=SM+DX(I)
      END DO

      SM=SM/DBLE(NEQ)

      DCLIMV = SM

      END

***********************************************************************
* The following routine changes the given coefficient vector to have
* integral mean value=0.
*
* In:
*  DX     - Solution vector; array [1..NEQ] of double
*  NEQ    - length of solution vector
*
* Out:
*  DX     - updated solution vector.
*
* As this function interpretes the entries in the solution vector
* as function values in nodes, this technique only ensures
* integral-mean-value=0 with conforming finite element spaces!
***********************************************************************

      SUBROUTINE IMVZER (DX,NEQ)

      IMPLICIT NONE

C parameters

      INTEGER NEQ
      DOUBLE PRECISION DX(NEQ)

C local variables

      DOUBLE PRECISION SM
      INTEGER I

      DOUBLE PRECISION DCLIMV
      EXTERNAL DCLIMV

C Sum up the coefficients, divide by NEQ to get the mean value.
C For piecewise constant functions this is exactly the integral
C mean value (because of midpoint rule). For non-constant
C functions this is an approximation to the mean value of
C 2nd order.

      SM=DCLIMV(DX,NEQ)

C Subtract this from the solution vector to ensure integral mean
C value = 0 (at least approximatively...)

      DO I=1,NEQ
        DX(I)=DX(I)-SM
      END DO

C      SM=DCLIMV(DX,NEQ)
C Debug: Recalculate the integral mean value
C      SM=0D0
C      DO I=1,NEQ
C        SM=SM+DX(NEQ)
C      END DO
C      SM=SM/DBLE(NEQ)

      END

***********************************************************************
* Neumann filtering routine for multigrid.
*
* This routine is called in multigrid on different positions of the
* algorithm to perform filtering.
* This version performs filtering to integral-mean-value=0
*
* In:
*  DX     - Solution vector; array [1..NEQ] of double
*  NEQ    - length of solution vector
*  IALGP  - Position in the algorithm
*           0=undefined - enforce the filtering
*           1=on start of the algorithm on finest level;
*             DX is solution vector
*           2=on start of the MG sweep on the current level;
*             DX is the first solution vector before the
*             sweep starts (0D0-array normally, escept for the
*             finest level, there it's the result of the previous
*             call with IALGP=1)
*           3=before presmoothing; DX is solution vector
*           4=after presmoothing; DX is solution vector
*           5=before restriction; DX is defect vector
*           6=after restriction; DX is defect vector
*           7=before coarse grid solver;
*             DX is RHS vector on coarsest level
*             (the result of IALGP=6 !)
*           8=before coarse grid solver;
*             DX is start vector on coarsest level (normally filled
*             with 0)
*           9=after coarse grid solver;
*             DX is calculated solution vector on coarsest level
*          10=before prolongation;
*             DX is update-vector on coarser level
*          11=after prolongation; DX is prolongated update vector
*          12=after coarse grid correction, before post smoothing;
*             DX is solution vector
*          13=after post-smoothing; DX is solution vector
*          14=after one step of MG; DX is the solution vector on the
*             finest level.
*  IPARAM - array [1..SZMGRI] of integer
*           Integer parameter structure of the solver
*  DPARAM - array [1..SZMGRI] of integer
*           Double precision parameter structure of the solver
*  IDATA  - array [1..*] of integer
*           User defined integer array
*  DDATA  - array [1..*] of double
*           User defined double array
*
* Out:
*  DX     - updated vector.
***********************************************************************

      SUBROUTINE YNMFLT (DX,NEQ,IALGP,IPARAM,DPARAM,IDATA,DDATA)

      IMPLICIT NONE

C parameters

      INTEGER NEQ,IALGP
      DOUBLE PRECISION DX(NEQ)

      DOUBLE PRECISION DCLIMV
      EXTERNAL DCLIMV

      INTEGER IPARAM(*),IDATA(*)
      DOUBLE PRECISION DPARAM(*),DDATA(*)

C Perform the filtering after the coarse grid correction and after the
C post-smoothing. This is the point where the new solution is generated,
C which is only defined up to an additive constant. Here we ensure
C integral-mean-value=0.

C Caution: The solution must ensure Du/Dn=0, so it's not possible to
C prescribe an arbitrary RHS! But: A RHS to a solution with Du/Dn=0
C automatically provides integral mean value=0...

      IF ((IALGP.EQ.0).OR.(IALGP.EQ.13)) THEN
        CALL IMVZER (DX,NEQ)
      END IF

C      PRINT *,'MG-Pos: ',IALGP,', IMV=',DCLIMV(DX,NEQ)

99999 END

***********************************************************************
* Neumann filtering routine for multigrid M020.
*
* This routine is called in multigrid on different positions of the
* algorithm to perform filtering.
* This version performs filtering to integral-mean-value=0
*
* In:
*  DX     - Solution vector; array [1..NEQ] of double
*  NEQ    - length of solution vector
*  IALGP  - Position in the algorithm
*           0=undefined - enforce the filtering
*           1=on start of the algorithm on finest level;
*             DX is solution vector
*           2=on start of the MG sweep on the current level;
*             DX is the first solution vector before the
*             sweep starts (0D0-array normally, escept for the
*             finest level, there it's the result of the previous
*             call with IALGP=1)
*           3=before presmoothing; DX is solution vector
*           4=after presmoothing; DX is solution vector
*           5=before restriction; DX is defect vector
*           6=after restriction; DX is defect vector
*           7=before coarse grid solver;
*             DX is RHS vector on coarsest level
*             (the result of IALGP=6 !)
*           8=before coarse grid solver;
*             DX is start vector on coarsest level (normally filled
*             with 0)
*           9=after coarse grid solver;
*             DX is calculated solution vector on coarsest level
*          10=before prolongation;
*             DX is update-vector on coarser level
*          11=after prolongation; DX is prolongated update vector
*          12=after coarse grid correction, before post smoothing;
*             DX is solution vector
*          13=after post-smoothing; DX is solution vector
*          14=after one step of MG; DX is the solution vector on the
*             finest level.
*   IPARAM- array [1..SZMGRI] of integer
*           Integer parameter structure of multigrid solver
*   DPARAM- array [1..SZMGRI] of integer
*           Double precision parameter structure of multigrid solver
*   IDATA - array [1..*] of integer
*           User defined integer array
*   DDATA - array [1..*] of double
*           User defined double array
*
* Out:
*  DX     - updated vector.
***********************************************************************

      SUBROUTINE YNMFL2 (DX,NEQ,IALGP,IPARAM,DPARAM,IDATA,DDATA)

      IMPLICIT NONE

C parameters

      INTEGER NEQ,IALGP
      DOUBLE PRECISION DX(NEQ)

      INTEGER IPARAM(*)
      DOUBLE PRECISION DPARAM(*)
      INTEGER IDATA(*)
      DOUBLE PRECISION DDATA(*)

      DOUBLE PRECISION DCLIMV
      EXTERNAL DCLIMV

C Perform the filtering after the coarse grid correction and after the
C post-smoothing. This is the point where the new solution is generated,
C which is only defined up to an additive constant. Here we ensure
C integral-mean-value=0.

C Caution: The solution must ensure Du/Dn=0, so it's not possible to
C prescribe an arbitrary RHS! But: A RHS to a solution with Du/Dn=0
C automatically provides integral mean value=0...

      IF ((IALGP.EQ.0).OR.(IALGP.EQ.13)) THEN
        CALL IMVZER (DX,NEQ)
      END IF

C      PRINT *,'MG-Pos: ',IALGP,', IMV=',DCLIMV(DX,NEQ)

99999 END


! { dg-do run }

! Check that generic bindings targetting ELEMENTAL procedures work.

MODULE m
  IMPLICIT NONE

  TYPE :: t
  CONTAINS
    PROCEDURE, NOPASS :: double
    PROCEDURE, NOPASS :: double_here
    GENERIC :: double_it => double
    GENERIC :: double_inplace => double_here
  END TYPE t

CONTAINS

  ELEMENTAL INTEGER FUNCTION double (val)
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: val
    double = 2 * val
  END FUNCTION double

  ELEMENTAL SUBROUTINE double_here (val)
    IMPLICIT NONE
    INTEGER, INTENT(INOUT) :: val
    val = 2 * val
  END SUBROUTINE double_here

END MODULE m

PROGRAM main
  USE m
  IMPLICIT NONE

  TYPE(t) :: obj
  INTEGER :: arr(42), arr2(42), arr3(42), arr4(42)
  INTEGER :: i

  arr = (/ (i, i = 1, 42) /)

  arr2 = obj%double (arr)
  arr3 = obj%double_it (arr)

  arr4 = arr
  CALL obj%double_inplace (arr4)

  IF (ANY (arr2 /= 2 * arr) .OR. &
      ANY (arr3 /= 2 * arr) .OR. &
      ANY (arr4 /= 2 * arr)) THEN
    CALL abort ()
  END IF
END PROGRAM main

! { dg-final { cleanup-modules "m" } }


      PROGRAM xsprsax
C     driver for routine sprsax
      INTEGER NP,NMAX
      PARAMETER(NP=5,NMAX=2*NP*NP+1)
      INTEGER i,j,msize,ija(NMAX)
      REAL a(NP,NP),sa(NMAX),ax(NP),b(NP),x(NP)
      DATA a/3.0,0.0,0.0,0.0,0.0,
     *     0.0,4.0,7.0,0.0,0.0,
     *     1.0,0.0,5.0,0.0,0.0,
     *     0.0,0.0,9.0,0.0,6.0,
     *     0.0,0.0,0.0,2.0,5.0/
      DATA x/1.0,2.0,3.0,4.0,5.0/
      call sprsin(a,NP,NP,0.5,NMAX,sa,ija)
      msize=ija(1)-2
      call sprsax(sa,ija,x,b,msize)
      do 12 i=1,msize
        ax(i)=0.0
        do 11 j=1,msize
          ax(i)=ax(i)+a(i,j)*x(j)
11      continue
12    continue
      write(*,'(t4,a,t18,a)') 'Reference','sprsax result'
      do 13 i=1,msize
        write(*,'(t4,f5.2,t22,f5.2)') ax(i),b(i)
13    continue
      END

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