c
c***************************************************************************
c

       subroutine maxwell_dist(u0, NUPAR, NUPER,
     .                       UminPara, UmaxPara,
     .                       UPERP, UPARA, DFDUPER, DFDUPAR, FPERP)
       implicit none

       integer, intent(in) ::NUPAR,NUPER
       integer n,m

       real :: UminPara,UmaxPara
       real :: UPERP(NUPER)
       real :: UPARA(NUPAR)
       real, intent(inout) :: DFDUPER(NUPER,NUPAR), DFDUPAR(NUPER,NUPAR)
       real, intent(inout) :: FPERP(NUPER)
       real  pi, fnorm, f, u2, u0, u02

       parameter (PI = 3.141592653597932384)

       fnorm = u0**3 / pi**1.5
       u02 = u0**2

       do n = 1, NUPER
          do m = 1, NUPAR
             u2 = UPERP(n)**2 + UPARA(m)**2
             f = fnorm * exp(-u2 * u02)
	     fperp(n) = fnorm * exp(-UPERP(n)**2 * u02)
             DFDUPER(n, m) = f *(-2.0 * UPERP(n) * u02)
             DFDUPAR(n, m) = f *(-2.0 * UPARA(m) * u02)
          end do
       end do

       end subroutine maxwell_dist

c
c***************************************************************************
c

      subroutine besjc (z,n,b,ier)
c
c subroutine besjc (z,n,b,ier)
c
c dimension of           b(n+1)
c arguments
c
c latest revision        october 1978
c
c purpose                to calculate j bessel functions for complex
c                        argument and integer order
c
c usage                  call besjc (z,n,b,ier)
c
c arguments
c
c on input               z
c                          complex argument for which j bessel functions
c                          are to be calculated.  abs(aimag(z)) must be
c                          less than the largest real argument that the
c                          fortran function exp can handle.
c
c                        n
c                          integer, the highest order to be calculated.
c                          n must be greater than or equal to zero.
c
c on output              b
c                          complex vector of length n+1 containing the
c                          bessel function values j-sub-0(z),j-sub-1(z),
c                          ...,j-sub-n(z) in b(1),b(2),...,b(n+1).
c                        ier
c                          an integer error flag.
c                          =0 if all desired orders have been calculated
c                             satisfactorily,
c                          =1 if abs(aimag(z)) is too large,
c                          =2 if n is less than zero,
c                          =2+k if only the first k results are correct.
c                             in the returned values b(m) for m greater
c                             than k, approximately the last
c                             alog10(abs(b(m)/b(k))) significant digits
c                             are in error.
c
c entry points           besjc
c
c special conditions     none
c
c common blocks          none
c
c i/o                    none, except for error messages produced by
c                        calling the error handling routine uliber.
c
c precision              single
c
c specialist             russ rew, ncar, boulder, colorado
c
c accuracy               in tests run on the 7600 with orders from 0
c                        through 10 using random values of the argument
c                        with absolute value less than 50 but
c                        concentrated around the origin, the maximum
c                        relative error (or absolute error when it was
c                        larger) observed was about 8.2e-14.
c
c timing                 on ncar"s control data 7600, besic takes about
c                        .32+.008*n milliseconds when z=(1.0,1.0).
c
c portability            ansi 1966 standard
c
c
c
c
c
c
      complex         z          ,b(1)
      data iorj/0/,xlarge/1000000./
c
      nb = n+1
      call b2slci (real(z),aimag(z),nb,iorj,b,ncalc)
      ier = 0
      if (ncalc .eq. nb) go to 103
      if (ncalc .ge. 0) go to 102
      if (n .ge. 0) go to 101
      ier = 2
      call uliber (ier,25h in besjc, n out of range,25)
      go to 103
  101 ier = 1
      call uliber (ier,25h in besjc, x out of range,25)
      go to 103
  102 ier = 2+ncalc
      call uliber (ier,40h in besjc, accuracy lost for some orders,40)
  103 return
      end

c
c********************************************************************
c

c***************************************************************************
c

      subroutine polavg(f, favg, rho, nxdim, nydim, nrhodim,
     .   nnodex, nnodey, nnoderho, drho, dx, dy, capr, r0, vol, fvol)

      implicit none

      integer nxdim, nydim, nrhodim, nnodex, nnodey, nnoderho
      integer n, i, j

      real f(nxdim, nydim), favg(nrhodim), rho(nxdim, nydim), r0,
     .   drho, dx, dy, fvol(nrhodim), vol(nrhodim), capr(nxdim)

      logical use_vol_ij
      parameter(use_vol_ij=.false.)

      integer n_ij(nnodex,nnodey)
      real fvol_ij(nnodex,nnodey)
      real vol_ij(nnodex,nnodey)
      logical has_n(nnodex,nnodey)

      do n = 1, nnoderho
          fvol(n) = 0.0
          vol(n) = 0.0
          favg(n) = 0.0
      end do

      if (use_vol_ij) then
         do j=1,nnodey
         do i=1,nnodex
            n = int(rho(i,j) / drho) + 1
            has_n(i,j) = (1.le.n).and.(n.le.nnoderho)
            if(has_n(i,j)) then
               n_ij(i,j) = n
               fvol_ij(i,j) =  dx * dy * f(i,j)
               vol_ij(i,j) =   dx * dy
            endif
         enddo
         enddo

!dir$ novector
         do j=1,nnodey
!dir$ novector
         do i=1,nnodex
           if (has_n(i,j)) then
              n = n_ij(i,j)
              fvol(n) = fvol(n) + fvol_ij(i,j)
              vol(n) = vol(n) + vol_ij(i,j)
           endif
         enddo
         enddo
!dir$ vector

      else

      do i = 1, nnodex
         do j = 1, nnodey
            n = int(rho(i,j) / drho) + 1
            if(n .le. nnoderho)then
               fvol(n) = fvol(n) + dx * dy * f(i,j)
               vol(n) =  vol(n) + dx * dy
            end if
         end do
      end do

      endif

      do n = 1, nnoderho
         favg(n) = 0.0
         if(vol(n) .ne. 0.0)favg(n) = fvol(n) / vol(n)
c         if(favg(n) .eq. 0.0 .and. n .gt. 1)favg(n) = favg(n-1)
      end do

      do n = 2, nnoderho -1
         if(favg(n) .eq. 0.0)then
            favg(n) = (favg(n-1) + favg(n+1)) / 2.0
         end if
      end do

      if (favg(1) .eq. 0.0) favg(1) = favg(2)
      if (favg(nnoderho) .lt. 1.e-03) favg(nnoderho) = favg(nnoderho -1)

  100 format (1i10, 1p8e12.4)
  102 format (2i10)
      return
      end

c
c***************************************************************************
c

c
c***************************************************************************
c

      SUBROUTINE TRIDI(N,A,B,C,Y,X)

      implicit none

      real A(1),B(1),C(1),Y(1),X(1),D(1001),W(1001)
      real dn
      integer n, nm, j, k
      NM=N-1
      D(1)=C(1)/B(1)
      W(1)=Y(1)/B(1)
      DO 1 J=2,NM
      DN=B(J)-A(J)*D(J-1)
      D(J)=C(J)/DN
    1 W(J)=(Y(J)-A(J)*W(J-1))/DN
      X(N)=(Y(N)-A(N)*W(N-1))/(B(N)-A(N)*D(N-1))
      DO 2 J=1,NM
      K=N-J
    2 X(K)=W(K)-D(K)*X(K+1)
      RETURN
      END

c
c***************************************************************************
c
      subroutine tridag(a, b, c, r, u, n)

      implicit none

      integer n, nmax
      real a(n), b(n), c(n), r(n), u(n)
      parameter (nmax = 500)
      integer j
      real bet, gam(nmax)

      if(b(1) .eq. 0) pause 'tridag: rewrite equations'
      bet = b(1)
      u(1) = r(1) / bet

      do j = 2, n
         gam(j) = c(j-1) / bet
         bet = b(j) - a(j) * gam(j)
c         if(bet .eq. 0) pause 'tridag failed'

         if(bet .eq. 0) then
	    write (6, *) "j = ", j
	    write (6, *) "a(j) = ", a(j)
	    write (6, *) "b(j) = ", b(j)
	    write (6, *) "c(j) = ", c(j)
	    write (6, *) "gam(j) = ", gam(j)
	    write (6, *) "bet = ", bet
	    write (6, *) "tridag failed"
	    call exit
	 end if

         u(j) = (r(j) - a(j) * u(j-1)) / bet
      end do

      do j = n-1, 1, -1
         u(j) = u(j) - gam(j+1) * u(j+1)
      enddo

      return
      end

c
c***************************************************************************
c
      subroutine deriv_x(f, id, jd, i, j, imax, jmax, dx, dfdx, d2fdx2)

      implicit none

      integer id, jd, i, j, imax, jmax
      real f(id, jd), dx, dfdx, d2fdx2

      if(i .ne. 1 .and. i .ne. imax)then
         dfdx = (f(i+1, j) - f(i-1, j)) / (2.0 * dx)
         d2fdx2 = (f(i+1, j) - 2.0 * f(i,j) + f(i-1, j)) / dx**2
      end if

      if(i .eq. 1)then
         dfdx = (f(i+1, j) - f(i, j)) / dx
         d2fdx2 = (f(i+2, j) - 2.0 * f(i+1,j) + f(i, j)) / dx**2
      end if

      if(i .eq. imax)then
         dfdx = (f(i, j) - f(i-1, j)) / dx
         d2fdx2 = (f(i, j) - 2.0 * f(i-1,j) + f(i-2, j)) / dx**2
      end if

      return
      end

c
c***************************************************************************
c
      subroutine deriv_y(f, id, jd, i, j, imax, jmax, dy, dfdy, d2fdy2)

      implicit none

      integer id, jd, i, j, imax, jmax
      real f(id, jd), dy, dfdy, d2fdy2

      if(j .ne. 1 .and. j .ne. jmax)then
         dfdy = (f(i, j+1) - f(i, j-1)) / (2.0 * dy)
         d2fdy2 = (f(i, j+1) - 2.0 * f(i,j) + f(i, j-1)) / dy**2
      end if

      if(j .eq. 1)then
         dfdy = (f(i, j+1) - f(i, j)) / dy
         d2fdy2 = (f(i, j+2) - 2.0 * f(i,j+1) + f(i, j)) / dy**2
      end if

      if(j .eq. jmax)then
         dfdy = (f(i, j) - f(i, j-1)) / dy
         d2fdy2 = (f(i, j) - 2.0 * f(i,j-1) + f(i, j-2)) / dy**2
      end if

      return
      end

c
c***************************************************************************
c
      subroutine deriv_xy(f, id, jd, i, j, imax, jmax, dx, dy, d2fdxy)

      implicit none

      integer id, jd, i, j, imax, jmax
      real f(id, jd), dx, dy, d2fdxy

      d2fdxy = 0.0

      if (i .ne. 1 .and. i .ne. imax .and.
     .    j .ne. 1 .and. j .ne. jmax) then

         d2fdxy = (f(i+1,j+1) - f(i-1,j+1) - f(i+1,j-1) + f(i-1,j-1) )
     .      / (4.0 * dx * dy)

      end if

      return
      end

c
c***************************************************************************
c

      subroutine sgrator(x, y, f, nx1, nx2, ny1, ny2, ans,
     .   capr, r0, nxmax, nymax)

      implicit none

      integer i, j, nx1, nx2, ny1, ny2, nxmax, nymax
      real f(nxmax, nxmax), x(nxmax), y(nymax), ans, dx, dy
      real capr(nxmax), r0

      ans = 0.0

      do i = nx1, nx2 - 1
         dx = x(i+1) - x(i)

         do j = ny1, ny2 - 1
            dy = y(j+1) - y(j)
            ans = ans + dx * dy* (capr(i)   * f(i, j)
     .                          + capr(i+1) * f(i+1, j)
     .                          + capr(i)   * f(i, j+1)
     .                          + capr(i+1) * f(i+1, j+1) ) / 4.0
         end do
      end do

      ans = ans / r0

      return
      end

