      subroutine rpt2cons_manifold(ixy,imp,maxm,meqn,mwaves,maux,
     &               mbc,mx,ql,qr,
     &               aux1,aux2,aux3,asdq,bmasdq,bpasdq)

      implicit none

      integer ixy, maxm, meqn,mwaves,mbc,mx,maux,imp

      double precision     ql(meqn,1-mbc:maxm+mbc)
      double precision     qr(meqn,1-mbc:maxm+mbc)
      double precision   asdq(meqn,1-mbc:maxm+mbc)
      double precision bmasdq(meqn,1-mbc:maxm+mbc)
      double precision bpasdq(meqn,1-mbc:maxm+mbc)
      double precision   aux1(maux,1-mbc:maxm+mbc)
      double precision   aux2(maux,1-mbc:maxm+mbc)
      double precision   aux3(maux,1-mbc:maxm+mbc)

      integer i, i1, k, idir, iface
      double precision vrrot, vlrot, g, vhat

c     # ixy = 1 --> idir = 1
c     # ixy = 2 --> idir = 0
      idir = 2-ixy

c     # iface = 2*(2-ixy)
      if (ixy .eq. 1) then
         iface = 2  !! Bottom edge
      else
         iface = 0  !! left edge
      endif

      do i = 2-mbc, mx+mbc
c         # imp = 1 : i-1   (for apdq)
c         # imp = 2 : i     (for apdq)
          i1 = i-2+imp

c         # -----------------------------------------
c         # Lower faces - cell centered velocities
c         # -----------------------------------------

c         # 6-7 (left-right)
c         # 8-9 (bottom-top)
          g = aux2(6 + 2*idir,i1)

c         # left-right : 2,3
c         # bottom-top : 4,5
          vrrot = g*aux2(2 + 2*idir,i1)   !! Left edge of right cell
          vlrot = g*aux1(3 + 2*idir,i1)   !! Right edge of left cell

          vhat = (vrrot + vlrot)/2.0

          bmasdq(1,i) = min(vhat,0.d0)*asdq(1,i)

c         # -----------------------------------------
c         # Upper faces - cell centered velocities
c         # -----------------------------------------

          g = aux3(6+2*idir,i1)

c         # left-right : 2,3
c         # bottom-top : 4,5
          vrrot = g*aux3(2 + 2*idir,i1)   !! Left edge of right cell
          vlrot = g*aux2(3 + 2*idir,i1)   !! Right edge of left cell

          vhat = (vrrot + vlrot)/2.0

          bpasdq(1,i) = max(vhat,0.d0)*asdq(1,i)

      enddo

      return
      end


	FUNCTION CHELIUM(X,Y,N,CHE2)

c	Compute number of Helium ionizing photons in sed Y(X).
c	Assumes X is in Angstroms and Y in ergs/sec/Angstroms (physical flux)

	real x(n),y(n),w(100000),f(100000)
	save c,h,const
	data icall/0/,const/0./

c	compute proportionality constant
	if (icall.eq.0) then
		c=2.997925E10
		h=6.6262E-27
		const=1.0E-8/h/c
		icall=1
	endif

c	Find Helium limit in sed and log(number of photons)
c	First electron, all photons shortward of whelium = 504.4 A
	whelium = 504.4
	if (x(1).ge.whelium) then
		chelium=0.
		che2=0.
		return
	endif
	do i=1,n
	if (x(i).lt.whelium) then
		w(i)=x(i)
		f(i)=w(i)*y(i)
	elseif (x(i).eq.whelium) then
		w(i)=x(i)
		f(i)=w(i)*y(i)
		goto 1
	elseif (x(i).gt.whelium) then
		w(i)=whelium
		f(i)=y(i-1)+(w(i)-x(i-1))*(y(i)-y(i-1))/(x(i)-x(i-1))
		f(i)=w(i)*f(i)
		goto 1
	endif
	enddo
1	chelium=const*trapz1(w,f,i)

!	Second electron, all photons shortward of whelium = 228. A
	whelium = 228.
	if (x(1).ge.whelium) then
		che2=0.
		return
	endif
	do i=1,n
	if (x(i).lt.whelium) then
		w(i)=x(i)
		f(i)=w(i)*y(i)
	elseif (x(i).eq.whelium) then
		w(i)=x(i)
		f(i)=w(i)*y(i)
		goto 2
	elseif (x(i).gt.whelium) then
		w(i)=whelium
		f(i)=y(i-1)+(w(i)-x(i-1))*(y(i)-y(i-1))/(x(i)-x(i-1))
		f(i)=w(i)*f(i)
		goto 2
	endif
	enddo
2	che2=const*trapz1(w,f,i)
	return
	end


module hamiltonians

contains
  subroutine hamiltonians_diag_on_basis(H, S, w, C)
    implicit none
    double precision, intent(in) :: H(1:,1:), S(1:,1:)
    double precision, allocatable, intent(out) :: w(:), C(:,:)

    ! workspace
    integer :: naos, info, lwork
    double precision, allocatable :: work(:), Scopy(:,:)
    naos = size(H, 1)
    allocate(w(naos))
    Scopy = S
    C = H

   ! workspace query
   lwork = -1
   info = 0
   allocate(work(1))
   call dsygv(1, 'V', 'U',  naos,&
        C, naos, Scopy, naos, w, &
        work, lwork, info)

   if (info .ne. 0) then
      write(*,*) 'hamiltonians_diag_on_basis: error in dsygv work query', info
      error stop -1
   end if

   lwork = int(work(1))

   ! allocate work array
   deallocate(work)
   allocate(work(lwork))

   ! Diagonalizing...
   call dsygv(1, 'V', 'U',  naos,&
        C, naos, Scopy, naos, w, &
        work, lwork, info)

   if (info .ne. 0) then
      write(*,*) 'hamiltonians_diag_on_basis: error in dsygv diagonalization', info
      error stop -1
   end if
end subroutine hamiltonians_diag_on_basis
end module hamiltonians


      subroutine flow_dur_curve

      use time_module
      use hydrograph_module

      implicit none

      real, dimension(time%nbyr) :: val      !             |
      real :: sum                         !             |
      integer :: iyr                      !none         |number of years
      integer :: next                     !             |
      integer :: npts                     !             |
      integer :: ipts                     !             |
      integer :: iprv                     !             |
      integer :: mle                      !             |
      integer :: nprob                    !             |
      integer :: iday                     !             |
      integer :: mfe                      !             |
      integer :: iyr_ch                   !             |

      val = 0.
        !set linked list for daily flow duration curves
        ob(icmd)%fdc_ll(time%day)%val = ob(icmd)%hd(1)%flo
        next = ob(icmd)%fdc%mfe
        npts = time%day - 1
        do ipts = 1, npts
          if (ob(icmd)%fdc_ll(time%day)%val <= ob(icmd)%fdc_ll(next)%val) then
            ob(icmd)%fdc_ll(time%day)%next = next
            if (ipts == 1) then
              ob(icmd)%fdc%mfe = time%day
            else
              ob(icmd)%fdc_ll(iprv)%next = time%day
            end if
            exit
          end if
          iprv = next
          next = ob(icmd)%fdc_ll(next)%next
        end do
        if (npts > 0 .and. ipts == npts + 1) then
          mle = ob(icmd)%fdc%mle
          ob(icmd)%fdc_ll(mle)%next = time%day
          ob(icmd)%fdc%mle = time%day
        end if
        !set linked list for daily flow duration curves

        !save flow duration curve probabilities for the year
        if (time%end_yr == 1) then
          sum = 0.
          nprob = 1
          next = ob(icmd)%fdc%mfe
          do iday = 1, time%day
            if (iday == fdc_p(nprob)) then
              select case (nprob)
              case (1)  ! 5% prob
                ob(icmd)%fdc%p(time%yrs)%p5 = ob(icmd)%fdc_ll(next)%val
              case (2)  ! 10% prob
                ob(icmd)%fdc%p(time%yrs)%p10 = ob(icmd)%fdc_ll(next)%val
              case (3)  ! 25% prob
                ob(icmd)%fdc%p(time%yrs)%p25 = ob(icmd)%fdc_ll(next)%val
              case (4)  ! 50% prob
                ob(icmd)%fdc%p(time%yrs)%p50 = ob(icmd)%fdc_ll(next)%val
              case (5)  ! 75% prob
                ob(icmd)%fdc%p(time%yrs)%p75 = ob(icmd)%fdc_ll(next)%val
              case (6)  ! 90% prob
                ob(icmd)%fdc%p(time%yrs)%p90 = ob(icmd)%fdc_ll(next)%val
              case (7)  ! 95% prob
                ob(icmd)%fdc%p(time%yrs)%p95 = ob(icmd)%fdc_ll(next)%val
              end select
              nprob = nprob + 1
            end if
            sum = sum + ob(icmd)%fdc_ll(next)%val
            next = ob(icmd)%fdc_ll(next)%next
          end do
          ob(icmd)%fdc%p(time%yrs)%mean = sum / float(iday + 1)
          mfe = ob(icmd)%fdc%mfe
          mle = ob(icmd)%fdc%mle
          ob(icmd)%fdc%p(time%yrs)%min = ob(icmd)%fdc_ll(mfe)%val
          ob(icmd)%fdc%p(time%yrs)%max = ob(icmd)%fdc_ll(mle)%val
          !write ob(icmd)%fdc%p before we reinitialize
          ob(icmd)%fdc%mfe = 1
          ob(icmd)%fdc%mle = 1
        end if

        !save flow duration curve probabilities for the year

        !master duration curve from annual curves (median)
        if (time%end_sim == 1) then
          do nprob = 1, 7
            ob(icmd)%fdc%mfe = 1
            ob(icmd)%fdc%mle = 1
            select case (nprob)
              case (1)  ! 5% prob
                do iyr = 1, time%nbyr
                  val(iyr) = ob(icmd)%fdc%p(iyr)%p5
                end do
              case (2)  ! 10% prob
                do iyr = 1, time%nbyr
                  val(iyr) = ob(icmd)%fdc%p(iyr)%p10
                end do
              case (3)  ! 25% prob
                do iyr = 1, time%nbyr
                  val(iyr) = ob(icmd)%fdc%p(iyr)%p25
                end do
              case (4)  ! 50% prob
                do iyr = 1, time%nbyr
                  val(iyr) = ob(icmd)%fdc%p(iyr)%p50
                end do
              case (5)  ! 75% prob
                do iyr = 1, time%nbyr
                  val(iyr) = ob(icmd)%fdc%p(iyr)%p75
                end do
              case (6)  ! 90% prob
                do iyr = 1, time%nbyr
                  val(iyr) = ob(icmd)%fdc%p(iyr)%p90
                end do
              case (7)  ! 95% prob
                do iyr = 1, time%nbyr
                  val(iyr) = ob(icmd)%fdc%p(iyr)%p95
                end do
              end select

          do iyr = 1, time%nbyr
            ob(icmd)%fdc_lla(iyr)%val = val(iyr)
            next = ob(icmd)%fdc%mfe
            npts = iyr - 1
            do ipts = 1, npts
              if (ob(icmd)%fdc_lla(iyr)%val <= ob(icmd)%fdc_lla(next)%val) then
                ob(icmd)%fdc_lla(iyr)%next = next
                if (ipts == 1) then
                  ob(icmd)%fdc%mfe = iyr
                else
                  ob(icmd)%fdc_lla(iprv)%next = iyr
                end if
                exit
              end if
              iprv = next
              next = ob(icmd)%fdc_lla(next)%next
            end do  !ipts
            if (npts > 0 .and. ipts == npts + 1) then
              mle = ob(icmd)%fdc%mle
              ob(icmd)%fdc_lla(mle)%next = iyr
              ob(icmd)%fdc%mle = iyr
            end if
          end do    !iyr

          !calc mean, abs max and min
          sum = 0.
          do iyr = 1, time%nbyr
            sum = sum + ob(icmd)%fdc%p(iyr)%mean
            ob(icmd)%fdc%p_md%max = Max (ob(icmd)%fdc%p_md%max, ob(icmd)%fdc%p(iyr)%max)
            ob(icmd)%fdc%p_md%min = amin1 (ob(icmd)%fdc%p_md%min, ob(icmd)%fdc%p(iyr)%min)
          end do
          ob(icmd)%fdc%p_md%mean = sum / time%nbyr

          !calc probabilities
          next = ob(icmd)%fdc%mfe
          do iyr = 1, time%nbyr
            if (iyr > time%nbyr / 2) then
              select case (nprob)
              case (1)  ! 5% prob
                iyr_ch = (time%nbyr + 1.1) / 2
                if (iyr <= iyr_ch) then
                  ob(icmd)%fdc%p_md%p5 = ob(icmd)%fdc%p(next)%p5
                else
                  ob(icmd)%fdc%p_md%p5 = (ob(icmd)%fdc%p(next)%p5 + ob(icmd)%fdc%p(iprv)%p5) / 2.
                end if
                exit
              case (2)  ! 10% prob
                iyr_ch = (time%nbyr + 1.1) / 2
                if (iyr <= iyr_ch) then
                  ob(icmd)%fdc%p_md%p10 = ob(icmd)%fdc%p(next)%p10
                else
                  ob(icmd)%fdc%p_md%p10 = (ob(icmd)%fdc%p(next)%p10 + ob(icmd)%fdc%p(iprv)%p10) / 2.
                end if
                exit
              case (3)  ! 25% prob
                iyr_ch = (time%nbyr + 1.1) / 2
                if (iyr <= iyr_ch) then
                  ob(icmd)%fdc%p_md%p25 = ob(icmd)%fdc%p(next)%p25
                else
                  ob(icmd)%fdc%p_md%p25 = (ob(icmd)%fdc%p(next)%p25 + ob(icmd)%fdc%p(iprv)%p25) / 2.
                end if
                exit
              case (4)  ! 50% prob
                iyr_ch = (time%nbyr + 1.1) / 2
                if (iyr <= iyr_ch) then
                  ob(icmd)%fdc%p_md%p50 = ob(icmd)%fdc%p(next)%p50
                else
                  ob(icmd)%fdc%p_md%p50 = (ob(icmd)%fdc%p(next)%p50 + ob(icmd)%fdc%p(iprv)%p50) / 2.
                end if
                exit
              case (5)  ! 75% prob
                iyr_ch = (time%nbyr + 1.1) / 2
                if (iyr <= iyr_ch) then
                  ob(icmd)%fdc%p_md%p75 = ob(icmd)%fdc%p(next)%p75
                else
                  ob(icmd)%fdc%p_md%p75 = (ob(icmd)%fdc%p(next)%p75 + ob(icmd)%fdc%p(iprv)%p75) / 2.
                end if
                exit
              case (6)  ! 90% prob
                iyr_ch = (time%nbyr + 1.1) / 2
                if (iyr <= iyr_ch) then
                  ob(icmd)%fdc%p_md%p90 = ob(icmd)%fdc%p(next)%p90
                else
                  ob(icmd)%fdc%p_md%p90 = (ob(icmd)%fdc%p(next)%p90 + ob(icmd)%fdc%p(iprv)%p90) / 2.
                end if
                exit
              case (7)  ! 95% prob
                iyr_ch = (time%nbyr + 1.1) / 2
                if (iyr <= iyr_ch) then
                  ob(icmd)%fdc%p_md%p95 = ob(icmd)%fdc%p(next)%p95
                else
                  ob(icmd)%fdc%p_md%p95 = (ob(icmd)%fdc%p(next)%p95 + ob(icmd)%fdc%p(iprv)%p95) / 2.
                end if
                exit
              end select
            end if
            iprv = next
            next = ob(icmd)%fdc_lla(next)%next
          end do    !iyr

          end do    !nprob
         write (6000,*) ob(icmd)%typ, ob(icmd)%props, ob(icmd)%fdc%p_md
        end if

        !master duration curve from annual curves (median)

      return
      end  subroutine flow_dur_curve


      program testh
