c***********************************************************************
c> \file orrbfs.f
c> \brief Solves the Orr-Sommerfeld equation for incompressible
c>        backward-facing step with slip boundary on upper wall
c> \author S. Scott Collis
c***********************************************************************
      program orr_bfs
c***********************************************************************
c
c     Purpose:  This program solves the Orr-Sommerfeld equation using a
c               Chebyshev-collocation method for backward facing step
c               profiles provide from the DNS of Hung Le.  The
c               boundary conditions are basically that of a channel
c               with a slip wall at the upper boundary, similar to
c               the DNS boundary conditions.
c
c     Author:   S. Scott Collis
c
c     Date:     3-14-92
c
c     Revision: 1-5-2020
c
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=256)
      integer     n
      real        eta(0:idim), th(0:idim), lmap
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim)
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     dA2(0:idim,0:idim), dA1(0:idim,0:idim)
      complex     dA0(0:idim,0:idim), dB0(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type
      character*20 filename

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,type,filename
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0, dA2, dA1,
     .                     dA0, dB0
c***********************************************************************
      integer     nar, nai, ians
      real        alphar(100), alphai(100)
      real        minar, maxar, incar, minai, maxai, incai, dar, dai
      complex     oldeig, dwda
      complex     eigenvalue(100,100), eigenvector(0:idim), ctemp
      logical     print
c***********************************************************************
c
c     Setup IMSL workspace
c
#ifdef USE_IMSL
      REAL             RWKSP(10000)
      COMMON /WORKSP/  RWKSP
      call IWKIN(10000)
#endif
c
c     User input
c
      write (*,10)
  10  format (/,/,10x,'Solve Orr-Sommerfeld (Collocation)')
      write (*,20)
  20  format (/,1x,'Enter the number of modes ==> ',$)
      read (*,*) n
      write (*,30)
  30  format (/,1x,'Enter Reynolds number ==> ',$)
      read (*,*) Re
      write (*,40)
  40  format (/,1x,'Enter alpha_r (min,max,inc) ==> ',$)
      read (*,*) minar,maxar,incar
      write (*,45)
  45  format (/,1x,'Enter alpha_i (min,max,inc) ==> ',$)
      read (*,*) minai,maxai,incai
      write (*,50)
  50  format (/,1x,'Enter root filename ==> ',$)
      read (*,'(a)') filename
      write (*,52)
  52  format (/,1x,'Print eigenvectors (1,0) ==> ',$)
      read (*,*) ians
      if (ians.eq.1) then
         print = .true.
      else
         print = .false.
      end if

      nar = AINT((maxar-minar)/incar)+1
      nai = AINT((maxai-minai)/incai)+1
      write (*,55) nar, nai
 55   format (/,1x,' nar = ',i5,'  nai = ',i5)
      do i = 1, nar
        alphar(i) = minar + (i-1.)*incar
      end do
      do i = 1, nai
        alphai(i) = minai + (i-1.)*incai
      end do

      nx = nar
      ny = nai
      oldeig = cmplx(-999.,-999.)

      iloc = index(filename,' ')-1
      open (unit=10,file=filename(1:iloc)//'.g',form='unformatted',
     .      status='unknown')
      write (10) nx, ny
 100  format(i5,1x,$)
      write (10)((alphar(i), i=1,nx), j=1,ny),
     .          ((alphai(j), i=1,nx), j=1,ny)
 110  format (1x,e15.8,$)
      close (10)
      open (unit=12,file=filename(1:iloc)//'.dat',form='formatted',
     .      status='unknown')
      call MAKE_DERIVATIVES
      call INIT_BFS_PROFILE
      write (*,*)
      do j = 1, ny
        do i = 1, nx
          alpha = cmplx (alphar(i), alphai(j))
          call MAKE_MATRIX
          if (j.eq.2) then
            oldeig = eigenvalue(i,j-1)
          else if (j.gt.2) then
c            oldeig = eigenvalue(i,j-1)+(eigenvalue(i,j-1)-
c     .               eigenvalue(i,j-2))/(alphai(j-1)-alphai(j-2))*
c     .               (alphai(j)-alphai(j-1))
            oldeig = eigenvalue(i,j-1)
          else
            oldeig = cmplx(-9999.,-9999.)
          end if
          call SOLVE(ctemp, eigenvector, print, oldeig, dwda)
          eigenvalue(i,j) = ctemp
          write (12,60) real(alpha),aimag(alpha),real(eigenvalue(i,j)),
     .                  aimag(eigenvalue(i,j)),real(dwda),aimag(dwda)
          write (*,60)  real(alpha),aimag(alpha),real(eigenvalue(i,j)),
     .                  aimag(eigenvalue(i,j)),real(dwda),aimag(dwda)
  60      format (1x,6(e17.10,1x))
        end do
      end do

      open (unit=11,file=filename(1:iloc)//'.q',form='unformatted',
     .      status='unknown')
      write (11) nx, ny
      write (11) 0.0,0.0,0.0,0.0
      write (11)  ((1.0                   , i=1,nx), j=1,ny),
     .            ((real(eigenvalue(i,j)) , i=1,nx), j=1,ny),
     .            ((aimag(eigenvalue(i,j)), i=1,nx), j=1,ny),
     .            ((1.0                   , i=1,nx), j=1,ny)
      close (11)

      stop
      end

C***********************************************************************
      subroutine MAKE_DERIVATIVES
C***********************************************************************
C
C     Make the required matrices that take derivatives in Chebyshev
C     space
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=256)
      integer     n
      real        eta(0:idim), th(0:idim), lmap
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim)
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     dA2(0:idim,0:idim), dA1(0:idim,0:idim)
      complex     dA0(0:idim,0:idim), dB0(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type
      character*20 filename

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,type,filename
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0, dA2, dA1,
     .                     dA0, dB0
c***********************************************************************
      integer  m, p, LDD, i, j, k
      real     Identity(0:idim,0:idim), D1hat(0:idim,0:idim)

      LDD = idim
      call CHEBYD (D1hat, LDD, n)
      call CHEBYD (D1   , LDD, n)
c
c     We enforce noslip indirectly by setting v' = 0 at -1.
c     NOTE THAT D1-D4 SHOULD ONLY BE APPLIED TO THE v FIELD ONLY.
c
      do i = 0, n
c       D1(0,i) = 0.0
        D1(N,i) = 0.0
      end do
C
C     To get higher derivatives just do matrix multiplication
C
      do i = 0, n
        do j = 0, n
          D2(i,j) = 0.0
          do k = 0, n
            D2(i,j) = D2(i,j) +  D1hat(i,k)*D1(k,j)
          end do
        end do
      end do
c
c     At the upper surface we allow the flow to slip by setting v'' = 0
c     at 1.  NOTE THAT D1-D4 SHOULD ONLY BE APPLIED TO THE v FIELD ONLY.
c
      do i = 0, n
        D2(0,i) = 0.0
c       D2(N,i) = 0.0
      end do

      do i = 0, n
        do j = 0, n
          D3(i,j) = 0.0
          do k = 0, n
            D3(i,j) = D3(i,j) +  D1hat(i,k)*D2(k,j)
          end do
        end do
      end do
      do i = 0, n
        do j = 0, n
          D4(i,j) = 0.0
          do k = 0, n
            D4(i,j) = D4(i,j) +  D1hat(i,k)*D3(k,j)
          end do
        end do
      end do

c      CALL WRRRN ('D1', N+1, N+1, D1, LDd+1, 0)
c      CALL WRRRN ('D2', N+1, N+1, D2, LDd+1, 0)
c      CALL WRRRN ('D3', N+1, N+1, D3, LDd+1, 0)
c      CALL WRRRN ('D4', N+1, N+1, D4, LDd+1, 0)

      return
      end

C***********************************************************************
      subroutine MAKE_BL_METRICS
C***********************************************************************
C
C     Setup the collocation points in the mapped coordinate, eta and in
C     chebyshev space, th.  Also compute the transformation metrics.
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=256)
      integer     n
      real        eta(0:idim), th(0:idim), lmap
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim)
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     dA2(0:idim,0:idim), dA1(0:idim,0:idim)
      complex     dA0(0:idim,0:idim), dB0(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type
      character*20 filename

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,type,filename
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0, dA2, dA1,
     .                     dA0, dB0
c***********************************************************************
      real       pi, dth
      integer    i

      pi  = ACOS(-1.0)
      dth = pi/FLOAT(n)
c
c     Make mesh in transformed, eta, and Chebyshev space, th
c
      do i = 0, n
        th(i) = FLOAT(i)*dth
        eta(i) = COS(th(i))
      end do
c
c     Make transformation metrics
c
      do i = 0, n
        m1(i) = 2.0/Lmap
        m2(i) = 0.0
        m3(i) = 0.0
        m4(i) = 0.0
        if (i.eq.0) then
          c(i) = 2.
        else
          c(i) = 1.
        end if
      end do

      return
      end

C***********************************************************************
      SUBROUTINE FUNCD(X,F,DF)
C***********************************************************************
      REAL          X, ETA, GAMMA, ETAOUT
      COMMON        /map/  ETA

      GAMMA = 1.2
      ETAOUT  = 15.0

      F = ETAOUT*(1.-TANH(GAMMA))/2.*(X+1)/
     .           (1.-TANH(GAMMA/2.*(X+1)))-ETA
      A = ETAOUT/2.*(1-TANH(GAMMA))
      B = GAMMA/2.
      DF = A/2.*(1.+EXP(2.*B*(1.+X)) + 2.*B*EXP(2.*B*(1.+X)) +
     .           2.*B*EXP(2.*B*(1.+X))*X)
      RETURN
      END

C***********************************************************************
      subroutine INIT_BFS_PROFILE
C***********************************************************************
C
C     Setup the initial BL profile
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=256)
      integer     n
      real        eta(0:idim), th(0:idim), lmap
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim)
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     dA2(0:idim,0:idim), dA1(0:idim,0:idim)
      complex     dA0(0:idim,0:idim), dB0(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type
      character*20 filename

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,type,filename
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0, dA2, dA1,
     .                     dA0, dB0
c***********************************************************************
      parameter    (idim2=1000)
      integer      i, nbl, LDD
      character*20 profile
      real         junk, us(0:idim2), d2us(0:idim2), pi, xitemp
      real         xi(0:idim2), d1us(0:idim2), d1max, d2max
      real         ydat(0:idim2), ymin, ymax, h, ut(0:idim2)
      real         uspl(0:idim2), d2Uspl(0:idim2), metric, Lmap2
      real         D1hat(0:idim,0:idim), D2hat(0:idim,0:idim)
      character*1  temp

      pi = ACOS(-1.0)
      LDD = idim

      if (.false.) then
        write (*,10)
  10    format (/,1x,'Read Mean Profile',/)
        write (*,20)
  20    format (1x,'Enter filename ==> ',$)
        read (*,'(a)') profile
        open (unit=11,file=profile,status='unknown')

        i = 0
        read (11,35) temp, nbl
  35    format (a1,i5)
        nbl = nbl - 1
        do i = 0, nbl
          read (11,*,end=100) ydat(i),Ut(i),junk
        end do
        close (11)
 100    continue
      else
        nbl = 100
        do i = 0, nbl
          ydat(i) = -1.0+i*1.0/nbl
          Ut(i) = (1.0-ydat(i)**2)
        end do
      end if
c
c     Make a mirror image
c
      do i = nbl-1, 0, -1
        ydat(2*nbl-i) = 2.*ydat(nbl)-ydat(i)
        Ut(2*nbl-i) = Ut(i)
      end do
      nbl2 = 2*nbl
c
c     Interpolate data onto a Chebyshev Grid
c
      ymin2 = ydat(0)
      ymax2 = ydat(nbl2)
      h2 = (ymax2-ymin2)/float(nbl)
      Lmap2 = ymax2-ymin2

      write (*,11) nbl2
  11  format (/,1x,'Nbl = ',i5)
      call SPLINE(nbl2+1,ydat,Ut,uspl)
      ilen = index(filename,' ')-1
      open(unit=8,file=filename(1:ilen)//'.org',form='formatted',
     .     status='unknown')
      do i = 0, nbl2
        write (8,40) ydat(i),ut(i),uspl(i)
      end do
      close (8)
      dth = pi/(nbl2)
      ilen = index(filename,' ')-1
      open(unit=9,file=filename(1:ilen)//'.spl',form='formatted',
     .     status='unknown')
      do i = 0, nbl2
        thtemp = i*dth
        xi(i) = COS(thtemp)*Lmap2/2. + Lmap2/2. + ymin2
        call SPEVAL(nbl2+1,ydat,Ut,uspl,xi(i),us(i))
        write (9,40) xi(i), us(i), thtemp
      end do
      close (9)

      write (*,66) nbl2
   66 format (/,1x,'nbl =  ',i5,'   Enter ncut ==> ',$)
      read (*,*) ifilter
      write (*,77) ifilter
   77 format (/,1x,'Low pass filter at n = ',i5)

      call COSFT(us,nbl2,1)
      do i = ifilter, nbl2
        us(i) = 0.0
      end do
      call DCHEBYSHEVF(us,d1us,nbl2)
      call DCHEBYSHEVF(d1us,d2us,nbl2)
c     call COSFT(us,nbl,-1)
c     call COSFT(d1us,nbl,-1)
c     call COSFT(d2us,nbl,-1)
c     do i = 0, nbl
c       write (10,50) xi(i),us(i),d1us(i)*metric,d2us(i)*metric**2
c  50   format (1x,4(e12.4,1x))
c     end do
c
c     Convert to theta grid
c
      ymin = ydat(0)
      ymax = ydat(nbl)
      h = (ymax-ymin)/float(nbl)
      Lmap = ymax-ymin

      call MAKE_BL_METRICS

      do i = 0, n
        xitemp = COS(th(i))*Lmap/2. + Lmap/2. + ymin
        xitemp2 = (xitemp-(ymin2 + Lmap2/2.))*2./Lmap2
        if (xitemp2 .ge. 1.) then
          xitemp2 = 1.0
        else if (xitemp2 .le. -1.) then
          xitemp2 = -1.0
        end if
        thtemp = ACOS( xitemp2 )
        call CHEBYINTF(nbl2,u(i),thtemp,us)
        call CHEBYINTF(nbl2,d1u(i),thtemp,d1us)
        call CHEBYINTF(nbl2,d2u(i),thtemp,d2us)
        d1u(i) = d1u(i)*Lmap/Lmap2
        d2u(i) = d2u(i)*(Lmap/Lmap2)**2
      end do
c
c     Compute the collocation derivatives
c
c      call CHEBYD (D1hat, LDD, n)
c      do i = 0, n
c        do j = 0, n
c          D2hat(i,j) = 0.0
c          do k = 0, n
c            D2hat(i,j) = D2hat(i,j) +  D1hat(i,k)*D1hat(k,j)
c          end do
c        end do
c      end do
c      do i = 0, n
c        d1u(i) = 0.0
c        d2u(i) = 0.0
c        do k = 0, n
c            d1u(i) = d1u(i) + D1hat(i,k)*u(k)
c            d2u(i) = d2u(i) + D2hat(i,k)*u(k)
c        end do
c      end do

      ilen = index(filename,' ')-1
      open(unit=10,file=filename(1:ilen)//'.vel',form='formatted',
     .     status='unknown')
      do i = 0, n
        xitemp = eta(i)*Lmap/2. + Lmap/2. + ymin
        write (10,12) xitemp,u(i),d1u(i)*2./Lmap,d2u(i)*(2./Lmap)**2
      end do
  12  format (1x,4(e16.8,4x))
      close (10)

      write (*,30)

  30  format (/,1x,'Velocity Profile completed...',/)
  40  format (1x,5(e12.5,2x))
  90  format (1x,i5,1x,e12.5)

      return
      end

C***********************************************************************
      subroutine MAKE_MATRIX
C***********************************************************************
C
C     This routine generates the matrices which are combined to make
C     the generalized eigenvalue problem.
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=256)
      integer     n
      real        eta(0:idim), th(0:idim), lmap
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim)
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     dA2(0:idim,0:idim), dA1(0:idim,0:idim)
      complex     dA0(0:idim,0:idim), dB0(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type
      character*20 filename

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,type,filename
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0, dA2, dA1,
     .                     dA0, dB0
c***********************************************************************
      real      identity(0:idim,0:idim)
      complex   work, ai

      do i = 0, n
        do j = 0, n
          A4(i,j) = 0.0
          A3(i,j) = 0.0
          A2(i,j) = 0.0
          A1(i,j) = 0.0
          B2(i,j) = 0.0
          B1(i,j) = 0.0
          B0(i,j) = 0.0
          identity(i,j) = 0.0
        end do
        identity(i,i) = 1.0
      end do
C
C     Include the independent variable transformation metrics
C
      do i = 0, n
        work = m1(i)**4
        do j = 0, n
          A4(i,j) = work*D4(i,j)
        end do
      end do

      do i = 0, n
        work = 6.*m1(i)**2*m2(i)
        do j = 0, n
          A3(i,j) = work*D3(i,j)
        end do
      end do

      do i = 0, n
        work = 3.*m2(i)**2+4.*m1(i)*m3(i)-2.*alpha**2*m1(i)**2-
     .         cmplx(0.,1.)*alpha*Re*U(i)*m1(i)**2
        do j = 0, n
          A2(i,j) = work*D2(i,j)
        end do
      end do

      do i = 0, n
        work = m4(i)-2.*alpha**2*m2(i)-cmplx(0.,1.)*alpha*Re*U(i)*m2(i)
        do j = 0, n
          A1(i,j) = work*D1(i,j)
        end do
      end do

      do i = 0, n
        work = alpha**4+cmplx(0.,1.)*alpha**3*Re*U(i)+
     .         cmplx(0.,1.)*alpha*Re*(d2u(i)*m1(i)**2+d1u(i)*m2(i))
        do j = 0, n
          A0(i,j) = work*identity(i,j)
        end do
      end do

      do i = 0, n
        work = -1.0*cmplx(0.,1.)*Re*m1(i)**2
        do j = 0, n
          B2(i,j) = work*D2(i,j)
        end do
      end do

      do i = 0, n
        work = -1.0*cmplx(0.,1.)*Re*m2(i)
        do j = 0, n
          B1(i,j) = work*D1(i,j)
        end do
      end do

      do i = 0, n
        work = cmplx(0.,1.)*alpha**2*Re
        do j = 0, n
          B0(i,j) = work*identity(i,j)
        end do
      end do

      ai = cmplx(0.,1.)

c     Make the derivative (wrt alpha) matrices

      do i = 0, n
        work = -4.*alpha*m1(i)**2 - ai*Re*U(i)*m1(i)**2
        do j = 0, n
          dA2(i,j) = work*D2(i,j)
        end do
      end do

      do i = 0, n
        work = -4.*alpha*m2(i) - ai*Re*U(i)*m2(i)
        do j = 0, n
          dA1(i,j) = work*D1(i,j)
        end do
      end do

      do i = 0, n
        work =  4.*alpha**3 + 3.*ai*alpha**2*Re*U(i) +
     .          ai*Re*( d2U(i)*m1(i)**2 + d1U(i)*m2(i) )
        do j = 0, n
          dA0(i,j) = work*identity(i,j)
        end do
      end do

      do i = 0, n
        work = ai*2.*alpha*Re
        do j = 0, n
          dB0(i,j) = work*identity(i,j)
        end do
      end do

      return
      end

C***********************************************************************
      function CHECKEIG(N,A,LDA,EVAL,EVEC)
C***********************************************************************
C
C     Check an eigenvalue and eigenvector
C
C***********************************************************************
      integer    N
      complex    A(LDA,N), EVAL, EVEC(N)
      complex    X(N), Y(N)
      real       CHECKEIG
#if USE_IMSL
      CALL MUCRV (N, N, A, LDA, N, EVEC, 1, N, X)
#else
      CALL ZGEMV ('N', N, N, 1.0, A, LDA, EVEC, 1, 0.0, X, 1)
#endif
      CHECKEIG = 0.0
      DO I = 1, N
        CHECKEIG = CHECKEIG + ABS(X(I)-EVAL*EVEC(I))
      END DO
      CHECKEIG = CHECKEIG/FLOAT(N)

      RETURN
      END

C***********************************************************************
      subroutine HTRAN(N,A,B,LD)
C***********************************************************************
C
C     Take the complex conjugate transpose of A and put it in B
C
C***********************************************************************
      integer    N, LD
      complex    A(LD,N), B(LD,N)

      do i = 1, N
        do j = 1, N
          B(j,i) = CONJG(A(i,j))
        end do
      end do

      RETURN
      END

C***********************************************************************
      subroutine CXDOTY (N,X,Y,C)
C***********************************************************************
C
C     Take the complex conjugate dot product of vector x and y
C
C***********************************************************************
      integer    N
      complex    X(N), Y(N), C

      C = CMPLX(0.0,0.0)
      do I = 1, N
        C = C + CONJG(X(I))*Y(I)
      end do

      RETURN
      END

C***********************************************************************
C               S O L V E   O R R   S O M M E R F E L D
C***********************************************************************
      subroutine SOLVE(eigenvalue,eigenvector,print,oldeig,dwda)
C***********************************************************************
C
C     This routine generates the discrete eigenvalue problem in
C     Chebyshev space for the Orr-Sommerfeld equation.
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=256)
      integer     n
      real        eta(0:idim), th(0:idim), lmap
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim)
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     dA2(0:idim,0:idim), dA1(0:idim,0:idim)
      complex     dA0(0:idim,0:idim), dB0(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type
      character*20 filename

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,type,filename
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0, dA2, dA1,
     .                     dA0, dB0
c***********************************************************************
      complex     A(0:idim,0:idim), B(0:idim,0:idim)
      complex     dA(0:idim,0:idim), dB(0:idim,0:idim)
      complex     T1(0:idim,0:idim), T2(0:idim,0:idim)
      complex     T3(0:idim,0:idim), T4(0:idim,0:idim)

      complex     eval(0:idim), evec(0:idim,0:idim), tvec(0:idim)
      complex     aeval(0:idim), aevec(0:idim,0:idim), tavec(0:idim)

      complex     eigenvalue, eigenvector(0:idim)
      complex     dwda, dw, dalp, y(0:idim), prod

      real        temp1(0:idim), temp2(0:idim), residual, CHECKEIG
      real        temp3(0:idim), temp4(0:idim), dalpha, diff(0:idim)
      complex     oldeig

      integer     lda, ldb, ldevec, p, i, j, which, k, l, m
      integer     index(0:idim), index2(0:idim)
      logical     first, print
      external    CHECKEIG
C***********************************************************************
      lda = idim+1
      ldb = idim+1
      ldevec = idim+1

      do i = 1, n-1
        do j = 1, n-1
          A(i-1,j-1) = A4(i,j)+A3(i,j)+A2(i,j)+A1(i,j)+A0(i,j)
          B(i-1,j-1) = B2(i,j)+B1(i,j)+B0(i,j)
          dA(i-1,j-1) = dA2(i,j)+dA1(i,j)+dA0(i,j)
          dB(i-1,j-1) = dB0(i,j)
        end do
      end do
c
c     Now enforce the v = 0 @ +_ 1 boundary condition instead of the
c     Orr-Sommerfeld equation at n = 0 and n = N.  The Neumann
c     boundary condition is implicitly enforced.
c
c      do j = 0, n
c        B(0,j) = CMPLX(0.0, 0.0)
c        B(n,j) = CMPLX(0.0, 0.0)
c        A(0,j) = CMPLX(0.0, 0.0)
c        A(n,j) = CMPLX(0.0, 0.0)
c      end do
c      A(0,0) = CMPLX(1.0, 0.0)
c      A(n,n) = CMPLX(1.0, 0.0)
c
c     But the top and bottom rows are trivial so that they can be
c     removed
c
#ifdef USE_IMSL
      CALL LINCG (N-1, B, LDA, T1, LDA)
      CALL MCRCR (N-1, N-1, T1, LDA, N-1, N-1, A, LDA,
     .            N-1, N-1, T4, LDA)
      CALL EVCCG (N-1, T4, LDA, eval, evec, ldevec)
C
C     Solve adjoint problem too
C
      CALL MCRCR (N-1, N-1, A, LDA, N-1, N-1, T1, LDA,
     .            N-1, N-1, T3, LDA)
      call HTRAN (N-1, T3, T2, LDA)
      call EVCCG (N-1, T2, LDA, aeval, aevec, ldevec)
#else
      write(*,*) "Need to implement LAPACK/BLAS"
#endif
      do i = 0, N-2
        temp1(i) = REAL(eval(i))
        temp2(i) = AIMAG(eval(i))
      end do

c     Need to issolate the most unstable eigenvalue and eigenvector
c     Must watch out, this routine isn't very robust.

      do i = 0,N-2
        index(i) = i
      end do
      call PIKSR2(n-1,temp2,index)
      do i = 0, n-2
        temp1(i) = REAL(eval(index(i)))
      end do

      eigenvalue = cmplx(temp1(n-2),temp2(n-2))

      iloc = n-2

c      first = .true.
c      if ( real(oldeig) .le. -999.) then
c        eigenvalue = cmplx(temp1(n-2),temp2(n-2))
c        iloc = n-2
c      else
c        do j = 0, n-2
c          diff(j) = abs(real(temp1(j)) - real(oldeig))
c          index2(j) = j
c        end do
c        call PIKSR2(n-1,diff,index2)
c        eigenvalue = cmplx(temp1(index2(1)),temp2(index2(1)))
c        iloc = index2(1)
c      end if

      eigenvector(0) = cmplx(0.0,0.0)
      eigenvector(n) = cmplx(0.0,0.0)

      do j = 1, n-1
        eigenvector(j) = evec(j-1,index(iloc))
        tvec(j-1)  = evec(j-1,index(iloc))
        tavec(j-1) = aevec(j-1,index(iloc))
      end do

c     write (*,120) real(eigenvalue),aimag(eigenvalue),
c    .              real(oldeig), aimag(oldeig)
c120  format (1x,'Eigs = ',4(e15.8,2x))

      residual = CHECKEIG (N-1,T4,lda,eigenvalue,tvec)
      if (residual .gt. .01) then
        write (*,*) 'WARNING eigenvalue not converged!'
      end if

c     Compute dw/da

       do i = 0, n-2
         do j = 0, n-2
           T1(i,j) = dB(i,j)*eigenvalue-dA(i,j)
         end do
       end do
#ifdef USE_IMSL
       call MUCRV  (N-1, N-1, T1, LDA, N-1, tvec, 1, N-1, temp1)
       call CXDOTY (N-1, tavec, temp1, dw)
       call MUCRV  (N-1, N-1, B, LDA, N-1, tvec, 1, N-1, temp1)
       call CXDOTY (N-1, tavec, temp1, dalp)
#else
       write(*,*) "Need to implement LAPACK/BLAS"
#endif
       dwda = -dw/dalp
       dalpha = -AIMAG(eigenvalue)/AIMAG(dwda)
       nalpha = alpha + dalpha
       nw = REAL(eigenvalue) + dalpha*REAL(dwda)
c      write (*,105) real(dwda), aimag(dwda), dalpha
  105  format (/,1x,'dw/da = ',e15.8,',  ',e15.8,' i   dalpha = ',
     .          e15.8)

      if (print) then
        write (*,100) residual
  100   format (/,1x,'Residual = ',e17.10)
c       write (*,105) real(dwda), aimag(dwda), dalpha
c 105   format (/,1x,'dw/da = ',e15.8,',  ',e15.8,' i   dalpha = ',
c    .          e15.8)
c       write (*,115) nalpha, nw
c 115   format (/,1x,'nalpha = ',e15.8,',   nw = ',e15.8)
        write (*,31) Re, real(alpha), aimag(alpha)
        write (*,32)
        do i = n-2,0,-1
          write (*,37) REAL(eval(index(i))/alpha),
     .                 AIMAG(eval(index(i))/alpha),index(i)
c          write (20,37) REAL(eval(index(i))),AIMAG(eval(index(i))),
c     .                  REAL(aeval(index(i))),AIMAG(aeval(index(i))),
c     .                  index(i)
        end do
        write (*,40)
        read (*,*) which
        do while (which .ne. -1)
          temp1(0) = 0.0
          temp2(0) = 0.0
          temp1(n) = 0.0
          temp2(n) = 0.0
          temp3(0) = 0.0
          temp4(0) = 0.0
          temp3(n) = 0.0
          temp4(n) = 0.0
          do j = 1, n-1
            temp1(j) =  REAL( evec(j-1,which))
            temp2(j) = AIMAG( evec(j-1,which))
            temp3(j) =  REAL(aevec(j-1,which))
            temp4(j) = AIMAG(aevec(j-1,which))
          end do
c         do j = 0, n
c           write (*,38) eta(j),temp1(j),temp2(j),temp3(j),temp4(j)
c         end do
c
c         Write out normal solution
c
          write (*,*)
          call WRITEOUT (alpha,eval(which)/alpha,Re,n,temp1,temp2,
     .                   256,Lmap,ymin)
c
c         Write out Adjoint solution
c
c         write (*,*)
c         call CHEBYINT (n, temp3, temp4, 128)

          write (*,40)
          read (*,*) which
        end do
      end if

 31   format(/,1x,3(e17.10,4x))
 32   format(/,1x,'       c_r                c_i              count',/)
 35   format(1x,2(e17.10,4x),i5)
 36   format(1x,2(e17.10,4x))
 37   format(1x,2(e17.10,2x),i5)
 38   format(1x,5(e15.8,1x))
 40   format(/,1x,'Eigenvector for which eigenvalue (-1 quits) ==> ',$)
 55   format(/,1x,'Performance Index = ',g12.5,/)

      return
      end

C***********************************************************************
      SUBROUTINE WRITEOUT(ALPHA,C,RE,NMODE,EIGR,EIGI,NBIG,LMAP,YMIN)
C***********************************************************************
C
C     INTERPOLATE EIGENFUNCTIONS TO A FINER MESH AND OUTPUT
C
c***********************************************************************
      INTEGER   NBIG, NMODE
      REAL      EIGR(0:NMODE), EIGI(0:NMODE), LMAP, XI, YMIN
      REAL      TR, TI, X(0:NBIG), Y(0:NBIG), PI
      REAL      D1(0:NBIG,0:NBIG),TIME,U(0:NBIG,0:NBIG),V(0:NBIG,0:NBIG)
      REAL      PSIR(0:NBIG,0:NBIG), PSII(0:NBIG,0:NBIG)
      COMPLEX   T(0:NBIG), DT(0:NBIG), ALPHA, C

      PI = ACOS(-1.0)

      call CHEBYSHEV (EIGR,NMODE,1)
      call CHEBYSHEV (EIGI,NMODE,1)

      OPEN (UNIT=20,FILE='eigfun.dat',FORM='FORMATTED',STATUS='UNKNOWN')
      DO J = 0, NBIG
        Y(J) = J*PI/NBIG
        X(J) = J*2.*PI/NBIG
        TR = 0.0
        TI = 0.0
        DO M = 0, NMODE
          TR = TR + EIGR(M)*COS(FLOAT(M)*Y(J))
          TI = TI + EIGI(M)*COS(FLOAT(M)*Y(J))
        END DO
        T(J) = CMPLX(TR,TI)
        XI = COS(Y(J))*LMAP/2.+LMAP/2.+YMIN
        WRITE (20,10) XI, TR, TI
      END DO
      CLOSE (20)
C
C     NEED TO COMPUTE U AND V
C
      call CHEBYD (D1, NBIG, NBIG)
      DO I = 0, NBIG
        DT(I) = 0.0
        DO K = 0, NBIG
            DT(I) = DT(I) + D1(I,K)*T(K)
        END DO
        DT(I) = DT(I)*2./LMAP
      END DO

      OPEN (UNIT=21,FILE='eigvel.dat',FORM='FORMATTED',STATUS='UNKNOWN')
      TIME = 0.0
      DO I = 0, NBIG
        DO J = 0, NBIG
          U(I,J) = REAL(DT(J)*CEXP((0.,1.)*ALPHA*(X(I)-C*TIME)))
          V(I,J) = REAL((0.,-1.)*ALPHA*T(J)*
     .                  CEXP((0.,1.)*ALPHA*(X(I)-C*TIME)))
          PSIR(I,J) = REAL(T(J)*CEXP((0.,1.)*ALPHA*(X(I)-C*TIME)))
          PSII(I,J) = AIMAG(T(J)*CEXP((0.,1.)*ALPHA*(X(I)-C*TIME)))
          IF (I.EQ.0) THEN
            XI = COS(Y(J))*LMAP/2.+LMAP/2.+YMIN
            WRITE (21,20) XI, U(I,J), V(I,J), REAL(DT(J)),
     .                    AIMAG(DT(J)), REAL(T(J)), AIMAG(T(J))
          END IF
        END DO
      END DO
      CLOSE (21)
C
C     Write a Plot3d file
C
      open (unit=10,file='g.dat',form='unformatted',status='unknown')
      write (10) NBIG, NBIG
      write (10) (( X(I), i=1,NBIG), j=1,NBIG),
     .           (( COS(Y(J))*LMAP/2.+LMAP/2.+YMIN,i=1,NBIG),j=1,NBIG)

      open (unit=11,file='q.dat',form='unformatted',status='unknown')
      write (11) NBIG, NBIG
      write (11) 0.0,0.0,RE,TIME
      write (11)  ((PSIR(i,j), i=1,NBIG), j=1,NBIG),
     .            ((   U(i,j), i=1,NBIG), j=1,NBIG),
     .            ((   V(i,j), i=1,NBIG), j=1,NBIG),
     .            ((PSII(i,j), i=1,NBIG), j=1,NBIG)

  10  format (1x,3(e16.8,4x))
  20  format (1x,7(e16.8,4x))

      RETURN
      END

C***********************************************************************
      SUBROUTINE DCHEBYSHEV(N, Y, DY)
C***********************************************************************
C
C     Calculate the Chebyshev transform of a set Y of N+1 real-valued
C     data points and compute the derivative in Chebyshev space.
C     Then inverse transform and return the derivative in DY in real
C     space.  Note that Y is returned unscathed.
C
C***********************************************************************
      INTEGER N
      REAL Y(0:N), DY(0:N)

      PARAMETER (idim=256)
      REAL WORK(0:IDIM)

      IF (N.GT.IDIM) THEN
        WRITE (*,*) 'ERROR.  N > IDIM in DCHEBYSHEV'
        STOP
      END IF
C
C     SAVE THE INPUT VECTOR
C
      DO I = 0, N
        WORK(I) = Y(I)
      END DO
C
C     COMPUTE THE CHEBYSHEV TRANSFORM
C
      CALL CHEBYSHEV(Y,N,1)
C
C     NOW USE THE RECURSIVE RELATION TO TAKE THE DERIVATIVE
C
      DY(N) = 0.0
      DY(N-1) = 2.*FLOAT(N)*Y(N)
      DO K = N-2, 0, -1
        DY(K) = DY(K+2) + 2.*(K+1.)*Y(K+1)
      END DO
      DY(0) = DY(0)/2.
C
C     INVERSE TRANSFORM TO GET BACK TO REAL SPACE
C
      CALL CHEBYSHEV(DY,N,-1)

      DO I = 0, N
        Y(I) = WORK(I)
      END DO

      RETURN
      END

C***********************************************************************
      SUBROUTINE ICHEBYSHEV(Y,YI,N)
C***********************************************************************
C
C     Calculate the Chebyshev transform of a set Y of N+1 real-valued
C     data points and integrate in Chebyshev space.  The integral is
C     returned in real space in YI and Y is unscathed.
C
C***********************************************************************
      REAL Y(0:N), YI(0:N+1)
      PARAMETER (idim=256)
      REAL WORK(0:IDIM)

      DO I = 0, N
        WORK(I) = Y(I)
      END DO
C
C     COMPUTE THE CHEBYSHEV TRANSFORM
C
      CALL CHEBYSHEV(Y,N,1)
C
C     NOW INTEGRATE
C     NOTE I AM ASSUMING THAT Y(N) IS SMALL SUCH THAT YI(N+1) = 0.0
C
      YI(N+1) = Y(N)/(2.*(N+1.))
      YI(N) = Y(N-1)/(2.*N)
      YI(1) = 1./2.*(2.*Y(0)-Y(2))
      YI(0) = YI(1)
      DO K = 2, N-1
        YI(K) = 1./(2.*K)*(Y(K-1)-Y(K+1))
        YI(0) = YI(0) + (-1.)**(K-1)*YI(K)
      END DO

      CALL CHEBYSHEV(YI,N,-1)
      DO I = 0, N
        Y(I) = WORK(I)
      END DO

      RETURN
      END

C***********************************************************************
      SUBROUTINE CHEBYINT(nmode,U,V,NBIG)
C***********************************************************************
C
C     Interpolate two functions to a finer mesh
C
c***********************************************************************
      INTEGER   NBIG, nmode
      REAL      U(0:Nmode), V(0:Nmode)
      REAL      IU, IV, X, PI

      PI = ACOS(-1.0)

      call CHEBYSHEV (U,nmode,1)
      call CHEBYSHEV (V,nmode,1)

      do i = 0, NBIG
        X = I*PI/NBIG
        IU = 0.0
        IV = 0.0
        DO M = 0, Nmode
          IU = IU + U(M)*COS(FLOAT(M)*X)
          IV = IV + V(M)*COS(FLOAT(M)*X)
        END DO
        write (*,10) cos(x),Iu,Iv
      end do
  10  format (1x,3(e16.8,4x))

      RETURN
      END

C***********************************************************************
      SUBROUTINE COSFT3 (Y,N,ISIGN)
C***********************************************************************
C
C     Do a brute force transform.  ISIGN = 1 does a forward transform.
C     ISIGN = -1 a backward transform.  This is a hybrid double/single
C     precision routine.
C
C***********************************************************************
      integer     N, ISIGN
      real        Y(0:N), T(0:N)
      real*16     YY(0:N), TT(0:N), PI

      PI = DACOS(-1.0D0)

      DO I = 0, N
        TT(I) = DBLE(Y(I))
      END DO

      if (isign .eq. 1) then
        DO I = 0, N
          YY(I) = TT(0)/2.D0 + TT(N)*DCOS(DFLOAT(I)*PI)/2.D0
          DO M = 1, N-1
            YY(I) = YY(I) + TT(M)*DCOS(DFLOAT(M)*DFLOAT(I)*PI/DFLOAT(N))
          END DO
          YY(I) = YY(I)*2./DFLOAT(N)
        end do
        YY(0) = YY(0)/2.D0
        YY(N) = YY(N)/2.D0
      else
        DO I = 0, N
          YY(I) = 0.0
          DO M = 0, N
            YY(I) = YY(I) + TT(M)*DCOS(DFLOAT(M)*DFLOAT(I)*PI/DFLOAT(N))
          END DO
        END DO
      end if
C
C     GO BACK TO SINGLE PRECISION
C
      DO I = 0, N
        if (Y(i).le.1e-14) then
          Y(I) = 0.0
        end if
        Y(I) = SNGL(YY(I))
      END DO

      RETURN
      END

C***********************************************************************
      subroutine CHEBYSHEV (Y, N, ISIGN)
C***********************************************************************
C
C     Take the Chebyshev transform and normalize
C
C***********************************************************************
      integer  n, isign
      real     y(0:n), t(0:256)

      if (isign .ne. 1) then
        if (isign .ne. -1) then
          write (*,*) 'ERROR:  Invalid Isign in CHEBYSHEV'
          stop
        end if
      end if

      do i = 1, n
        t(i) = y(i)
      end do

      call COSFT3 (y,n,isign)

c     call COSFT (y,n,isign)

c     if (isign .eq. 1) then
c       do i = 0,n
c         y(i) = y(i)/float(n)*2.
c       end do
c     end if

      return
      end

C***********************************************************************
      subroutine CONVOLVE (NDIM, A, B, LDB, ES, LDE, C)
C***********************************************************************
C
C     Form the Chebyshev convolution of real vector A with real matrix B
C     and put the result in real matrix E.
c
c     A  double
c     B  double
c     ES single
C
C***********************************************************************
      INTEGER NDIM, LDB, LDE
      REAL    ES(0:LDE,0:NDIM), C(0:NDIM)
      REAL*16 A(0:NDIM),  B(0:LDB,0:NDIM),  E(0:LDE,0:NDIM)

      call COSFT3D (A,NDIM,1)

      DO N = 0, NDIM
        DO J = 0, NDIM
          E(N,J) = 0.0D0
        END DO
        DO M = -NDIM, NDIM
          IF (ABS(N-M).LE.NDIM) THEN
            DO J = 0, NDIM
              E(N,J) = E(N,J)+ DBLE(C(ABS(N-M))) * A(ABS(N-M)) *
     .                         DBLE(C(ABS(M)))   * B(ABS(M),J)
            END DO
          END IF
        END DO
        DO J = 0, NDIM
          E(N,J) = E(N,J)/2.D0
        END DO
      END DO
      DO J = 0, NDIM
        E(0,J) = E(0,J)/2.D0
      END DO

      DO N = 0, NDIM
        DO J = 0, NDIM
          ES(N,J) = SNGL(E(N,J))
        END DO
      END DO

      RETURN
      END

C*************************************************************************
      SUBROUTINE COSFT3D (YY,N,ISIGN)
C*************************************************************************
C
C     Do a brute force transform.  ISIGN = 1 does a forward transform.
C     ISIGN = -1 a backward transform.  This one is fully double
C     precision.
C
C*************************************************************************
      integer     N, ISIGN
      real*16     YY(0:N), TT(0:N), PI

      PI = DACOS(-1.0D0)

      DO I = 0, N
        TT(I) = YY(I)
      END DO

      if (isign .eq. 1) then
        DO I = 0, N
          YY(I) = TT(0)/2.D0 + TT(N)*DCOS(DFLOAT(I)*PI)/2.D0
          DO M = 1, N-1
            YY(I) = YY(I) + TT(M)*DCOS(DFLOAT(M)*DFLOAT(I)*PI/DFLOAT(N))
          END DO
          YY(I) = YY(I)*2./DFLOAT(N)
        end do
        YY(0) = YY(0)/2.D0
        YY(N) = YY(N)/2.D0
      else
        DO I = 0, N
          YY(I) = 0.0
          DO M = 0, N
            YY(I) = YY(I) + TT(M)*DCOS(DFLOAT(M)*DFLOAT(I)*PI/DFLOAT(N))
          END DO
        END DO
      end if

      RETURN
      END

C*************************************************************************
      SUBROUTINE CHEBYD (D, LDD1, N)
C*************************************************************************
C
C     Calculation the Chebyshev collocation derivative matrix
C
C*************************************************************************
      PARAMETER (IDIM=256)
      REAL      D(0:LDD1,0:N), PI
      REAL      C(0:IDIM)

      IF (N .GT. IDIM) THEN
        WRITE (*,*) 'ERROR:  N > IDIM in CHEBYD'
        STOP
      END IF

      PI = ACOS(-1.0)

      DO I = 1, N-1
        C(I) = 1.0
      END DO
      C(0) = 2.0
      C(N) = 2.0

      DO J = 0, N
        DO K = 0, N
          IF ( J.EQ.0 .AND. K.EQ.0) THEN
            D(J,K) = (2.0*FLOAT(N)**2+1.0)/6.0
          ELSE IF ( J.EQ.N .AND. K.EQ.N) THEN
            D(J,K) = -1.0*(2.*FLOAT(N)**2+1.0)/6.0
          ELSE IF (J.EQ.K) THEN
            D(J,K) =  -1.0*COS(FLOAT(J)*PI/FLOAT(N))/
     .                (2.*(1.-(COS(FLOAT(J)*PI/FLOAT(N)))**2))
          ELSE
            D(J,K) = C(J)*(-1.0)**(J+K)/(C(K)*(COS(FLOAT(J)*PI/
     .               FLOAT(N))-COS(FLOAT(K)*PI/FLOAT(N))))
          END IF
        END DO
      END DO

      RETURN
      END

C*************************************************************************
C
C     These routines are for READ_BL only!
C
C*************************************************************************
      SUBROUTINE DCHEBYSHEVF(Y,YP,N)
C*************************************************************************
C
C     Calculate the Chebyshev transform of a set Y of N+1 real-valued data
C     points and compute the derivative in Chebyshev space.  Then inverse
C     transform and return the derivative in YP and the chebyshev
C     coefficients of the derivative in Y.
C
C************************************************************************
      DIMENSION Y(0:N), YP(0:N)
C
C     NOW USE THE RECURSIVE RELATION TO TAKE THE DERIVATIVE
C
      YP(N) = 0.0
      YP(N-1) = 2.*FLOAT(N)*Y(N)
      DO K = N-2, 0, -1
        YP(K) = YP(K+2) + 2.*(K+1.)*Y(K+1)
      END DO
      YP(0) = YP(0)/2.

c     DO K = 0, N
c       Y(K) = YP(K)
c     END DO

      RETURN
      END

C***********************************************************************
      SUBROUTINE COSFT (Y,N,ISIGN)
C***********************************************************************
C
C     Do a brute force transform.  ISIGN = 1 does a forward transform.
C     ISIGN = -1 a backward transform.  This is a hybrid double/single
C     precision routine.
C
C***********************************************************************
      integer     N, ISIGN
      real        Y(0:N), T(0:N)
      real*16     YY(0:N), TT(0:N), PI

      PI = DACOS(-1.0D0)

      DO I = 0, N
        TT(I) = DBLE(Y(I))
      END DO

      if (isign .eq. 1) then
        DO I = 0, N
          YY(I) = TT(0)/2.D0 + TT(N)*DCOS(DFLOAT(I)*PI)/2.D0
          DO M = 1, N-1
            YY(I) = YY(I) + TT(M)*DCOS(DFLOAT(M)*DFLOAT(I)*PI/DFLOAT(N))
          END DO
          YY(I) = YY(I)*2./DFLOAT(N)
        end do
        YY(0) = YY(0)/2.D0
        YY(N) = YY(N)/2.D0
      else
        DO I = 0, N
          YY(I) = 0.0
          DO M = 0, N
            YY(I) = YY(I) + TT(M)*DCOS(DFLOAT(M)*DFLOAT(I)*PI/DFLOAT(N))
          END DO
        END DO
      end if
C
C     GO BACK TO SINGLE PRECISION
C
      DO I = 0, N
        if (Y(i).le.1e-14) then
          Y(I) = 0.0
        end if
        Y(I) = SNGL(YY(I))
      END DO

      RETURN
      END

C*************************************************************************
      SUBROUTINE CHEBYINTF(N,INTERP,X,Y)
C*************************************************************************
C
C     Do a Chebyshev interpolation based on the Chebyshev coefficients Y.
C     The interpolated result is given in INTERP.
C
C*************************************************************************
      INTEGER   N
      REAL      Y(0:N)
      REAL      INTERP, X

      INTERP = 0.0
      DO M = 0, N
        INTERP = INTERP + Y(M)*COS(FLOAT(M)*X)
      END DO

      RETURN
      END

C***********************************************************************
      SUBROUTINE SPLINE (N,X,Y,FDP)
C***********************************************************************
C-----THIS SUBROUTINE COMPUTES THE SECOND DERIVATIVES NEEDED
C-----IN CUBIC SPLINE INTERPOLATION.  THE INPUT DATA ARE:
C-----N = NUMBER OF DATA POINTS
C-----X = ARRAY CONTAINING THE VALUES OF THE INDEPENDENT VARIABLE
C-----    (ASSUMED TO BE IN ASCENDING ORDER)
C-----Y = ARRAY CONTAINING THE VALUES OF THE FUNCTION AT THE
C-----    DATA POINTS GIVEN IN THE X ARRAY
C-----THE OUTPUT IS THE ARRAY FDP WHICH CONTAINS THE SECOND
C-----DERIVATIVES OF THE INTERPOLATING CUBIC SPLINE.
      DIMENSION X(N),Y(N),A(N),B(N),C(N),R(N),FDP(N)
C-----COMPUTE THE COEFFICIENTS AND THE RHS OF THE EQUATIONS.
C-----THIS ROUTINE USES THE CANTILEVER CONDITION.  THE PARAMETER
C-----ALAMDA (LAMBDA) IS SET TO 1. BUT THIS CAN BE USER-MODIFIED.
C-----A,B,C ARE THE THREE DIAGONALS OF THE TRIDIAGONAL SYSTEM;
C-----R IS THE RIGHT HAND SIDE.  THESE ARE NOW ASSEMBLED.
      ALAMDA = 1.
      NM2 = N - 2
      NM1 = N - 1
      C(1) = X(2) - X(1)
      DO 1 I=2,NM1
      C(I) = X(I+1) - X(I)
      A(I) = C(I-1)
      B(I) = 2.*(A(I) + C(I))
      R(I) = 6.*((Y(I+1) - Y(I))/C(I) - (Y(I) - Y(I-1))/C(I-1))
    1 CONTINUE
      B(2) = B(2) + ALAMDA * C(1)
      B(NM1) = B(NM1) + ALAMDA * C(NM1)
C-----AT THIS POINT WE COULD CALL A TRIDIAGONAL SOLVER SUBROUTINE
C-----BUT THE NOTATION IS CLUMSY SO WE WILL SOLVE DIRECTLY.  THE
C-----NEXT SECTION SOLVES THE SYSTEM WE HAVE JUST SET UP.
      DO 2 I=3,NM1
      T = A(I)/B(I-1)
      B(I) = B(I) - T * C(I-1)
      R(I) = R(I) - T * R(I-1)
    2 CONTINUE
      FDP(NM1) = R(NM1)/B(NM1)
      DO 3 I=2,NM2
      NMI = N - I
      FDP(NMI) = (R(NMI) - C(NMI)*FDP(NMI+1))/B(NMI)
    3 CONTINUE
      FDP(1) = ALAMDA * FDP(2)
      FDP(N) = ALAMDA * FDP(NM1)
C-----WE NOW HAVE THE DESIRED DERIVATIVES SO WE RETURN TO THE
C-----MAIN PROGRAM.
      RETURN
      END

C***********************************************************************
      SUBROUTINE SPEVAL (N,X,Y,FDP,XX,F)
C***********************************************************************
C-----THIS SUBROUTINE EVALUATES THE CUBIC SPLINE GIVEN
C-----THE DERIVATIVE COMPUTED BY SUBROUTINE SPLINE.
C-----THE INPUT PARAMETERS N,X,Y,FDP HAVE THE SAME
C-----MEANING AS IN SPLINE.
C-----XX = VALUE OF INDEPENDENT VARIABLE FOR WHICH
C-----     AN INTERPOLATED VALUE IS REQUESTED
C-----F =  THE INTERPOLATED RESULT
      DIMENSION X(N),Y(N),FDP(N)
C-----THE FIRST JOB IS TO FIND THE PROPER INTERVAL.
      NM1 = N - 1
      DO 1 I=1,NM1
      IF (XX.LE.X(I+1)) GO TO 10
    1 CONTINUE
C-----NOW EVALUATE THE CUBIC
   10 DXM = XX - X(I)
      DXP = X(I+1) - XX
      DEL = X(I+1) - X(I)
      F = FDP(I)*DXP*(DXP*DXP/DEL - DEL)/6.
     1   +FDP(I+1)*DXM*(DXM*DXM/DEL - DEL)/6.
     2   +Y(I)*DXP/DEL + Y(I+1)*DXM/DEL
      RETURN
      END


C$Procedure     ISROT ( Indicate whether a matrix is a rotation matrix )

      LOGICAL FUNCTION ISROT ( M, NTOL, DTOL )

C$ Abstract
C
C     Indicate whether a 3x3 matrix is a rotation matrix.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     ROTATION
C
C$ Keywords
C
C     ERROR
C     MATRIX
C     ROTATION
C
C$ Declarations

      DOUBLE PRECISION      M    ( 3, 3 )
      DOUBLE PRECISION      NTOL
      DOUBLE PRECISION      DTOL

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     M          I   A matrix to be tested.
C     NTOL       I   Tolerance for the norms of the columns of M.
C     DTOL       I   Tolerance for the determinant of a matrix whose
C                    columns are the unitized columns of M.
C
C     The function returns the value .TRUE. if and only if M is
C     a rotation matrix.
C
C$ Detailed_Input
C
C     M              is a 3x3 matrix to be tested.
C
C     NTOL           is the tolerance for the norms of the columns
C                    of M.
C
C     DTOL           is the tolerance for the determinant of a matrix
C                    whose columns are the unitized columns of M.
C
C$ Detailed_Output
C
C     The function returns the value .TRUE. if and only if M is found
C     to be a rotation matrix.  The criteria that M must meet are:
C
C
C        1) The norm of each column of M must satisfy the relation
C
C              1.D0 - NTOL  <   || column ||   <  1.D0 + NTOL.
C                           -                  -
C
C        2) The determinant of the matrix whose columns are the
C           unitized columns of M must satisfy
C
C              1.D0 - DTOL  <   determinant   <  1.D0 + DTOL.
C                           -                 -
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If either of NTOL or DTOL is negative, the error
C         SPICE(VALUEOUTOFRANGE) is signalled.  ISROT returns the
C         value .FALSE. in this case.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine is an error checking `filter'; its purpose is to
C     detect gross errors, such as uninitialized matrices.  Matrices
C     that do not pass the tests used by this routine hardly qualify as
C     rotation matrices.  The test criteria can be adjusted by varying
C     the parameters NTOL and DTOL.
C
C     A property of rotation matrices is that their columns form a
C     right-handed, orthonormal basis in 3-dimensional space.  The
C     converse is true:  all 3x3 matrices with this property are
C     rotation matrices.
C
C     An ordered set of three vectors V1, V2, V3 forms a right-handed,
C     orthonormal basis if and only if
C
C        1)   || V1 ||  =  || V2 ||  =  || V3 ||  =  1
C
C        2)   V3 = V1 x V2.  Since V1, V2, and V3 are unit vectors,
C             we also have
C
C             < V3, V1 x V2 > = 1.
C
C             This quantity is the determinant of the matrix whose
C             colums are V1, V2 and V3.
C
C     When finite precision numbers are used, rotation matrices will
C     usually fail to satisfy these criteria exactly.  We must use
C     criteria that indicate approximate conformance to the criteria
C     listed above.  We choose
C
C        1)   |   || Vi ||  -  1   |   <   NTOL,  i = 1, 2, 3.
C                                      -
C
C        2)   Let
C
C                       Vi
C                Ui = ------ ,   i = 1, 2, 3.
C                     ||Vi||
C
C             Then we require
C
C                | < U3, U1 x U2 > - 1 |  <  DTOL;
C                                         -
C
C             equivalently, letting U be the matrix whose columns
C             are U1, U2, and U3, we insist on
C
C                | det(U) - 1 |  <  DTOL.
C                                _
C$ Examples
C
C     1)  We have obtained an instrument pointing matrix C from a
C         C-kernel, and we wish to test whether it is in fact a
C         rotation matrix.  We can use ISROT to check this:
C
C            C
C            C    Obtain pointing matrix:
C            C
C                 CALL CKGP ( INST, TIMEIN, TOL, REF, C, TIMOUT, FOUND )
C
C            C
C            C    Verify that C is a rotation:
C            C
C                 IF ( .NOT. ISROT ( C )  ) THEN
C
C                    [ perform exception handling ]
C
C                 ELSE
C
C                    [ code for the normal case goes here ]
C
C                 END IF
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C     H.A. Neilan    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 17-MAY-1994 (HAN)
C
C       If the value of the function RETURN is TRUE upon execution of
C       this module, this function is assigned a default value of
C       either 0, 0.0D0, .FALSE., or blank depending on the type of the
C       function.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 06-SEP-1990  (NJB)
C
C-&

C$ Index_Entries
C
C     indicate whether a matrix is a rotation matrix
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      BRCKTD
      DOUBLE PRECISION      DET

      LOGICAL               RETURN

C
C     Local variables
C
      DOUBLE PRECISION      D
      DOUBLE PRECISION      N1
      DOUBLE PRECISION      N2
      DOUBLE PRECISION      N3
      DOUBLE PRECISION      UNIT ( 3, 3 )

      LOGICAL               DETOK
      LOGICAL               NORMOK

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         ISROT = .FALSE.
         RETURN
      ELSE
         CALL CHKIN ( 'ISROT' )
      END IF

C
C     Tolerances must be non-negative.
C
      IF ( NTOL .LT. 0.D0 ) THEN

         ISROT = .FALSE.

         CALL SETMSG ( 'NTOL should be non-negaitve; it is #.' )
         CALL ERRDP  ( '#',  NTOL                              )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'                )
         CALL CHKOUT ( 'ISROT'                                 )
         RETURN

      ELSE IF ( DTOL .LT. 0.D0 ) THEN

         ISROT = .FALSE.

         CALL SETMSG ( 'DTOL should be non-negaitve; it is #.' )
         CALL ERRDP  ( '#',  DTOL                              )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)' )
         CALL CHKOUT ( 'ISROT'                  )
         RETURN

      END IF

C
C     The columns of M must resemble unit vectors.  If the norms are
C     outside of the allowed range, M is not a rotation matrix.
C
C     Also, the columns of M are required to be pretty nearly
C     orthogonal.  The discrepancy is gauged by taking the determinant
C     of the matrix UNIT, computed below, whose columns are the
C     unitized columns of M.
C
      CALL UNORM (  M(1,1),  UNIT(1,1),  N1  )
      CALL UNORM (  M(1,2),  UNIT(1,2),  N2  )
      CALL UNORM (  M(1,3),  UNIT(1,3),  N3  )

      D      =  DET ( UNIT )

      NORMOK =       ( N1 .EQ. BRCKTD ( N1, 1.D0 - NTOL, 1.D0 + NTOL ) )
     .         .AND. ( N2 .EQ. BRCKTD ( N2, 1.D0 - NTOL, 1.D0 + NTOL ) )
     .         .AND. ( N3 .EQ. BRCKTD ( N3, 1.D0 - NTOL, 1.D0 + NTOL ) )

      DETOK  =         D  .EQ. BRCKTD ( D,  1.D0 - DTOL, 1.D0 + DTOL )

      IF ( NORMOK .AND. DETOK ) THEN
         ISROT = .TRUE.
      ELSE
         ISROT = .FALSE.
      END IF

      CALL CHKOUT ( 'ISROT' )
      RETURN
      END


      SUBROUTINE LUDCMP(A,N,NP,INDX,D)
C
C CHANGE RECORD
C
      INTEGER::I,J,K,IMAX,INDX
      REAL::TINY,D,AAMAX,A,SUM,DUM
      PARAMETER (TINY=1.0E-20)
      DIMENSION A(NP,NP),INDX(N)
      REAL,ALLOCATABLE,DIMENSION(:)::VV
      ALLOCATE(VV(N))
C
      D=1.
      DO 12 I=1,N
        AAMAX=0.
        DO 11 J=1,N
          IF(ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
   11   CONTINUE
        IF(AAMAX.EQ.0.) PAUSE 'SINGULAR MATRIX.'
        VV(I)=1./AAMAX
   12 CONTINUE
      DO 19 J=1,N
        IF(J.GT.1)THEN
          DO 14 I=1,J-1
            SUM=A(I,J)
            IF(I.GT.1)THEN
              DO 13 K=1,I-1
                SUM=SUM-A(I,K)*A(K,J)
   13         CONTINUE
              A(I,J)=SUM
            ENDIF
   14     CONTINUE
        ENDIF
        AAMAX=0.
        DO 16 I=J,N
          SUM=A(I,J)
          IF(J.GT.1)THEN
            DO 15 K=1,J-1
              SUM=SUM-A(I,K)*A(K,J)
   15       CONTINUE
            A(I,J)=SUM
          ENDIF
          DUM=VV(I)*ABS(SUM)
          IF(DUM.GE.AAMAX)THEN
            IMAX=I
            AAMAX=DUM
          ENDIF
   16   CONTINUE
        IF(J.NE.IMAX)THEN
          DO 17 K=1,N
            DUM=A(IMAX,K)
            A(IMAX,K)=A(J,K)
            A(J,K)=DUM
   17     CONTINUE
          D=-D
          VV(IMAX)=VV(J)
        ENDIF
        INDX(J)=IMAX
        IF(J.NE.N)THEN
          IF(A(J,J).EQ.0.)A(J,J)=TINY
          DUM=1./A(J,J)
          DO 18 I=J+1,N
            A(I,J)=A(I,J)*DUM
   18     CONTINUE
        ENDIF
   19 CONTINUE
      IF(A(N,N).EQ.0.)A(N,N)=TINY
      DEALLOCATE(VV)
      RETURN
      END


subroutine setupmodel
! Definir el modelo a partir de input.txt
use gloVars
use modelVars
use sourceVars
use fitting
use resultVars
implicit none
! variables auxiliares:
logical :: lexist
character(21) :: time,auxtx
CHARACTER(len=400) :: path
real :: H, ALF, BET, RO
integer :: J,i
real*8 :: BEALF,frac,minBeta,k1_3,kmax
integer :: thelayeris,ths_layer
logical :: tellisoninterface, ths_isoninterface
real    :: xfsource,zfsource,l
real*8  :: nxfsource,nzfsource, PW_theta
real :: Escala
real :: mastimere,Ts,Tp,T0
integer :: ampfunction
real :: sigGaus
integer :: PW_pol
integer :: tipofuente,nnsabanas,thisnsab,iIndex,nIpts,nSabanapts
real :: xini,deltax,zini,deltaz,dx,dz
real*8 :: escalax,escalay,offsetx,offsety

CALL getcwd(path)
write(PrintNum,'(a,/,a)') 'At:',TRIM(path)
call date_and_time(TIME=time); write(PrintNum,'(a,a)') "hhmmss.sss = ",time
      inquire(file="input.txt",exist=lexist)
      if (lexist) then
        OPEN(35,FILE="input.txt",FORM="FORMATTED")
      else
        write(PrintNum,'(a)') 'There is a missing input file. '
        stop 'Check "input.txt" on Working directory'
      end if
READ(35,*) !########## del modelo #################################################################
READ(35,*) DFREC
READ(35,*) NFREC
READ(35,*) NPTSTIME
         NPTSTIME = int(log10(real(NPTSTIME)) / log10(2.)+0.99 ) ! porqueFFT
         NPTSTIME = 2** NPTSTIME     !adjuste to a 2**N value
         if (NPTSTIME .lt. 2*NFREC) then
           NPTSTIME=2*NFREC
           print*,"WARNING, modified NPTSTIME to" , NPTSTIME
         end if
         Dt = (1.0) / (real(NPTSTIME) * DFREC)
READ(35,*) Qq
READ(35,'(L1)') useAzimi
READ(35,*) NK
READ(35,*) cKbeta
READ(35,*) TW
READ(35,*) periodicdamper
READ(35,*) !########### del medio estratificado ###################################################
READ(35,'(I2)')N   !NUMBER OF LAYERS
      ALLOCATE (Z(0:N+1)); Z(1)=real(0,8)
      ALLOCATE (RHO(0:N+2));     ALLOCATE(ANU(0:N+2))
      ALLOCATE (BETA0  (0:N+2)); ALLOCATE (ALFA0(0:N+2))
      ALLOCATE (BETA   (0:N+2)); ALLOCATE (ALFA (0:N+2))
      ALLOCATE (LAMBDA0(0:N+2)); ALLOCATE (AMU0 (0:N+2))
      ALLOCATE (LAMBDA (0:N+2)); ALLOCATE (AMU  (0:N+2))
write(PrintNum,'(a,I0)')'Number of layers= ',N
write(PrintNum,'(a)')'    zini     zfin      alpha    beta    mu       rho      lambda      nu '
READ(35,*) ! H(m)    Alfa(m/s) Beta(m/s) Dens(T/m3)
DO J=1,N
         READ(35,*) H, ALF, BET, RO
         Z(J+1)=Z(J)+real(H)
         AMU0(J)=RO*BET**2.0
         BETA0(J)=BET
         ALFA0(J)=ALF
         RHO(J) = RO
         LAMBDA0(J)=RHO(J)*ALF**2.0 - real(2.)*real(AMU0(J))
!        BEALF=SQRT((0.5-ANU)/(1.0-ANU)) !IF POISSON RATIO IS GIVEN
         BEALF = beta0(J)/alfa0(J)
         anu(J) = (bealf**2 - 0.5)/(-1 + bealf**2)
!        ALFA(J)=BET/BEALF
          write(PrintNum,&
          '(F7.1,A,F7.1,2x, F7.1,2x, F7.1,2x, E8.2,2x, E8.2,2x, E8.2,2x, E8.2)') &
          Z(J),' - ',Z(J+1),ALFA0(J),BETA0(J),real(AMU0(J)),&
          RHO(J), real(LAMBDA0(J)),real(anu(J))
      END DO
      READ(35,*) H, ALF, BET, RO
      AMU0(N+1)=RO*BET**2
      BETA0(N+1)=BET
      ALFA0(N+1)=ALF
      RHO(N+1) = RO
      LAMBDA0(N+1)=RHO(n+1)*ALF**2 - real(2.)*real(AMU0(n+1))
      BEALF = beta0(N+1)/alfa0(N+1)
      anu(N+1) = (bealf**2 - 0.5)/(-1 + bealf**2)
         write(PrintNum,&
         '(F7.1,A,           F7.1,2x, F7.1,2x, E8.2,2x, E8.2,2x, E8.2,2x, E8.2)') &
         Z(1),' -     inf. ',ALFA0(N+1),BETA0(N+1),real(AMU0(N+1)),&
         RHO(N+1), real(LAMBDA0(N+1)),real(anu(N+1))

!#< r ----  dk para ver estar CKbeta veces por arriba de polo Rayleigh------- !#>
      frac = 1./3.
      minBeta = minval(beta0(1:N+1));
      kmax = 0.9* (2*pi*DFREC*NFREC) / minBeta * cKbeta !1.5
      DK = kmax / nk
      k1_3 = (2*pi*DFREC*NFREC * frac) / minBeta * cKbeta

      allocate(vecNk(NFREC+1))
      ! cantidad de numeros de onda {donde se invierte la matriz} en cada frecuencia
      ! el resto hasta nmax+1(o hasta SpliK) se interpola
      vecNk = (/(i,i=1, NFREC+1)/)
      call splineIn(vecNk, & ! vector x [int]
                    vecNk, & ! vector interpolado [int]
                    int(nfrec * frac),& ! n puntos [x0 ... x1-1]
                    NFREC+1-int(nfrec * frac), & ! [x1 ...  x2 ]
                    1,                  int(0.55*nK), &  !x0,y0
                    int(nfrec * frac)+1,int(0.6*nk), &  !x1,y1
                    NFREC+1,            nk) !x2,y2
      NMAX = vecNK(NFREC)
      NMAX = int(log10(real(NMAX)) / log10(2.)+0.99 )
      NMAX = 2**NMAX     !adjuste to a 2**N value

      ! complex frecuency to "smooth" the poles and be able to integrate
        ! Bouchon (2003) OMEI entre -pi/T y -2pi/T ; T= 2pi/DFREC tiempo total
        ! tengo TW la ventana de tiempo de inter�s.
      OMEI = - periodicdamper*PI/TW ! se cumple que exp(omei TW) << 1

       write(PrintNum,'(/,a)') &
       "--- frecuency --------------------------------------------------------------------"
       write(PrintNum,'(a,F9.7,/,a,F15.5)') "   dt = (1.0) / (real(NPTSTIME) * DFREC) = ",Dt,"   Tmax=",Dt* NPTSTIME
       write(PrintNum,'(a,F8.1)') '   Atenuation Q = ',Qq
       write(PrintNum,'(a,I0,a,F8.4,a,F12.4,a,/)') &
           '   N. frequencies: ',NFREC,'  @',DFREC,'Hertz :. Fmax = ', &
           NFREC*DFREC,'Hertz'

       write(PrintNum,'(a)') &
       "--- DWN -------------------------------------------------------------------------"
       write(PrintNum,'(a,F15.7)') "   kmax = 0.9* (2*pi*DFREC*NFREC) / minBeta * cKbeta = ",kmax
       write(PrintNum,'(a,F9.7)') "   DK = kmax / nk = ",DK
       write(PrintNum,'(a,I0,a,I0,a,I0,a,I0,a,I0,a,I0,a)') "   nk a 3pt spline with (",&
          1,",",int(0.55*nK),"), (",&
          int(nfrec * frac)+1,",",int(0.6*nk),"), (",&
          NFREC+1,",",nk,")"
       write(PrintNum,'(a,I0)') '   nk average = ',int(sum(vecNK)/(NFREC+1))
       write(PrintNum,'(a,I0)') '   nmax (each sign): ',NMAX
       write(PrintNum,'(a,F12.7)') "   delta X = ", real(pi / (NMAX * DK),4)
       write(PrintNum,'(a)') "   Periodicidad de la fuente (metodo dwn):"
       write(PrintNum,'(a,EN14.2E2,a)') "   L = 2*pi/DK = ",2*pi/DK, " m"
       write(PrintNum,'(a,EN19.5E2,a)') &
       "   L/maxalfa = ",(2*pi/DK)/maxval(abs(ALFA0(1:N+1))), " seconds"
       write(PrintNum,'(a,EN19.5E2,a)') &
       "   L/maxbeta = ",(2*pi/DK)/maxval(abs(BETA0(1:N+1))), " seconds"
       write(PrintNum,'(a,EN19.5E2,a)') &
       "   L/minalfa = ",(2*pi/DK)/minval(abs(ALFA0(1:N+1))), " seconds"
       write(PrintNum,'(a,EN19.5E2,a)') &
       "   L/minbeta = ",(2*pi/DK)/minval(abs(BETA0(1:N+1))), " seconds"
       write(PrintNum,'(a,E10.2,a)') '   Frec. Imaginary part: - periodicdamper*PI/TW = ',OMEI,' rad/s'
       write(PrintNum,'(/,a)') &
       "--- SOURCE ----------------------------------------------------------------------"
READ(35,*) !########### de la incidencia ##########################################################
      READ(35,'(I1)') i
      SH = .false.; PSV = .true.; skipdir=.true.
       if (i .eq. 2) then ! SH
            SH = .true.; PSV = .false.
            skipdir(1) = .true.
            skipdir(2) = .false.
            skipdir(3) = .true.
       end if

      READ(35,'(I1)') nFuentes
      READ(35,*) !  X    Z  | nx   nz  |  th    l    Esca  Afn  T0   Tmax   Ts    Tp    Gsg   PWp  Knd
      allocate(Po(nFuentes))
do i=1,nFuentes
       READ(35,*) xfsource, zfsource, &
                  nxfsource, nzfsource, &
                  PW_theta, l,&
                  Escala, ampfunction,&
                  t0,mastimere, Ts, Tp, sigGaus,&
                  PW_pol
       Po(i)%center%x = xfsource
       Po(i)%center%z = zfsource
       Po(i)%normal%x = nxfsource
       Po(i)%normal%z = nzfsource
       Po(i)%cosT = cos((360-PW_theta)*pi/180.0)
       Po(i)%sinT = sin((360-PW_theta)*pi/180.0)
       Po(i)%gamma = PW_theta*pi/180.0 !clockwise desde el eje z (hacia abajo)

       Po(i)%Escala=Escala
       Po(i)%ampfunction=ampfunction
       Po(i)%maxtime = mastimere
       Po(i)%Ts=Ts
       Po(i)%Tp=Tp
       Po(i)%t0=T0;
       Po(i)%sigGaus=sigGaus
       Po(i)%PW_pol=PW_pol
     if (PSV .eqv. .true.) then
       if (PW_pol .eq. 0)then
          !fuerza puntual P_SV,
          if (abs(nxfsource) > 0.01) skipdir(1) = .false.
          if (abs(nzfsource) > 0.01) skipdir(3) = .false.
          if (abs(nxfsource)+abs(nzfsource) < 0.01) then
          stop "normales nulas"
          end if
          tipoFuente = 0
       elseif (PW_pol .eq. 1) then
          !SV
          skipdir(1) = .false.
          tipoFuente = 1
       elseif (PW_pol .eq. 2) then
          !P
          skipdir(1) = .false.
          tipoFuente = 1
       else
          stop "PW_pol incorrecto"
       end if
     else !SH
       if (PW_pol .eq. 3) then
          !SH
          tipoFuente = 1
        elseif (PW_pol .eq. 0) then
          !fuerza puntual SH
          tipoFuente = 0
        else
           stop "PW_pol incorrecto"
        end if
     end if
       Po(i)%tipoFuente=tipoFuente
       if (tipoFuente .eq. 1) then ! onda plana
            ! se coloca en la interfaz con el semiespacio
            Po(i)%center%z = Z(N+1)
            ths_layer = N+1
            ths_isoninterface = .true.
       else ! fuente puntual
           ths_layer = thelayeris(real(zfsource,8))
           ths_isoninterface = tellisoninterface(real(zfsource,8))
       end if
       Po(i)%layer = ths_layer
       Po(i)%isOnInterface = ths_isoninterface
       if (tipoFuente .eq. 1) then ! onda plana
        write(auxtx,'(a)') " plane wave"
      else
        write(auxtx,'(a)') " point force"
      end if
      write(PrintNum,'(a,F8.2,a,F8.2,a,2x,a,F9.2,a,F9.2,a,I0,a,L1,a)') &
      "   (",Po(i)%center%x,",",Po(i)%center%z,")", &
      "n=[",Po(i)%normal%x,",",Po(i)%normal%z,&
      "] e=",Po(i)%layer," intf=",Po(i)%isOnInterface,auxtx
end do
       print*,"   skipdir=",skipdir
       print*,"   PSV= ",PSV
       print*,"   SH=  ",SH

      write(PrintNum,'(/,a)') &
       "--- RECEIVERS -------------------------------------------------------------------"
      READ(35,*) !########### de los receptores #########################################################
      READ(35,*) nIpts
      READ(35,*) nnsabanas, nSabanapts
      READ(35,*) !_____________________SINGLE RECEIVERS__________________________
      READ(35,*) escalax,escalay
      READ(35,*) offsetx,offsety
      READ(35,*) ! X        Z          nx       nz   guardarFK
      allocate(allPoints(nIpts + nSabanapts))
      nPts = nIpts + nSabanapts
      do i=1, nIpts
         READ(35,*) allPoints(i)%center%x, allPoints(i)%center%z, allPoints(i)%guardarFK
           allPoints(i)%center%x = allPoints(i)%center%x * escalax + offsetx
           allPoints(i)%center%z = allPoints(i)%center%z * escalay + offsety
      !encontrar el layer en el que estan o 0 si est� sobre la interfaz
           allPoints(i)%layer = thelayeris(real(allPoints(i)%center%z,8))
           allPoints(i)%isOnInterface = &
                         tellisoninterface(real(allPoints(i)%center%z,8))
      end do
      iIndex = nIpts
      READ(35,*) !___________________RECEIVER LINES_____________________________
      if (nSabanapts .gt. 0) then
      read(35,*) escalax,escalay
      READ(35,*) offsetx,offsety
      read(35,*) !npuntos xini   deltax   zini   delta z  guardarFK
      do j=1,nnsabanas
      read(35,*) thisnsab,xini,deltax,zini,deltaz
      dx = 0.0
      dz = 0.0
      do i=1,thisnsab
        iIndex = iIndex + 1
        allPoints(iIndex)%isSabana = .true.
        allPoints(iIndex)%center%x = (xini + dx)*escalax + offsetx
        allPoints(iIndex)%center%z = (zini + dz)*escalay + offsety
        ths_layer = thelayeris(allPoints(iIndex)%center%z)
        ths_isoninterface = tellisoninterface(allPoints(iIndex)%center%z)
        allPoints(iIndex)%layer = ths_layer
        allPoints(iIndex)%isOnInterface = ths_isoninterface
        dx = dx + deltax
        dz = dz + deltaz
        allPoints(iIndex)%guardarFK = .false.
      end do ! i
      end do ! j
      else
      READ(35,*) !escala
      READ(35,*) !offsetof
      READ(35,*) !encabezado
      end if
      CLOSE(35)
      do i=1,nPts
      write(PrintNum,'(I0,2x,a,f7.2,a,f7.2,a,a,i0,a,l)'),&
        i,"[",allpoints(i)%center%x,",",allpoints(i)%center%z,"]",&
        " l",allpoints(i)%layer,&
        " OnIntfce=",allpoints(i)%isOnInterface
      end do
end subroutine setupmodel

      function thelayeris(zi)
      use modelVars, only : Z,N
      implicit none
      integer :: i,e,thelayeris
      real*8 :: zi
      i = 1
      if (Z(0) .lt. 0.0) i = 0
      do e=i,N
         if(real(zi) .lt. Z(e+1)) then
            exit
         end if
      end do
      thelayeris = e
      end function thelayeris

      function tellisoninterface(zi)
      use modelVars, only : Z,N
      implicit none
      real*8 ::  errT = 0.0001 !0.01_8
      integer :: e
      real*8 :: zi
      logical :: tellisoninterface
      tellisoninterface = .false.
      do e=1,N+1
        if((Z(e)-errT .lt. real(zi)) &
             .and. (real(zi) .lt. Z(e)+errT)) then
           tellisoninterface = .true.
        end if
      end do
      end function tellisoninterface


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_unifact_2x2diagblock
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes a two by two diagonal block of a unitary upper
! hessenberg matrix that is stored as a product of givens rotations
! and a complex diagonal matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  TOP             LOGICAL
!                    .TRUE.: top block is computed
!                    .FALSE.: bottom block is computed
!
!  Q               REAL(8) array of dimension (6)
!                    array of generators for givens rotations
!                    generators must be orthogonal to working precision
!
!  D               REAL(8) array of dimension (4)
!                    array of generators for complex diagonal matrix
!                    on output contains the eigenvalues
!
! OUTPUT VARIABLES:
!
!  H              COMPLEX(8) array of dimension (2,2)
!                   on exit contains the desired 2x2 block
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_unifact_2x2diagblock(TOP,Q,D,H)

  implicit none

  ! input variables
  logical, intent(in) :: TOP
  real(8), intent(in) :: Q(6), D(4)
  complex(8), intent(inout) :: H(2,2)

  ! TOP == .TRUE.
  if (TOP) then

    ! initialize H
    H(1,1) = cmplx(Q(1),Q(2),kind=8)
    H(2,1) = cmplx(Q(3),0d0,kind=8)
    H(1,2) = -H(2,1)
    H(2,2) = conjg(H(1,1))

    ! second rotation
    H(:,2) = H(:,2)*cmplx(Q(4),Q(5),kind=8)

  ! TOP == .FALSE.
  else

    ! initialize H
    H(1,1) = cmplx(Q(4),Q(5),kind=8)
    H(2,1) = cmplx(Q(6),0d0,kind=8)
    H(1,2) = -H(2,1)
    H(2,2) = conjg(H(1,1))

    ! second rotation
    H(1,:) = H(1,:)*cmplx(Q(1),-Q(2),kind=8)

  end if

  ! diagaonal
  H(:,1) = H(:,1)*cmplx(D(1),D(2),kind=8)
  H(:,2) = H(:,2)*cmplx(D(3),D(4),kind=8)

end subroutine z_unifact_2x2diagblock


*     TB04AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          MAXMP
      PARAMETER        ( MAXMP = MAX( MMAX, PMAX ) )
      INTEGER          LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, LDUCO2,
     $                 NMAXP1
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = MAXMP,
     $                   LDD = MAXMP, LDDCOE = MAXMP, LDUCO1 = MAXMP,
     $                   LDUCO2 = MAXMP, NMAXP1 = NMAX+1 )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX + MAXMP )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX*( NMAX + 1 ) +
     $                            MAX( NMAX*MAXMP + 2*NMAX +
     $                                 MAX( NMAX, MAXMP ), 3*MAXMP ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL1, TOL2
      INTEGER          I, II, IJ, INDBLK, INFO, J, JJ, KDCOEF, M, N,
     $                 NR, P, PORM, PORP
      CHARACTER*1      ROWCOL
      CHARACTER*132    ULINE
      LOGICAL          LROWCO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX),
     $                 D(LDD,MAXMP), DCOEFF(LDDCOE,NMAXP1),
     $                 DWORK(LDWORK), UCOEFF(LDUCO1,LDUCO2,NMAXP1)
      INTEGER          INDEX(MAXMP), IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TB04AD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL1, TOL2, ROWCOL
      LROWCO = LSAME( ROWCOL, 'R' )
      ULINE(1:20) = ' '
      DO 20 I = 21, 132
         ULINE(I:I) = '-'
   20 CONTINUE
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99986 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99985 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99984 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Find the transfer matrix T(s) of (A,B,C,D).
               CALL TB04AD( ROWCOL, N, M, P, A, LDA, B, LDB, C, LDC, D,
     $                      LDD, NR, INDEX, DCOEFF, LDDCOE, UCOEFF,
     $                      LDUCO1, LDUCO2, TOL1, TOL2, IWORK, DWORK,
     $                      LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NR
                  DO 40 I = 1, NR
                     WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,NR )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99995 )
                  DO 60 I = 1, NR
                     WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99994 )
                  DO 80 I = 1, P
                     WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,NR )
   80             CONTINUE
                  INDBLK = 0
                  DO 100 I = 1, N
                     IF ( IWORK(I).NE.0 ) INDBLK = INDBLK + 1
  100             CONTINUE
                  IF ( LROWCO ) THEN
                     PORM = P
                     PORP = M
                     WRITE ( NOUT, FMT = 99993 ) INDBLK,
     $                          ( IWORK(I), I = 1,INDBLK )
                  ELSE
                     PORM = M
                     PORP = P
                     WRITE ( NOUT, FMT = 99992 ) INDBLK,
     $                          ( IWORK(I), I = 1,INDBLK )
                  END IF
                  WRITE ( NOUT, FMT = 99991 ) ( INDEX(I), I = 1,PORM )
                  WRITE ( NOUT, FMT = 99990 )
                  KDCOEF = 0
                  DO 120 I = 1, PORM
                     KDCOEF = MAX( KDCOEF, INDEX(I) )
  120             CONTINUE
                  KDCOEF = KDCOEF + 1
                  DO 160 II = 1, PORM
                     DO 140 JJ = 1, PORP
                        WRITE ( NOUT, FMT = 99989 ) II, JJ,
     $                    ( UCOEFF(II,JJ,IJ), IJ = 1,KDCOEF )
                        WRITE ( NOUT, FMT = 99988 ) ULINE(1:7*KDCOEF+21)
                        WRITE ( NOUT, FMT = 99987 )
     $                        ( DCOEFF(II,IJ), IJ = 1,KDCOEF )
  140                CONTINUE
  160             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB04AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB04AD = ',I2)
99997 FORMAT (' The order of the transformed state-space representatio',
     $       'n = ',I2,//' The transformed state dynamics matrix A is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The transformed input/state matrix B is ')
99994 FORMAT (/' The transformed state/output matrix C is ')
99993 FORMAT (/' The controllability index of the transformed state-sp',
     $       'ace representation = ',I2,//' The dimensions of the diag',
     $       'onal blocks of the transformed A are ',/20(I5))
99992 FORMAT (/' The observability index of the transformed state-spac',
     $       'e representation = ',I2,//' The dimensions of the diagon',
     $       'al blocks of the transformed A are ',/20(I5))
99991 FORMAT (/' The degrees of the denominator polynomials are',/20(I5)
     $       )
99990 FORMAT (/' The coefficients of polynomials in the transfer matri',
     $       'x T(s) are ')
99989 FORMAT (/' element (',I2,',',I2,') is ',20(1X,F6.2))
99988 FORMAT (1X,A)
99987 FORMAT (20X,20(1X,F6.2))
99986 FORMAT (/' N is out of range.',/' N = ',I5)
99985 FORMAT (/' M is out of range.',/' M = ',I5)
99984 FORMAT (/' P is out of range.',/' P = ',I5)
      END


*DECK DLPDP
      SUBROUTINE DLPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS,
     +   IS)
C***BEGIN PROLOGUE  DLPDP
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DLSEI
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (LPDP-S, DLPDP-D)
C***AUTHOR  Hanson, R. J., (SNLA)
C           Haskell, K. H., (SNLA)
C***DESCRIPTION
C
C  **** Double Precision version of LPDP ****
C     DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1),
C     where N=N1+N2.  This is a slight overestimate for WS(*).
C
C     Determine an N1-vector W, and
C               an N2-vector Z
C     which minimizes the Euclidean length of W
C     subject to G*W+H*Z .GE. Y.
C     This is the least projected distance problem, LPDP.
C     The matrices G and H are of respective
C     dimensions M by N1 and M by N2.
C
C     Called by subprogram DLSI( ).
C
C     The matrix
C                (G H Y)
C
C     occupies rows 1,...,M and cols 1,...,N1+N2+1 of A(*,*).
C
C     The solution (W) is returned in X(*).
C                  (Z)
C
C     The value of MODE indicates the status of
C     the computation after returning to the user.
C
C          MODE=1  The solution was successfully obtained.
C
C          MODE=2  The inequalities are inconsistent.
C
C***SEE ALSO  DLSEI
C***ROUTINES CALLED  DCOPY, DDOT, DNRM2, DSCAL, DWNNLS
C***REVISION HISTORY  (YYMMDD)
C   790701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated the AUTHOR section.  (WRB)
C***END PROLOGUE  DLPDP
C
      INTEGER I, IS(*), IW, IX, J, L, M, MDA, MODE, MODEW, N, N1, N2,
     *     NP1
      DOUBLE PRECISION A(MDA,*), DDOT, DNRM2, FAC, ONE,
     *     PRGOPT(*), RNORM, SC, WNORM, WS(*), X(*), YNORM, ZERO
      SAVE ZERO, ONE, FAC
      DATA ZERO,ONE /0.0D0,1.0D0/, FAC /0.1D0/
C***FIRST EXECUTABLE STATEMENT  DLPDP
      N = N1 + N2
      MODE = 1
      IF (M .GT. 0) GO TO 20
         IF (N .LE. 0) GO TO 10
            X(1) = ZERO
            CALL DCOPY(N,X,0,X,1)
   10    CONTINUE
         WNORM = ZERO
      GO TO 200
   20 CONTINUE
C        BEGIN BLOCK PERMITTING ...EXITS TO 190
            NP1 = N + 1
C
C           SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE.
            DO 40 I = 1, M
               SC = DNRM2(N,A(I,1),MDA)
               IF (SC .EQ. ZERO) GO TO 30
                  SC = ONE/SC
                  CALL DSCAL(NP1,SC,A(I,1),MDA)
   30          CONTINUE
   40       CONTINUE
C
C           SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO).
            YNORM = DNRM2(M,A(1,NP1),1)
            IF (YNORM .EQ. ZERO) GO TO 50
               SC = ONE/YNORM
               CALL DSCAL(M,SC,A(1,NP1),1)
   50       CONTINUE
C
C           SCALE COLS OF MATRIX H.
            J = N1 + 1
   60       IF (J .GT. N) GO TO 70
               SC = DNRM2(M,A(1,J),1)
               IF (SC .NE. ZERO) SC = ONE/SC
               CALL DSCAL(M,SC,A(1,J),1)
               X(J) = SC
               J = J + 1
            GO TO 60
   70       CONTINUE
            IF (N1 .LE. 0) GO TO 130
C
C              COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*).
               IW = 0
               DO 80 I = 1, M
C
C                 MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY.
                  CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1)
                  IW = IW + N2
C
C                 MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY.
                  CALL DCOPY(N1,A(I,1),MDA,WS(IW+1),1)
                  IW = IW + N1
C
C                 MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY.
                  WS(IW+1) = A(I,NP1)
                  IW = IW + 1
   80          CONTINUE
               WS(IW+1) = ZERO
               CALL DCOPY(N,WS(IW+1),0,WS(IW+1),1)
               IW = IW + N
               WS(IW+1) = ONE
               IW = IW + 1
C
C              SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U.GE.0.  THE
C              MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR
C              F = TRANSPOSE OF (0,...,0,1).
               IX = IW + 1
               IW = IW + M
C
C              DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF
C              DWNNLS( ).
               IS(1) = 0
               IS(2) = 0
               CALL DWNNLS(WS,NP1,N2,NP1-N2,M,0,PRGOPT,WS(IX),RNORM,
     *                     MODEW,IS,WS(IW+1))
C
C              COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W.
               SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1)
               IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO)
     *            GO TO 110
                  SC = ONE/SC
                  DO 90 J = 1, N1
                     X(J) = SC*DDOT(M,A(1,J),1,WS(IX),1)
   90             CONTINUE
C
C                 COMPUTE THE VECTOR Q=Y-GW.  OVERWRITE Y WITH THIS
C                 VECTOR.
                  DO 100 I = 1, M
                     A(I,NP1) = A(I,NP1) - DDOT(N1,A(I,1),MDA,X,1)
  100             CONTINUE
               GO TO 120
  110          CONTINUE
                  MODE = 2
C        .........EXIT
                  GO TO 190
  120          CONTINUE
  130       CONTINUE
            IF (N2 .LE. 0) GO TO 180
C
C              COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*).
               IW = 0
               DO 140 I = 1, M
                  CALL DCOPY(N2,A(I,N1+1),MDA,WS(IW+1),1)
                  IW = IW + N2
                  WS(IW+1) = A(I,NP1)
                  IW = IW + 1
  140          CONTINUE
               WS(IW+1) = ZERO
               CALL DCOPY(N2,WS(IW+1),0,WS(IW+1),1)
               IW = IW + N2
               WS(IW+1) = ONE
               IW = IW + 1
               IX = IW + 1
               IW = IW + M
C
C              SOLVE RV=S SUBJECT TO V.GE.0.  THE MATRIX R =(TRANSPOSE
C              OF (H Q)), WHERE Q=Y-GW.  THE (N2+1)-VECTOR S =(TRANSPOSE
C              OF (0,...,0,1)).
C
C              DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF
C              DWNNLS( ).
               IS(1) = 0
               IS(2) = 0
               CALL DWNNLS(WS,N2+1,0,N2+1,M,0,PRGOPT,WS(IX),RNORM,MODEW,
     *                     IS,WS(IW+1))
C
C              COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z.
               SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1)
               IF (ONE + FAC*ABS(SC) .EQ. ONE .OR. RNORM .LE. ZERO)
     *            GO TO 160
                  SC = ONE/SC
                  DO 150 J = 1, N2
                     L = N1 + J
                     X(L) = SC*DDOT(M,A(1,L),1,WS(IX),1)*X(L)
  150             CONTINUE
               GO TO 170
  160          CONTINUE
                  MODE = 2
C        .........EXIT
                  GO TO 190
  170          CONTINUE
  180       CONTINUE
C
C           ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION.
            CALL DSCAL(N,YNORM,X,1)
            WNORM = DNRM2(N1,X,1)
  190    CONTINUE
  200 CONTINUE
      RETURN
      END


!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130
Subroutine RT_calculation(ubk,ubkGS)
  use Constants
  use Global_variables, only : sys_name, NG, NB, NK, dvcell,&
       NT, dt, &
       Myrank, MPI_COMM_WORLD,ierr, MPI_WTIME
  use Functions
!  use Functions_MPI
  implicit none
  complex(8),intent(inout) :: ubk(NG,NB,NK)
  complex(8),intent(in) :: ubkGS(NG,NB,NK)
  character(256) :: RTinfo
  real(8) :: dns(NG)
  real(8) :: time(1:NT), Etot(1:NT), Nele(1:NT), Jtot(1:NT), E(1:NT), E2(1:NT), A(1:NT), Aave(1:NT)
  real(8) :: Etotm1, Nelem1, Am1, Jtotm1
  integer :: it, NTpulse
  real(8) :: tRTs, tRTe

  tRTs = MPI_WTIME()
  If (Myrank == 0) Write(*,'("########Real-time propagation is started.########")')
  If (Myrank == 0) then
    RTinfo = trim(sys_name)//'_EtotNJEAt.out'
    Open(10,file=trim(RTinfo),action='write')
    Write(10,'("#time(it), Etot(it)-Etot0, N(it)-N0, J(it), E(it), A(it)")')
  End If

  call Define_Afield(time,A,Aave,E,E2)

  Am1 = 0.d0
  dns(:) = ubk_dns(ubk)
!  dns(:,:,:) = ubk_dns_MPI(ubk)
  Nelem1 = sum(dns)*dvcell
  Etotm1 = ubk_Etot(ubk,Am1)
  Jtotm1 = ubk_Je(ubk,Am1)
!  Etot0 = ubk_Etot_MPI(ubk,A0)
!  Jtot0 = ubk_Je_MPI(ubk,A0)
  If (Myrank == 0) Write(*,'("#time(it), Etot(it)-Etot0, N(it)-N0, J(it), E(it), A(it)")')
  Do it = 1, NT
!    Call RT_TE_ubk(ubk,Aave(it))
!    Call RT_TEPC_ubk(ubk,Aave(it))
!    Call RT_TEPC2_ubk(ubk,Aave(it))
    Call RT_RK4_ubk(ubk,Aave(it),A(it))
    dns(:) = ubk_dns(ubk)
!    dns(:,:,:) = ubk_dns_MPI(ubk)
    Nele(it) = sum(dns)*dvcell
    Etot(it) = ubk_Etot(ubk,A(it))
    Jtot(it) = ubk_Je(ubk,A(it))
!    Etot(it) = ubk_Etot_MPI(ubk,A(1:3,it))
!    Jtot(:,it) = ubk_Je_MPI(ubk,A(1:3,it))
    If (Myrank == 0) then
      tRTe = MPI_WTIME()
      Write(10,'(20e20.12)') time(it), Etot(it), Etot(it)-Etotm1, Nele(it), Nele(it)-Nelem1, &
           Jtot(it), E(it), A(it)
      If (mod(it,100) == 0) Write(*,'(i6,20e14.6)') it, time(it), Etot(it), Etot(it)-Etotm1, &
           Nele(it), Nele(it)-Nelem1, Jtot(it), E(it), A(it)
      If (mod(it,1000) == 0) &
           Write(*,'("## calc-time for ",i4," iterations :",e12.4," [sec] =",f12.8," [hour]##")') &
           it,tRTe-tRTs, (tRTe-tRTs)/3600.d0
    End If
  End Do
  If (Myrank == 0) Write(*,'("########Real-time propagation is finished.########")')
  If (Myrank == 0) close(10)

  If (Myrank == 0) Call FourierTr(time,Jtot,Jtotm1,E,A)
  If (Myrank == 0) Call WindowFourierTr(time,Jtot,Jtotm1,E,A)
!  Ecomps = ubk_Ecomps(ubk,A0)

  return
End Subroutine RT_calculation
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130
!Real-time evolution with Taylor-expansion (TE)
Subroutine RT_TE_ubk(ubk,Aave)
  use Constants
  use Global_variables, only : NG, NB, NK, dt
  use Functions
!  use Functions_MPI
  implicit none
  complex(8),intent(inout) :: ubk(NG,NB,NK)
  real(8),intent(in) :: Aave
  integer :: iter, iorder, Norder = 4
  complex(8) :: workbk(NG,NB,NK),ubk0(NG,NB,NK)

  ubk0 = ubk
  workbk = ubk
  Do iorder = 1,Norder
    workbk = -(zI*dt)*ubkwbk_hwbk(ubk0,workbk,Aave)/dble(iorder)
!    workbk = -(zI*dt)*ubkwbk_hwbk_MPI(ubk,workbk,Aave)/dble(iorder)
    ubk = ubk + workbk
  End Do

  return
End Subroutine RT_TE_ubk
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130
!Real-time evolution with Taylor-expansion (TE) withint predictor-corrector (PC)
Subroutine RT_TEPC_ubk(ubk,Aave)
  use Constants
  use Global_variables, only : NG, NB, NK, dt
  use Functions
!  use Functions_MPI
  implicit none
  complex(8),intent(inout) :: ubk(NG,NB,NK)
  real(8),intent(in) :: Aave
  integer :: iter, iorder, Norder = 4
  complex(8) :: workbk(NG,NB,NK),ubk0(NG,NB,NK),ubk1(NG,NB,NK)

  ubk0 = ubk
  ubk1 = ubk
  workbk = ubk
  Do iorder = 1,Norder
    workbk = -(zI*dt)*ubkwbk_hwbk(ubk0,workbk,Aave)/dble(iorder)
    ubk1 = ubk1 + workbk
  End Do

  workbk = ubk
  Do iorder = 1,Norder
    workbk = -(zI*dt*0.5d0)*(ubkwbk_hwbk(ubk0,workbk,Aave)+ubkwbk_hwbk(ubk1,workbk,Aave))/dble(iorder)
    ubk = ubk + workbk
  End Do

  return
End Subroutine RT_TEPC_ubk
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130
!Real-time evolution with Taylor-expansion (TE) withint predictor-corrector (PC)
Subroutine RT_TEPC2_ubk(ubk,Aave)
  use Constants
  use Global_variables, only : NG, NB, NK, dt
  use Functions
!  use Functions_MPI
  implicit none
  complex(8),intent(inout) :: ubk(NG,NB,NK)
  real(8),intent(in) :: Aave
  integer :: iter, iorder, Norder = 4
  complex(8) :: workbk(NG,NB,NK),ubk0(NG,NB,NK),ubk1(NG,NB,NK)

  ubk0 = ubk
  ubk1 = ubk
  workbk = ubk
  Do iorder = 1,Norder
    workbk = -(zI*dt)*ubkwbk_hwbk(ubk0,workbk,Aave)/dble(iorder)
    ubk1 = ubk1 + workbk
  End Do

  workbk = ubk
  ubk0 = 0.5d0*(ubk0+ubk1)
  Do iorder = 1,Norder
    workbk = -(zI*dt)*ubkwbk_hwbk(ubk0,workbk,Aave)/dble(iorder)
    ubk = ubk + workbk
  End Do

  return
End Subroutine RT_TEPC2_ubk
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130
!Real-time evolution with Taylor-expansion (TE)
Subroutine RT_RK4_ubk(ubk,Aave,A)
  use Constants
  use Global_variables, only : NG, NB, NK, dt
  use Functions
!  use Functions_MPI
  implicit none
  complex(8),intent(inout) :: ubk(NG,NB,NK)
  real(8),intent(in) :: Aave, A
  real(8) :: Am
  complex(8) :: k1(NG,NB,NK),k2(NG,NB,NK),k3(NG,NB,NK),k4(NG,NB,NK)

  Am = 2.0d0*Aave - A
  k1 = -zI*ubkwbk_hwbk(ubk,ubk,Am)
  k2 = -zI*ubkwbk_hwbk(ubk+(0.5*dt)*k1,ubk+(0.5*dt)*k1,Aave)
  k3 = -zI*ubkwbk_hwbk(ubk+(0.5*dt)*k2,ubk+(0.5*dt)*k2,Aave)
  k4 = -zI*ubkwbk_hwbk(ubk+dt*k3,ubk+dt*k3,A)
  ubk = ubk + (k1+2.0d0*k2+2.0d0*k3+k4)*dt/6.d0

  return
End Subroutine RT_RK4_ubk
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130
Subroutine Define_Afield(time,A,Aave,E,E2)
  use Constants
  use Global_variables, only : NT, dt, omegac, Tpulse, E0, dAc, field_option, phiCEP, nenvelope, &
       Myrank
  implicit none
  real(8), intent(out) :: time(1:NT), A(1:NT), Aave(1:NT), E(1:NT), E2(1:NT)
  integer :: it, ixyz, NTpulse
  real(8) ::  Am1, Aamp

!Time and field construction
!time(1) = 0.d0; time-origin but not "initial condition", initial condition is the GS
  Do it = 1,NT
    time(it) = dt*(it-1)
  End Do
  Am1 = 0.d0
  A(:) = 0.d0
  If (Myrank == 0) then
    Write(*,'(" Time and field infromatio+++++++++++++++++++")')
    Write(*,'(" Time-step: ",f12.4," [a.u.] =",f12.4," [fs]")') dt, dt*Atomtime
    Write(*,'(" The corresponding energy: ",f12.4," [a.u.] =",f12.4," [eV]")') &
         tpi/dt, tpi/dt*Hartree
    Write(*,'(" Total time: ",f12.4," [a.u.] =",f12.4," [fs]")') dble(NT)*dt, dble(NT)*dt*Atomtime
    Write(*,'(" The corresponding energy: ",f12.4," [a.u.] =",f12.4," [meV]")') &
         tpi/(dble(NT)*dt), tpi/(dble(NT)*dt)*Hartree*1000.d0
  End If

  If (field_option == 'LR') then
    If (Myrank == 0) Write(*,*) 'This calculation is the linear-response  with impulsive kick, whose amplitude', dAc, '[a.u.]'
    A(:) = dAc
!    write(*,*) 'The initial current is approximated as',J0-N0*Ac(:,1)/vcell
!    write(*,*) 'The initial energy is approximated as',Etot0+ 0.5*N0*(Ac(1,1)**2+Ac(2,1)**2+Ac(3,1)**3)

  Else if (field_option == 'LP') then
!Unit conversion
    omegac = omegac/Hartree
    Tpulse = Tpulse/Atomtime
    E0 = E0/Atomfield
    If (Myrank == 0) Write(*,*) 'This calculation is under a laser pulse.'
    Aamp = E0/omegac
    If (Myrank == 0) Write(*,*) 'Amplitude of the A-field:',Aamp, '[a.u.]'
    NTpulse = int(min(Tpulse/dt,dble(NT)))
! A(t) = Aamp*sin(omegac*(t-T/2)+phi)*sin(pi*t/T)**nenvelope
    Do it = 1,NTpulse
      A(it) = Aamp*sin(omegac*(time(it)-0.5*Tpulse)+2.0*pi*phiCEP)*(sin(pi*time(it)/Tpulse))**nenvelope
    End do

  Else
    stop ('# Error stop: substituted field_option  is not acceptable.')
  End if

!Construct an averaging A-field: Aave(it) = (A(it)+A(it-1))/2
!Convert E-field from A-field: E = - d(Ac)/dt
  Aave(1) = 0.5d0*(A(1)+Am1)
  Do it = 2,NT
    Aave(it) = 0.5d0*(A(it)+A(it-1))
  End do
  E(1) = -(A(1)-Am1)/dt  !It may be replaced more accurate derivative formula
  Do it = 2,NT
    E(it) = -(A(it)-A(it-1))/dt  !It may be replaced more accurate derivative formula
  End do
  Do it = 1,NT
    E2(it) = E(it)**2
  End do
  If (Myrank == 0) then
    Write(*,*) 'Fluence of the field:', sum(E2)*dt*Atomfluence,' J/cm^2'
    Write(*,'("++++++++++++++++++++++++++++++++++++++++++++")')
  End If

  return
End Subroutine Define_Afield
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130
Subroutine FourierTr(time,Jtot,Jtotm1,E,A)
  use Constants
  use Global_variables, only : sys_name, NT,dt, omegaM,Nomega, dAc, field_option
  implicit none
  real(8), intent(in) :: time(1:NT), Jtot(1:NT), Jtotm1, E(1:NT), A(1:NT)
  character(256) :: FTinfo, LRinfo
  integer :: it,iomega
  real(8) ::  filter(1:NT), omega(1:Nomega), Jtemp(1:NT)
  complex(8) :: JF(1:Nomega), EF(1:Nomega), AF(1:Nomega), eiwt(1:NT)
  complex(8) :: sigma(1:Nomega), eps(1:Nomega)

!Filter construction
  filter(:) = 1.0d0-3.0d0*(time(:)/time(NT))**2+2.0d0*(time(:)/time(NT))**3

!Frequency construction
  Do iomega = 1,Nomega
    omega(iomega) = dble(iomega)/dble(Nomega)*omegaM
  End Do

  Write(*,*) 'Jtotm1 =', Jtotm1
  Jtemp(:) = filter(:)*(Jtot(:) - Jtotm1)

  Do iomega = 1,Nomega
!     eiwt(:) = exp(+zI*omega(iomega)*(time(:)+0.5d0*dt))
     eiwt(:) = exp(+zI*omega(iomega)*time(:))
     JF(iomega) = sum(eiwt(:)*Jtemp(:))*dt
     EF(iomega) = sum(eiwt(:)*filter(:)*E(:))*dt
     AF(iomega) = sum(eiwt(:)*filter(:)*A(:))*dt
  End Do

  FTinfo = trim(sys_name)//'_JEAF.out'
  Open(10,file=trim(FTinfo),action='write')
  Write(10,'("#omega(iomega), JF(iomega), EF(iomega), AF(iomega)")')
  Do iomega = 1, Nomega
    Write(10,'(20e20.12)') omega(iomega), &
         real(JF(iomega)),aimag(JF(iomega)), &
         real(EF(iomega)),aimag(EF(iomega)), &
         real(AF(iomega)),aimag(AF(iomega))
  End Do
  Close(10)

  If (field_option == 'LR') then
    sigma(:) = -JF(:)/dAc
    eps(:) = fpi*zI*sigma(:)/omega(:)

    LRinfo = trim(sys_name)//'_sigmaeps.out'
    Open(10,file=trim(LRinfo),action='write')
    Write(10,'("#omega(iomega), sigma(iomega), eps(iomega)")')
    Do iomega = 1, Nomega
      Write(10,'(20e20.12)') omega(iomega), &
           real(sigma(iomega)),aimag(sigma(iomega)), &
           real(eps(iomega)),aimag(eps(iomega))
    End Do
  Close(10)
  End If

  return
End Subroutine FourierTr
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130
Subroutine WindowFourierTr(time,Jtot,Jtotm1,E,A)
  use Constants
  use Global_variables, only : sys_name, NT,dt, omegaM,Nomega, field_option, Tpulse, nenvelope
  implicit none
  real(8), intent(in) :: time(1:NT), Jtot(1:NT), Jtotm1, E(1:NT), A(1:NT)
  character(256) :: FTinfo, LRinfo
  integer :: it,iomega, NTpulse
  real(8) ::  filter(1:NT), omega(1:Nomega), Jtemp(1:NT)
  complex(8) :: JF(1:Nomega), EF(1:Nomega), AF(1:Nomega), eiwt(1:NT)

  If (field_option == 'LR') return

!Filter construction
  NTpulse = int(min(Tpulse/dt,dble(NT)))
  filter(:) = 0.0d0
  Do it = 1,NTpulse
    filter(it) = (sin(pi*time(it)/Tpulse))**nenvelope
  End do

!Frequency construction
  Do iomega = 1,Nomega
    omega(iomega) = dble(iomega)/dble(Nomega)*omegaM
  End Do

  Jtemp(:) = filter(:)*(Jtot(:) - Jtotm1)

  Do iomega = 1,Nomega
!     eiwt(:) = exp(+zI*omega(iomega)*(time(:)+0.5d0*dt))
     eiwt(:) = exp(+zI*omega(iomega)*time(:))
     JF(iomega) = sum(eiwt(:)*Jtemp(:))*dt
     EF(iomega) = sum(eiwt(:)*filter(:)*E(:))*dt
     AF(iomega) = sum(eiwt(:)*filter(:)*A(:))*dt
  End Do

  FTinfo = trim(sys_name)//'_JEAF_window.out'
  Open(10,file=trim(FTinfo),action='write')
  Write(10,'("#omega(iomega), JF(iomega), EF(iomega), AF(iomega)")')
  Do iomega = 1, Nomega
    Write(10,'(20e20.12)') omega(iomega), &
         real(JF(iomega)),aimag(JF(iomega)), &
         real(EF(iomega)),aimag(EF(iomega)), &
         real(AF(iomega)),aimag(AF(iomega))
  End Do
  Close(10)

  return
End Subroutine WindowFourierTr