c
c***************************************************************************
c
      subroutine sgrator_core(x, y, f, nx1, nx2, ny1, ny2, ans,
     .   capr, r0, nxmax, nymax, rho)

      implicit none

      integer i, j, nx1, nx2, ny1, ny2, nxmax, nymax
      real f(nxmax, nxmax), x(nxmax), y(nymax), ans, dx, dy
      real capr(nxmax), r0, rho(nxmax, nymax)

      ans = 0.0

      do i = nx1, nx2 - 1
         dx = x(i+1) - x(i)

         do j = ny1, ny2 - 1
            dy = y(j+1) - y(j)
	    if (rho(i,j) .le. 1.0) then
               ans = ans + dx * dy* (capr(i)   * f(i, j)
     .                             + capr(i+1) * f(i+1, j)
     .                             + capr(i)   * f(i, j+1)
     .                             + capr(i+1) * f(i+1, j+1) ) / 4.0
            end if
         end do
      end do

      ans = ans / r0

      return
      end

c
c***************************************************************************
c
      subroutine sgrator_edge(x, y, f, nx1, nx2, ny1, ny2, ans,
     .   capr, r0, nxmax, nymax, rho)

      implicit none

      integer i, j, nx1, nx2, ny1, ny2, nxmax, nymax
      real f(nxmax, nxmax), x(nxmax), y(nymax), ans, dx, dy
      real capr(nxmax), r0, rho(nxmax, nymax)

      ans = 0.0

      do i = nx1, nx2 - 1
         dx = x(i+1) - x(i)

         do j = ny1, ny2 - 1
            dy = y(j+1) - y(j)
	    if(rho(i,j) .gt. 1.0) then
               ans = ans + dx * dy* (capr(i)   * f(i, j)
     .                             + capr(i+1) * f(i+1, j)
     .                             + capr(i)   * f(i, j+1)
     .                             + capr(i+1) * f(i+1, j+1) ) / 4.0
            end if
         end do
      end do

      ans = ans / r0

      return
      end

c
c***************************************************************************
c

      subroutine sgrator1(x, y, f, nx1, nx2, ny1, ny2, ans,
     .   capr, r0, nxmax, nymax, j)

      implicit none

      integer i, j, nx1, nx2, ny1, ny2, nxmax, nymax
      real f(nxmax, nxmax), x(nxmax), y(nymax), ans, dx, dy
      real capr(nxmax), r0

      ans = 0.0

      do i = nx1, nx2 - 1
         dx = x(i+1) - x(i)

         ans = ans + dx * (capr(i)   * f(i, j)
     .                      + capr(i+1) * f(i+1, j) ) / 2.0
      end do

      ans = ans / r0

      return
      end

c
c***************************************************************************
c

      SUBROUTINE ZFUN_IM(Z,FU)

*     ---------------------------------------------------
*     Evaluates only the imaginary part of the Z function
*     ---------------------------------------------------

      implicit none

      complex z, fu, zi
      real pi

      pi = 3.14159
      zi = cmplx (0.0, 1.0)

      fu = zi * sqrt(pi) * cexp (-z*z)

      return
      end

c
c***************************************************************************
c

      SUBROUTINE ZFUN(Z,FU)
C
C     ROUTINE WHICH EVALUATES THE PLASMA DISPERSION FUNCTION.  USES
C     NUMERICAL INTEGRATION (ABSOLUTE VALUE OF THE COMPLEX ARGUMENT, Z,
C     LESS THAN 5) OR ASYMPTOTIC EXPANSION.
C
      COMPLEX Z,FU,TEMP1,TEMP2,Z2,TPIIOD
      DIMENSION C(21),D(21),E(21),F(21),W(21)
      DATA DELTA/5.0E-1/, YI/-1.0E+0/, N/21/, ITEST/0/
      DATA ZERO/0.0E+0/, OSQPI/5.6418958355E-1/, TPI/6.28318530718E+0/
C
      IF(ITEST .EQ. 1) GO TO 1
      ITEST=1
C***     DEFINE WEIGHTS AND STORE CONSTANTS USED FOR INTEGRATION.
C***     WEIGHTS ARE DERIVED FROM A 3 POINT INTEGRATION SCHEME.
      NM3=N-3
      CONOI=DELTA*OSQPI
      W(1)=CONOI*3.75E-1
      W(2)=CONOI*1.1666666667E+0
      W(3)=CONOI*9.5833333333E-1
      DO 20 I=1,3
        NMIP1=N-I+1
   20 W(NMIP1)=W(I)
      DO 30 I=4,NM3
   30 W(I)=CONOI
      NO2=N/2
      NO2P1=NO2+1
      X=ZERO
      Y=YI
      E(NO2P1)=X
      F(NO2P1)=Y
      TEMP1=CMPLX(X,Y)
      TEMP2=CEXP(-TEMP1*TEMP1)
      C(NO2P1)=REAL(TEMP2)*W(NO2P1)
      D(NO2P1)=AIMAG(TEMP2)*W(NO2P1)
      DO 200 I=1,NO2
      X=DELTA*real(I)
      NPI=NO2P1+I
      NMI=NO2P1-I
      TEMP1=CMPLX(X,Y)
      TEMP2=CEXP(-TEMP1*TEMP1)
      C(NPI)=REAL(TEMP2)*W(NPI)
      C(NMI)=REAL(TEMP2)*W(NMI)
      D(NPI)=AIMAG(TEMP2)*W(NPI)
      D(NMI)=AIMAG(TEMP2)*W(NMI)*(-1.0E+0)
      E(NMI)=-X
      E(NPI)=X
      F(NPI)=Y
      F(NMI)=Y
  200 CONTINUE
      TPIOD=TPI/DELTA
      TPIIOD=CMPLX(ZERO,TPIOD)
C***     BEGIN CALCULATIONS.
    1 G=REAL(Z)
      YY=AIMAG(Z)
      H=ABS(YY)
      ZA=Z*CONJG(Z)
      IF(ZA .GE. 2.5E+1) GO TO 5
      Z2=Z*Z
C***     NUMERICAL INTEGRATION.
C***     F=1/SQRT(PI)*SUM OF...W(I)*EXP(-X(I)**2)/(X(I)-Z)...I=1,N.
C***     INTEGRATION IS ALONG A LINE X(I) IN THE COMPLEX PLANE, WHERE
C***     THE IMAGINARY PART OF X(I)=YI AND THE DIFFERENCE BETWEEN
C***     SUCCESSIVE REAL PARTS OF X(I)=DELTA.  LIMITS OF INTEGRATION
C***     ARE FROM -DELTA*N/2 TO DELTA*N/2.
C***     COMPUTE THE INTEGRAL BY TAKING THE SUM FROM 1 TO N OF THE
C***     CONSTANTS DIVIDED BY X(I)-Z.  USES REAL ARITHMETIC.
      ZR=0.0E+0
      ZI=0.0E+0
      DO 7 I=1,N
      A=E(I)-G
      B=F(I)-H
      DEN=A*A+B*B
      ODEN=1.0E+0/DEN
      ZR=ZR+(A*C(I)+B*D(I))*ODEN
      ZI=ZI+(A*D(I)-B*C(I))*ODEN
    7 CONTINUE
C***     ADD THE CORRECTION TERM.
      FU=CMPLX(ZR,ZI)+(0.0E+0,-3.5449077018E+0)*CEXP(-Z2-TPIOD*
     *   (H-YI)+TPIIOD*G)
      IF(YY .GE. ZERO) GO TO 6
C***     IMAGINARY PART OF ARGUMENT IS NEGATIVE.
      FU=CONJG(FU)+(0.0E+0,3.5449077018E+0)*CEXP(-Z2)
      GO TO 6
C***     MAGNITUDE OF ARGUMENT IS GREATER THAN 5, USE
C***     ASYMPTOTIC EXPANSION.
    5 CALL AEXPAN(Z,G,H,YY,FU)
    6 RETURN
      END
      SUBROUTINE AEXPAN(Z,G,H,YY,FU)
C
C     ROUTINE WHICH COMPUTES THE PLASMA DISPERSION FUNCTION USING
C     ASYMPTOTIC EXPANSION.  IF THE IMAGINARY PART OF THE ARGUMENT, YY,
C     IS EQUAL TO ZERO REAL ARITHMETIC IS USED.
C
      COMPLEX Z,FU,A,Z2,OZ2
      DATA ZERO/0.0E+0/, N/8/
C
      IF(YY .EQ. ZERO) GO TO 1
C***     COMPLEX ARITHMETIC.
      Z2=Z*Z
      OZ2=1.0E+0/Z2
      FU=-1.0E+0/Z
      A=FU
      EN=5.0E-1
      DO 10 I=1,N
      A=EN*A*OZ2
      FU=FU+A
   10 EN=EN+1.0E+0
      IF(YY .GT. ZERO) GO TO 30
      IF(H .GT. SQRT(G*G+1.72E+2)) GO TO 20
      FU=FU+(0.0E+0,3.5449077018E+0)*CEXP(-Z2)
      GO TO 30
C***     ERROR STOP TO AVOID OVERFLOW.
   20 WRITE (51,100) Z
  100 FORMAT(//1X,'*** ERROR STOP IN FRDCNT ROUTINE, ARGUMENT IS',
     * ' TOO SMALL,  ARG =',1P2E14.6)
      STOP
C***     REAL ARITHMETIC.
    1 X2=G*G
      OX2=1.0E+0/X2
      F=-1.0E+0/G
      B=F
      EN=5.0E-1
      DO 11 I=1,N
      B=EN*B*OX2
      F=F+B
   11 EN=EN+1.0E+0
      C=1.7724538509E+0*EXP(-X2)
      FU=CMPLX(F,C)
   30 RETURN
      END
C
C
C TWO POL APPROXIMATION
C
      SUBROUTINE Z2P(Z,F)
      COMPLEX Z,F
      F=CMPLX(.5,.81)/(CMPLX(.51,-.81)-Z)-CMPLX(.5,-.81)
     1/(CMPLX(.51,.81)+Z)
      RETURN
      END

c
c THIS CODE IS SUPERIOR TO PDF AND PDFLL.  NO ERROR AT ZETA=(4.,0.1)
c  disp(z) is the plasma z function
c
      complex function disp(z)
      complex z
      real im
      x=real(z)
      y=aimag(z)
      call zzdisp(x,y,re,im)
      disp=cmplx(re,im)
      return
      end
c
c***************************************************************************
c
c
c  disp1(z) calculates first derivative of disp(z)
c
      complex function disp1(z)
      complex z,dp,disp
      complex zz
      zz=z
      dp=disp(z)
      disp1=-2.0-2.0*zz*dp
      return
      end
c
c***************************************************************************
c
c
c  calculates plasma z function
c
      subroutine zzdisp(x,y,zzr,zzi)
      x1=abs(x)
      y1=abs(y)
      call wzdisp(x1,y1,wzr1,wzi1)
      if(x.ge.0..and.y.ge.0.) go to 1
      if(x.le.0..and.y.ge.0.) go to 2
      a=2*x1*y1
      b=-(x1*x1-y1*y1)
      abr=2*exp(b)*cos(a)
      abi=-2*exp(b)*sin(a)
      wzr1=abr-wzr1
      wzi1=abi-wzi1
      if(x.le.0..and.y.le.0.) go to 1
    2 wzi1=-wzi1
    1 zzr=-1.7724538509055*wzi1
      zzi=1.7724538509055*wzr1
      return
      end
c
c***************************************************************************
c
cc   needed for z function
cc
      subroutine wzdisp(x,y,re,im)
      equivalence(epsh,epsl,epsy)
      real im,lambda
      integer capn
      logical b
      epsh=1.e-12
      if(y.lt.4.29 .and. x.lt.5.33) go to 10
c
c  (x,y) belongs to q1-r
c
      h=0.
      capn=0
      nu=8
      go to 20
c
c  (x,y) belongs to r
c
   10 s=(1.-y/4.29)*sqrt(1.-x*x/28.41)
      h=1.6*s
      h2=2.*h
      capn=6.+23*s+.5
      nu=9.+21*s+.5
      lambda=h2**capn
   20 b=(h.eq.0. .or. lambda.lt.epsl)
c
c  statement (lambda.lt.epsl) covers the underflow case
c  when h(.gt.0) is very small.
c
      rr=0.
      ri=0.
      sr=0.
      si=0.
      nup=nu+1
      do 100 i=1,nup
      n=nup-i
      np1=n+1
      tr=y+h+np1*rr
      ti=x-np1*ri
      c=.5/(tr*tr+ti*ti)
      rr=c*tr
      ri=c*ti
      if(.not.(h.gt.0..and.n.le.capn)) go to 100
      tr=lambda+sr
      sr=rr*tr-ri*si
      si=ri*tr+rr*si
      lambda=lambda/h2
  100 continue
      cc=1.12837916709551
      if(y.lt.epsy) go to 120
      if(b) go to 110
      re=sr*cc
      go to 130
  110 re=rr*cc
      go to 130
  120 re=exp(-x*x)
  130 if(b) go to 140
      im=si*cc
      go to 150
  140 im=ri*cc
  150 return
      end