c...............................................................|
c
c   program used to study performance:  test host
c
c   code:  erlebacher
c          - calculation of variable derivatives
c          - tri-diagonal solver
c          - sequential for HYPERCUBE target
c
c   Thomas M. Eidson
c   ICASE
c   March, 1991
c...............................................................|
c
      parameter (ioprt=6)
c
      common /grids/ dx,dy,dz
      common /times/ dt,dtx,dty,dtz
      double precision dt,dtx,dty,dtz
      include 'erle.h'

      call setgrid
      call dotest
C     call prntout

      call checksum(dux)
      call checksum(duy)
      call checksum(duz)

      stop 0
      end

c===============================================================|
      subroutine checksum(ar)
      include 'par.h'
      double precision ar(N,N,N)

      double precision sum
      sum = 0.0
      do i = 1, N
         do j = 1,N
            do k = 1,N
              sum = sum + ar(k, j, i)
            enddo
         enddo
      enddo
      print *, sum
      end

c===============================================================|
      subroutine tridvpk(a,b,c,d,e,tot)

      include 'erle.h'
      double precision tot(N,N)
      double precision a(N),b(N),c(N),d(N),e(N)

c
c...............................................................|
c
c     perform forward substitution
c  //@; BEGIN(looplist1=CODE.LoopNestList)
      do 10 j=1,N
      do 10 i=1,N
         duz(i,j,1) = duz(i,j,1)*b(1)
   10 continue

      do  k=2,N-1
      do  j=1,N
      do  i=1,N
         duz(i,j,k)=(duz(i,j,k)-a(k)*duz(i,j,k-1))*b(k)
      enddo
      enddo
      enddo

   20 continue
c
      do 30 j=1,N
      do 30 i=1,N
         tot(i,j) = 0.
   30 continue
c
      do 40 k=1,N-1
      do 40 j=1,N
      do 40 i=1,N
            tot(i,j) = tot(i,j) + d(k)*duz(i,j,k)
   40 continue
c
      do 50 j=1,N
      do 50 i=1,N
         duz(i,j,N) = (duz(i,j,N) - tot(i,j))*b(N)
   50 continue
c
c     perform backward substitution
c
      do 60 j=1,N
      do 60 i=1,N
         duz(i,j,N-1)=duz(i,j,N-1) - e(N-1)*duz(i,j,N)
   60 continue
c
      do  k=N-2,1,-1
      do  j=1,N
      do  i=1,N
         duz(i,j,k) = duz(i,j,k) - c(k)*duz(i,j,k+1) - e(k)*duz(i,j,N)
      enddo
      enddo
      enddo

   70 continue
c
      return
      end
c===============================================================|
      subroutine tridvpj(a,b,c,d,e,tot)

      include 'erle.h'
        double precision tot(N,N)
        double precision a(N),b(N),c(N),d(N),e(N)

c
c...............................................................|
c
c     perform forward substitution
c
c  //@; BEGIN(looplist2=CODE.LoopNestList)
      do 10 k=1,N
      do 10 i=1,N
         duy(i,1,k) = duy(i,1,k)*b(1)
   10 continue
c
      do 20 k=1,N
      do 20 j=2,N-1
      do 20 i=1,N
         duy(i,j,k)=(duy(i,j,k)-a(j)*duy(i,j-1,k))*b(j)
   20 continue
c
      do 30 k=1,N
      do 30 i=1,N
         tot(i,k) = 0.
   30 continue
c
      do 40 k=1,N
      do 40 j=1,N-1
      do 40 i=1,N
         tot(i,k) = tot(i,k) + d(j)*duy(i,j,k)
   40 continue
c
      do 50 k=1,N
      do 50 i=1,N
         duy(i,N,k) = (duy(i,N,k) - tot(i,k))*b(N)
   50 continue
c
c     perform backward substitution
c
      do 60 k=1,N
      do 60 i=1,N
         duy(i,N-1,k)=duy(i,N-1,k) - e(N-1)*duy(i,N,k)
   60 continue
c
      do 70 k=1,N
      do 70 j=N-2,1,-1
      do 70 i=1,N
         duy(i,j,k) = duy(i,j,k) - c(j)*duy(i,j+1,k) - e(j)*duy(i,N,k)
   70 continue
c
      return
      end
c===============================================================|
      subroutine tridvpi(a,b,c,d,e,tot)

      include 'erle.h'
        double precision tot(N,N)
        double precision a(N),b(N),c(N),d(N),e(N)

c
c...............................................................|
c
c     perform forward substitution
c
c  //@; BEGIN(looplist3=CODE.LoopNestList)
      do 10 k=1,N
      do 10 j=1,N
         dux(1,j,k) = dux(1,j,k)*b(1)
   10 continue
c
      do 20 k=1,N
      do 20 j=1,N
      do 20 i=2,N-1
         dux(i,j,k)=(dux(i,j,k)-a(i)*dux(i-1,j,k))*b(i)
   20 continue
c
      do 30 k=1,N
      do 30 j=1,N
         tot(j,k) = 0.
   30 continue
c
      do 40 k=1,N
      do 40 j=1,N
      do 40 i=1,N-1
         tot(j,k) = tot(j,k) + d(i)*dux(i,j,k)
   40 continue
c
      do 50 k=1,N
      do 50 j=1,N
         dux(N,j,k) = (dux(N,j,k) - tot(j,k))*b(N)
   50 continue
c
c     perform backward substitution
c
      do 60 k=1,N
      do 60 j=1,N
         dux(N-1,j,k)=dux(N-1,j,k) - e(N-1)*dux(N,j,k)
   60 continue
c
      do 70 k=1,N
      do 70 j=1,N
      do 70 i=N-2,1,-1
         dux(i,j,k) = dux(i,j,k) - c(i)*dux(i+1,j,k) - e(i)*dux(N,j,k)
   70 continue
c
      return
      end
c===============================================================|
      subroutine tridvpf(a,b,c,d,e)
c...............................................................|
c
c   routine:
c      factorization stage of vectorized tridiagonal solver
c      equations are periodic
c      all equations have the same coefficients
c
c...............................................................|
c
      include 'erle.h'
      double precision a(N),b(N),c(N),d(N),e(N)
c
c...............................................................|
c
c     generate first elements of LU
c
      b(1) = 1.0/b(1)
      c(1) = c(1)*b(1)
      e(1) = a(1)*b(1)
      d(1) = c(N)
c
c     generate n=2 to n=N-2 elements of LU
c
      do 10 k=2,N-2
         b(k) = b(k) - a(k)*c(k-1)
         b(k) = 1.0/b(k)
         c(k) = c(k)*b(k)
         e(k) = -a(k)*e(k-1)*b(k)
         d(k) = -d(k-1)*c(k-1)
   10 continue
c
c     generate N-1 elements
c
      b(N-1) = b(N-1) - a(N-1)*c(N-2)
      b(N-1) = 1.0/b(N-1)
      e(N-1) = (c(N-1) - a(N-1)*e(N-2))*b(N-1)
      d(N-1) = a(N) - d(N-2)*c(N-2)