c
c***************************************************************************
c
      real function second1_old(dummy)

      implicit none

      integer :: v(8)
c      integer mtime, mclock
      real dummy

c*****Fortran 90 standard for wall clock time
c      call date_and_time(values=v)
c      second1_old=(v(5)*3600)+(v(6)*60)+v(7)+0.001d0*v(8)

c*****FALCON:
      double precision mpi_wtime
      external mpi_wtime
      second1_old = MPI_WTIME()

c*****EAGLE:
c      mtime = mclock()
c      second1_old  = 0.01 * mtime

      return
      end

c
c***************************************************************************
c

      real function second1(dummy)
!     returns a monotonically increasing wall-clock time-stamp in seconds
!     with an attempt to cross multiple days between calls
!     (assumes one day if end-of-the-month is spanned between calls)

      implicit none

      real dummy

      integer :: v(8)

      integer,save :: ld
      logical,save :: elapsed=.false.

!*****Fortran 90 standard for wall clock time
      call date_and_time(values=v)

      if(elapsed)then  ! second has been called before
        if(v(3).ge.ld)then ! days have advanced monotonically
         second1=(v(3)-ld)*86400+(v(5)*3600)+(v(6)*60)+v(7)+0.001d0*v(8)
        else  ! day counter reset past end of the month
          print *,'WARNING: SECOND1 TRIPPED OVER THE END OF THE MONTH'
          print *,'         SECOND1 IS ASSUMING ONLY ONE ELAPSED DAY'
!         proper fix requires full blown calendar program
          ld=0
         second1=(v(3)-ld)*86400+(v(5)*3600)+(v(6)*60)+v(7)+0.001d0*v(8)
        endif
      else  ! first call
        second1=(v(5)*3600)+(v(6)*60)+v(7)+0.001d0*v(8)
        ld=v(3)
        elapsed=.true.
      endif

      return
      end

c
c*******************************************************************************
c

      subroutine intplt_z(xgiv, ygiv, fout, nx, ny, f,
     .   nxmax, nymax, xa, ya)

      implicit none

      integer nx, ny, nxmax, nymax, n, m
      real x, y, xgiv, ygiv, dx, dy, zeta, eta
      complex f(nxmax, nymax), fout, a, b, c, d
      real xa(nxmax), ya(nymax), xmin, xmax, ymin, ymax

      x = xgiv
      y = ygiv
      fout = 0.0

      xmin = xa(1)
      xmax = xa(nx)
      ymin = ya(1)
      ymax = ya(ny)

      if(x .le. xmax .and. x .ge. xmin .and.
     .   y .le. ymax .and. y .ge. ymin) then

         dx = (xmax - xmin) / (nx - 1)
         dy = (ymax - ymin) / (ny - 1)

         n = int((x - xmin) / dx) + 1
         m = int((y - ymin) / dy) + 1

         zeta = (x - (xmin + (n - 1) * dx)) / dx
         eta  = (y - (ymin + (m - 1) * dy)) / dy

         a = f(n, m)
         b = f(n+1 ,m) - f(n, m)
         c = f(n, m+1) - f(n, m)
         d = f(n+1, m+1) + f(n, m) - f(n+1, m) - f(n, m+1)

         fout = a + b * zeta + c * eta + d * zeta * eta

      end if

      return

  900 format(1p6e12.4)
  901 format(10i10)
  910 format(1p8e12.4)
  920 format(2i10)
      end

c
c***************************************************************************
c


#include "scalar.fpp"
!=====================================================================!
! Newmark-Beta-Gamma Integration Module for first and second order
! systems with adjoint derivative capabilities.
!
! Author: Komahan Boopathy (komahan@gatech.edu)
!=====================================================================!

module nbg_integrator

  use integrator_class, only : integrator
  use physics_class,    only : physics

  implicit none

  private
  public :: NBG

  type(scalar), parameter :: ONE  = 1.0d0
  type(scalar), parameter :: ZERO = 0.0d0

  !===================================================================!
  ! NBG Integrator type
  !===================================================================!

  type, extends(integrator) :: NBG

     ! Average Constant Accelearation (second order unconditionally stable)
     type(scalar) :: BETA   = 0.25d0
     type(scalar) :: GAMMA  = 0.50d0

!!$     ! Fox & Goodwin  (third order & conditionally stable wh=2.45)
!!$     type(scalar) :: BETA   = 1.0d0/12.0d0
!!$     type(scalar) :: GAMMA  = 0.50d0
!!$
!!$     ! Linear Acceleration (second order & conditionally stable wh=3.46)
!!$     type(scalar) :: BETA   = 1.0d0/6.0d0
!!$     type(scalar) :: GAMMA  = 0.50d0
!!$
!!$     ! Central Difference (second order & conditionally stable wh=2)
!!$     type(scalar) :: BETA   = 1.0d0/2.0d0
!!$     type(scalar) :: GAMMA  = 0.50d0

!!$     ! Purely Explicit
!!$     type(scalar) :: BETA   = 0.0d0
!!$     type(scalar) :: GAMMA  = 0.0d0

     type(scalar), allocatable, dimension(:) :: rho
     type(scalar), allocatable, dimension(:) :: sigma

   contains

     ! Destructor
     procedure, public  :: finalize

     ! Routines for integration
     procedure, private :: approximateStates
     procedure, private :: getLinearCoeff

     ! Routines for adjoint gradient
     procedure, public  :: marchBackwards
     procedure, private :: assembleRHS
     procedure          :: computeTotalDerivative

  end type NBG

  interface NBG
     module procedure initialize
  end interface NBG

contains

  !===================================================================!
  ! Initialize the NBG datatype and allocate required variables
  !===================================================================!

  type(nbg) function initialize( system, tinit, tfinal, h, second_order )  result (this)

    class(physics), target          :: system
    real(dp) , OPTIONAL, intent(in) :: tinit, tfinal
    real(dp) , OPTIONAL, intent(in) :: h
    logical  , OPTIONAL, intent(in) :: second_order

    print *, "======================================"
    print *, ">>   Newmark Beta Gamma (NBG)      << "
    print *, "======================================"

    call this % construct(system, tinit, tfinal, h, second_order)

    !-----------------------------------------------------------------!
    ! Allocate space for auxiliary adjoint variables
    !-----------------------------------------------------------------!

    allocate(this % rho(this % nsvars))
    this % rho = 0.0d0

    allocate(this % sigma(this % nsvars))
    this % sigma = 0.0d0

    !-----------------------------------------------------------------!
    ! Setup adjoint RHS
    !-----------------------------------------------------------------!

    this % num_rhs_bins = 2

    allocate(this % rhs(this % nsvars))
    this % rhs = 0.0d0

  end function initialize

  !===================================================================!
  ! Deallocate the allocated variables
  !===================================================================!

  subroutine finalize( this )

    class(NBG) :: this

    call this % destruct()

    ! Clear global states and time
    if(allocated(this % rho))   deallocate(this % rho)
    if(allocated(this % sigma)) deallocate(this % sigma)

    if (allocated(this % rhs))  deallocate(this % rhs)

  end subroutine finalize

  !===================================================================!
  ! Approximate the state variables at each step using NBG formula
  !===================================================================!

  subroutine approximateStates( this )

    class(NBG) :: this
    integer                   :: k
    type(scalar)              :: scale

    k = this % current_step

    !-----------------------------------------------------------------!
    ! Assume a UDDOT for the next time step
    !-----------------------------------------------------------------!

    this % uddot(k,:) = this % uddot(k-1,:)

    !-----------------------------------------------------------------!
    ! Approximate UDOT using NBG
    !-----------------------------------------------------------------!

    this % udot(k,:) = this % udot(k-1,:)

    scale = this % h * (1.0d0 - this % GAMMA)
    this % udot(k,:) = this % udot(k,:) + scale*this % uddot(k-1,:)

    scale = this % h * this % GAMMA
    this % udot(k,:) = this % udot(k,:) + scale*this % uddot(k,:)

    !-----------------------------------------------------------------!
    ! Approximate U using NBG
    !-----------------------------------------------------------------!

    this % u(k,:) = this % u(k-1,:)

    scale = this % h
    this % u(k,:) = this % u(k,:) + scale*this % udot(k-1,:)

    scale = this % h * this % h * (1.0d0 - 2.0d0 * this % BETA)/2.0d0
    this % u(k,:) = this % u(k,:) + scale*this % uddot(k-1,:)

    scale = this % h * this % h * this % BETA
    this % u(k,:) = this % u(k,:) + scale*this % uddot(k,:)

  end subroutine approximateStates

  !===================================================================!
  ! Returns the linearization scalar coefficients: alpha, beta, gamma
  !===================================================================!

  subroutine getLinearCoeff( this, alpha, beta, gamma )

    class(NBG) :: this
    type(scalar), intent(out) :: alpha, beta, gamma
    integer                     :: m

    if ( this % second_order ) then
       gamma = 1.0d0/this % h/ this % h
       beta  = this % GAMMA/ this % h
       alpha = this % BETA
    else
       stop"Error: Newmark-Beta-Gamma method works for second order systems in current form..."
    end if

!!$    gamma = 1.0d0
!!$    beta  = this % h * this % GAMMA
!!$    alpha = this % h * this % h * this % BETA

  end subroutine getLinearCoeff

  !===================================================================!
  ! Subroutine that marches backwards in time to compute the lagrange
  ! multipliers (adjoint variables for the function)
  ! ===================================================================!

  subroutine marchBackwards( this )

    class(NBG)                :: this
    integer                   :: k
    integer, parameter :: unit = 88
    type(scalar)              :: alpha, beta, gamma

    open(unit=88, file=trim("nbg_adjoint.dat"))

    time: do k = this % num_steps, 2, -1

       this % current_step = k

       !--------------------------------------------------------------!
       ! Determine the linearization coefficients for the Jacobian
       !--------------------------------------------------------------!

       call this % getLinearCoeff(alpha, beta, gamma)

       !--------------------------------------------------------------!
       ! Solve the adjoint equation at each step
       !--------------------------------------------------------------!

       call this % adjointSolve(this % psi(k,:), alpha, beta, gamma, &
            & this % time(k), this % u(k,:), this % udot(k,:), this % uddot(k,:))

       write_output: block

         type(integer) :: j

         ! Write the solution as output
         write(unit, *)  this % time(k), &
              & (dble(this % psi(k,j)), j=1,this%nsvars ), &
              & (dble(this % rho(j)), j=1,this%nsvars ), &
              & (dble(this % sigma(j)), j=1,this%nsvars )

       end block write_output
       !print*, "k, psi=", k, this % psi(k,:)

    end do time

  end subroutine marchBackwards

  !===================================================================!
  ! Function that puts together the right hand side of the adjoint
  ! equation into the supplied rhs vector.
  !===================================================================!

  subroutine assembleRHS( this, rhs )

    class(NBG)                                :: this
    type(scalar), dimension(:), intent(inout) :: rhs
    type(scalar), dimension(:,:), allocatable :: jac
    type(scalar)                              :: alpha, beta, gamma
    type(integer)                             :: k

    allocate( jac(this % nSVars, this % nSVars) )

    k = this % current_step

    ! Zero the RHS first
    rhs = 0.0d0

    if ( k .ne. this % num_steps) then

       !-----------------------------------------------------!
       ! Add previous residual contributions to RHS
       !-----------------------------------------------------!

       gamma = 0.0d0
       beta  = 1.0d0/this % h
       alpha = 0.5d0 + this % GAMMA

       ! Add the state variable sensitivity from the previous step
       call this % system % func % addFuncSVSens(rhs, &
            & alpha, beta, gamma, &
            & this % time(k+1), &
            & this % system % X, &
            & this % u(k+1,:), &
            & this % udot(k+1,:), &
            & this % uddot(k+1,:))

       ! Add the residual adjoint product from the previous step
       call this % system % assembleJacobian(jac, &
            & alpha, beta, gamma, &
            & this % time(k+1), &
            & this % u(k+1,:), &
            & this % udot(k+1,:), &
            & this % uddot(k+1,:))

       rhs = rhs + matmul(transpose(jac(:,:)), this % psi(k+1,:))

       !-------------------------------------------------------!
       ! Add similar contributions to RHS
       !-------------------------------------------------------!

       rhs = rhs + beta  * this % sigma/this % h
       rhs = rhs + alpha * this % rho/this % h

       !-----------------------------------------------------------!
       ! Compute NEW THIS % SIGMA (k)
       !-----------------------------------------------------------!

       this % sigma = this % sigma + this % h * this % rho

       gamma = 0.0d0
       beta  = this % h
       alpha = this % h * this % h

       ! Add the state variable sensitivity from the previous step
       call this % system % func % addFuncSVSens(this % sigma, &
            & alpha, beta, gamma, &
            & this % time(k+1), &
            & this % system % X, &
            & this % u(k+1,:), &
            & this % udot(k+1,:), &
            & this % uddot(k+1,:))

       ! Add the residual adjoint product from the previous step
       call this % system % assembleJacobian(jac, &
            & alpha, beta, gamma, &
            & this % time(k+1), &
            & this % u(k+1,:), &
            & this % udot(k+1,:), &
            & this % uddot(k+1,:))

       this % sigma = this % sigma + matmul(transpose(jac(:,:)), this % psi(k+1,:))

       !-----------------------------------------------------------!
       ! Compute THIS % RHO (K)
       !-----------------------------------------------------------!

       gamma = 0.0d0
       beta  = 0.0d0
       alpha = this % h

       ! Add the state variable sensitivity from the previous step
       call this % system % func % addFuncSVSens(this % rho, &
            & alpha, beta, gamma, &
            & this % time(k+1), &
            & this % system % X, &
            & this % u(k+1,:), &
            & this % udot(k+1,:), &
            & this % uddot(k+1,:))

       ! Add the residual adjoint product from the previous step
       call this % system % assembleJacobian(jac, &
            & alpha, beta, gamma, &
            & this % time(k+1), &
            & this % u(k+1,:), &
            & this % udot(k+1,:), &
            & this % uddot(k+1,:))

       this % rho = this % rho + matmul(transpose(jac(:,:)), this % psi(k+1,:))

    end if

    ! Get the coefficients
    call this % getLinearCoeff( alpha, beta, gamma)

    ! Add the state variable sensitivity
    call this % system % func % addFuncSVSens(rhs, &
         & alpha, beta, gamma, &
         & this % time(k), &
         & this % system % X, &
         & this % u(k,:), &
         & this % udot(k,:), &
         & this % uddot(k,:))

    ! Negate the RHS
    rhs = -rhs

    if(allocated(jac)) deallocate(jac)

  end subroutine assembleRHS

  !===================================================================!
  ! Compute the total derivative of the function with respect to the
  ! design variables and return the gradient
  !===================================================================!

  subroutine computeTotalDerivative( this, dfdx )

    class(NBG)                                         :: this
    type(scalar) , dimension(:), intent(inout)             :: dfdx
    type(scalar) , dimension(this % nSVars, this % nDVars) :: dRdX
    type(scalar)                                           :: scale = 1.0d0
    integer                                            :: k

    !scale = this % h

    dfdx = 0.0d0

    !-----------------------------------------------------------------!
    ! Compute dfdx
    !-----------------------------------------------------------------!

    do k = 2, this % num_steps
       call this % system % func % addFuncDVSens(dfdx, scale, this % time(k), &
            & this % system % x, this % u(k,:), this % udot(k,:), this % uddot(k,:) )
    end do

    ! Initial condition
!!$    call this % system % func % addFuncDVSens(dfdx, scale, this % time(1), &
!!$         & this % system % x, this % u(1,:), this % udot(1,:), this % uddot(1,:) )

    !-----------------------------------------------------------------!
    ! Compute the total derivative
    !-----------------------------------------------------------------!

    do k = 2, this % num_steps
       call this % system % getResidualDVSens(dRdX, scale, this % time(k), &
            & this % system % x, this % u(k,:), this % udot(k,:), this % uddot(k,:))
       dfdx = dfdx + matmul(this % psi(k,:), dRdX) ! check order
    end do

!!$    ! Add constraint contribution
!!$    call this % system % getResidualDVSens(dRdX, scale, this % time(1), &
!!$         & this % system % x, this % u(1,:), this % udot(1,:), this % uddot(1,:))
!!$    dfdx = dfdx + matmul(this % psi(2,:), dRdX)

    ! Finally multiply by the scalar
    dfdx = this % h * dfdx

    print*, "Check scaling of dfdx, and transpose"

  end subroutine computeTotalDerivative

end module nbg_integrator


!! Program to determine the permutation and combination
!! Recursive functions

program percom
    implicit none

    INTEGER(KIND=8), external :: per, comm, com, comb
    INTEGER(KIND=8) :: n, r, per1, com1, com2, com3

    print*, "Enter the value of n and r: "
    read*, n, r

    per1 = per(n,r)
    com1 = com(per1,r)
    com2 = comm(n,r)
    com3 = comb(n,r)

    print*, " The permutation of ", r, " in", n, " : ", per1
    print*, " The combination of ", r, " in", n, " : ", com1
    print*, " The combination of ", r, " in", n, " : ", com2
    print*, " The combination of ", r, " in", n, " : ", com3

end program percom


      SUBROUTINE cosft1(y,n)
      INTEGER n
      REAL y(n+1)
CU    USES realft
      INTEGER j
      REAL sum,y1,y2
      DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp
      theta=3.141592653589793d0/n
      wr=1.0d0
      wi=0.0d0
      wpr=-2.0d0*sin(0.5d0*theta)**2
      wpi=sin(theta)
      sum=0.5*(y(1)-y(n+1))
      y(1)=0.5*(y(1)+y(n+1))
      do 11 j=1,n/2-1
        wtemp=wr
        wr=wr*wpr-wi*wpi+wr
        wi=wi*wpr+wtemp*wpi+wi
        y1=0.5*(y(j+1)+y(n-j+1))
        y2=(y(j+1)-y(n-j+1))
        y(j+1)=y1-wi*y2
        y(n-j+1)=y1+wi*y2
        sum=sum+wr*y2
11    continue
      call realft(y,n,+1)
      y(n+1)=y(2)
      y(2)=sum
      do 12 j=4,n,2
        sum=sum+y(j)
        y(j)=sum
12    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/cosft1.for


program binomial
    integer :: i, j

    do j=1,20
        write(*,fmt='(i2,a)',advance='no') j,'Cr = '
        do i=0,j
            write(*,fmt='(i0,a)',advance='no') n_C_r(j,i),' '
        end do
        write(*,'(a,i0)') ' 60C30 = ',n_C_r(60,30)
    end do
    stop

contains

    pure function n_C_r(n, r) result(bin)
        integer(16)         :: bin
        integer, intent(in) :: n
        integer, intent(in) :: r

        integer(16)         :: num
        integer(16)         :: den
        integer             :: i
        integer             :: k
        integer, parameter  :: primes(*) = [2,3,5,7,11,13,17,19]
        num = 1
        den = 1
        do i=0,r-1
            num = num*(n-i)
            den = den*(i+1)
            if (i > 0) then
                ! Divide out common prime factors
                do k=1,size(primes)
                    if (mod(i,primes(k)) == 0) then
                        num = num/primes(k)
                        den = den/primes(k)
                    end if
                end do
            end if
        end do
        bin = num/den
    end function n_C_r