c
c     generate the n-th element
c
      tot = 0.
      do 20 k=1,N-1
         tot = tot + d(k)*e(k)
   20 continue
      b(N) = b(N) - tot
      b(N) = 1.0/b(N)
c
      return
      end

      subroutine prnt(ar)
      include 'erle.h'
      double precision ar(N,N,N)

c
c
      parameter (size = N)
      do i = 1, size
	 do j = 1, size
	    print *, "ROW ", i , " COL ", j
	    do k = 1, size
	       print *, ar(i,j,k)
            enddo
         enddo
      enddo
      end
c===============================================================|
      subroutine dz3d6p(dz)
c...............................................................|
c
c   routine:
c      computes the z-derivatives of u storing the result in ud
c      uses a 6th order Pade scheme (Periodic domain)
c      periodic in z (evenly spaced grid)
c      third index corresponds to z direction
c
c...............................................................|
c

      parameter (pi=3.1415926535898)
c
      include 'erle.h'
      double precision a(N),b(N),c(N),d(N),e(N)

c
c...............................................................|
c
      nij=N*N
c
c  first derivative
c
         c13    = 1./3.
         c79dz  = 7./(9.*dz)
         c136dz = 1./(36.*dz)
c
c  set up the left hand side and factor the periodic matrix
c
         do 30 i=1,N
            a(i) = c13
            b(i) = 1.
            c(i) = c13
   30    continue
         call tridvpf(a,b,c,d,e)
c
c  set up right hand side and do forward/backward substitution
c
   91    do 41 j=1,N
         do 41 i=1,N
            duz(i,j,1) = c79dz*(u(i,j,2) - u(i,j,N))
     1                 + c136dz*(u(i,j,3) - u(i,j,N-1))
            duz(i,j,2) = c79dz*(u(i,j,3) - u(i,j,1))
     1                 + c136dz*(u(i,j,4) - u(i,j,N))
   41    continue

   92  do 40 j=1,N
         do 40 i=1,N
           duz(i,j,N-1) = c79dz*(u(i,j,N) - u(i,j,N-2))
     1                    + c136dz*(u(i,j,1) - u(i,j,N-3))
            duz(i,j,N)   = c79dz*(u(i,j,1) - u(i,j,N-1))
     1                    + c136dz*(u(i,j,2) - u(i,j,N-2))
   40    continue

         do 50 k=3,N-2
         do 50 j=1,N
         do 50 i=1,N
              duz(i,j,k) = c79dz*(u(i,j,k+1) - u(i,j,k-1))
     1                   + c136dz*(u(i,j,k+2) - u(i,j,k-2))
   50    continue
         call tridvpk(a,b,c,d,e,wrk)
c
      return
      end
c===============================================================|
      subroutine setgrid
c
      common /grids/ dx,dy,dz

      include 'erle.h'
c
c...............................................................|
c
c calculate boundary indices for data section on each node
c

c
c calculate grid
c
      pi=acos(-1.0)
      dx=2.*pi/N
      dy=2.*pi/N
      dz=2.*pi/N
c
      do 5 i=1,N
         x(i)=(i-1)*dx
    5 continue
c
      do 6 j=1,N
         y(j)=(j-1)*dy
    6 continue
c
      do 7 k=1,N
         z(k)=(k-1)*dz
    7 continue
c
      return
      end
c===============================================================|
      subroutine dotest

      common /grids/ dx,dy,dz
      common /times/ dt,dtx,dty,dtz
      double precision dt,dtx,dty,dtz

c...............................................................|
c
c*** generate data
c
      call genvar
c
c...............................................................|
c
c*** time derivative calculation
c
      call dx3d6p(dx)
      call dy3d6p(dy)
      call dz3d6p(dz)

      return
      end
c===============================================================|
      subroutine genvar
c
      common /grids/ dx,dy,dz
      include 'erle.h'

      do 10 kk=1,N
         do 10 jj=1,N
            do 10 ii=1,N
               u(ii,jj,kk)   =sin(x(ii))*cos(y(jj))*cos(3.*z(kk))
   10 continue
c
      return
      end
c===============================================================|
      subroutine dx3d6p(dx)
c...............................................................|
c
c   routine:
c      computes the x-derivatives of u storing the result in ud
c      uses a 6th order Pade scheme (Periodic domain)
c      periodic in x (evenly spaced grid)
c      first index corresponds to x direction
c
c...............................................................|
c
      parameter (pi=3.1415926535898)
c
      include 'erle.h'
        double precision a(N),b(N),c(N),d(N),e(N)

c...............................................................|
c
c  first derivative
c
         c13    = 1./3.
         c79dx  = 7./(9.*dx)
         c136dx = 1./(36.*dx)
c
c  set up the left hand side and factor the periodic matrix
c
         do 30 i=1,N
            a(i) = c13
            b(i) = 1.
            c(i) = c13
   30    continue
         call tridvpf(a,b,c,d,e)
c
c  set up right hand side and do forward/backward substitution
c
         do 40 k=1,N
         do 40 j=1,N
            dux(1,j,k) = c79dx*(u(2,j,k) - u(N,j,k))
     &               + c136dx*(u(3,j,k) - u(N-1,j,k))
            dux(2,j,k) = c79dx*(u(3,j,k) - u(1,j,k))
     &               + c136dx*(u(4,j,k) - u(N,j,k))
   40    continue
c
         do 41 k=1,N
         do 41 j=1,N
            dux(N-1,j,k) = c79dx*(u(N,j,k) - u(N-2,j,k))
     &                     + c136dx*(u(1,j,k)    - u(N-3,j,k))
            dux(N,j,k) = c79dx*(u(1,j,k) - u(N-1,j,k))
     &                   + c136dx*(u(2,j,k) - u(N-2,j,k))
   41    continue
c
         do 50 k=1,N
         do 50 j=1,N
         do 50 i=3,N-2
              dux(i,j,k) = c79dx*(u(i+1,j,k) - u(i-1,j,k))
     &                 + c136dx*(u(i+2,j,k) - u(i-2,j,k))
   50    continue
         call tridvpi(a,b,c,d,e,wrk)
      return
      end
c===============================================================|
      subroutine dy3d6p(dy)
c...............................................................|
c
c   routine:
c      computes the y-derivatives of u storing the result in ud
c      uses a 6th order Pade scheme (Periodic domain)
c      periodic in y (evenly spaced grid)
c      second index corresponds to y direction
c
c...............................................................|
c

      parameter (pi=3.1415926535898)
c
      include 'erle.h'

        double precision a(N),b(N),c(N),d(N),e(N)
c...............................................................|
c
c  first derivative
c
         c13    = 1./3.
         c79dy  = 7./(9.*dy)
         c136dy = 1./(36.*dy)
c
c  set up the left hand side and factor the periodic matrix
c
         do 30 i=1,N
            a(i) = c13
            b(i) = 1.
            c(i) = c13
  30     continue
         call tridvpf(a,b,c,d,e)
c
c  set up right hand side and do forward/backward substitution
c
         do 40 k=1,N
         do 40 i=1,N
            duy(i,1,k) = c79dy*(u(i,2,k) - u(i,N,k))
     1               + c136dy*(u(i,3,k) - u(i,N-1,k))
            duy(i,2,k) = c79dy*(u(i,3,k) - u(i,1,k))
     1               + c136dy*(u(i,4,k) - u(i,N,k))
  40     continue

         do 41 k=1,N
         do 41 i=1,N
            duy(i,N-1,k) = c79dy*(u(i,N,k)
     1                          - u(i,N-2,k))
     2                     + c136dy*(u(i,1,k) - u(i,N-3,k))
            duy(i,N,k) = c79dy*(u(i,1,k) - u(i,N-1,k))
     1                   + c136dy*(u(i,2,k) - u(i,N-2,k))
  41     continue
c
         do 50 k=1,N
         do 50 j=3,N-2
         do 50 i=1,N
              duy(i,j,k) = c79dy*(u(i,j+1,k) - u(i,j-1,k))
     1                 + c136dy*(u(i,j+2,k) - u(i,j-2,k))
  50     continue
         call tridvpj(a,b,c,d,e,wrk)
c
      return
      end


!##############################################################################
!# ****************************************************************************
!# <name> schurapprox </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module contains a set of routines which calculate an approximation
!# of a Schur-complement matrix S of a saddle-point matrix of the style
!#
!# <verb>
!#                             ( A  B )
!#                             ( D  0 )
!# </verb>
!#
!# where the exact Schur-complement matrix S is given as
!#
!#             <tex>$$     S := -D * A^{-1} * B   $$</tex>
!#
!# See the comment block below the routine list for more detailed information
!# on how exactly the approximation is assembled, as there are multiple
!# different variants available.
!#
!# The following routines can be found in this module:
!#
!# 1.) schur_assembleApprox2D
!#     -> Assembles a Schur-complement approximation matrix for a
!#        2D saddle-point system.
!#
!# 2.) schur_initPerfConfig
!#     -> Initialises the global performance configuration
!#
!#
!# -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\\
!# Detailed information on the approximation assembly variants\\
!# -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\\
!# Basically, all currently implemented algorithms calculate the approximation
!# of S by replacing <tex>$A^{-1}$</tex> by an approximation.
!#
!# All the currently implemented algorithms also support matrices S which have
!# an extended stencil, however, it is currently not clear under which
!# circumstances the approximation using an extended stencil is more accurate
!# than an approximation with the 'normal' stencil.
!#
!#
!#  SCHUR_TYPE_MAIN_DIAGONAL  \\
!# -------------------------- \\
!# This variant approximates <tex>$A^{-1}$</tex> by the inverse of the main diagonal of A.
!# This is the most simple and cheapest variant, which should do a good job
!# for Stokes systems.
!#
!#
!#  SCHUR_TYPE_LUMP_DIAGONAL  \\
!# -------------------------- \\
!# This variant approximates <tex>$A^{-1}$</tex> by the inverse of the lumped diagonal
!# matrix of A, i.e. a diagonal matrix L with
!#
!#
!#          <tex>$$       L_{ii} :=  \sum_{j=1}^n  a_ij      $$</tex>
!#
!#
!# This variant calculates the L_ii 'on the fly' without modifying the original
!# matrix A. This variant should only be used if A is (mostly) a mass matrix.
!#
!# Remark:
!# Even if the off-diagonal block sub-matrices of A (e.g. A12) exist, they are
!# ignored by this 'lumping' variant, i.e. the lumping is only performed on the
!# main diagonal blocks A11, A22 and (in 3D) A33 of A.
!#
!#
!#  SCHUR_TYPE_LOCAL_INVERSE  \\
!# -------------------------- \\
!# THIS ONE IS EXPERIMENTAL, USE AT YOUR OWN RISK!
!# This variant is a little difficult to explain, as it approximates <tex>$A^{-1}$</tex>
!# by local inverse matrices. The algorithm assembles the entries of S by
!# proceeding row-wise, and for each row i of S, there is a different local
!# matrix used, which we shall denote by T_i here.
!#
!# Assume that the algorithm is currently processing row i of S, then the
!# entry S(i,j) is defined as:
!#
!#            <tex>$$ S(i,j) := D(i,:) * T_i^{-1} * B(:,j)  $$</tex>
!#
!# where T_i is the local m by m sub-matrix of A, with m being the number of
!# non-zero entries in row i of D, where T_i contains all non-zero entries A_kl
!# of A, such that k and l are non-zero entries in row i of D, i.e. D(i,k) and
!# D(i,l) are non-zero entries in the sparsity pattern of D.
!#
!# This variant is (much) more expensive than the diagonal versions, however,
!# it *might* provide a better approximation of S.
!#
!# Remark:
!# Comparing the 'main diagonal' and 'local inverse' variants here is similar
!# to the comparision of 'diagonal' and 'full' Vanka or SP-SOR preconditioners;
!# see the vanka.f90 module for more information on this.
!#
!# </purpose>
!##############################################################################