end program binomial


      SUBROUTINE IB01QD( JOBX0, JOB, N, M, L, NSMP, A, LDA, C, LDC, U,
     $                   LDU, Y, LDY, X0, B, LDB, D, LDD, TOL, IWORK,
     $                   DWORK, LDWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To estimate the initial state and the system matrices  B  and  D
C     of a linear time-invariant (LTI) discrete-time system, given the
C     matrix pair  (A,C)  and the input and output trajectories of the
C     system. The model structure is :
C
C           x(k+1) = Ax(k) + Bu(k),   k >= 0,
C           y(k)   = Cx(k) + Du(k),
C
C     where  x(k)  is the  n-dimensional state vector (at time k),
C            u(k)  is the  m-dimensional input vector,
C            y(k)  is the  l-dimensional output vector,
C     and  A, B, C, and D  are real matrices of appropriate dimensions.
C     Matrix  A  is assumed to be in a real Schur form.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBX0   CHARACTER*1
C             Specifies whether or not the initial state should be
C             computed, as follows:
C             = 'X':  compute the initial state x(0);
C             = 'N':  do not compute the initial state (x(0) is known
C                     to be zero).
C
C     JOB     CHARACTER*1
C             Specifies which matrices should be computed, as follows:
C             = 'B':  compute the matrix B only (D is known to be zero);
C             = 'D':  compute the matrices B and D.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the system.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     L       (input) INTEGER
C             The number of system outputs.  L > 0.
C
C     NSMP    (input) INTEGER
C             The number of rows of matrices  U  and  Y  (number of
C             samples,  t).
C             NSMP >= N*M + a + e,  where
C             a = 0,  if  JOBX0 = 'N';
C             a = N,  if  JOBX0 = 'X';
C             e = 0,  if  JOBX0 = 'X'  and  JOB = 'B';
C             e = 1,  if  JOBX0 = 'N'  and  JOB = 'B';
C             e = M,  if  JOB   = 'D'.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             system state matrix  A  in a real Schur form.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading L-by-N part of this array must contain the
C             system output matrix  C  (corresponding to the real Schur
C             form of  A).
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= L.
C
C     U       (input/output) DOUBLE PRECISION array, dimension (LDU,M)
C             On entry, the leading NSMP-by-M part of this array must
C             contain the t-by-m input-data sequence matrix  U,
C             U = [u_1 u_2 ... u_m].  Column  j  of  U  contains the
C             NSMP  values of the j-th input component for consecutive
C             time increments.
C             On exit, if  JOB = 'D',  the leading NSMP-by-M part of
C             this array contains details of the QR factorization of
C             the t-by-m matrix  U, possibly computed sequentially
C             (see METHOD).
C             If  JOB = 'B',  this array is unchanged on exit.
C             If M = 0, this array is not referenced.
C
C     LDU     INTEGER
C             The leading dimension of the array U.
C             LDU >= MAX(1,NSMP),  if M > 0;
C             LDU >= 1,            if M = 0.
C
C     Y       (input) DOUBLE PRECISION array, dimension (LDY,L)
C             The leading NSMP-by-L part of this array must contain the
C             t-by-l output-data sequence matrix  Y,
C             Y = [y_1 y_2 ... y_l].  Column  j  of  Y  contains the
C             NSMP  values of the j-th output component for consecutive
C             time increments.
C
C     LDY     INTEGER
C             The leading dimension of the array Y.  LDY >= MAX(1,NSMP).
C
C     X0      (output) DOUBLE PRECISION array, dimension (N)
C             If  JOBX0 = 'X',  the estimated initial state of the
C             system,  x(0).
C             If  JOBX0 = 'N',  x(0)  is set to zero without any
C             calculations.
C
C     B       (output) DOUBLE PRECISION array, dimension (LDB,M)
C             If  N > 0,  M > 0,  and  INFO = 0,  the leading N-by-M
C             part of this array contains the system input matrix  B
C             in the coordinates corresponding to the real Schur form
C             of  A.
C             If  N = 0  or  M = 0,  this array is not referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.
C             LDB >= N,  if  N > 0  and  M > 0;
C             LDB >= 1,  if  N = 0  or   M = 0.
C
C     D       (output) DOUBLE PRECISION array, dimension (LDD,M)
C             If  M > 0,  JOB = 'D',  and  INFO = 0,  the leading
C             L-by-M part of this array contains the system input-output
C             matrix  D.
C             If  M = 0  or  JOB = 'B',  this array is not referenced.
C
C     LDD     INTEGER
C             The leading dimension of the array D.
C             LDD >= L,  if  M > 0  and  JOB = 'D';
C             LDD >= 1,  if  M = 0  or   JOB = 'B'.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used for estimating the rank of
C             matrices. If the user sets  TOL > 0,  then the given value
C             of  TOL  is used as a lower bound for the reciprocal
C             condition number;  a matrix whose estimated condition
C             number is less than  1/TOL  is considered to be of full
C             rank.  If the user sets  TOL <= 0,  then  EPS  is used
C             instead, where  EPS  is the relative machine precision
C             (see LAPACK Library routine DLAMCH).  TOL <= 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK), where
C             LIWORK >= N*M + a,            if  JOB = 'B',
C             LIWORK >= max( N*M + a, M ),  if  JOB = 'D',
C             with  a = 0,  if  JOBX0 = 'N';
C                   a = N,  if  JOBX0 = 'X'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if  INFO = 0,  DWORK(1) returns the optimal value
C             of LDWORK;  DWORK(2)  contains the reciprocal condition
C             number of the triangular factor of the QR factorization of
C             the matrix  W2  (see METHOD); if  M > 0  and  JOB = 'D',
C             DWORK(3)  contains the reciprocal condition number of the
C             triangular factor of the QR factorization of  U.
C             On exit, if  INFO = -23,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= max( LDW1, min( LDW2, LDW3 ) ),  where
C             LDW1 = 2,          if  M = 0  or   JOB = 'B',
C             LDW1 = 3,          if  M > 0  and  JOB = 'D',
C             LDWa = t*L*(r + 1) + max( N + max( d, f ), 6*r ),
C             LDW2 = LDWa,       if  M = 0  or  JOB = 'B',
C             LDW2 = max( LDWa, t*L*(r + 1) + 2*M*M + 6*M ),
C                                if  M > 0  and JOB = 'D',
C             LDWb = (b + r)*(r + 1) +
C                     max( q*(r + 1) + N*N*M + c + max( d, f ), 6*r ),
C             LDW3 = LDWb,       if  M = 0  or  JOB = 'B',
C             LDW3 = max( LDWb, (b + r)*(r + 1) + 2*M*M + 6*M ),
C                                if  M > 0  and JOB = 'D',
C                r = N*M + a,
C                a = 0,                  if  JOBX0 = 'N',
C                a = N,                  if  JOBX0 = 'X';
C                b = 0,                  if  JOB   = 'B',
C                b = L*M,                if  JOB   = 'D';
C                c = 0,                  if  JOBX0 = 'N',
C                c = L*N,                if  JOBX0 = 'X';
C                d = 0,                  if  JOBX0 = 'N',
C                d = 2*N*N + N,          if  JOBX0 = 'X';
C                f = 2*r,                if  JOB   = 'B'   or  M = 0,
C                f = M + max( 2*r, M ),  if  JOB   = 'D'  and  M > 0;
C                q = b + r*L.
C             For good performance,  LDWORK  should be larger.
C             If  LDWORK >= LDW2  or
C                 LDWORK >= t*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c +
C                           max( d, f ),
C             then standard QR factorizations of the matrices  U  and/or
C             W2  (see METHOD) are used.
C             Otherwise, the QR factorizations are computed sequentially
C             by performing  NCYCLE  cycles, each cycle (except possibly
C             the last one) processing  s < t  samples, where  s  is
C             chosen from the equation
C               LDWORK = s*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c +
C                        max( d, f ).
C             (s  is at least  N*M+a+e,  the minimum value of  NSMP.)
C             The computational effort may increase and the accuracy may
C             decrease with the decrease of  s.  Recommended value is
C             LDWORK = LDW2,  assuming a large enough cache size, to
C             also accommodate  A,  C,  U,  and  Y.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 4:  the least squares problem to be solved has a
C                   rank-deficient coefficient matrix.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 2:  the singular value decomposition (SVD) algorithm did
C                   not converge.
C
C     METHOD
C
C     An extension and refinement of the method in [1,2] is used.
C     Specifically, denoting
C
C           X = [ vec(D')' vec(B)' x0' ]',
C
C     where  vec(M)  is the vector obtained by stacking the columns of
C     the matrix  M,  then  X  is the least squares solution of the
C     system  S*X = vec(Y),  with the matrix  S = [ diag(U)  W ],
C     defined by
C
C           ( U         |     | ... |     |     | ... |     |         )
C           (   U       |  11 | ... |  n1 |  12 | ... |  nm |         )
C       S = (     :     | y   | ... | y   | y   | ... | y   | P*Gamma ),
C           (       :   |     | ... |     |     | ... |     |         )
C           (         U |     | ... |     |     | ... |     |         )
C                                                                     ij
C     diag(U)  having  L  block rows and columns.  In this formula,  y
C     are the outputs of the system for zero initial state computed
C     using the following model, for j = 1:m, and for i = 1:n,
C            ij          ij                    ij
C           x  (k+1) = Ax  (k) + e_i u_j(k),  x  (0) = 0,
C
C            ij          ij
C           y  (k)   = Cx  (k),
C
C     where  e_i  is the i-th n-dimensional unit vector,  Gamma  is
C     given by
C
C                (     C     )
C                (    C*A    )
C        Gamma = (   C*A^2   ),
C                (     :     )
C                ( C*A^(t-1) )
C
C     and  P  is a permutation matrix that groups together the rows of
C     Gamma  depending on the same row of  C,  namely
C     [ c_j;  c_j*A;  c_j*A^2; ...  c_j*A^(t-1) ],  for j = 1:L.
C     The first block column,  diag(U),  is not explicitly constructed,
C     but its structure is exploited. The last block column is evaluated
C     using powers of A with exponents 2^k. No interchanges are applied.
C     A special QR decomposition of the matrix  S  is computed. Let
C     U = q*[ r' 0 ]'  be the QR decomposition of  U,  if  M > 0,  where
C     r  is  M-by-M.   Then,  diag(q')  is applied to  W  and  vec(Y).
C     The block-rows of  S  and  vec(Y)  are implicitly permuted so that
C     matrix  S  becomes
C
C        ( diag(r)  W1 )
C        (    0     W2 ),
C
C     where  W1  has L*M rows. Then, the QR decomposition of  W2 is
C     computed (sequentially, if  M > 0) and used to obtain  B  and  x0.
C     The intermediate results and the QR decomposition of  U  are
C     needed to find  D.  If a triangular factor is too ill conditioned,
C     then singular value decomposition (SVD) is employed. SVD is not
C     generally needed if the input sequence is sufficiently
C     persistently exciting and  NSMP  is large enough.
C     If the matrix  W  cannot be stored in the workspace (i.e.,
C     LDWORK < LDW2),  the QR decompositions of  W2  and  U  are
C     computed sequentially.
C
C     REFERENCES
C
C     [1] Verhaegen M., and Varga, A.
C         Some Experience with the MOESP Class of Subspace Model
C         Identification Methods in Identifying the BO105 Helicopter.
C         Report TR R165-94, DLR Oberpfaffenhofen, 1994.
C
C     [2] Sima, V., and Varga, A.
C         RASP-IDENT : Subspace Model Identification Programs.
C         Deutsche Forschungsanstalt fur Luft- und Raumfahrt e. V.,
C         Report TR R888-94, DLR Oberpfaffenhofen, Oct. 1994.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically stable.
C
C     FURTHER COMMENTS
C
C     The algorithm for computing the system matrices  B  and  D  is
C     less efficient than the MOESP or N4SID algorithms implemented in
C     SLICOT Library routine IB01PD, because a large least squares
C     problem has to be solved, but the accuracy is better, as the
C     computed matrices  B  and  D  are fitted to the input and output
C     trajectories. However, if matrix  A  is unstable, the computed
C     matrices  B  and  D  could be inaccurate.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Identification methods; least squares solutions; multivariable
C     systems; QR decomposition; singular value decomposition.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, THREE
      PARAMETER          ( ZERO  = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     $                     THREE = 3.0D0 )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   TOL
      INTEGER            INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU,
     $                   LDWORK, LDY, M, N, NSMP
      CHARACTER          JOB, JOBX0
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *),
     $                   DWORK(*),  U(LDU, *), X0(*), Y(LDY, *)
      INTEGER            IWORK(*)
C     .. Local Scalars ..
      DOUBLE PRECISION   RCOND, RCONDU, TOLL
      INTEGER            I, I2, IA, IAS, IC, ICYCLE, IE, IERR, IEXPON,
     $                   IG, IGAM, IGS, INI, INIH, INIR, INIS, INY,
     $                   INYGAM, IQ, IREM, IRHS, ISIZE, ISV, ITAU,
     $                   ITAUU, IUPNT, IX, IXINIT, IXSAVE, IY, IYPNT, J,
     $                   JWORK, K, LDDW, LDR, LDW2, LDW3, LM, LN, LNOB,
     $                   MAXWRK, MINSMP, MINWLS, MINWRK, N2M, NCOL,
     $                   NCP1, NCYCLE, NM, NN, NOBS, NROW, NSMPL, RANK
      LOGICAL            FIRST, NCYC, POWER2, WITHB, WITHD, WITHX0
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM(1)
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, ILAENV, LSAME
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGELSS, DGEMV, DGEQRF, DLACPY,
     $                   DLASET, DORMQR, DTRCON, DTRMM, DTRMV, DTRSM,
     $                   MA02AD, MB01TD, MB02UD, MB04OD, MB04OY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, LOG, MAX, MIN, MOD
C     .. Executable Statements ..
C
C     Check the input parameters.
C
      WITHD  = LSAME( JOB,   'D' )
      WITHB  = LSAME( JOB,   'B' ) .OR. WITHD
      WITHX0 = LSAME( JOBX0, 'X' )
C
      IWARN = 0
      INFO  = 0
      LM    = L*M
      LN    = L*N
      NN    = N*N
      NM    = N*M
      N2M   = N*NM
      NCOL  = NM
      IF( WITHX0 )
     $   NCOL = NCOL + N
      MINSMP  = NCOL
      IF( WITHD ) THEN
         MINSMP = MINSMP + M
         IQ     = MINSMP
      ELSE IF ( .NOT.WITHX0 ) THEN
         IQ     = MINSMP
         MINSMP = MINSMP + 1
      ELSE
         IQ     = MINSMP
      END IF
C
      IF( .NOT.( WITHX0 .OR. LSAME( JOBX0, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.WITHB ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( L.LE.0 ) THEN
         INFO = -5
      ELSE IF( NSMP.LT.MINSMP ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.L ) THEN
         INFO = -10
      ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN
         INFO = -12
      ELSE IF( LDY.LT.MAX( 1, NSMP ) ) THEN
         INFO = -14
      ELSE IF( LDB.LT.1 .OR. ( LDB.LT.N .AND. M.GT.0 ) )
     $      THEN
         INFO = -17
      ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) )
     $      THEN
         INFO = -19
      ELSE IF( TOL.GT.ONE ) THEN
         INFO = -20
      END IF
C
C     Compute workspace.
C      (Note: Comments in the code beginning "Workspace:" describe the
C       minimal amount of workspace needed at that point in the code,
C       as well as the preferred amount for good performance.
C       NB refers to the optimal block size for the immediately
C       following subroutine, as returned by ILAENV.)
C
      NSMPL = NSMP*L
      IQ    = IQ*L
      NCP1  = NCOL + 1
      ISIZE = NSMPL*NCP1
      IF ( N.GT.0 .AND. WITHX0 ) THEN
         IC = 2*NN + N
      ELSE
         IC = 0
      END IF
      MINWLS = NCOL*NCP1
      IF ( WITHD )
     $   MINWLS = MINWLS + LM*NCP1
      IF ( M.GT.0 .AND. WITHD ) THEN
         IA = M + MAX( 2*NCOL, M )
      ELSE
         IA = 2*NCOL
      END IF
      ITAU = N2M + MAX( IC, IA )
      IF ( WITHX0 )
     $   ITAU = ITAU + LN
      LDW2 = ISIZE  + MAX( N + MAX( IC, IA ), 6*NCOL )
      LDW3 = MINWLS + MAX( IQ*NCP1 + ITAU, 6*NCOL )
      IF ( M.GT.0 .AND. WITHD ) THEN
         LDW2 = MAX( LDW2, ISIZE  + 2*M*M + 6*M )
         LDW3 = MAX( LDW3, MINWLS + 2*M*M + 6*M )
      END IF
      MINWRK = MIN( LDW2, LDW3 )
      MINWRK = MAX( MINWRK, 2 )
      IF ( M.GT.0 .AND. WITHD )
     $   MINWRK = MAX( MINWRK, 3 )
      IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN
         IF ( M.GT.0 .AND. WITHD ) THEN
            MAXWRK = ISIZE + N + M +
     $               MAX( M*ILAENV( 1, 'DGEQRF', ' ', NSMP, M, -1, -1 ),
     $                    NCOL + NCOL*ILAENV( 1, 'DGEQRF', ' ', NSMP-M,
     $                                        NCOL, -1, -1 ) )
            MAXWRK = MAX( MAXWRK, ISIZE + N + M +
     $                    MAX( NCP1*ILAENV( 1, 'DORMQR', 'LT', NSMP,
     $                                      NCP1, M, -1 ),
     $                         NCOL + ILAENV( 1, 'DORMQR', 'LT',
     $                                        NSMP-M, 1, NCOL, -1 ) ) )
         ELSE
            MAXWRK = ISIZE + N + NCOL +
     $               MAX( NCOL*ILAENV( 1, 'DGEQRF', ' ', NSMPL, NCOL,
     $                                 -1, -1 ),
     $                         ILAENV( 1, 'DORMQR', 'LT',NSMPL, 1, NCOL,
     $                                 -1 ) )
         END IF
         MAXWRK = MAX( MAXWRK, MINWRK )
      END IF
C
      IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN
         INFO = -23
         DWORK(1) = MINWRK
      END IF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'IB01QD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MAX( N, M ).EQ.0 ) THEN
         DWORK(2) = ONE
         IF ( M.GT.0 .AND. WITHD ) THEN
            DWORK(1) = THREE
            DWORK(3) = ONE
         ELSE
            DWORK(1) = TWO
         END IF
         RETURN
      END IF
C
C     Set up the least squares problem, either directly, if enough
C     workspace, or sequentially, otherwise.
C
      IYPNT = 1
      IUPNT = 1
      LDDW  = ( LDWORK - MINWLS - ITAU )/NCP1
      NOBS  = MIN( NSMP, LDDW/L )
C
      IF ( LDWORK.GE.LDW2 .OR. NSMP.LE.NOBS ) THEN
C
C        Enough workspace for solving the problem directly.
C
         NCYCLE = 1
         NOBS   = NSMP
         LDDW   = MAX( 1, NSMPL )
         IF ( WITHD ) THEN
            INIR = M + 1
         ELSE
            INIR = 1
         END IF
         INY  = 1
         INIS = 1
      ELSE
C
C        NCYCLE > 1  cycles are needed for solving the problem
C        sequentially, taking  NOBS  samples in each cycle (or the
C        remaining samples in the last cycle).
C
         LNOB   = L*NOBS
         LDDW   = MAX( 1, LNOB )
         NCYCLE = NSMP/NOBS
         IF ( MOD( NSMP, NOBS ).NE.0 )
     $      NCYCLE = NCYCLE + 1
         INIR = 1
         INIH = INIR + NCOL*NCOL
         INIS = INIH + NCOL
         IF ( WITHD ) THEN
            INY = INIS + LM*NCP1
         ELSE
            INY = INIS
         END IF
      END IF
C
      NCYC   = NCYCLE.GT.1
      INYGAM = INY  + LDDW*NM
      IRHS   = INY  + LDDW*NCOL
      IXINIT = IRHS + LDDW
      IF( NCYC ) THEN
         IC = IXINIT + N2M
         IF ( WITHX0 ) THEN
            IA = IC + LN
         ELSE
            IA = IC
         END IF
         LDR = MAX( 1, NCOL )
         IE  = INY
      ELSE
         IF ( WITHD ) THEN
            INIH = IRHS + M
         ELSE
            INIH = IRHS
         END IF
         IA  = IXINIT + N
         LDR = LDDW
         IE  = IXINIT
      END IF
      IF ( N.GT.0 .AND. WITHX0 )
     $   IAS = IA + NN
C
      ITAUU = IA
      IF ( WITHD ) THEN
         ITAU = ITAUU + M
      ELSE
         ITAU = ITAUU
      END IF
      DUM(1) = ZERO
C
      DO 190 ICYCLE = 1, NCYCLE
         FIRST = ICYCLE.EQ.1
         IF ( .NOT.FIRST ) THEN
            IF ( ICYCLE.EQ.NCYCLE ) THEN
               NOBS = NSMP - ( NCYCLE - 1 )*NOBS
               LNOB = L*NOBS
            END IF
         END IF
C
         IY     = INY
         IXSAVE = IXINIT
C
C        Compute the  M*N  output trajectories for zero initial state
C        or for the saved final state value of the previous cycle.
C        This can be performed in parallel.
C        Workspace: need  s*L*(r + 1) + b + w,
C                   where r = M*N + a,  s = NOBS,
C                         a = 0,             if JOBX0 = 'N';
C                         a = N,             if JOBX0 = 'X';
C                         b = N,             if NCYCLE = 1;
C                         b = N*N*M,         if NCYCLE > 1;
C                         w = 0,             if NCYCLE = 1;
C                         w = r*(r+1),       if NCYCLE > 1,  JOB = 'B';
C                         w = (M*L+r)*(r+1), if NCYCLE > 1,  JOB = 'D'.
C
         DO 40 J = 1, M
            DO 30 I = 1, N
C                            ij
C              Compute the  y    trajectory and put the vectorized form
C              of it in an appropriate column of  DWORK.  To gain in
C              efficiency, a specialization of SLICOT Library routine
C              TF01ND is used.
C
               IF ( FIRST )
     $            CALL DCOPY( N, DUM, 0, DWORK(IXSAVE), 1 )
               CALL DCOPY( N, DWORK(IXSAVE), 1, X0, 1 )
               INI = IY
C
               DO 20 K = 1, NOBS
                  CALL DGEMV( 'No transpose', L, N, ONE, C, LDC, X0, 1,
     $                        ZERO, DWORK(IY), NOBS )
                  IY = IY + 1
                  CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N,
     $                        A, LDA, X0, 1 )
C
                  DO 10 IX = 2, N
                     X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXSAVE+IX-2)
   10             CONTINUE
C
                  X0(I) = X0(I) + U(IUPNT+K-1,J)
                  CALL DCOPY( N, X0, 1, DWORK(IXSAVE), 1 )
   20          CONTINUE
C
               IF ( NCYC )
     $            IXSAVE = IXSAVE + N
               IY = INI + LDDW
   30       CONTINUE
C
   40    CONTINUE
C
         IF ( N.GT.0 .AND. WITHX0 ) THEN
C
C           Compute the permuted extended observability matrix  Gamma
C                                                                ij
C           in the following  N  columns of  DWORK  (after the  y
C           trajectories).  Gamma  is directly constructed in the
C           required row structure.
C           Workspace: need  s*L*(r + 1) + 2*N*N + N + b + c + w,
C                      where c = 0,   if NCYCLE = 1;
C                            c = L*N, if NCYCLE > 1.
C
            JWORK  = IAS + NN
            IG     = INYGAM
            IEXPON = INT( LOG( DBLE( NOBS ) )/LOG( TWO ) )
            IREM   = NOBS - 2**IEXPON
            POWER2 = IREM.EQ.0
            IF ( .NOT.POWER2 )
     $         IEXPON = IEXPON + 1
C
            IF ( FIRST ) THEN
C
               DO 50 I = 1, N
                  CALL DCOPY( L, C(1,I), 1, DWORK(IG), NOBS )
                  IG = IG + LDDW
   50          CONTINUE
C
            ELSE
C
               DO 60 I = IC, IC + LN - 1, L
                  CALL DCOPY( L, DWORK(I), 1, DWORK(IG), NOBS )
                  IG = IG + LDDW
   60          CONTINUE
C
            END IF
C                                          p
C           Use powers of the matrix  A:  A ,  p = 2**(J-1).
C
            CALL DLACPY( 'Upper', N, N, A, LDA, DWORK(IA), N )
            IF( N.GT.1 )
     $         CALL DCOPY( N-1, A(2,1), LDA+1, DWORK(IA+1), N+1 )
            I2   = 1
            NROW = 0
C
            DO 90 J = 1, IEXPON
               IGAM = INYGAM
               IF ( J.LT.IEXPON .OR. POWER2 ) THEN
                  NROW = I2
               ELSE
                  NROW = IREM
               END IF
C
               DO 80 I = 1, L
                  CALL DLACPY( 'Full', NROW, N, DWORK(IGAM), LDDW,
     $                         DWORK(IGAM+I2), LDDW )
                  CALL DTRMM(  'Right', 'Upper', 'No Transpose',
     $                         'Non Unit', NROW, N, ONE, DWORK(IA), N,
     $                         DWORK(IGAM+I2), LDDW )
                  IG = IGAM
C                                                                  p
C                 Compute the contribution of the subdiagonal of  A
C                 to the product.
C
                  DO 70 IX = 1, N - 1
                     CALL DAXPY( NROW, DWORK(IA+(IX-1)*N+IX),
     $                           DWORK(IG+LDDW), 1, DWORK(IG+I2), 1 )
                     IG = IG + LDDW
   70             CONTINUE
C
                  IGAM = IGAM + NOBS
   80          CONTINUE
C
               IF ( J.LT.IEXPON ) THEN
                  CALL DLACPY( 'Upper', N, N, DWORK(IA), N, DWORK(IAS),
     $                         N )
                  IF( N.GT.1 )
     $               CALL DCOPY( N-1, DWORK(IA+1), N+1, DWORK(IAS+1),
     $                           N+1 )
                  CALL MB01TD( N, DWORK(IAS), N, DWORK(IA), N,
     $                         DWORK(JWORK), IERR )
                  I2 = I2*2
               END IF
   90       CONTINUE
C
            IF ( NCYC .AND. ICYCLE.LT.NCYCLE ) THEN
               IG  = INYGAM + I2 + NROW - 1
               IGS = IG
C
               DO 100 I = IC, IC + LN - 1, L
                  CALL DCOPY( L, DWORK(IG), NOBS, DWORK(I), 1 )
                  IG = IG + LDDW
  100          CONTINUE
C
               CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit',
     $                     L, N, ONE, A, LDA, DWORK(IC), L )
               IG = IGS