module schurapprox

!$ use omp_lib
  use fsystem
  use genoutput
  use linearsystemscalar
  use perfconfig

  implicit none

  private

  public :: t_schurApprox
  public :: schur_initPerfConfig
  public :: schur_assembleApprox2D

!<constants>

!<constantblock>

  ! Approximate <tex>$A^{-1}$</tex> by the inverse of the main diagonal of A.
  integer, parameter, public :: SCHUR_TYPE_MAIN_DIAGONAL = 1

  ! Approximate <tex>$A^{-1}$</tex> by the inverse of the lumped diagonal of A.
  integer, parameter, public :: SCHUR_TYPE_LUMP_DIAGONAL = 2

  ! EXPERIMENTAL: Approximate <tex>$A^{-1}$</tex> by local inverse matrices.
  integer, parameter, public :: SCHUR_TYPE_LOCAL_INVERSE = 10

!</constantblock>

!</constants>

!<types>

!<typeblock>

  type t_schurApprox

    ! A pointer to a scalar matrix containing A11.
    type(t_matrixScalar), pointer :: p_rmatrixA11 => null()

    ! A pointer to a scalar matrix containing A22.
    type(t_matrixScalar), pointer :: p_rmatrixA22 => null()

    ! A pointer to a scalar matrix containing A33 (3D only).
    type(t_matrixScalar), pointer :: p_rmatrixA33 => null()

    ! A pointer to a scalar matrix containing B1.
    type(t_matrixScalar), pointer :: p_rmatrixB1 => null()

    ! A pointer to a scalar matrix containing B2.
    type(t_matrixScalar), pointer :: p_rmatrixB2 => null()

    ! A pointer to a scalar matrix containing B3 (3D only).
    type(t_matrixScalar), pointer :: p_rmatrixB3 => null()

    ! A pointer to a scalar matrix containing D1.
    type(t_matrixScalar), pointer :: p_rmatrixD1 => null()

    ! A pointer to a scalar matrix containing D2.
    type(t_matrixScalar), pointer :: p_rmatrixD2 => null()

    ! A pointer to a scalar matrix containing D3 (3D only).
    type(t_matrixScalar), pointer :: p_rmatrixD3 => null()

    ! A pointer to a scalar matrix containing S.
    type(t_matrixScalar), pointer :: p_rmatrixS => null()

    ! A factor that the approximation of S is to be multiplied by when adding
    ! it onto the content of S.
    real(DP) :: dtheta = 1.0_DP

    ! One of the SCHUR_TYPE_XXXX constants which specifies how the approximation
    ! is to be calculated.
    integer :: ctype = SCHUR_TYPE_MAIN_DIAGONAL

    ! Specifies whether S is to be cleared before assembling the approximation
    ! of the Schur-complement matrix.
    logical :: bclearS = .true.

  end type

!</typeblock>

!</types>

  !*****************************************************************************

  ! global performance configuration
  type(t_perfconfig), target, save :: schur_perfconfig

  !*****************************************************************************

contains

  ! ****************************************************************************

!<subroutine>

  subroutine schur_initPerfConfig(rperfconfig)

!<description>
  ! This routine initialises the global performance configuration
!</description>

!<input>
  ! OPTIONAL: performance configuration that should be used to initialise
  ! the global performance configuration. If not present, the values of
  ! the legacy constants is used.
  type(t_perfconfig), intent(in), optional :: rperfconfig
!</input>
!</subroutine>

    if (present(rperfconfig)) then
      schur_perfconfig = rperfconfig
    else
      call pcfg_initPerfConfig(schur_perfconfig)
    end if

  end subroutine schur_initPerfConfig

  ! ***************************************************************************

!<subroutine>

  subroutine schur_assembleApprox2D(rschur, rperfconfig)

!<description>
  ! TODO
!</description>

!<input>
  ! OPTIONAL: local performance configuration. If not given, the
  ! global performance configuration is used.
  type(t_perfconfig), intent(in), target, optional :: rperfconfig
!</input>

!<inputoutput>
  ! A t_schurApprox structure that contains the information of how the
  ! Schur-complement matrix approximation is to be assembled.
  type(t_schurApprox), intent(inout) :: rschur
!</inputoutput>

!</subroutine>

  ! The scaling factor for the approximation.
  real(DP) :: dtheta

  ! The scaling factors for the corresponding parts of the assembly.
  real(DP) :: dsf1, dsf2

  ! Arrays for the matrix structures
  integer, dimension(:), pointer :: p_IrowA, p_IcolA, &!p_IrowA12, p_IcolA12,&
      p_IdiagA, p_IrowB, p_IcolB, p_IrowD, p_IcolD, p_IrowS, p_IcolS

  ! Arrays for the matrix entries
  real(DP), dimension(:), pointer :: p_DA11, p_DA22, &!p_DA12, p_DA21, &
      p_DB1, p_DB2, p_DD1, p_DD2, p_DS

  ! The assembly type
  integer :: ctype

  ! The degree of D
  integer :: ndegree, neq

    ! First of all, let us make sure that all necessary matrices are present.
    if(.not. associated(rschur%p_rmatrixA11)) then
      call output_line ('Submatrix A11 is missing!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()
    end if
    if(.not. associated(rschur%p_rmatrixA22)) then
      call output_line ('Submatrix A22 is missing!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()
    end if
    if(.not. associated(rschur%p_rmatrixB1)) then
      call output_line ('Submatrix B1 is missing!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()
    end if
    if(.not. associated(rschur%p_rmatrixB2)) then
      call output_line ('Submatrix B2 is missing!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()
    end if
    if(.not. associated(rschur%p_rmatrixD1)) then
      call output_line ('Submatrix D1 is missing!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()
    end if
    if(.not. associated(rschur%p_rmatrixD2)) then
      call output_line ('Submatrix D2 is missing!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()
    end if
    if(.not. associated(rschur%p_rmatrixS)) then
      call output_line ('Matrix S is missing!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()
    end if

    ! Make sure A11 and A22 are compatible
    if(.not. lsyssc_isMatrixStructureShared(rschur%p_rmatrixA11, &
                                            rschur%p_rmatrixA22)) then
      call output_line ('Submatrices A11 and A22 must have the same structure!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()
    end if
    if((iand(rschur%p_rmatrixA11%imatrixSpec,LSYSSC_MSPEC_TRANSPOSED) .ne. 0) .or. &
       (iand(rschur%p_rmatrixA22%imatrixSpec,LSYSSC_MSPEC_TRANSPOSED) .ne. 0)) then
      call output_line ('A11 and A22 must not be transposed!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()
    end if

    ! Make sure B1 and B2 are compatible
    if(.not. lsyssc_isMatrixStructureShared(rschur%p_rmatrixB1, &
                                            rschur%p_rmatrixB2)) then
      call output_line ('Submatrices B1 and B2 must have the same structure!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()
    end if
    if((iand(rschur%p_rmatrixB1%imatrixSpec,LSYSSC_MSPEC_TRANSPOSED) .ne. 0) .or. &
       (iand(rschur%p_rmatrixB2%imatrixSpec,LSYSSC_MSPEC_TRANSPOSED) .ne. 0)) then
      call output_line ('B1 and B2 must not be transposed!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()
    end if

    ! Make sure D1 and D2 are compatible
    if(.not. lsyssc_isMatrixStructureShared(rschur%p_rmatrixD1, &
                                            rschur%p_rmatrixD2)) then
      call output_line ('Submatrices D1 and D2 must have the same structure!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()
    end if
    if((iand(rschur%p_rmatrixD1%imatrixSpec,LSYSSC_MSPEC_TRANSPOSED) .ne. 0) .or. &
       (iand(rschur%p_rmatrixD2%imatrixSpec,LSYSSC_MSPEC_TRANSPOSED) .ne. 0)) then
      call output_line ('D1 and D2 must not be transposed!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()
    end if

    ! Make sure A, B and D are compatible
    if(rschur%p_rmatrixA11%NEQ .ne. rschur%p_rmatrixB1%NEQ) then
      call output_line ('B1/B2 submatrices are incompatible to A11/A22!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()
    end if
    if(rschur%p_rmatrixA11%NCOLS .ne. rschur%p_rmatrixD1%NCOLS) then
      call output_line ('D1/D2 submatrices are incompatible to A11/A22!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()
    end if
    if(rschur%p_rmatrixD1%NEQ .ne. rschur%p_rmatrixB1%NCOLS) then
      call output_line ('D1/D2 submatrices are incompatible to B1/B2!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()
    end if

    ! Make sure S is valid
    if(iand(rschur%p_rmatrixS%imatrixSpec,LSYSSC_MSPEC_TRANSPOSED) .ne. 0) then
      call output_line ('S must not be transposed!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()
    end if

    ! Make sure S is compatible to A, B and D
    if((rschur%p_rmatrixS%NEQ   .ne. rschur%p_rmatrixD1%NEQ) .or. &
       (rschur%p_rmatrixS%NCOLS .ne. rschur%p_rmatrixB1%NCOLS)) then
      call output_line ('S is incompatible to saddle point system!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()
    end if

    ! Okay, the matrices are given and seem to be valid.

    ! Do we need to clear S?
    if(rschur%bclearS) call lsyssc_clearMatrix(rschur%p_rmatrixS)

    ! If theta is zero, then we have nothing more to do...
    dtheta = rschur%dtheta
    if(dtheta .eq. 0.0_DP) return

    ! Okay, let us calculate the scaling factors for the diagonal assembly
    ! types.
    dsf1 = dtheta * (rschur%p_rmatrixD1%dscaleFactor * &
                     rschur%p_rmatrixB1%dscaleFactor) / &
                    (rschur%p_rmatrixA11%dscaleFactor * &
                     rschur%p_rmatrixS%dscaleFactor)
    dsf2 = dtheta * (rschur%p_rmatrixD2%dscaleFactor * &
                     rschur%p_rmatrixB2%dscaleFactor) / &
                    (rschur%p_rmatrixA22%dscaleFactor * &
                     rschur%p_rmatrixS%dscaleFactor)

    ! Fetch the arrays of the necessary matrices
    call lsyssc_getbase_Kld (rschur%p_rmatrixA11, p_IrowA)
    call lsyssc_getbase_Kcol(rschur%p_rmatrixA11, p_IcolA)
    call lsyssc_getbase_Kdiagonal(rschur%p_rmatrixA11, p_IdiagA)
    call lsyssc_getbase_double(rschur%p_rmatrixA11, p_DA11)
    call lsyssc_getbase_double(rschur%p_rmatrixA22, p_DA22)

    call lsyssc_getbase_Kld (rschur%p_rmatrixB1, p_IrowB)
    call lsyssc_getbase_Kcol(rschur%p_rmatrixB1, p_IcolB)
    call lsyssc_getbase_double(rschur%p_rmatrixB1, p_DB1)
    call lsyssc_getbase_double(rschur%p_rmatrixB2, p_DB2)

    call lsyssc_getbase_Kld (rschur%p_rmatrixD1, p_IrowD)
    call lsyssc_getbase_Kcol(rschur%p_rmatrixD1, p_IcolD)
    call lsyssc_getbase_double(rschur%p_rmatrixD1, p_DD1)
    call lsyssc_getbase_double(rschur%p_rmatrixD2, p_DD2)

    call lsyssc_getbase_Kld (rschur%p_rmatrixS, p_IrowS)
    call lsyssc_getbase_Kcol(rschur%p_rmatrixS, p_IcolS)
    call lsyssc_getbase_double(rschur%p_rmatrixS, p_DS)

    ! Fetch the number of equations in S
    neq = rschur%p_rmatrixS%NEQ

    ! Fetch the assembly type
    ctype = rschur%ctype

    ! Okay, now what are we going to assemble?
    select case(ctype)
    case(SCHUR_TYPE_MAIN_DIAGONAL)

      ! This one is easy.
      call schur_mainDiagonal2D(neq, p_IdiagA, p_DA11, p_DA22, p_IrowB, &
          p_IcolB, p_DB1, p_DB2, p_IrowD, p_IcolD, p_DD1, p_DD2, p_IrowS, &
          p_IcolS, p_DS, dsf1, dsf2, rperfconfig)

    case(SCHUR_TYPE_LUMP_DIAGONAL)

      ! This one is also easy.
      call schur_lumpDiagonal2D(neq, p_IrowA, p_DA11, p_DA22, p_IrowB, &
          p_IcolB, p_DB1, p_DB2, p_IrowD, p_IcolD, p_DD1, p_DD2, p_IrowS, &
          p_IcolS, p_DS, dsf1, dsf2, rperfconfig)

    case(SCHUR_TYPE_LOCAL_INVERSE)

      ! Okay, this one is a little more interesting.

!      celemVelo = 0_I32
!      celemPres = 0_I32
!
!      ! Fetch the discretisations of B (if they exist)
!      p_rdiscrVelo => p_rB%RmatrixBlock(1,1)%p_rspatialDiscrTest
!      p_rdiscrPres => p_rB%RmatrixBlock(1,1)%p_rspatialDiscrTrial
!      if(associated(p_rdiscrVelo) .and. associated(p_rdiscrPres)) then
!
!        ! Check whether both discretisations are uniform
!        if((p_rdiscrVelo%inumFESpaces .eq. 1) .and. &
!           (p_rdiscrPres%inumFESpaces .eq. 1)) then
!
!          ! Yes, they are uniform, so get the element identifiers.
!          celemVelo = p_rdiscrVelo%RelementDistr(1)%celement
!          celemPres = p_rdiscrPres%RelementDistr(1)%celement
!
!        end if
!
!      end if
!
!      ! Now let us see if there is an interesting combination of velocity and
!      ! pressure spaces that we have a special implementation for. If not, then
!      ! there still is a 'generic' routine which we can call which performs
!      ! exactly the same job. However, the 'generic' routine is much slower
!      ! than the specialised versions...
!
!      if(.false.) then
!
!        ! ...
!
!      else

        ! Okay, we do not have a specialised version. So we will call the 'generic'
        ! routine, but first we need to calculate the degree of D - this is the
        ! maximum number of velocity DOFs which are adjacent to one pressure DOF.
        ! This information is needed by the 'generic' routine.
        ndegree = schur_aux_calcDegree(p_IrowD)

        ! And call the routine
        call schur_localInverse2D(neq, ndegree, p_IrowA, p_IcolA, &
            p_DA11, p_DA22, p_IrowB, p_IcolB, p_DB1, p_DB2, p_IrowD, p_IcolD, &
            p_DD1, p_DD2, p_IrowS, p_IcolS, p_DS, dsf1, dsf2)

!      end if

    case default

      ! stupid caller...
      call output_line ('Invalid assembly type!', &
                        OU_CLASS_ERROR,OU_MODE_STD, 'schur_assembleApprox2D')
      call sys_halt()

    end select

    ! That is it

  end subroutine

  ! ***************************************************************************

!<function>

  integer function schur_aux_calcDegree(p_IrowPtr) result(ndegree)

!<description>
  ! AUXILIARY FUNCTION:
  ! This function calculates the degree of the adjacency graph of a CSR matrix.
!</description>

!<input>
  ! A scalar matrix from which the degree is to be calculated.
  integer, dimension(:), pointer :: p_IrowPtr
!</input>

!<result>
  ! The degree of the adjacency graph of the matrix.
!</result>

!</function>

  integer :: i

    ! Get the row-pointer array of the matrix
    ndegree = 0
    do i = 1, ubound(p_IrowPtr,1)-1
      ndegree = max(ndegree, p_IrowPtr(i+1)-p_IrowPtr(i))
    end do

  end function

  ! ***************************************************************************

!<subroutine>

  subroutine schur_mainDiagonal2D(n, p_IdiagA, p_DA11, p_DA22, p_IrowB, p_IcolB, &
             p_DB1, p_DB2, p_IrowD, p_IcolD, p_DD1, p_DD2, p_IrowS, p_IcolS, &
             p_DS, dsf1, dsf2, rperfconfig)

!<description>
  ! INTERNAL ROUTINE:
  ! Assembles a Schur-complement approximation for a 2D saddle-point system
  ! by approximating <tex>$A^{-1}$</tex> by the inverse of the main diagonal of A.
!</description>

!<input>
  ! The number of rows of S (= #DOFs in pressure space)
  integer, intent(in) :: n

  ! The diagonal pointer array of A
  integer, dimension(*), intent(in) :: p_IdiagA

  ! The data arrays of A11 and A22
  real(DP), dimension(*), intent(in) :: p_DA11, p_DA22

  ! The matrix structure of B
  integer, dimension(*), intent(in) :: p_IrowB, p_IcolB

  ! The data arrays of B1 and B2
  real(DP), dimension(*), intent(in) :: p_DB1, p_DB2

  ! The matrix structure of D
  integer, dimension(*), intent(in) :: p_IrowD, p_IcolD

  ! The data arrays of D1 and D2
  real(DP), dimension(*), intent(in) :: p_DD1, p_DD2

  ! The matrix structure of S
  integer, dimension(*), intent(in) :: p_IrowS, p_IcolS

  ! The scaling factor for D1 * A11^{-1} * B1
  real(DP), intent(in) :: dsf1

  ! The scaling factor for D2 * A22^{-1} * B2
  real(DP), intent(in) :: dsf2

  ! OPTIONAL: local performance configuration. If not given, the
  ! global performance configuration is used.
  type(t_perfconfig), intent(in), target, optional :: rperfconfig
!</input>

!<inputoutput>
  ! The data array of S
  real(DP), dimension(*), intent(inout) :: p_DS
!</inputoutput>

!</subroutine>

  ! local variables
  integer :: i,j,k,l,idxB,idxD,idxS,inextS
  real(DP) :: dDA1, dDA2

  ! Pointer to the performance configuration
  type(t_perfconfig), pointer :: p_rperfconfig

  if (present(rperfconfig)) then
    p_rperfconfig => rperfconfig
  else
    p_rperfconfig => schur_perfconfig
  end if

    ! Loop over all rows of S/D
    !$omp parallel do if(n > p_rperfconfig%NEQMIN_OMP)&
    !$omp private(j,k,l,idxB,idxD,idxS,inextS,dDA1,dDA2)
    do i = 1, n

      ! Loop over all non-zeroes of row i of D
      do j = p_IrowD(i), p_IrowD(i+1)-1

        ! Get the column index of D_ij
        idxD = p_IcolD(j)

        ! Precalculate D1_ij / A11_jj and D2 / A22_jj, scaled by the
        ! corresponding scaling factors.
        k = p_IdiagA(idxD)
        dDA1 = (dsf1 * p_DD1(j)) / p_DA11(k)
        dDA2 = (dsf2 * p_DD2(j)) / p_DA22(k)

        ! Reset next non-zero pointer of row i of S. See the comment inside the
        ! loop below for closer information.
        inextS = p_IrowS(i)

        ! Loop over all non-zeroes of row j of B
        do k = p_IrowB(idxD), p_IrowB(idxD+1)-1

          ! Get the column index of B_jk
          idxB = p_IcolB(k)

          ! We are current processing entry B_jk, so we are going to calculate
          ! D_ij * A_jj * B_jk. This is only interesting if S_ik exists in the
          ! sparsity pattern of S. So let us loop over all non-zeroes of row i
          ! of S now to check whether S_ik exists and, if it exists, update its
          ! entry.

          ! We will exploit a little trick here: Since the non-zero entries of a
          ! row of B and S are sorted in ascending order in respect to their
          ! column indices, we do not need to loop through all non-zero entries
          ! of row i of S for each non-zero entry in row j of B.
          do l = inextS, p_IrowS(i+1)-1

            ! Get the column index
            idxS = p_IcolS(l)

            ! Is this entry S_ik?
            if(idxS .eq. idxB) then

              ! Yes, S_ik exists, so update it:
              ! S_ik := S_ik - D_ij * A_jj^-1 * B_jk
              p_DS(l) = p_DS(l) - dDA1*p_DB1(k) - dDA2*p_DB2(k)

              ! Also, update the next non-zero pointer of S.
              inextS = l+1
              exit

            else if(idxS .gt. idxB) then

              ! If we come out here, then we are at entry S_il with l > k, so
              ! S_ik does not exist, so let us update the next non-zero pointer
              ! of S and exit the inner-most loop here.
              inextS = l
              exit

            end if

          end do ! l

        end do ! k

      end do ! j

    end do ! i
    !$omp end parallel do

    ! That is it

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine schur_lumpDiagonal2D(n, p_IrowA, p_DA11, p_DA22, p_IrowB, p_IcolB, &
             p_DB1, p_DB2, p_IrowD, p_IcolD, p_DD1, p_DD2, p_IrowS, p_IcolS, &
             p_DS, dsf1, dsf2, rperfconfig)

!<description>
  ! INTERNAL ROUTINE:
  ! Assembles a Schur-complement approximation for a 2D saddle-point system
  ! by approximating <tex>$A^{-1}$</tex> by the inverse of the lumped diagonal matrix of A.
!</description>

!<input>
  ! The number of rows of S (= #DOFs in pressure space)
  integer, intent(in) :: n

  ! The row-pointer array of A
  integer, dimension(*), intent(in) :: p_IrowA

  ! The data arrays of A11 and A22
  real(DP), dimension(*), intent(in) :: p_DA11, p_DA22

  ! The matrix structure of B
  integer, dimension(*), intent(in) :: p_IrowB, p_IcolB

  ! The data arrays of B1 and B2
  real(DP), dimension(*), intent(in) :: p_DB1, p_DB2

  ! The matrix structure of D
  integer, dimension(*), intent(in) :: p_IrowD, p_IcolD

  ! The data arrays of D1 and D2
  real(DP), dimension(*), intent(in) :: p_DD1, p_DD2

  ! The matrix structure of S
  integer, dimension(*), intent(in) :: p_IrowS, p_IcolS

  ! The scaling factor for D1 * A11^{-1} * B1
  real(DP), intent(in) :: dsf1

  ! The scaling factor for D2 * A22^{-1} * B2
  real(DP), intent(in) :: dsf2

  ! OPTIONAL: local performance configuration. If not given, the
  ! global performance configuration is used.
  type(t_perfconfig), intent(in), target, optional :: rperfconfig
!</input>

!<inputoutput>
  ! The data array of S
  real(DP), dimension(*), intent(inout) :: p_DS
!</inputoutput>

!</subroutine>

  ! local variables
  integer :: i,j,k,l,idxB,idxD,idxS,inextS
  real(DP) :: dDA1, dDA2

  ! Pointer to the performance configuration
  type(t_perfconfig), pointer :: p_rperfconfig

  if (present(rperfconfig)) then
    p_rperfconfig => rperfconfig
  else
    p_rperfconfig => schur_perfconfig
  end if

    ! Loop over all rows of S/D
    !$omp parallel do if(n > p_rperfconfig%NEQMIN_OMP)&
    !$omp private(j,k,l,idxB,idxD,idxS,inextS,dDA1,dDA2)
    do i = 1, n

      ! Loop over all non-zeros of row i of D
      do j = p_IrowD(i), p_IrowD(i+1)-1

        ! Get the column index of D_ij
        idxD = p_IcolD(j)

        ! First of all, lump row j of A11/A22
        dDA1 = 0.0_DP
        dDA2 = 0.0_DP
        do k = p_IrowA(idxD), p_IrowA(idxD+1)-1
          dDA1 = dDA1 + p_DA11(k)
          dDA2 = dDA2 + p_DA22(k)
        end do

        ! Precalculate D1_ij / A11_jj and D2 / A22_jj, scaled by the
        ! corresponding scaling factors.
        dDA1 = (dsf1 * p_DD1(j)) / dDA1
        dDA2 = (dsf2 * p_DD2(j)) / dDA2

        ! Reset next non-zero pointer of row i of S.
        inextS = p_IrowS(i)

        ! Loop over all non-zeroes of row j of B
        do k = p_IrowB(idxD), p_IrowB(idxD+1)-1

          ! Get the column index of B_jk
          idxB = p_IcolB(k)

          do l = inextS, p_IrowS(i+1)-1

            ! Get the column index
            idxS = p_IcolS(l)

            ! Is this entry S_ik?
            if(idxS .eq. idxB) then

              ! Yes, S_ik exists, so update it:
              ! S_ik := S_ik - D_ij * A_jj^-1 * B_jk
              p_DS(l) = p_DS(l) - dDA1*p_DB1(k) - dDA2*p_DB2(k)

              ! Also, update the next non-zero pointer of S.
              inextS = l+1
              exit

            else if(idxS .gt. idxB) then

              inextS = l
              exit

            end if

          end do ! l

        end do ! k

      end do ! j

    end do ! i
    !$omp end parallel do

    ! That is it

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine schur_localInverse2D(n, ndegree, p_IrowA, p_IcolA, p_DA11, p_DA22, &
             p_IrowB, p_IcolB, p_DB1, p_DB2, p_IrowD, p_IcolD, p_DD1, p_DD2, &
             p_IrowS, p_IcolS, p_DS, dsf1, dsf2)

!<description>
  ! INTERNAL ROUTINE:
  ! Assembles a Schur-complement approximation for a 2D saddle-point system
  ! by approximating <tex>$A^{-1}$</tex> by local inverse sub-matrices.
!</description>

!<input>
  ! The number of rows of S (= #DOFs in pressure space)
  integer, intent(in) :: n

  ! The degree of the matrix D.
  integer, intent(in) :: ndegree

  ! The matrix structure of A
  integer, dimension(*), intent(in) :: p_IrowA, p_IcolA

  ! The data arrays of A11 and A22
  real(DP), dimension(*), intent(in) :: p_DA11, p_DA22

  ! The matrix structure of B
  integer, dimension(*), intent(in) :: p_IrowB, p_IcolB

  ! The data arrays of B1 and B2
  real(DP), dimension(*), intent(in) :: p_DB1, p_DB2

  ! The matrix structure of D
  integer, dimension(*), intent(in) :: p_IrowD, p_IcolD

  ! The data arrays of D1 and D2
  real(DP), dimension(*), intent(in) :: p_DD1, p_DD2

  ! The matrix structure of S
  integer, dimension(*), intent(in) :: p_IrowS, p_IcolS

  ! The scaling factor for D1 * A11^{-1} * B1
  real(DP), intent(in) :: dsf1

  ! The scaling factor for D2 * A22^{-1} * B2
  real(DP), intent(in) :: dsf2
!</input>

!<inputoutput>
  ! The data array of S
  real(DP), dimension(*), intent(inout) :: p_DS
!</inputoutput>

!</subroutine>

  integer :: i,j,k,l,m,idxA,idxB,idxD,idxS,inextD,inextS,irowD1,irowD2

  ! Local matrices
  real(DP), dimension(ndegree) :: DDA1, DDA2
  real(DP), dimension(ndegree,ndegree) :: DA11, DA22

  ! Column index array for current row of D
  integer, dimension(ndegree) :: IidxD

  ! A pivot array for LAPACK
  integer, dimension(ndegree) :: Ipivot
  integer :: info1, info2

    ! Remark:
    ! For an explaination of what 'inextD' and 'inextS' are used for here,
    ! see the comments in the routine 'schur_mainDiagonal2D'.

    ! Loop over all rows of S/D
    do i = 1, n

      ! Clear the local matrices
      !DDA1 = 0.0_DP
      !DDA2 = 0.0_DP
      DA11 = 0.0_DP
      DA22 = 0.0_DP

      ! Fetch the current row of D
      irowD1 = p_IrowD(i)
      irowD2 = p_IrowD(i+1)-1
      m = irowD2 - irowD1 + 1
      DDA1(1:m) = dsf1 * p_DD1(irowD1:irowD2)
      DDA2(1:m) = dsf2 * p_DD2(irowD1:irowD2)
      IidxD(1:m) = p_IcolD(irowD1:irowD2)

      ! Loop over all non-zeroes of row i of D
      do j = 1, m

        ! Get the column index of D_ij
        idxD = IidxD(j)

        ! Reset next non-zero pointer of D
        inextD = 1

        ! Loop over all non-zeroes of row j of A
        do k = p_IrowA(idxD), p_IrowA(idxD+1)-1

          ! Get the column index of A_jk
          idxA = p_IcolA(k)

          ! Check whether A_jk exists in our local A matrix and, if it exists,
          ! store the entry.
          do l = inextD, m

            if(IidxD(l) .eq. idxA) then

              ! Yes, so store A_jk to our local matrix.
              ! Remark: We store the local matrix in transposed format, as this
              ! will be needed by LAPACK's DGESV routine below!
              DA11(l,j) = p_DA11(k)
              DA22(l,j) = p_DA22(k)

              inextD = l+1
              exit

            else if(IidxD(l) .gt. idxA) then

              inextD = l
              exit

            end if

          end do ! l

        end do ! k

      end do ! j

      ! Okay, we now have row i of D and the local matrix of A stored in
      ! DDA1/DA2 and DA11/DA22. Now we are going to calculate D * A^-1.
      ! Since D is a row vector, we stored A in transposed format in the code
      ! above, so we will solve now (A^T)^-1 * D^T.
      call DGESV(m,1,DA11,ndegree,Ipivot,DDA1,ndegree,info1)
      call DGESV(m,1,DA22,ndegree,Ipivot,DDA2,ndegree,info2)

      ! Make sure LAPACK did not fail
      if((info1 .ne. 0) .or. (info2 .ne. 0)) then
        call output_line ('Local matrix singular!', &
                          OU_CLASS_ERROR,OU_MODE_STD, 'schur_localInverse2D')
        call sys_halt()
      end if

      ! Okay, loop over all non-zeroes of row D again.
      do j = 1, m

        ! Get the column index of D_ij
        idxD = IidxD(j)

        ! Reset next non-zero pointer of S
        inextS = p_IrowS(i)

        ! Loop over all non-zeroes of row j of B
        do k = p_IrowB(idxD), p_IrowB(idxD+1)-1

          ! Get the column index of B_jk
          idxB = p_IcolB(k)

          ! Try to find S_ik
          do l = inextS, p_IrowS(i+1)-1

            ! Get column index of S
            idxS = p_IcolS(l)

            ! Is this entry S_ik?
            if(idxS .eq. idxB) then

              ! Yes, so update it.
              p_DS(l) = p_DS(l) - DDA1(j)*p_DB1(k) - DDA2(j)*p_DB2(k)

              inextS = l+1
              exit

            else if(idxS .gt. idxB) then

              inextS = l
              exit

            end if

          end do ! l

        end do ! k

      end do ! j

    end do ! i

    ! That is it

  end subroutine

end module


module nbinMod
  integer :: nbin
  integer :: imemb
  real    :: dpia13srt(100)
  integer :: n9(9)
  integer :: iTcount
!begin  WSO 8/8/13
  integer :: ntransition
!end    WSO 8/8/13
contains
  subroutine init_nbin
    use ran_mod
    nbin=88
    iTcount=0
    do i=1,100
       dpia13srt(i)=normal2(0.,1.)
    enddo
!begin  WSO 8/14/13
    ntransition = 10
!end    WSO 8/14/13

  end subroutine init_nbin
end module nbinMod


      SUBROUTINE cftrig_g (n, trigs)
      USE stel_kinds
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER n
      REAL(rprec), DIMENSION(*) :: trigs
#if !defined(CRAY) || defined(LONESTAR) || defined(MCURIE)
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      REAL(rprec), PARAMETER :: one = 1, two = 2, p5 = .5_dp
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: l, i
      REAL(rprec) :: pi, del, angle
!-----------------------------------------------
      pi = two*ASIN(one)
      del = (pi + pi)/n
      l = n + n
      DO 10 i=1,l,2
        angle=(p5*del)*(i-1)
        trigs(i)=COS(angle)
        trigs(i+1)=SIN(angle)
   10 CONTINUE
#else
      CALL cftrig (n, trigs)
#endif
      END SUBROUTINE cftrig_g


      SUBROUTINE DT_XGLOGY(N,Iarg,X,Y1,Y2)
C***********************************************************************
C
C     calculate quasi graphic picture with 25 lines and 79 columns
C     logarithmic y axis
C     ranges will be chosen automatically
C
C     input     N          dimension of input fields
C               IARG       number of curves (fields) to plot
C               X          field of X
C               Y1         field of Y1
C               Y2         field of Y2
C
C This subroutine is written by R. Engel.
C***********************************************************************
C
      IMPLICIT NONE
      DOUBLE PRECISION DEPS , EPS , X , xmax , xmin , xzoom , xzoom1 ,
     &                 Y1 , Y2 , yma , ymax , ymi , ymin , ypos , yzoom
      INTEGER i , Iarg , IBREIT , id , ii , ilast , ispalt , itest ,
     &        IXRAST , IYRAST , IZEIL , k , kk , l , ld , llast , N
      SAVE

      INCLUDE 'inc/dtflka'

      DIMENSION X(N) , Y1(N) , Y2(N)
      PARAMETER (EPS=1.D-30)
      PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
      CHARACTER symb(5)
      CHARACTER col(0:149,0:49)
      PARAMETER (DEPS=1.D-10)
C
      DATA symb/'0' , 'e' , 'z' , '#' , 'x'/
C
      ispalt = IBREIT - 10
C
C
      xmax = X(1)
      xmin = X(1)
      DO i = 1 , N
         xmax = MAX(X(i),xmax)
         xmin = MIN(X(i),xmin)
      END DO
      xzoom = (xmax-xmin)/DBLE(ispalt)
C
      itest = 0
      DO k = 0 , IZEIL - 1
         itest = itest + 1
         IF ( itest.EQ.IYRAST ) THEN
            DO l = 1 , ispalt - 1
               col(l,k) = '-'
            END DO
            col(ispalt,k) = '+'
            itest = 0
            DO l = 0 , ispalt - 1 , IXRAST
               col(l,k) = '+'
            END DO
         ELSE
            DO l = 1 , ispalt - 1
               col(l,k) = ' '
            END DO
            DO l = 0 , ispalt - 1 , IXRAST
               col(l,k) = '|'
            END DO
            col(ispalt,k) = '|'
         END IF
      END DO
C
C
      ymax = Y1(1)
      ymin = MAX(Y1(1),EPS)
      DO i = 1 , N
         ymax = MAX(Y1(i),ymax)
         IF ( Y1(i).GT.EPS ) THEN
            IF ( ymin.EQ.EPS ) THEN
               ymin = Y1(i)/10.D0
            ELSE
               ymin = MIN(Y1(i),ymin)
            END IF
         END IF
      END DO
      IF ( Iarg.GT.1 ) THEN
         DO i = 1 , N
            ymax = MAX(Y2(i),ymax)
            IF ( Y2(i).GT.EPS ) THEN
               IF ( ymin.EQ.EPS ) THEN
                  ymin = Y2(i)
               ELSE
                  ymin = MIN(Y2(i),ymin)
               END IF
            END IF
         END DO
      END IF
C
      DO i = 1 , N
         Y1(i) = MAX(Y1(i),ymin)
      END DO
      IF ( Iarg.GT.1 ) THEN
         DO i = 1 , N
            Y2(i) = MAX(Y2(i),ymin)
         END DO
      END IF
C
      IF ( ymax.LE.ymin ) THEN

         IF ( LPRi.GT.4 ) WRITE (LOUt,'(/1X,A,2E12.3,/)')
     &         'XGLOGY:ERROR:YMIN,YMAX ' , ymin , ymax

         IF ( LPRi.GT.4 ) WRITE (LOUt,'(1X,A)')
     &         'MIN = MAX, OUTPUT SUPPRESSED'
         RETURN
      END IF
C
      yma = (LOG10(ymax)-LOG10(ymin))/20.0D0 + LOG10(ymax)
      ymi = LOG10(ymin) - (LOG10(ymax)-LOG10(ymin))/20.0D0
      yzoom = (yma-ymi)/DBLE(IZEIL)
      IF ( yzoom.LT.EPS ) THEN

         IF ( LPRi.GT.4 ) WRITE (LOUt,'(1X,A)')
     &         'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
         RETURN
      END IF
C
C
      ilast = -1
      llast = -1
      DO k = 1 , N
         l = NINT((X(k)-xmin)/xzoom)
         i = NINT((yma-LOG10(Y1(k)))/yzoom)
         IF ( ilast.GE.0 ) THEN
            ld = l - llast
            id = i - ilast
            DO ii = 0 , ld , SIGN(1,ld)
               DO kk = 0 , id , SIGN(1,id)
                  col(ii+llast,kk+ilast) = symb(1)
               END DO
            END DO
         ELSE
            col(l,i) = symb(1)
         END IF
         ilast = i
         llast = l
      END DO
C
      IF ( Iarg.GT.1 ) THEN
C
C
         DO k = 1 , N
            l = NINT((X(k)-xmin)/xzoom)
            i = NINT((yma-LOG10(Y2(k)))/yzoom)
            col(l,i) = symb(2)
         END DO
      END IF
C
C

      IF ( LPRi.GT.4 ) WRITE (LOUt,'(2X,A)') '(LOGARITHMIC Y AXIS)'

      IF ( LPRi.GT.4 ) WRITE (LOUt,'(1X,79A)') ('-',i=1,IBREIT)
C
C
      xzoom1 = (xmax-xmin)/DBLE(7)

      IF ( LPRi.GT.4 ) WRITE (LOUt,99020) (xzoom1*DBLE(i-1)+xmin,i=1,7)
C
      DO k = 0 , IZEIL - 1
         ypos = 10.D0**(yma-((DBLE(k)+0.5D0)*yzoom))

         IF ( LPRi.GT.4 ) WRITE (LOUt,99010) ypos ,
     &        (col(i,k),i=0,ispalt)
99010    FORMAT (1X,1PE9.2,70A1)
      END DO
C
C

      IF ( LPRi.GT.4 ) WRITE (LOUt,99020) (xzoom1*DBLE(i-1)+xmin,i=1,7)

      IF ( LPRi.GT.4 ) WRITE (LOUt,'(1X,79A)') ('-',i=1,IBREIT)
99020 FORMAT (6X,7(1PE10.3))
C
      END SUBROUTINE


      real*8 function drand48()
!-------------------------------------------------------------------------
!
      integer m, ia, ic, ntab
      real*8  rm
      parameter (ntab=97,m=714025,ia=1366,ic=150889,rm=1.0/m)
      integer ir(ntab), iff, idum, j, iy
      data iff /0/, idum/0/
      save iff, idum, iy, ir
!
!
      if(idum.lt.0.or.iff.eq.0) then
        iff=1
        idum=mod(ic-idum,m)
        do j=1,ntab
           idum=mod(ia*idum+ic,m)
           ir(j)=idum
        end do
        idum=mod(ia*idum+ic,m)
        iy=idum
      endif
      j=1+(ntab*iy)/m
      if(j.gt.ntab.or.j.lt.1) then
        print*, 'error! in drand48, j out of range',j
	  stop
      endif
      iy=ir(j)
      drand48=iy*rm
      idum=mod(ia*idum+ic,m)
      ir(j)=idum
      return
      end


! test of fftsg3d.f
!
      program main
      integer nmax, nmaxsqrt
      parameter (nmax = 128)
      parameter (nmaxsqrt = 16)
      integer ip(0 : nmaxsqrt + 1), n1, n2, n3, i, j
      real*8 a(0 : nmax - 1, 0 : nmax - 1, 0 : nmax - 1),
     &    t(0 : 8 * nmax - 1),
     &    w(0 : nmax * 3 / 2 - 1), err, errorcheck3d
!
      write (*, *) 'data length n1=? (n1 = power of 2) '
      read (*, *) n1
      write (*, *) 'data length n2=? (n2 = power of 2) '
      read (*, *) n2
      write (*, *) 'data length n3=? (n3 = power of 2) '
      read (*, *) n3
      ip(0) = 0
!
!   check of CDFT
      call putdata3d(nmax, nmax, n1, n2, n3, a)
      call cdft3d(nmax, nmax, n1, n2, n3, 1, a, t, ip, w)
      call cdft3d(nmax, nmax, n1, n2, n3, -1, a, t, ip, w)
      err = errorcheck3d(nmax, nmax, n1, n2, n3,
     &    2.0d0 / n1 / n2 / n3, a)
      write (*, *) 'cdft3d err= ', err
!
!   check of RDFT
      call putdata3d(nmax, nmax, n1, n2, n3, a)
      call rdft3d(nmax, nmax, n1, n2, n3, 1, a, t, ip, w)
      call rdft3d(nmax, nmax, n1, n2, n3, -1, a, t, ip, w)
      err = errorcheck3d(nmax, nmax, n1, n2, n3,
     &    2.0d0 / n1 / n2 / n3, a)
      write (*, *) 'rdft3d err= ', err
!
!   check of DDCT
      call putdata3d(nmax, nmax, n1, n2, n3, a)
      call ddct3d(nmax, nmax, n1, n2, n3, 1, a, t, ip, w)
      call ddct3d(nmax, nmax, n1, n2, n3, -1, a, t, ip, w)
      do j = 0, n2 - 1
          do i = 0, n1 - 1
              a(i, j, 0) = a(i, j, 0) * 0.5d0
          end do
      end do
      do j = 0, n3 - 1
          do i = 0, n1 - 1
              a(i, 0, j) = a(i, 0, j) * 0.5d0
          end do
          do i = 0, n2 - 1
              a(0, i, j) = a(0, i, j) * 0.5d0
          end do
      end do
      err = errorcheck3d(nmax, nmax, n1, n2, n3,
     &    8.0d0 / n1 / n2 / n3, a)
      write (*, *) 'ddct3d err= ', err
!
!   check of DDST
      call putdata3d(nmax, nmax, n1, n2, n3, a)
      call ddst3d(nmax, nmax, n1, n2, n3, 1, a, t, ip, w)
      call ddst3d(nmax, nmax, n1, n2, n3, -1, a, t, ip, w)
      do j = 0, n2 - 1
          do i = 0, n1 - 1
              a(i, j, 0) = a(i, j, 0) * 0.5d0
          end do
      end do
      do j = 0, n3 - 1
          do i = 0, n1 - 1
              a(i, 0, j) = a(i, 0, j) * 0.5d0
          end do
          do i = 0, n2 - 1
              a(0, i, j) = a(0, i, j) * 0.5d0
          end do
      end do
      err = errorcheck3d(nmax, nmax, n1, n2, n3,
     &    8.0d0 / n1 / n2 / n3, a)
      write (*, *) 'ddst3d err= ', err
!
      end
!
!
      subroutine putdata3d(n1max, n2max, n1, n2, n3, a)
      integer n1max, n2max, n1, n2, n3, j1, j2, j3, seed
      real*8 a(0 : n1max - 1, 0 : n2max - 1, 0 : *), drnd
      seed = 0
      do j3 = 0, n3 - 1
          do j2 = 0, n2 - 1
              do j1 = 0, n1 - 1
                  a(j1, j2, j3) = drnd(seed)
              end do
          end do
      end do
      end
!
!
      function errorcheck3d(n1max, n2max, n1, n2, n3, scale, a)
      integer n1max, n2max, n1, n2, n3, j1, j2, j3, seed
      real*8 scale, a(0 : n1max - 1, 0 : n2max - 1, 0 : *),
     &    drnd, err, e, errorcheck3d
      err = 0
      seed = 0
      do j3 = 0, n3 - 1
          do j2 = 0, n2 - 1
              do j1 = 0, n1 - 1
                  e = drnd(seed) - a(j1, j2, j3) * scale
                  err = max(err, abs(e))
              end do
          end do
      end do
      errorcheck3d = err
      end
!
!
! random number generator, 0 <= drnd < 1
      real*8 function drnd(seed)
      integer seed
      seed = mod(seed * 7141 + 54773, 259200)
      drnd = seed * (1.0d0 / 259200)
      end
!


      SUBROUTINE SLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
*
*  -- LAPACK auxiliary routine (version 3.2) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          EQUED, UPLO
      INTEGER            N
      REAL               AMAX, SCOND
*     ..
*     .. Array Arguments ..
      REAL               AP( * ), S( * )
*     ..
*
*  Purpose
*  =======
*
*  SLAQSP equilibrates a symmetric matrix A using the scaling factors
*  in the vector S.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the upper or lower triangular part of the
*          symmetric matrix A is stored.
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  AP      (input/output) REAL array, dimension (N*(N+1)/2)
*          On entry, the upper or lower triangle of the symmetric matrix
*          A, packed columnwise in a linear array.  The j-th column of A
*          is stored in the array AP as follows:
*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*
*          On exit, the equilibrated matrix:  diag(S) * A * diag(S), in
*          the same storage format as A.
*
*  S       (input) REAL array, dimension (N)
*          The scale factors for A.
*
*  SCOND   (input) REAL
*          Ratio of the smallest S(i) to the largest S(i).
*
*  AMAX    (input) REAL
*          Absolute value of largest matrix entry.
*
*  EQUED   (output) CHARACTER*1
*          Specifies whether or not equilibration was done.
*          = 'N':  No equilibration.
*          = 'Y':  Equilibration was done, i.e., A has been replaced by
*                  diag(S) * A * diag(S).
*
*  Internal Parameters
*  ===================
*
*  THRESH is a threshold value used to decide if scaling should be done
*  based on the ratio of the scaling factors.  If SCOND < THRESH,
*  scaling is done.
*
*  LARGE and SMALL are threshold values used to decide if scaling should
*  be done based on the absolute size of the largest matrix element.
*  If AMAX > LARGE or AMAX < SMALL, scaling is done.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, THRESH
      PARAMETER          ( ONE = 1.0E+0, THRESH = 0.1E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J, JC
      REAL               CJ, LARGE, SMALL
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               SLAMCH
      EXTERNAL           LSAME, SLAMCH
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( N.LE.0 ) THEN
         EQUED = 'N'
         RETURN
      END IF
*
*     Initialize LARGE and SMALL.
*
      SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
      LARGE = ONE / SMALL
*
      IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
*
*        No equilibration
*
         EQUED = 'N'
      ELSE
*
*        Replace A by diag(S) * A * diag(S).
*
         IF( LSAME( UPLO, 'U' ) ) THEN
*
*           Upper triangle of A is stored.
*
            JC = 1
            DO 20 J = 1, N
               CJ = S( J )
               DO 10 I = 1, J
                  AP( JC+I-1 ) = CJ*S( I )*AP( JC+I-1 )
   10          CONTINUE
               JC = JC + J
   20       CONTINUE
         ELSE
*
*           Lower triangle of A is stored.
*
            JC = 1
            DO 40 J = 1, N
               CJ = S( J )
               DO 30 I = J, N
                  AP( JC+I-J ) = CJ*S( I )*AP( JC+I-J )
   30          CONTINUE
               JC = JC + N - J + 1
   40       CONTINUE
         END IF
         EQUED = 'Y'
      END IF
*
      RETURN
*
*     End of SLAQSP
*
      END


!====================================================================
!
! MODULE: ConvLevelLayer
!
!  SUBROUTINE: Conv_LevelLayer()
!
!
! Created by Y.Tahara in Aug,02
!
!====================================================================

module ConvLevelLayer

  ! -- include modules

  use type_kinds, only : fp_kind
  use ParametersGenCoef

  ! -- disable implicit typing

  IMPLICIT NONE

  !--- public & private

  Private

  Public  Conv_LevelLayer

 CONTAINS

  !===========================================================================
  ! Subroutine to convert atmospheric elements on levels to layers.
  ! For the conversion, Paul's utilities are used.
  !===========================================================================

  subroutine Conv_LevelLayer( level_p, level_t, level_aa, &
                              layer_p, layer_t, layer_aa, &
                              N_LEVELS, N_ABSORBERS )

    ! -- Inputs

    INTEGER        , INTENT(IN)  :: N_LEVELS                    ! # of levels
    INTEGER        , INTENT(IN)  :: N_ABSORBERS                 ! # of gases
    REAL( fp_kind ), INTENT(IN)  :: level_p ( N_LEVELS )        ! pressure on levels (hPa)
    REAL( fp_kind ), INTENT(IN)  :: level_t ( N_LEVELS )        ! temperature on levels (K)
    REAL( fp_kind ), INTENT(IN)  :: level_aa( N_LEVELS, N_ABSORBERS )
                                                                ! atmospheric gases
                                                                ! level_aa(:,1) : contains water vapor mixing ratio (g/kg)

    ! -- Outputs

    REAL( fp_kind ), INTENT(OUT) :: layer_p ( N_LEVELS-1 )      ! pressure on layers
    REAL( fp_kind ), INTENT(OUT) :: layer_t ( N_LEVELS-1 )      ! temperature on layers
    REAL( fp_kind ), INTENT(OUT) :: layer_aa( N_LEVELS-1, N_ABSORBERS )
                                                                ! atmospheric gases
                                                                ! level_aa(:,1) : water vapor mixing ratio (g/kg)

    ! -- layer P

    layer_p(1:(N_LEVELS-1)) =    ( level_p(1:(N_LEVELS-1)) - level_p(2:N_LEVELS) ) / &
                              log( level_p(1:(N_LEVELS-1)) / level_p(2:N_LEVELS) )

    ! -- layer T

    layer_t(1:(N_LEVELS-1)) = ( level_t(1:(N_LEVELS-1)) + level_t(2:N_LEVELS) ) / TWO

    ! -- layer absorber

    layer_aa(1:(N_LEVELS-1),:) = ( level_aa(1:(N_LEVELS-1),:) + level_aa(2:N_LEVELS,:) ) / TWO

  end subroutine Conv_LevelLayer

end module ConvLevelLayer


*----------------------------------------------------------------------*
      subroutine calc_xref(xref,xao,cmo,xhlf,nsym,nbas,nxbas,
     &                     ngas,hpvx_gas,idxcmo,mostnd)
*----------------------------------------------------------------------*
*
*     calculates reference expectation value for x-operator
*     matthias, 2008
*----------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'

      integer, parameter ::
     &     ntest = 00

      real(8), intent(out) ::
     &     xref

      real(8), intent(in) ::
     &     cmo(*), xao(*)

      real(8), intent(inout) ::
     &     xhlf(*)

      integer, intent(in) ::
     &     nsym, nbas(nsym), nxbas(nsym), ngas, hpvx_gas(ngas),
     &     idxcmo(nsym,ngas,1), mostnd(2,nsym,ngas)

      integer ::
     &     isym, igas, ixao, icmoc, norb

      real(8), external ::
     &     ddot

      ixao = 1
      xref = 0d0

      do isym = 1, nsym

        if (ntest.ge.100)
     &       write(lulog,*) 'isym: ',isym

        if (nbas(isym).eq.0) cycle

        do igas = 1, ngas

          if (ntest.ge.100)
     &       write(lulog,*) 'igas,hpvx_gas(igas): ',igas,hpvx_gas(igas)

          if (hpvx_gas(igas).ne.1) cycle

          icmoc = idxcmo(isym,igas,1)
          norb = mostnd(2,isym,igas)-mostnd(1,isym,igas)+1

          if (ntest.ge.100)
     &         write(lulog,*) 'norb,nbas(isym),ntao: ',
     &             norb,nbas(isym),nbas(isym)+nxbas(isym)

          if (norb.gt.0) then

            if (ntest.ge.100)
     &            write(lulog,*) 'xao(ixao) = ',xao(ixao)
            if (ntest.ge.100)
     &            write(lulog,*) 'cmo(icmoc) = ',cmo(icmoc)

            call dgemm('n','n',nbas(isym),norb,nbas(isym),
     &                1d0,xao(ixao),nbas(isym)+nxbas(isym),
     &                    cmo(icmoc),nbas(isym),
     &                0d0,xhlf,nbas(isym))

            if (ntest.ge.100)
     &            write(lulog,*) 'xhlf(1) = ',xhlf(1)

            xref = xref + 2*ddot(nbas(isym)*norb,xhlf(1),1,cmo(icmoc),1)

            if (ntest.ge.100)
     &            write(lulog,*) 'xref = ',xref

          end if
        end do
        ixao = ixao + (nbas(isym) + nxbas(isym))**2
      end do

      if (ntest.ge.100)
     &          write(lulog,*) 'total xref = ',xref

      return
      end


!-----subroutine---------------------------------------------g.guidati--
!
     subroutine SETMATA
!
!-----------------------------------------------------------------------
!
!     franco guidati    IAG
!                       Uni Stuttgart
!
!
!     scope             set up acoustic influence
!                       coefficients matrix
!
!.......................................................................
!               declarations
!.......................................................................
      USE TINoiseGeneric
      USE TINoiseGeo
      USE TINoiseDDD
      USE TINoiseCancela
      IMPLICIT                        NONE

   ! Local variables.
INTEGER (4)                  :: i,j,ishift,jshift,ng,info

REAL(DbKi)                   :: rhelp,solidangle,summ
COMPLEX(DbKi)                :: HERM(na+1,na+1,4),ampi,value
COMPLEX(DbKi)                :: herm1, herm2, herm3, herm4, HANK1, HANK0
!.......................................................................
!
!.......................................................................
      ng = 10

!      write(*,*) 'SETTING UP AIC-MATRIX'
      rhelp = acos(-tc1at(1)*tc1at(na+1) - tc2at(1)*tc2at(na+1))
      solidangle = 1.0 - 0.5*(2.0*rhelp/pi2)

      do i=1,na+2
        do j=1,na+2
	  Kerna(i,j) = 0.0d0
	end do
      end do

      do i=1,na

!          write(*,*) i

        x1 = yc1at(i)
        x2 = yc2at(i)

        Kerna(i,i) = 0.5d0
        if(i.eq.1) Kerna(i,i) = solidangle

        do j=1,na
          s1 = sworkat(j)   + 0.0000001
          s2 = sworkat(j+1) - 0.0000001

          call CDA0   (sworkat, yc1at, yc2at, d2yc1at, d2yc2at,na, ng, td, Ad, pi2i, kwave,herm1, herm2, herm3, herm4 )

          HERM(i,j,1) = herm1
          HERM(i,j,2) = herm2
          HERM(i,j,3) = herm3
          HERM(i,j,4) = herm4

          do jshift=0,1

            Kerna(i,j+jshift) = Kerna(i,j+jshift) - HERM(i,j,jshift+1)

            ishift=0
            if(j+jshift.eq.1     ) ishift= 2
            if(j+jshift.eq.2     ) ishift= 1
            if(j+jshift.eq.n     ) ishift=-1
            if(j+jshift.eq.n+1   ) ishift=-2
  	    Kerna(i,j-2+ishift+jshift) = Kerna(i,j-2+ishift+jshift) -dst(-2,ishift)*HERM(i,j,jshift+3)*.5

            Kerna(i,j-1+ishift+jshift) = Kerna(i,j-1+ishift+jshift) -dst(-1,ishift)*HERM(i,j,jshift+3)*.5

            Kerna(i,j  +ishift+jshift) = Kerna(i,j  +ishift+jshift) -dst( 0,ishift)*HERM(i,j,jshift+3)*.5

            Kerna(i,j+1+ishift+jshift) = Kerna(i,j+1+ishift+jshift) -dst( 1,ishift)*HERM(i,j,jshift+3)*.5

	    Kerna(i,j+2+ishift+jshift) = Kerna(i,j+2+ishift+jshift) -dst( 2,ishift)*HERM(i,j,jshift+3)*.5

          enddo

        enddo

      enddo

      Kerna(na+1,1)       =  1.0
      Kerna(na+1,na+1)    = -1.0
      Kerna(na+2,na+2)    =  1.0

      call zgetrf (na+2,na+2,Kerna,na+2,ipiva,info)
      if(info.ne.0) then
        write(*,*) 'oopsy - something is wrong'
        stop
      endif
!      write(*,*) 'AKUSTIK MATRIX INVERTIERT',info

!.......................................................................
!               end of subroutine
!.......................................................................
      return
!***********************************************************************
      end


    program demo_eoshift
    implicit none
        integer, dimension(3,3) :: a
        a = reshape( [ 1, 2, 3, 4, 5, 6, 7, 8, 9 ], [ 3, 3 ])
        print '(3i3)', a(1,:)
        print '(3i3)', a(2,:)
        print '(3i3)', a(3,:)
        a = eoshift(a, SHIFT=[1, 2, 1], BOUNDARY=-5, DIM=2)
        print *
        print '(3i3)', a(1,:)
        print '(3i3)', a(2,:)
        print '(3i3)', a(3,:)
    end program demo_eoshift