C
C              Compute the contribution of the subdiagonal of  A  to the
C              product.
C
               DO 110 IX = 1, N - 1
                  CALL DAXPY( L, A(IX+1,IX), DWORK(IG+LDDW), NOBS,
     $                        DWORK(IC+(IX-1)*L), 1 )
                  IG = IG + LDDW
  110          CONTINUE
C
            END IF
         END IF
C
C        Setup (part of) the right hand side of the least squares
C        problem.
C
         IY = IRHS
C
         DO 120 K = 1, L
            CALL DCOPY( NOBS, Y(IYPNT,K), 1, DWORK(IY), 1 )
            IY = IY + NOBS
  120    CONTINUE
C
C        Compress the data using a special QR factorization.
C        Workspace: need   v + y,
C                   where  v = s*L*(r + 1) + b + c + w + x,
C                          x = M,  y = max( 2*r, M ),
C                                             if  JOB = 'D'  and  M > 0,
C                          x = 0,  y = 2*r,   if  JOB = 'B'  or   M = 0.
C
         IF ( M.GT.0 .AND. WITHD ) THEN
C
C           Case 1:  D  is requested.
C
            JWORK = ITAU
            IF ( FIRST ) THEN
               INI = INY + M
C
C              Compress the first or single segment of  U,  U1 = Q1*R1.
C              Workspace: need   v + M;
C                         prefer v + M*NB.
C
               CALL DGEQRF( NOBS, M, U, LDU, DWORK(ITAUU), DWORK(JWORK),
     $                      LDWORK-JWORK+1, IERR )
C                                                  ij
C              Apply  diag(Q1')  to the matrix  [ y   Gamma Y ].
C              Workspace: need   v + r + 1,
C                         prefer v + (r + 1)*NB.
C
               DO 130 K = 1, L
                  CALL DORMQR( 'Left', 'Transpose', NOBS, NCP1, M, U,
     $                         LDU, DWORK(ITAUU), DWORK(INY+(K-1)*NOBS),
     $                         LDDW, DWORK(JWORK), LDWORK-JWORK+1,
     $                         IERR )
  130          CONTINUE
C
               IF ( NCOL.GT.0 ) THEN
C
C                 Compress the first part of the first data segment of
C                    ij
C                 [ y   Gamma ].
C                 Workspace: need   v + 2*r,
C                            prefer v + r + r*NB.
C
                  JWORK = ITAU + NCOL
                  CALL DGEQRF( NOBS-M, NCOL, DWORK(INI), LDDW,
     $                         DWORK(ITAU), DWORK(JWORK),
     $                         LDWORK-JWORK+1, IERR )
C
C                 Apply the transformation to the corresponding right
C                 hand side part.
C                 Workspace: need   v + r + 1,
C                            prefer v + r + NB.
C
                  CALL DORMQR( 'Left', 'Transpose', NOBS-M, 1, NCOL,
     $                         DWORK(INI), LDDW, DWORK(ITAU),
     $                         DWORK(IRHS+M), LDDW, DWORK(JWORK),
     $                         LDWORK-JWORK+1, IERR )
C
C                 Compress the remaining parts of the first data segment
C                        ij
C                 of  [ y   Gamma ].
C                 Workspace: need   v + r - 1.
C
                  DO 140 K = 2, L
                     CALL MB04OD( 'Full', NCOL, 1, NOBS-M, DWORK(INI),
     $                            LDDW, DWORK(INI+(K-1)*NOBS), LDDW,
     $                            DWORK(IRHS+M), LDDW,
     $                            DWORK(IRHS+M+(K-1)*NOBS), LDDW,
     $                            DWORK(ITAU), DWORK(JWORK) )
  140             CONTINUE
C
               END IF
C
               IF ( NCYC ) THEN
C                                                   ij
C                 Save the triangular factor of  [ y   Gamma ],  the
C                 corresponding right hand side, and the first  M  rows
C                 in each  NOBS  group of rows.
C                 Workspace: need   v.
C
                  CALL DLACPY( 'Upper', NCOL, NCP1, DWORK(INI), LDDW,
     $                         DWORK(INIR), LDR )
C
                  DO 150 K = 1, L
                     CALL DLACPY( 'Full', M, NCP1,
     $                            DWORK(INY +(K-1)*NOBS), LDDW,
     $                            DWORK(INIS+(K-1)*M), LM )
  150             CONTINUE
C
               END IF
            ELSE
C
C              Compress the current data segment of  U,  Ui = Qi*Ri,
C              i = ICYCLE.
C              Workspace: need   v + r + 1.
C
               CALL MB04OD( 'Full', M, NCP1, NOBS, U, LDU, U(IUPNT,1),
     $                      LDU, DWORK(INIS), LM, DWORK(INY), LDDW,
     $                      DWORK(ITAUU), DWORK(JWORK) )
C
C              Apply  diag(Qi')  to the appropriate part of the matrix
C                 ij
C              [ y   Gamma Y ].
C              Workspace: need   v + r + 1.
C
               DO 170 K = 2, L
C
                  DO 160 IX = 1, M
                     CALL MB04OY( NOBS, NCP1, U(IUPNT,IX),
     $                            DWORK(ITAUU+IX-1),
     $                            DWORK(INIS+(K-1)*M+IX-1), LM,
     $                            DWORK(INY+(K-1)*NOBS), LDDW,
     $                            DWORK(JWORK) )
  160             CONTINUE
C
  170          CONTINUE
C
               IF ( NCOL.GT.0 ) THEN
C
                  JWORK = ITAU + NCOL
C
C                 Compress the current (but not the first) data segment
C                        ij
C                 of  [ y   Gamma ].
C                 Workspace: need   v + r - 1.
C
                  DO 180 K = 1, L
                     CALL MB04OD( 'Full', NCOL, 1, NOBS, DWORK(INIR),
     $                            LDR, DWORK(INY+(K-1)*NOBS), LDDW,
     $                            DWORK(INIH), LDR,
     $                            DWORK(IRHS+(K-1)*NOBS), LDDW,
     $                            DWORK(ITAU), DWORK(JWORK) )
  180             CONTINUE
C
               END IF
            END IF
C
         ELSE IF ( NCOL.GT.0 ) THEN
C
C           Case 2:  D  is known to be zero.
C
            JWORK = ITAU + NCOL
            IF ( FIRST ) THEN
C
C              Compress the first or single data segment of
C                 ij
C              [ y   Gamma ].
C              Workspace: need   v + 2*r,
C                         prefer v + r + r*NB.
C
               CALL DGEQRF( LDDW, NCOL, DWORK(INY), LDDW, DWORK(ITAU),
     $                      DWORK(JWORK), LDWORK-JWORK+1, IERR )
C
C              Apply the transformation to the right hand side.
C              Workspace: need   v + r + 1,
C                         prefer v + r + NB.
C
               CALL DORMQR( 'Left', 'Transpose', LDDW, 1, NCOL,
     $                      DWORK(INY), LDDW, DWORK(ITAU), DWORK(IRHS),
     $                      LDDW, DWORK(JWORK), LDWORK-JWORK+1, IERR )
               IF ( NCYC ) THEN
C                                                   ij
C                 Save the triangular factor of  [ y   Gamma ]  and the
C                 corresponding right hand side.
C                 Workspace: need   v.
C
                  CALL DLACPY( 'Upper', NCOL, NCP1, DWORK(INY), LDDW,
     $                         DWORK(INIR), LDR )
               END IF
            ELSE
C
C              Compress the current (but not the first) data segment.
C              Workspace: need   v + r - 1.
C
               CALL MB04OD( 'Full', NCOL, 1, LNOB, DWORK(INIR), LDR,
     $                      DWORK(INY), LDDW, DWORK(INIH), LDR,
     $                      DWORK(IRHS), LDDW, DWORK(ITAU),
     $                      DWORK(JWORK) )
            END IF
         END IF
C
         IUPNT = IUPNT + NOBS
         IYPNT = IYPNT + NOBS
  190 CONTINUE
C
C     Estimate the reciprocal condition number of the triangular factor
C     of the QR decomposition.
C     Workspace: need  u + 3*r, where
C                      u = t*L*(r + 1), if NCYCLE = 1;
C                      u = w,           if NCYCLE > 1.
C
      CALL DTRCON( '1-norm', 'Upper', 'No Transpose', NCOL, DWORK(INIR),
     $             LDR, RCOND, DWORK(IE), IWORK, IERR )
C
      TOLL = TOL
      IF ( TOLL.LE.ZERO )
     $   TOLL = DLAMCH( 'Precision' )
      IF ( RCOND.LE.TOLL**( TWO/THREE ) ) THEN
         IWARN = 4
C
C        The least squares problem is ill-conditioned.
C        Use SVD to solve it.
C        Workspace: need   u + 6*r;
C                   prefer larger.
C
         IF ( NCOL.GT.1 )
     $      CALL DLASET( 'Lower', NCOL-1, NCOL-1, ZERO, ZERO,
     $                   DWORK(INIR+1), LDR )
         ISV   = IE
         JWORK = ISV + NCOL
         CALL DGELSS( NCOL, NCOL, 1, DWORK(INIR), LDR, DWORK(INIH), LDR,
     $                DWORK(ISV), TOLL, RANK, DWORK(JWORK),
     $                LDWORK-JWORK+1, IERR )
         IF ( IERR.GT.0 ) THEN
C
C           Return if SVD algorithm did not converge.
C
            INFO = 2
            RETURN
         END IF
         MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 )
      ELSE
C
C        Find the least squares solution using QR decomposition only.
C
         CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non Unit', NCOL,
     $               1, ONE, DWORK(INIR), LDR, DWORK(INIH), LDR )
      END IF
C
C     Setup the estimated n-by-m input matrix  B,  and the estimated
C     initial state of the system  x0.
C
      CALL DLACPY( 'Full', N, M, DWORK(INIH), N, B, LDB )
C
      IF ( N.GT.0 .AND. WITHX0 ) THEN
         CALL DCOPY( N, DWORK(INIH+NM), 1, X0, 1 )
      ELSE
         CALL DCOPY( N, DUM, 0, X0, 1 )
      END IF
C
      IF ( M.GT.0 .AND. WITHD ) THEN
C
C        Compute the estimated l-by-m input/output matrix  D.
C
         IF ( NCYC ) THEN
            IRHS = INIS + LM*NCOL
            CALL DGEMV( 'No Transpose', LM, NCOL, -ONE, DWORK(INIS),
     $                  LM, DWORK(INIH), 1, ONE, DWORK(IRHS), 1 )
         ELSE
C
            DO 200 K = 1, L
               CALL DGEMV( 'No Transpose', M, NCOL, -ONE,
     $                     DWORK(INIS+(K-1)*NOBS), LDDW, DWORK(INIH), 1,
     $                     ONE, DWORK(IRHS+(K-1)*NOBS), 1 )
  200       CONTINUE
C
            DO 210 K = 2, L
               CALL DCOPY( M, DWORK(IRHS+(K-1)*NOBS), 1,
     $                     DWORK(IRHS+(K-1)*M), 1 )
  210       CONTINUE
C
         END IF
C
C        Estimate the reciprocal condition number of the triangular
C        factor of the QR decomposition of the matrix U.
C        Workspace: need  u + 3*M.
C
         CALL DTRCON( '1-norm', 'Upper', 'No Transpose', M, U, LDU,
     $                RCONDU, DWORK(IE), IWORK, IERR )
         IF ( RCONDU.LE.TOLL**( TWO/THREE ) ) THEN
            IWARN = 4
C
C           The least squares problem is ill-conditioned.
C           Use SVD to solve it. (QR decomposition of  U  is preserved.)
C           Workspace: need   u + 2*M*M + 6*M;
C                      prefer larger.
C
            IQ    = IE  + M*M
            ISV   = IQ  + M*M
            JWORK = ISV + M
            CALL DLACPY( 'Upper', M, M, U, LDU, DWORK(IE), M )
            CALL MB02UD( 'Not Factored', 'Left', 'No Transpose',
     $                   'No Pinv', M, L, ONE, TOLL, RANK, DWORK(IE),
     $                   M, DWORK(IQ), M, DWORK(ISV), DWORK(IRHS), M,
     $                   DUM, 1, DWORK(JWORK), LDWORK-JWORK+1, IERR )
            IF ( IERR.GT.0 ) THEN
C
C              Return if SVD algorithm did not converge.
C
               INFO = 2
               RETURN
            END IF
            MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 )
         ELSE
            CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non Unit', M,
     $                  L, ONE, U, LDU, DWORK(IRHS), M )
         END IF
         CALL MA02AD( 'Full', M, L, DWORK(IRHS), M, D, LDD )
C
      END IF
C
      DWORK(1) = MAXWRK
      DWORK(2) = RCOND
      IF ( M.GT.0 .AND. WITHD )
     $   DWORK(3) = RCONDU
C
      RETURN
C
C *** End of IB01QD ***
      END


!MIT License
!Copyright (c) 2017 VL Srinivas

! This program solves "Shallow Water Equations" in 2D using Richtmyer
! two-step Lax–Wendroff method with reference to John bukardt's 1D code.
! 3 types of initial conditions(IC) and 3 boundary conditions(BC) are tested.
! IC: Sine wave, Dam break, Gaussian functions
! BC: Periodic, Free, Reflective bcs
! @ author: VL Srinivas (https://www.linkedin.com/in/vl-srinivas/)

program main
implicit none

    integer, parameter:: nx=20, ny=20, nt=500
    real(8), parameter:: x_length=1.0d0, Y_length=1.0d0, T_length = 0.2d0
    integer:: iter, i, j
    real(8) :: dx, dy, dt, ck
    character(len=100):: fileplace, pico
    real(8), parameter:: g=9.81d0, pi=3.141592653589793D0
    real(8), dimension(nx,ny):: h, uh, vh
    real(8):: X(nx), Y(ny), t(nt+1)
    ! Arrays to store the values for each time step
    real(8), dimension(nx,ny,nt+1):: uh_array, vh_array, h_array
    ! Values at midpoints of grid points for half time step calculation
    real(8), dimension(nx-1,ny-1):: hmx, hmy, uhmx, uhmy, vhmx, vhmy
    ! RK4 variables
    real(8), dimension(nx):: kh1,kh2,kh3,kh4,kuh1,kuh2,kuh3,kuh4
    real:: t1, t2, t3       ! Time variables

    call cpu_time(t1)

!   write(*,*) "Enter the following input values:"
!    x_length = 1.0d0
!    T_length = 0.20d0

    ! Creating spatial and time grid
    call linspace(nx, 0.0d0, X_length, X)
    !print *, 'X'
    !print *, X
    call linspace(ny, 0.0d0, Y_length, Y)

    call linspace(nt, 0.0d0, T_length, T)
    !print *, 't'
    !print *, t

    ! Creating step size for time and space
    dx = X_length/(nx-1)
    !print *, 'dx', dx
    dy = Y_length/(ny-1)

    dt = T_length/(nt-1)

    call initial(pi, nx, ny, X, Y, h, uh, vh, X_length, Y_length)

    ck = max( maxval(h), abs(minval(h)) )

    ! ----------------------- MAIN LOOP --------------------
    do iter = 1, nt

        ! Solving using Ritchmyer 2-step lax-wendroff method
        call solver_lax_wendroff(nx,ny,dx,dy,dt,g,h,uh,vh)

!--------! Applying the boundary conditions
		call apply_BC(nx, ny, h, uh, vh, 3)

		! Entering the data into matrices with time
		h_array(1:nx, 1:ny, iter+1) = h(1:nx,1:ny)
		uh_array(1:nx, 1:ny, iter+1) = uh(1:nx,1:ny)
		vh_array(1:nx, 1:ny, iter+1) = vh(1:nx,1:ny)

		if ( iter == 1 )  then
            !call write_h(nx,ny,nt,dx,dy,dt,X,Y,h,iter)
        end if

		! Writing the data to the files : ( h & uh )
		if ( mod(iter,10) == 0 )  then
            call write_h(nx,ny,nt,dx,dy,dt,X,Y,h,iter)
        end if

		! Checking the time-step size
		!call check(dx,dt,nx,ny,h,uh,vh,ck)

        !if (iter==60) then

	end do
	! ----------------------- END MAIN LOOP --------------------

	! Writing the arrays to files

	call cpu_time(t2)

	t3 = t2 - t1

	write(*,*) "---------------------------------------------"
	write(*,*) "Shallow Water Equations 2D"
	write(*,*) "Spatial grid:", nx,'*',ny
	write(*,*) "Time grid:", nt
	write(*,*) "T_length:", real(t_length,kind=4)
	write(*,*) "X_length:", real(X_length,kind=4)
	write(*,*) "Y_length:", real(Y_length,kind=4)
	write(*,*) "Spatial step size-X:", real(dx,kind=4)
	write(*,*) "Spatial step size-Y:", real(dy,kind=4)
	write(*,*) "Time step size:", real(dt,kind=4)
	write(*,*) "Time taken:", t3, 'sec'
	write(*,*) "---------------------------------------------"
    print *, 'Extreme height',ck
 end program
!*******************************************************************************
subroutine linspace(n, first, last, A)
implicit none

    integer:: i
    integer, intent(in):: n
    real(8), intent(in):: first, last
    real(8), intent(out):: A(n)

    if (n==1) then
        a(1) = (first + last)/2.0d0

    else
        do i = 1, n

            A(i) = ( real(n-i, kind=8)*first + real(i-1, kind=8)*last )/ &
                   real(n-1,kind=8)
        end do

    end if

return
end subroutine
!*******************************************************************************
subroutine initial(pi, nx, ny, X, Y, h, uh, vh, X_length, Y_length)
implicit none

    integer, intent(in):: nx, ny
	real(8), intent(in):: X(nx), Y(ny), pi, X_length, Y_length
	real(8), intent(out):: h(nx,ny), uh(nx,ny), vh(nx,ny)
	real(8)::a, x0, y0, sx, sy
	integer:: i, j

    ! Sine wave initial condition

	!h(1:nx, 1:ny) = 2.0d0 + sin(2*pi* X(1:nx))

	! Dam break initial condition
	!h = 1.0d0
	!h(1:nx/2, :) = 3.0d0

    ! Gaussian function
    a = 3.0d0
    x0 = X_length/2.0d0
    y0 = Y_length/2.0d0
    sx = 0.2d0
    sy = 0.2d0

    do j = 1, ny
    do i = 1, nx
        h(i,j) = a*exp(- ( (X(i)-x0)**2 /(2*sx**2) + (Y(j)-y0)**2 /(2*sy**2) ) )
    end do
    end do

	uh(1:nx, 1:ny) = 0.0d0
	vh(1:nx, 1:ny) = 0.0d0

return
end subroutine
!*******************************************************************************
subroutine apply_BC(nx, ny, h, uh, vh, bc)
implicit none

	integer, intent(in):: bc, nx, ny
	real(8), dimension(nx,ny):: h, uh, vh

	! Applying Periodic boundary conditions
	if (bc==1) then

		! South boundary
		h(:,1) = h(:,ny-1)
		uh(:,1) = uh(:,ny-1)
		vh(:,1) = vh(:,ny-1)

		! North boundary
		h(:,ny) = h(:,2)
		uh(:,ny) = uh(:,2)
		vh(:,ny) = vh(:,2)

		! West boundary
		h(1,:) = h(nx-1,:)
		uh(1,:) = uh(nx-1,:)
		vh(1,:) = vh(nx-1,:)

		! East boundary
		h(nx,:) = h(2,:)
		uh(nx,:) = uh(2,:)
		vh(nx,:) = vh(2,:)

	! Applying Free Boundary Condition
	else if (bc==2) then
		! South boundary
		h(:,1) = h(:,2)
		uh(:,1) = uh(:,2)
		vh(:,1) = vh(:,2)

		! North boundary
		h(:,ny) = h(:,ny-1)
		uh(:,ny) = uh(:,ny-1)
		vh(:,ny) = vh(:,ny-1)

		! West boundary
		h(1,:) = h(2,:)
		uh(1,:) = uh(2,:)
		vh(1,:) = vh(2,:)

		! East boundary
		h(nx,:) = h(nx-1,:)
		uh(nx,:) = uh(nx-1,:)
		vh(nx,:) = vh(nx-1,:)

	! Applying Reflective BC for 'uh' & Free BC for 'h'
	else if (bc==3) then
		! South boundary
		h(:,1) = h(:,2)
		uh(:,1) = uh(:,2)
		vh(:,1) = -vh(:,2)

		! North boundary
		h(:,ny) = h(:,ny-1)
		uh(:,ny) = uh(:,ny-1)
		vh(:,ny) = -vh(:,ny-1)

		! West boundary
		h(1,:) = h(2,:)
		uh(1,:) = -uh(2,:)
		vh(1,:) = vh(2,:)

		! East boundary
		h(nx,:) = h(nx-1,:)
		uh(nx,:) = -uh(nx-1,:)
		vh(nx,:) = vh(nx-1,:)

	end if

return
end subroutine
!*******************************************************************************
subroutine solver_lax_wendroff(nx,ny,dx,dy,dt,g,h,uh,vh)
implicit none

    integer:: i,j
	integer, intent(in):: nx, ny
	real(8), intent(in):: dx,dy,dt,g
	real(8), dimension(nx,ny):: h, uh, vh
	real(8), dimension(nx-1,ny-1):: hmx, hmy, uhmx, uhmy, vhmx, vhmy

	! Lax-Wendroff's method in 2D for finite difference hyperbolic pde
    ! Taking half step at cell centres
    do j = 1, ny-1
	do i = 1, nx-1

		! Half steps at mid-points for the continuity equation
        hmx(i,j) =  ( h(i,j) + h(i+1,j) )/2.0d0 - dt/2.0d0 *( (uh(i+1,j)-uh(i,j)) )/dx
	    hmy(i,j) =  ( h(i,j) + h(i,j+1) )/2.0d0 - dt/2.0d0 *( (vh(i,j+1)-vh(i,j)) )/dy
	    !print *, 'hm-',i,hm(i)

		! Half steps at mid-points for X-Momentum equation
		uhmx(i,j) = ( uh(i,j) + uh(i+1,j) )/2.0d0 - dt/(2.0d0*dx) * &
				( ( uh(i+1,j)**2 /h(i+1,j) + g/2.0d0*h(i+1,j)**2 ) - &
					( uh(i,j)**2 /h(i,j) + g/2.0d0*h(i,j)**2) )

		uhmy(i,j) = ( uh(i,j) + uh(i,j+1) )/2.0d0 - dt/(2.0d0*dy) * &
				( uh(i,j+1)*vh(i,j+1) /h(i,j+1) - uh(i,j)*vh(i,j) /h(i,j) )

		! Half steps at mid-points for Y-Momemtum equation
		vhmx(i,j) = ( vh(i+1,j) + vh(i,j) )/2.0d0 - dt/(2.0d0*dy) * &
				( uh(i+1,j)*vh(i+1,j) /h(i+1,j) - uh(i,j)*vh(i,j) /h(i,j) )

		vhmy(i,j) = ( vh(i,j) + vh(i+1,j) )/2.0d0 - dt/(2.0d0*dy) * &
				( ( vh(i,j+1)**2 /h(i,j+1) + g/2.0d0*h(i,j+1)**2 ) - &
					( vh(i,j)**2 /h(i,j) + g/2.0d0*h(i,j)**2) )

	end do
    end do

	! Taking the full time step at grid points defining the parameters
	! at the next time step only for internal grid points and excluding the
	! extreme points
    do j = 2, ny-1
    do i = 2, nx-1

		! Continuity equation
        h(i,j) = h(i,j) - dt/dx*( uhmx(i,j) - uhmx(i-1,j) ) - dt/dy*( vhmy(i,j) - vhmy(i,j-1) )
            !print *, 'h-',i,h(i)

  		! X-Momemtum equation
		uh(i,j) = uh(i,j) - dt/dx*( (uhmx(i,j)**2/hmx(i,j) + 0.5d0*g*hmx(i,j)**2) - &
            	(uhmx(i-1,j)**2/hmx(i-1,j) + 0.5d0*g*hmx(i-1,j)**2) ) - &
            	dt/dy *( uhmy(i,j)*vhmy(i,j)/hmy(i,j) - uhmy(i,j-1)*vhmy(i,j-1)/hmy(i,j-1))

        ! Y-Momemtum equation
        vh(i,j) = vh(i,j) - dt/dx*(uhmx(i,j)*vhmx(i,j)/hmx(i,j) - uhmx(i-1,j)*vhmx(i-1,j)/hmx(i-1,j)) &
            	- dt/dy*( (vhmy(i,j)**2/hmy(i,j) + 0.5d0*g*hmy(i,j)**2) - &
            	(vhmy(i,j-1)**2/hmy(i,j-1) + 0.5d0*g*hmy(i,j-1)**2) )

    end do
    end do

return
end subroutine
!*******************************************************************************
subroutine write_h(nx,ny,nt,dx,dy,dt,X,Y,h,iter)
implicit none

    integer:: i, j
    integer, intent(in):: iter,nx,ny,nt
    character(len=100):: pico
    real(8):: dx,dy,dt,X(nx),Y(ny),h(nx,ny)

    write(pico,*) iter

    open(unit=03, file= "/home/srinivas/Desktop/vls_2/files/h_"// &
            trim(adjustl(pico))//".dat", status='unknown')

    write(03,*) "X steps:", nx
    write(03,*) "Y steps:", ny
    write(03,*) "T steps:", nt
    write(03,*) "Time:", real(iter*dt,kind=4)
    write(03,*) "X step-size:", dx
    write(03,*) "Y step-size:", dx
    write(03,*) "T step-size:", dt
    write(03,*) "       X   ", "     Y    ", "    Height  "

    !if (nx > 0) then
    ! Writing the data
    do j = 1, ny
    do i = 1, nx

        write(03,100) real(X(i),kind=4), real(Y(j),kind=4), real(h(i,j),kind=4)

    end do
    end do
    !end if
    100 format(2x, 10(e12.6,' '))

    close(unit=03)

return
end subroutine
!*******************************************************************************
subroutine check(dx,dt,nx,ny,h,uh,vh,ck)
! This checks the time step size for cfl condition and
! sets the divergent height to the maximum from initial
implicit none

    integer:: i,j,nx,ny
    real(8):: dx, dt, u, v, cfl, ck
    real(8),dimension(nx,ny):: h,uh,vh,u1,v1

    do j = 1, ny
        do i = 1, nx

            u1(i,j) = uh(i,j)/h(i,j)
            v1(i,j) = vh(i,j)/h(i,j)

            ! Setting the divergent height value to maximum
            if (h(i,j) > ck) h(i,j) = ck

            if (h(i,j) < -ck) h(i,j) = -ck

        end do
    end do

    u = max( maxval(u1), abs(minval(u1)) )
    v = max( maxval(v1), abs(minval(v1)) )

    cfl = dx/( sqrt(u**2 + v**2)*sqrt(2.0) )

    if (dt > cfl) dt = cfl/2.0d0

return
end subroutine
!*******************************************************************************