      subroutine profil(iopt,tx,nx,ty,ny,c,kx,ky,u,nu,cu,ier)
c  if iopt=0 subroutine profil calculates the b-spline coefficients of
c  the univariate spline f(y) = s(u,y) with s(x,y) a bivariate spline of
c  degrees kx and ky, given in the b-spline representation.
c  if iopt = 1 it calculates the b-spline coefficients of the univariate
c  spline g(x) = s(x,u)
c
c  calling sequence:
c     call profil(iopt,tx,nx,ty,ny,c,kx,ky,u,nu,cu,ier)
c
c  input parameters:
c   iopt  : integer flag, specifying whether the profile f(y) (iopt=0)
c           or the profile g(x) (iopt=1) must be determined.
c   tx    : real array, length nx, which contains the position of the
c           knots in the x-direction.
c   nx    : integer, giving the total number of knots in the x-direction
c   ty    : real array, length ny, which contains the position of the
c           knots in the y-direction.
c   ny    : integer, giving the total number of knots in the y-direction
c   c     : real array, length (nx-kx-1)*(ny-ky-1), which contains the
c           b-spline coefficients.
c   kx,ky : integer values, giving the degrees of the spline.
c   u     : real value, specifying the requested profile.
c           tx(kx+1)<=u<=tx(nx-kx), if iopt=0.
c           ty(ky+1)<=u<=ty(ny-ky), if iopt=1.
c   nu    : on entry nu must specify the dimension of the array cu.
c           nu >= ny if iopt=0, nu >= nx if iopt=1.
c
c  output parameters:
c   cu    : real array of dimension (nu).
c           on succesful exit this array contains the b-spline
c   ier   : integer error flag
c    ier=0 : normal return
c    ier=10: invalid input data (see restrictions)
c
c  restrictions:
c   if iopt=0 : tx(kx+1) <= u <= tx(nx-kx), nu >=ny.
c   if iopt=1 : ty(ky+1) <= u <= ty(ny-ky), nu >=nx.
c
c  other subroutines required:
c    fpbspl
c
c  author :
c    p.dierckx
c    dept. computer science, k.u.leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  latest update : march 1987
c
c  ..scalar arguments..
      integer iopt,nx,ny,kx,ky,nu,ier
      real*8 u
c  ..array arguments..
      real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),cu(nu)
c  ..local scalars..
      integer i,j,kx1,ky1,l,l1,m,m0,nkx1,nky1
      real*8 sum
c  ..local array
      real*8 h(6)
c  ..
c  before starting computations a data check is made. if the input data
c  are invalid control is immediately repassed to the calling program.
      kx1 = kx+1
      ky1 = ky+1
      nkx1 = nx-kx1
      nky1 = ny-ky1
      ier = 10
      if(iopt.ne.0) go to 200
      if(nu.lt.ny) go to 300
      if(u.lt.tx(kx1) .or. u.gt.tx(nkx1+1)) go to 300
c  the b-splinecoefficients of f(y) = s(u,y).
      ier = 0
      l = kx1
      l1 = l+1
 110  if(u.lt.tx(l1) .or. l.eq.nkx1) go to 120
      l = l1
      l1 = l+1
      go to 110
 120  call fpbspl(tx,nx,kx,u,l,h)
      m0 = (l-kx1)*nky1+1
      do 140 i=1,nky1
        m = m0
        sum = 0.
        do 130 j=1,kx1
          sum = sum+h(j)*c(m)
          m = m+nky1
 130    continue
        cu(i) = sum
        m0 = m0+1
 140  continue
      go to 300
 200  if(nu.lt.nx) go to 300
      if(u.lt.ty(ky1) .or. u.gt.ty(nky1+1)) go to 300
c  the b-splinecoefficients of g(x) = s(x,u).
      ier = 0
      l = ky1
      l1 = l+1
 210  if(u.lt.ty(l1) .or. l.eq.nky1) go to 220
      l = l1
      l1 = l+1
      go to 210
 220  call fpbspl(ty,ny,ky,u,l,h)
      m0 = l-ky
      do 240 i=1,nkx1
        m = m0
        sum = 0.
        do 230 j=1,ky1
          sum = sum+h(j)*c(m)
          m = m+1
 230    continue
        cu(i) = sum
        m0 = m0+nky1
 240  continue
 300  return
      end


      module func_atlas
      implicit none

      contains

      double precision function expi (n, x)
      implicit none
!
!.... EXPONENTIAL INTEGRAL FOR POSITIVE ARGUMENTS AFTER CODY AND
!... THACHER, MATH. OF COMP.,22,641(1968)
!
!--------------------------- DUMMY ARGUMENTS ---------------------------
!
      double precision  x
      integer  n
!
!--------------------------- LOCAL VARIABLES --------------------------

      real(kind=8)  a0, a1, a2, a3, a4, a5
      real(kind=8)  b0, b1, b2, b3, b4
      real(kind=8)  c0, c1, c2, c3, c4, c5, c6
      real(kind=8)  d1, d2, d3, d4, d5, d6
      real(kind=8)  e0, e1, e2, e3, e4, e5, e6, ex, ex1
      real(kind=8)  f1, f2, f3, f4, f5, f6
      real(kind=8)  x1

      integer  i
      save     ex1, x1
!
!--------------------------- INITIALIZATION ---------------------------
!
       x1 = -1.0d20
!
!      data a0, a1, a2, a3, a4, a5 /

       a0 =  -44178.5471728217d0
       a1 =   57721.7247139444d0
       a2 =   9938.31388962037d0
       a3 =   1842.11088668000d0
       a4 =   101.093806161906d0
       a5 =   5.03416184097568d0
!
!      data b0, b1, b2, b3, b4 /

       b0 =   76537.3323337614d0
       b1 =   32597.1881290275d0
       b2 =   6106.10794245759d0
       b3 =   635.419418378382d0
       b4 =   37.2298352833327d0
!
!      data c0, c1, c2, c3, c4, c5, c6 /

       c0 =  4.65627107975096d-7
       c1 =  0.999979577051595d0
       c2 =  9.04161556946329d0
       c3 =  24.3784088791317d0
       c4 =  23.0192559391333d0
       c5 =   6.90522522784444d0
       c6 =   0.430967839469389d0
!
!      data d1, d2, d3, d4, d5, d6 /

       d1 =  10.0411643829054d0
       d2 =  32.4264210695138d0
       d3 =  41.2807841891424d0
       d4 =  20.4494785013794d0
       d5 =  3.31909213593302d0
       d6 =  0.103400130404874d0
!
!      data e0, e1, e2, e3, e4, e5, e6 /

       e0 =  -0.999999999998447d0
       e1 =  -26.6271060431811d0
       e2 =  -241.055827097015d0
       e3 =  -895.927957772937d0
       e4 =  -1298.85688746484d0
       e5 =  -545.374158883133d0
       e6 =  -5.66575206533869d0
!
!      data f1, f2, f3, f4, f5, f6 /

       f1 =   28.6271060422192d0
       f2 =   292.310039388533d0
       f3 =   1332.78537748257d0
       f4 =   2777.61949509163d0
       f5 =   2404.01713225909d0
       f6 =   631.657483280800d0
!*
!*------------------------------- EXECUTION -----------------------------
!*
      if (x .ne. x1) then
         x1 = x
         ex = dexp(-x1)
!*
         if (x1 .gt. 4.0d0)  then
            ex1 = (ex + ex * (e0 + (e1 + (e2 + (e3 + (e4 + (e5 + e6 /
     &              x1) / x1) / x1) / x1) / x1) / x1) /
     &       (x1 + f1 +(f2 + (f3 + (f4 + (f5 + f6 / x1) / x1) / x1)
     &               / x1) / x1)) / x1
!*
         else if (x1 .gt. 1.0d0) then
            ex1 = ex * (c6 + (c5 + (c4 + (c3 + (c2 + (c1 + c0 * x1) *
     &            x1) * x1) * x1) * x1) * x1) / (d6 + (d5 + (d4 +
     &            (d3 + (d2 + (d1 + x1) * x1) * x1) * x1) * x1) * x1)
!*
         else if (x1 .gt. 0.0d0) then
            ex1 = (a0 + (a1 + (a2 + (a3 + (a4 + a5 * x1) * x1) * x1) *
     &               x1) * x1) / (b0 + (b1 + (b2 + (b3 + (b4 + x1) *
     &               x1) * x1) * x1) * x1) -dlog(x1)
!*
         else
            ex1 = 0.0d0
         end if
!*
      end if
!*
      expi = ex1
!*
      if (n .gt. 1) then
!
         do i = 1, n - 1
            expi = (ex - x1 * expi) / dble(i)
         end do
!*
      end if
!*
      end function
!*
!*********** E N D   O F   F U N C T I O N    E X P I *******************

      integer function map1 (xold, fold, nold, xnew, fnew, nnew)
      implicit none
!*
!*--------------------------- DUMMY ARGUMENTS ---------------------------
!*
      double precision  fnew(*), fold(*), xnew(*), xold(*)
      integer  nnew, nold
!*
!*--------------------------- LOCAL VARIABLES --------------------------
!*
      double precision  ab, af, bb, bf, cb, cf, d, db, df, wt
      integer  l, ll, k, lm1, lm2, lp1
!*
!*------------------------------- EXECUTION -----------------------------
!*
      l = 2
      ll = 0

      do k = 1, nnew

         do while (l .le. nold .and. xnew(k) .ge. xold(l))
            l = l + 1
         end do

         if (l .gt. nold) l = nold

         if (l .gt. 2 .and. l .lt. nold) then

!*.... PARABOLIC CASE
!*
            if (l .ne. ll) then

               if (l .gt. 3 .and. l .eq. ll+1) then
                  ab = af
                  bb = bf
                  cb = cf

               else
!*
!*.... MUST COMPUTE THE BACKWARD COEFFICIENTS
!*
                  lm1 = l - 1
                  lm2 = l - 2
                  d = (fold(lm1) - fold(lm2)) /
     &                (xold(lm1) - xold(lm2))
                  cb = ((fold(l) - fold(lm1)) /
     &                  (xold(l) - xold(lm1)) - d) /
     &                 (xold(l) - xold(lm2))
                  bb = d + cb * (xold(lm1) - xold(lm2))
                  ab = fold(lm1)
               end if
!*
               lp1 = l + 1
               lm1 = l - 1
               d = (fold(l) - fold(lm1)) / (xold(l) - xold(lm1))
               cf = ((fold(lp1) - fold(l)) /
     &               (xold(lp1) - xold(l)) - d) /
     &              (xold(lp1) - xold(lm1))
               bf = d + cf * (xold(l) - xold(lm1))
               af = fold(l)
               wt = 0.0d0
               if (cf .ne. 0.0d0) wt = abs(cf) / (abs(cf) + abs(cb))
               ll = l
            end if
!*
            df = xnew(k) - xold(l)
            db = xnew(k) - xold(lm1)
            fnew(k) = (1.0d0 - wt) * (af + (bf + cf * df) * df) + wt *
     &                (ab + (bb + cb * db) * db)
!*
         else
!*
            if (l .ne. ll) then
               ll = l
               lm1 = l - 1
               af = fold(lm1)
               bf = (fold(l) - fold(lm1)) / (xold(l) - xold(lm1))
            end if
!*
            fnew(k) = af + bf * (xnew(k) - xold(lm1))
         end if
!*
      end do
!*
      map1 = ll - 1
      end function

      end module


      SUBROUTINE T2D( BUFIN, NSAMPS, ST, SIT, BUFOUT, MSAMPS, SD, SID,
     &  SCRBUF, AVEVEL)
!     T2D CONVERTS A TIME TRACE (BUFIN) INTO A DEPTH TRACE (BUFOUT) USING
!  AVERAGE VELOCITIES (AVEVEL). THE TIMES ARE ONE WAY TRAVEL TIMES.
!  T2D EXPECTS A VELOCITY ARRAY IN A CONSTANT TIME INCREMENT (A VELOCITY FOR
!  EVERY SAMPLE).
!     T2D APPLIES A VELOCITY TRANSFORMATION TO A TIME DOMAIN TRACE TO GET
!  A DEPTH DOMAIN TRACE.  THE OUTPUT TRACE IS AT A UNIFORM SAMPLE INTERVAL, SO
!  IT IS READY TO BE PLOTTED IN THE NORMAL MANNER.
!  ARGUMENTS:
!   BUFIN  - AN ARRAY OF DATA TO BE MOVED (TRANSFORMED).  A TIME DOMAIN TRACE.
!   NSAMPS - THE INTEGER NUMBER OF SAMPLES IN ARRAY BUFIN.  THE LENGTH OF THE
!            THE INPUT DATA.
!   ST     - THE START TIME OF BUFIN.  THE TIME IN SECONDS ASSOCIATED WITH THE
!            SAMPLE BUFIN(1).
!   SIT    - SAMPLE INTERVAL IN TIME.  THE TIME UNITS, IN SECONDS, BETWEEN
!            SUCCESSIVE SAMPLES IN BUFIN.
!   BUFOUT - AN ARRAY TO RECEIVED THE TRANSFORMED TRACE.  THE DEPTH DOMAIN TRACE
!            THE OUTPUT ARRAY.  MUST BE DIFFERENT FROM BUFIN.
!   MSAMPS - THE NUMBER OF OUTPUT SAMPLES.  T2D WILL ONLY STORE MSAMPS SAMPLES
!            IN THE OUTPUT ARRAY.
!   SD     - START DEPTH.  THE DEPTH OF THE FIRST OUTPUT SAMPLE (BUFOUT(1)).
!   SID    - SAMPLE INTERVAL IN THE DEPTH DOMAIN.  THE  DISTANCE BETWEEN
!            SUCCESSIVE OUTPUT SAMPLES.
!   SCRBUF - A SCRATCH ARRAY OF LENGTH NSAMPS.
!   AVEVEL - AN ARRAY OF AVERAGE VELOCITIES ASSOCIATED WITH EACH SAMPLE (OR TIME
!            OF BUFIN.)  AVEVEL MUST BE NSAMPS LONG - ONE VELOCITY FOR EVERY TIME
!            SAMPLE.  THESE ARE ONE WAY TRAVEL TIMES!!!!
!
!      PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, APRIL 1979
!
      DIMENSION BUFIN(1),BUFOUT(1),SCRBUF(1),AVEVEL(1)
      INTEGER LINC, LTEMP, sd
!
!    CALCULATE A DEPTH FOR EVERY TIME SAMPLE.  ROUND THE DEPTH TO THE
!    NEAREST DEPTH SAMPLE INTERVAL BY ADDING HALF THE INTERVAL BEFORE
!    TRUNCATING BY MAKING IT INTO AN INTEGER.  DIVIDING THE INTEGER DEPTH
!    BY THE INTEGER SAMPLE INTERVAL AND THEN MULTIPLYING BY THE SAMPLE
!    INTERVAL THEN ASSURES THAT THE RESULTANT DEPTH IS A MULTIPLE OF THE
!    SAMPLE INTERVAL.
!
!   mod 13 Oct 08 - do depth as real number
!
      sdepth = REAL(sd)
      LINC=SID                                                          ! MAKE THE SAMPLE INTERVAL AN INTEGER
      SID2=SID/2.
!****
!****  fill scrbuf with the depth of every output sample
!****
      DO 10 I = 1, NSAMPS
         TIME = ST+SIT*FLOAT(I-1)
!         LTEMP = TIME*AVEVEL(I)+SID2
!         LTEMP = (LTEMP/LINC)*LINC
         ltemp = NINT( TIME*AVEVEL(I) )
!         SCRBUF(I) = LTEMP
          scrbuf(i) = time * avevel(i)
   10 CONTINUE
!
!    FIND THE CLOSEST DEPTH IN THE CONVERTED DEPTH ARRAY FOR EVERY
!    OUTPUT DEPTH SAMPLE.  THE OUTPUT DEPTH ARRAY IS A UNIFORMLY SAMPLED
!    ARRAY BUT THE CONVERTED (TIME) ARRAY IS NOT.  USE WHATEVER CONVERTED
!    ARRAY POINT THAT IS CLOSEST, THUS ALLOWING THE SAME POINT TO APPEAR
!    IN THE OUTPUT ARRAY OR SKIPPING SOME.
!
      INDXT=1                                                           ! THE INDEX TO THE CONVERTED TIME ARRAY
      INDXD=0                                                           ! THE INDEX TO THE OUTPUT DEPTH ARRAY
!
  110 INDXD=INDXD+1
      IF(INDXD.GT.MSAMPS) RETURN
      DEPTH = sdepth + (INDXD-1) * SID                                  ! CALCULATE THE NEXT DEPTH VALUE
  120 CONTINUE
      IF(DEPTH.GE.SCRBUF(INDXT)) GO TO 200
      IF(DEPTH.GE.SCRBUF(INDXT-1)) GO TO 130
!**** the depth wanted is before the one we're at, so back up
      INDXT=INDXT-1
      IF(INDXT.GT.0) GO TO 120
      BUFOUT(INDXD)=0.                                                  ! THE OUTPUT IS BEFORE THE INPUT!
      INDXT=1
      GO TO 110
!****
!**** the depth is between this one and the prior one, use the prior one
  130 BUFOUT(INDXD)=BUFIN(INDXT-1)
      GO TO 110
!****
!****  if the depth is after this one, go to the next one
  200 IF(DEPTH.GT.SCRBUF(INDXT)) GO TO 300
!***
!***  the depth is the same as this one, use it!
      BUFOUT(INDXD)=BUFIN(INDXT)
      GO TO 110
!****
!****  set up to try the next sample
  300 INDXT=INDXT+1
      IF(INDXT.LE.NSAMPS) GO TO 120
      DO I=INDXD,MSAMPS
  310    BUFOUT(I)=0.
      ENDDO
      RETURN
      END


      subroutine local_global(i,xl,yl,zl,xg,yg,zg)
c s kelkar March 24, 06
c map from local  to global coordinates, origin at
c corn(i,1:3) and scale axis by dx,dy, dz where
c i is a node# in the coarse grid, corn gives the lower, left, back
c corner of the brick shaped control volume ofi, and dx,dy,dz
c are the x,y,z cell sizes.
c********************************************************************
c INPUT VARIABLES
c
c OUTOUT VARIABLES
c
c INTERNAL VARIABLES
c********************************************************************
c INPUT
c     i   : node id in the coarse grid
c     xl,yl,zl: node coordinates in the global system
c     corn(i,1:3): coordinates in the global system
c                  of the corner to be used as the origin
c     dx,dy,dz: cell sizes in the global system
c OUTOUT
c     xg,yg,zg: node coordinates in the local system

      use comparttr_sg
      use comunits

      implicit none

      integer i

      real*8 xg,yg,zg,xl,yl,zl,dx,dy,dz

      dx=dxyz(i,1)
      dy=dxyz(i,2)
      dz=dxyz(i,3)

      if(dx*dy*dz.eq.0.) then
         write(error_unit_number,*)' zero cell size in global_local',
     1        'for cell# ',i
         write(error_unit_number,*)'STOP'
         stop
      else
         xg=xl*dx+corn(i,1)
         yg=yl*dy+corn(i,2)
         zg=zl*dz+corn(i,3)
      endif

      return

      end

c........................................................................


      SUBROUTINE RCOVIM (HIGHER)
C
C     THIS SUBROUTINE CALCULATES THE ENERGIES ON THE MODAL COORDINATES
C     IN A SUBSTRUCTURE THAT WAS MODAL REDUCED.  IT WILL ALSO
C     CALCULATE THE TOTAL ENERGY FOR EACH COLUMN.
C
      INTEGER         FSS        ,RSS        ,UA         ,RFNO      ,
     1                Z          ,RC         ,SOF1       ,SOF2      ,
     2                SOF3       ,BUF1       ,BUF2       ,BUF3      ,
     3                TFLAG      ,SIGNAB     ,SIGNC      ,SCRM      ,
     4                SCR5       ,SCR6       ,SCR7       ,SCR8      ,
     5                SCR9       ,NAME(2)    ,BUF4       ,FILE      ,
     6                RSP        ,HIGHER(2)  ,UVEC
      REAL            RZ(1)
      COMMON /BLANK / DRY        ,LOOP       ,STEP       ,FSS(2)     ,
     1                RFNO       ,NEIGV      ,LUI        ,UINMS(2,5) ,
     2                NOSORT     ,UTHRES     ,PTHRES     ,QTHRES
      COMMON /RCOVCR/ ICORE      ,LCORE      ,BUF1       ,BUF2       ,
     1                BUF3       ,BUF4       ,SOF1       ,SOF2       ,
     2                SOF3
      COMMON /RCOVCM/ MRECVR     ,UA         ,PA         ,QA         ,
     1                IOPT       ,RSS(2)     ,ENERGY     ,UIMPRO     ,
     2                RANGE(2)   ,IREQ       ,LREQ       ,LBASIC
      COMMON /ZZZZZZ/ Z(1)
      COMMON /MPYADX/ MCBA(7)    ,MCBB(7)    ,MCBC(7)    ,MCBD(7)    ,
     1                MPYZ       ,TFLAG      ,SIGNAB     ,SIGNC      ,
     2                MPREC      ,SCRM
      COMMON /UNPAKX/ ITINU      ,IRU        ,NRU        ,INCRU
      COMMON /PACKX / ITINP      ,ITOUTP     ,IRP        ,NRP        ,
     1                INCRP
      COMMON /NAMES / RD         ,RDREW      ,WRT        ,WRTREW     ,
     1                REW        ,NOREW      ,EOFNRW     ,RSP        ,
     2                RDP        ,CSP        ,CDP        ,SQUARE     ,
     3                RECT       ,DIAG       ,UPPER      ,LOWER      ,
     4                SYM
      EQUIVALENCE     (Z(1),RZ(1))
      DATA    UVEC  , KMTX,MMTX  / 4HUVEC,4HKMTX,4HMMTX /
      DATA    SCR5  , SCR6,SCR7,SCR8,SCR9 / 305,306,307,308,309 /
      DATA    NAME  / 4HRCOV,4HIM         /
C
C     INITIALIZE
C
      LCOREZ = KORSZ(Z)
      MPYZ   = LCOREZ
      TFLAG  = 0
      SIGNAB = 1
      SIGNC  = 1
      MPREC  = 0
C
C     GET THE DISPLACEMENT VECTOR FOR THE HIGHER LEVEL REDUCED
C     SUBSTRUCTURE.
C
      ITEM = UVEC
      CALL MTRXI (SCR5,HIGHER,UVEC,0,RC)
      IF (RC .NE. 1) GO TO 6000
C
C     CALCULATE VELOCITIES IF NOT ALREADY DONE FOR THE OUTPUT PHASE.
C
      INTYP = 1
      IF (RFNO.EQ.3 .OR. RFNO.EQ.8) INTYP = 0
      CALL RCOVVA (SCR5,INTYP,0,SCR8,SCR9,0,HIGHER,Z(1),Z(1),Z(1))
      IF (UA .LE. 0) GO TO 9200
C
C     CALCULATE THE KENETIC ENERTY MULTIPLIER - M * V
C
      ITEM = MMTX
      CALL MTRXI (SCR5,HIGHER,MMTX,0,RC)
      IF (RC .NE. 1) GO TO 6000
      MCBA(1) = SCR5
      CALL RDTRL (MCBA)
      MCBB(1) = SCR9
      CALL RDTRL (MCBB)
      NCOL    = MCBB(2)
      MCBC(1) = 0
      CALL MAKMCB (MCBD,SCR7,MCBB(3),RECT,MCBB(5))
      SCRM = SCR6
      CALL SOFCLS
      CALL MPYAD (Z(1),Z(1),Z(1))
      CALL WRTTRL (MCBD)
C
C     CALCULATE THE KENETIC ENERGIES BY PERFORMING THE SCALAR
C     MULTIPLY IN SINGLE PERCISION.  USE ONLY THE REAL PART IF COMPLEX
C     VECTORS.  APPEND THE TOTAL KINETIC ENERGY TO THE END OF EACH
C     COLUMN.
C
      ITINU = RSP
      IRU   = 1
      NRU   = MCBD(3)
      INCRU = 1
      ITINP = RSP
      ITOUTP= RSP
      IRP   = 1
      NRP   = NRU + 1
      INCRP = 1
      IVEC1 = 1
      IVEC2 = IVEC1 + NRU + 1
      IF (IVEC2+NRU+1 .GT. SOF3) GO TO 9008
C
      FILE = SCR9
      CALL GOPEN (SCR7,Z(SOF1),RDREW)
      CALL GOPEN (SCR9,Z(SOF2),RDREW)
      CALL GOPEN (SCR6,Z(SOF3),WRTREW)
      CALL MAKMCB (MCBA,SCR6,NRP,RECT,RSP)
C
      DO 160 I = 1,NCOL
      ISK = 1
      CALL UNPACK (*130,SCR7,RZ(IVEC1))
      ISK = 0
      CALL UNPACK (*130,SCR9,RZ(IVEC2))
C
      TOTAL = 0.0
      DO 120 J = 1,NRU
      K = J - 1
      RZ(IVEC1+K) = RZ(IVEC1+K)*RZ(IVEC2+K)
      TOTAL = TOTAL + RZ(IVEC1+K)
  120 CONTINUE
      RZ(IVEC1+NRU) = TOTAL
      GO TO 150
C
  130 DO 140 J = 1,NRP
  140 RZ(IVEC1+J-1) = 0.0
      IF (ISK .NE. 0)CALL FWDREC (*9002,SCR9)
C
  150 CALL PACK (RZ(IVEC1),SCR6,MCBA)
C
  160 CONTINUE
C
      CALL CLOSE (SCR7,REW)
      CALL CLOSE (SCR9,REW)
      CALL CLOSE (SCR6,REW)
      CALL WRTTRL (MCBA)
      CALL SOFOPN (Z(SOF1),Z(SOF2),Z(SOF3))
C
C     CALCULATE THE POTENTIAL ENERTY MULTPLYIER - K*U
C
      ITEM = KMTX
      CALL MTRXI (SCR5,HIGHER,KMTX,0,RC)
      IF (RC .NE. 1) GO TO 6000
      MCBA(1) = SCR5
      CALL RDTRL (MCBA)
      MCBB(1) = SCR8
      CALL RDTRL (MCBB)
      CALL MAKMCB (MCBD,SCR9,MCBB(3),RECT,MCBB(5))
      SCRM = SCR7
      CALL SOFCLS
      CALL MPYAD (Z(1),Z(1),Z(1))
      CALL WRTTRL (MCBD)
C
C     CALCULATE THE POTENTIAL ENERGIES BY PERFORMING THE SCALAR
C     MULTIPLY IN SINGLE PERCISION.  USE ONLY THE REAL PART IF COMPLEX
C     VECTORS.  APPEND THE TOTAL POTENTIAL ENERGY TO THE END OF EACH
C     COLUMN.
C
      ITINU = RSP
      IRU   = 1
      NRU   = MCBD(3)
      INCRU = 1
      ITINP = RSP
      ITOUTP= RSP
      IRP   = 1
      NRP   = NRU + 1
      INCRP = 1
C
      FILE = SCR8
      CALL GOPEN (SCR9,Z(SOF1),RDREW)
      CALL GOPEN (SCR8,Z(SOF2),RDREW)
      CALL GOPEN (SCR7,Z(SOF3),WRTREW)
      CALL MAKMCB (MCBA,SCR7,NRP,RECT,RSP)
C
      DO 260 I = 1,NCOL
      ISK = 1
      CALL UNPACK (*230,SCR9,RZ(IVEC1))
      ISK = 0
      CALL UNPACK (*230,SCR8,RZ(IVEC2))
      TOTAL = 0.0
      DO 220 J = 1,NRU
      K = J - 1
      RZ(IVEC1+K) = RZ(IVEC1+K)*RZ(IVEC2+K)
      TOTAL = TOTAL + RZ(IVEC1+K)
  220 CONTINUE
      RZ(IVEC1+NRU) = TOTAL
      GO TO 250
C
  230 DO 240 J = 1,NRP
  240 RZ(IVEC1+J-1) = 0.0
      IF (ISK .NE. 0)CALL FWDREC (*9002,SCR8)
C
  250 CALL PACK (RZ(IVEC1),SCR7,MCBA)
C
  260 CONTINUE
C
      CALL CLOSE (SCR9,REW)
      CALL CLOSE (SCR8,REW)
      CALL CLOSE (SCR7,REW)
      CALL WRTTRL (MCBA)
C
C     NORMAL RETURN
C
      CALL SOFOPN (Z(SOF1),Z(SOF2),Z(SOF3))
      RETURN
C
C     ERRORS
C
 6000 CALL SMSG (RC-2,ITEM,HIGHER)
      GO TO 9200
 9002 N = 2
      GO TO 9100
 9008 N = 8
 9100 CALL MESAGE (N,FILE,NAME)
 9200 IOPT = -1
      RETURN
      END


c
c     ROTATION VIA PROJECTION
c
c     Multipole expansions for complex-valued functions.
c
c     Requires FFT and Associated Legendre Function Libraries.
c
c     User-callable routine is rotviaproj.
c     The other routines are used internally.
c
c***********************************************************************
      subroutine rotviaproj(nd,beta,nterms,m1,m2,mpole,lmp,
     1           marray2,lmpn)
c***********************************************************************
c       Purpose:
c
c	Fast and stable algorithm for applying rotation operator about
c	the y-axis determined by angle beta.
c
c       The method is based on computing the induced potential and
c       its theta-derivative on the rotated equator
c       for each order (first index). The coefficients of  the rotated
c       expansion can then be obtained by FFT and projection.
c
c       There is some loss in speed over using recurrence relations
c       but it is stable to all orders whereas the recurrence schemes
c       are not.
c
c       If the rotation operator is to be used multiple times, and
c       memory is available, one can precompute and store the
c       multipliers used in evalall (see below). This has not yet been
c       implemented.
c
C---------------------------------------------------------------------
c       INPUT:
c
c       nd: number of multipole expansions
c       beta:  the rotation angle about the y-axis.
c       nterms: order of multipole expansion
C       mpole   coefficients of original multiple expansion
C       lmp     leading dim for mpole (must exceed nterms)
C       lmpn    leading dim for marray2 (must exceed nterms)
c
C---------------------------------------------------------------------
c       OUTPUT:
c
c       marray2  coefficients of rotated expansion.
c
C---------------------------------------------------------------------
c
c
c
      implicit none
      integer idim,nd
      integer nquad,ier,m1,m2,nterms,lmp,lmpn, next235_cproj_vec
      double precision beta
      double complex mpole(nd,0:lmp,-lmp:lmp)
      double complex marray2(nd,0:lmpn,-lmpn:lmpn)

      double precision, allocatable :: cthetas(:),cphis(:)
      double precision, allocatable :: sthetas(:),sphis(:)
      double precision, allocatable :: ynm(:,:),ynmd(:,:)
      double precision, allocatable :: rat1(:,:),rat2(:,:)
      double precision, allocatable :: wsave(:)

      double complex, allocatable :: avec(:),bvec(:)
      double complex, allocatable :: uder(:,:,:),uval(:,:,:)
      double complex, allocatable :: ephis(:)

      nquad = next235_cproj_vec((2*nterms+2)*1.0d0)

c
cc      allocate all temporary arrays
c

      allocate(cthetas(nquad),cphis(nquad))
      allocate(sthetas(nquad),sphis(nquad))
      allocate(ynm(0:nterms,0:nterms),ynmd(0:nterms,0:nterms))
      allocate(rat1(0:nterms,0:nterms),rat2(0:nterms,0:nterms))
      allocate(wsave(4*nquad+20))

      allocate(avec(nquad),bvec(nquad),uder(nd,nquad,0:nterms))
      allocate(uval(nd,nquad,0:nterms),ephis(-nterms:nterms))
c
c     Algorithm:
c     1) get locations of quadrature nodes
c     2) evaluate u and du/dtheta
c     3) project onto spherical harmonics.
c
      call getmeridian(beta,nquad,cthetas,sthetas,cphis,sphis)
      call evalall(nd,beta,nquad,cthetas,sthetas,cphis,sphis,
     1           mpole,lmp,nterms,uval,uder,ynm,ynmd,ephis,rat1,rat2)
      call projectonynm(nd,nquad,uval,uder,ynm,ynmd,marray2,lmpn,
     1           nterms,m2,wsave,avec,bvec,rat1,rat2)

      return
      end
c
c
      function next235_cproj_vec(base)
      implicit none
      integer next235_cproj_vec, numdiv
      real*8 base
c ----------------------------------------------------------------------
c     integer function next235_cproj returns a multiple of 2, 3, and 5
c
c     next235_cproj = 2^p 3^q 5^r >= base  where p>=1, q>=0, r>=0
************************************************************************
      next235_cproj_vec = 2 * int(base/2d0+.9999d0)
      if (next235_cproj_vec.le.0) next235_cproj_vec = 2

100   numdiv = next235_cproj_vec
      do while (numdiv/2*2 .eq. numdiv)
         numdiv = numdiv /2
      enddo
      do while (numdiv/3*3 .eq. numdiv)
         numdiv = numdiv /3
      enddo
      do while (numdiv/5*5 .eq. numdiv)
         numdiv = numdiv /5
      enddo
      if (numdiv .eq. 1) return
      next235_cproj_vec = next235_cproj_vec + 2
      goto 100
      end
c
c
c***********************************************************************
      subroutine getmeridian(beta,nquad,cthetas,sthetas,cphis,
     1             sphis)
C***********************************************************************
C     Purpose:
C
C           For a rotation of angle BETA about the y-axis, this
C           subroutine returns the NQUAD equispaced nodes on the
C           rotated equator in the original coordinate system.
C
C---------------------------------------------------------------------
C     INPUT:
C
C     beta  = angle of rotation
C     nquad = number of quadrature nodes in equator.
C
C---------------------------------------------------------------------
C     OUTPUT:
C
C     cthetas = cos(theta) values in original coordinate system of
C                    nquad equispaced nodes
C     sthetas = sin(theta) values in original coordinate system of
C                    nquad equispaced nodes
C     cphis =  cos(phi) values in original coordinate system of
C                    nquad equispaced nodes
C     sphis =  cos(phi) values in original coordinate system of
C                    nquad equispaced nodes
C
C***********************************************************************
      implicit double precision (a-h,o-z)
      integer nquad
      double precision cthetas(nquad)
      double precision sthetas(nquad)
      double precision cphis(nquad)
      double precision sphis(nquad)
C
      pi = 4.0d0*datan(1.0d0)
C
      ca = cos(beta)
      sa = sin(beta)
      do i = 1,nquad
	 im1 = i-1
         phi = 2*pi*im1/nquad
	 theta = pi/2.0d0
         xp = cos(phi)*sin(theta)
         yp = sin(phi)*sin(theta)
         zp = cos(theta)
         x = ca*xp + sa*zp
         y = yp
         z = -sa*xp + ca*zp
         proj = sqrt(x**2+y**2)
	 if (proj.le.1.0d-16) then
	    cphis(i) = 1.0d0
	    sphis(i) = 0.0d0
	 else
	    cphis(i) = x/proj
	    sphis(i) = y/proj
	 endif
	 cthetas(i) = z
	 sthetas(i) = proj
      enddo
      return
      end
C
C***********************************************************************
      subroutine evalall(nd,beta,nquad,cthetas,sthetas,cphis,sphis,
     1           mpole,lmp,nterms,uval,uder,ynm,ynmd,ephis,rat1,rat2)
C***********************************************************************
C
C     This subroutine evaluates the multipole expansion for each
C     order at the nquad nodes on the rotated equator.
C
C---------------------------------------------------------------------
C     INPUT:
C
C     nd      : numb3re of multipole expansions
C     beta    : angle of rotation about y-axis.
C     nquad    : number of target point son unit sphere
C     cthetas  : cos(theta) values of target points.
C     sthetas  : sin(theta) values of target points.
C     cphis    : cos(phi) values of target points.
C     sphis    : sin(phi) values of target points.
C     mpole    : original multipole expansion
C     nterms   : order of multipole expansion
C     ynm      : work array for ynm values
C     ynmd     : work array for ynmd values
C     ephis    : work array for exp(i m phi) values
C     rat1     : work array for accelerating ynm calculation.
C     rat2     : work array for accelerating ynm calculation.
C
C---------------------------------------------------------------------
C     OUTPUT:
C
C     uval(i,j) : contribution to potential
C                 of multipole terms of order j at ith quad node.
C     uder(i,j) : contributions to theta derivative of potential
C                 of multipole terms of order j at ith quad node.
C
C***********************************************************************
      implicit double precision (a-h,o-z)
      integer nd,idim
      integer ndeg,morder, nquad
      double precision cthetas(nquad),cphis(nquad)
      double precision sthetas(nquad),sphis(nquad)
      double precision ynm(0:nterms,0:nterms)
      double precision ynmd(0:nterms,0:nterms)
      double complex mpole(nd,0:lmp,-lmp:lmp)
      double complex ephi1,ephis(-nterms:nterms)
      double complex uder(nd,nquad,0:nterms),uval(nd,nquad,0:nterms)
      double complex uv,utheta,uphi,ztmp1,ztmp2,ztsum,ztdif
      double complex ux,uy,uz,ima
      double precision rat1(0:nterms,0:nterms)
      double precision rat2(0:nterms,0:nterms)
C
      data ima/(0.0d0,1.0d0)/
      pi = 4.0d0*datan(1.0d0)
C
      cbeta = cos(beta)
      sbeta = -sin(beta)
      call ylgndrini(nterms,rat1,rat2)
      nquad2=nquad/2
      if( mod(nquad2,2) .eq. 0 ) nquad4=nquad2/2+1
      if( mod(nquad2,2) .eq. 1 ) nquad4=nquad2/2+1
c
      do jj=1,nquad4
         ctheta = cthetas(jj)
         stheta = sthetas(jj)
         cphi = cphis(jj)
         sphi = sphis(jj)
         dir1 = -sbeta
         dir2 = 0
         dir3 = cbeta
         tang1 = cphi*ctheta
         tang2 = sphi*ctheta
         tang3 = -stheta
         proj2 = tang1*dir1 + tang2*dir2 + tang3*dir3
         tang1 = -sphi
         tang2 = cphi
         tang3 = 0
         proj1 = tang1*dir1 + tang2*dir2 + tang3*dir3
         call ylgndru2sf(nterms,ctheta,ynm,ynmd,rat1,rat2)
         ephi1 = dcmplx(cphis(jj),sphis(jj))
         ephis(1) = ephi1
         ephis(-1) = dconjg(ephi1)
	     do i = 2,nterms
	        ephis(i) = ephis(i-1)*ephi1
	        ephis(-i) = dconjg(ephis(i))
	     enddo
	     do ndeg = 0,nterms
            do idim=1,nd
	           uv=0
	           utheta=0
	           uphi=0
	           do morder = 1,ndeg
                  ztmp1=ephis(morder)*mpole(idim,ndeg,morder)
                  ztmp2=ephis(-morder)*mpole(idim,ndeg,-morder)
	              ztsum=ztmp1+ztmp2
	              ztdif=ztmp1-ztmp2
	              uv=uv+ynm(ndeg,morder)*ztsum
	              utheta=utheta+ynmd(ndeg,morder)*ztsum
	              uphi=uphi-ynm(ndeg,morder)*morder*ztdif
	           enddo
	           uv=stheta*uv+ynm(ndeg,0)*mpole(idim,ndeg,0)
	           utheta=utheta+ynmd(ndeg,0)*stheta*mpole(idim,ndeg,0)
c
c       ... apply the periodizing operator
c
                uval(idim,jj,ndeg) = uv
                uder(idim,jj,ndeg) = (utheta*proj2+uphi*ima*proj1)
                if( mod(ndeg,2) .eq. 0 ) then
                   uval(idim,jj+nquad/2,ndeg) = +uval(idim,jj,ndeg)
                   uder(idim,jj+nquad/2,ndeg) = -uder(idim,jj,ndeg)
                endif
                if( mod(ndeg,2) .eq. 1 ) then
                   uval(idim,jj+nquad/2,ndeg) = -uval(idim,jj,ndeg)
                   uder(idim,jj+nquad/2,ndeg) = +uder(idim,jj,ndeg)
                endif
	         enddo
          enddo

          if_reflect=1
          if( jj .eq. 1 ) if_reflect=0
          if( jj .eq. nquad4 .and. mod(nquad2,2) .eq. 0 ) if_reflect=0
c
          if( if_reflect .eq. 1 ) then
             jjr=nquad2 - jj + 2
             call ylgndr2pm_opt(nterms,ynm,ynmd)
             ctheta = -cthetas(jj)
             stheta = sthetas(jj)
             cphi = -cphis(jj)
             sphi = sphis(jj)
             dir1 = -sbeta
             dir2 = 0
             dir3 = cbeta
             tang1 = cphi*ctheta
             tang2 = sphi*ctheta
             tang3 = -stheta
             proj2 = tang1*dir1 + tang2*dir2 + tang3*dir3
             tang1 = -sphi
             tang2 = cphi
             tang3 = 0
             proj1 = tang1*dir1 + tang2*dir2 + tang3*dir3
             ephi1 = dcmplx(cphi,sphi)
             ephis(1) = ephi1
	         ephis(-1) = dconjg(ephi1)
	         do i = 2,nterms
	            ephis(i) = ephis(i-1)*ephi1
	            ephis(-i) = dconjg(ephis(i))
	         enddo
	         do ndeg = 0,nterms
                do idim=1,nd
	               uv=0
	               utheta=0
	               uphi=0
	               do morder = 1,ndeg
                      ztmp1=ephis(morder)*mpole(idim,ndeg,morder)
                      ztmp2=ephis(-morder)*mpole(idim,ndeg,-morder)
	                  ztsum=ztmp1+ztmp2
	                  ztdif=ztmp1-ztmp2
	                  uv=uv+ynm(ndeg,morder)*ztsum
	                  utheta=utheta+ynmd(ndeg,morder)*ztsum
	                  uphi=uphi-ynm(ndeg,morder)*morder*ztdif
	               enddo
	               uv=stheta*uv+ynm(ndeg,0)*mpole(idim,ndeg,0)
                   utheta=utheta+ynmd(ndeg,0)*stheta*mpole(idim,ndeg,0)
c
c       ... apply the periodizing operator
c
                   uval(idim,jjr,ndeg) = uv
                   uder(idim,jjr,ndeg) = (utheta*proj2+uphi*ima*proj1)
                   if( mod(ndeg,2) .eq. 0 ) then
                      uval(idim,jjr+nquad/2,ndeg) = +uval(idim,jjr,ndeg)
                      uder(idim,jjr+nquad/2,ndeg) = -uder(idim,jjr,ndeg)
                   endif
                   if( mod(ndeg,2) .eq. 1 ) then
                      uval(idim,jjr+nquad/2,ndeg)=-uval(idim,jjr,ndeg)
                      uder(idim,jjr+nquad/2,ndeg)=+uder(idim,jjr,ndeg)
                   endif
	            enddo
             enddo
         endif
      enddo

      return
      end
C
C
C
C
C
C***********************************************************************
      subroutine projectonynm(nd,nquad,uval,uder,
     1           ynm,ynmd,marray,lmpn,nterms,m2,wsave,avec,bvec,
     $           rat1,rat2)
C***********************************************************************
C
C     This subroutine projects from values on equator for each multipole
C     order (uval, uder = dudthteta)
C     onto spherical harmonics
C
C---------------------------------------------------------------------
C     INPUT:
C
C     nd       : number of multipole expansions
C     nquad    : number of points on equator
C     uval     : F values on equator
C     uder     : dFdtheta values on equator
C     ynm      : work array for ynm values
C     ynmd     : work array for ynmd values
C     lmpn     : leading dim of marray (must exceed nterms)
C     nterms   : order of expansion
C     m2       : NOT IMPLEMENTED (for reduced number of degrees in
C                expansion (second index)
C     wsave    : work array for FFT (dimension at least 4*nquad+20)
C     avec     : work array of length nquad for FFT (complex)
C     bvec     : work array of length nquad for FFT (complex)
C---------------------------------------------------------------------
C     OUTPUT:
C
C     marray   : rotated expansion
C
C
C***********************************************************************
      implicit double precision (a-h,o-z)
      integer nquad, norder
      integer nd,idim
      double complex ephi,ephi1,uval(nd,nquad,0:1)
      double complex uder(nd,nquad,0:1)
      double complex utheta,uphi,ztmp1,ztmp2
      double complex alpha,beta,ima
      double complex marray(nd,0:lmpn,-lmpn:lmpn)
      double precision ynm(0:nterms,0:nterms)
      double precision ynmd(0:nterms,0:nterms)
      double precision wsave(4*nquad+20)
      double complex avec(nquad)
      double complex bvec(nquad)
      double precision rat1(0:nterms,0:nterms)
      double precision rat2(0:nterms,0:nterms)
C
      data ima/(0.0d0,1.0d0)/
c
      ctheta = 0.0d0
      stheta = 1.0d0
      h = 1.0d0/nquad
      call ylgndru2sf(nterms,ctheta,ynm,ynmd,rat1,rat2)
      call zffti(nquad,wsave)
      do norder=0,nterms
         d=sqrt(2*norder+1.0d0)
         do idim=1,nd
   	        do ii = 1,nquad
               avec(ii) = uval(idim,ii,norder)*d + uder(idim,ii,norder)
            enddo
	        call zfftf(nquad,avec,wsave)
            do m = -norder,norder
	           if (m.ge.0)  alpha = avec(m+1)*h
	           if (m.lt.0)  alpha = avec(nquad+m+1)*h
               marray(idim,norder,m) = alpha/
     1            (ynm(norder,abs(m))*d - (ynmd(norder,abs(m))))
            enddo
         enddo
      enddo
      return
      end
c
c
c
c
c
c***********************************************************************


      SUBROUTINE MB03LF( COMPQ, COMPU, ORTH, N, Z, LDZ, B, LDB, FG,
     $                   LDFG, NEIG, Q, LDQ, U, LDU, ALPHAR, ALPHAI,
     $                   BETA, IWORK, LIWORK, DWORK, LDWORK, BWORK,
     $                   IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the relevant eigenvalues of a real N-by-N skew-
C     Hamiltonian/Hamiltonian pencil aS - bH, with
C
C                                   (  B  F  )      (  0  I  )
C       S = T Z = J Z' J' Z and H = (        ), J = (        ),      (1)
C                                   (  G -B' )      ( -I  0  )
C
C     where the notation M' denotes the transpose of the matrix M.
C     Optionally, if COMPQ = 'C', an orthogonal basis of the right
C     deflating subspace of aS - bH corresponding to the eigenvalues
C     with strictly negative real part is computed. Optionally, if
C     COMPU = 'C', an orthonormal basis of the companion subspace,
C     range(P_U) [1], which corresponds to the eigenvalues with strictly
C     negative real part, is computed.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPQ   CHARACTER*1
C             Specifies whether to compute the right deflating subspace
C             corresponding to the eigenvalues of aS - bH with strictly
C             negative real part.
C             = 'N':  do not compute the deflating subspace;
C             = 'C':  compute the deflating subspace and store it in the
C                     leading subarray of Q.
C
C     COMPU   CHARACTER*1
C             Specifies whether to compute the companion subspace
C             corresponding to the eigenvalues of aS - bH with strictly
C             negative real part.
C             = 'N': do not compute the companion subspace;
C             = 'C': compute the companion subspace and store it in the
C                    leading subarray of U.
C
C     ORTH    CHARACTER*1
C             If COMPQ = 'C' and/or COMPU = 'C', specifies the technique
C             for computing the orthogonal basis of the deflating
C             subspace, and/or of the companion subspace, as follows:
C             = 'P':  QR factorization with column pivoting;
C             = 'S':  singular value decomposition.
C             If COMPQ = 'N' and COMPU = 'N', the ORTH value is not
C             used.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the pencil aS - bH.  N >= 0, even.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
C             On entry, the leading N-by-N part of this array must
C             contain the non-trivial factor Z in the factorization
C             S = J Z' J' Z of the skew-Hamiltonian matrix S.
C             On exit, if COMPQ = 'C' or COMPU = 'C', the leading
C             N-by-N part of this array contains the transformed upper
C                               ~
C             triangular matrix Z11 (see METHOD), after moving the
C             eigenvalues with strictly negative real part to the top
C             of the pencil (3). The strictly lower triangular part is
C             not zeroed.
C             If COMPQ = 'N' and COMPU = 'N', the leading N-by-N part of
C             this array contains the matrix Z obtained by the SLICOT
C             Library routine MB04AD just before the application of the
C             periodic QZ algorithm. The elements of the (2,1) block,
C             i.e., in the rows N/2+1 to N and in the columns 1 to N/2
C             are not set to zero, but are unchanged on exit.
C
C     LDZ     INTEGER
C             The leading dimension of the array Z.  LDZ >= MAX(1, N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1, N/2).
C
C     FG      (input) DOUBLE PRECISION array, dimension (LDFG, N/2+1)
C             On entry, the leading N/2-by-N/2 lower triangular part of
C             this array must contain the lower triangular part of the
C             symmetric matrix G, and the N/2-by-N/2 upper triangular
C             part of the submatrix in the columns 2 to N/2+1 of this
C             array must contain the upper triangular part of the
C             symmetric matrix F.
C
C     LDFG    INTEGER
C             The leading dimension of the array FG.
C             LDFG >= MAX(1, N/2).
C
C     NEIG    (output) INTEGER
C             If COMPQ = 'C' or COMPU = 'C', the number of eigenvalues
C             in aS - bH with strictly negative real part.
C
C     Q       (output) DOUBLE PRECISION array, dimension (LDQ, 2*N)
C             On exit, if COMPQ = 'C', the leading N-by-NEIG part of
C             this array contains an orthogonal basis of the right
C             deflating subspace corresponding to the eigenvalues of
C             aS - bH with strictly negative real part. The remaining
C             part of this array is used as workspace.
C             If COMPQ = 'N', this array is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.
C             LDQ >= 1,           if COMPQ = 'N';
C             LDQ >= MAX(1, 2*N), if COMPQ = 'C'.
C
C     U       (output) DOUBLE PRECISION array, dimension (LDU, 2*N)
C             On exit, if COMPU = 'C', the leading N-by-NEIG part of
C             this array contains an orthogonal basis of the companion
C             subspace corresponding to the eigenvalues of aS - bH with
C             strictly negative real part. The remaining part of this
C             array is used as workspace.
C             If COMPU = 'N', this array is not referenced.
C
C     LDU     INTEGER
C             The leading dimension of the array U.
C             LDU >= 1,         if COMPU = 'N';
C             LDU >= MAX(1, N), if COMPU = 'C'.
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (N/2)
C             The real parts of each scalar alpha defining an eigenvalue
C             of the pencil aS - bH.
C
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (N/2)
C             The imaginary parts of each scalar alpha defining an
C             eigenvalue of the pencil aS - bH.
C             If ALPHAI(j) is zero, then the j-th eigenvalue is real.
C
C     BETA    (output) DOUBLE PRECISION array, dimension (N/2)
C             The scalars beta that define the eigenvalues of the pencil
C             aS - bH.
C             Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
C             beta = BETA(j) represent the j-th eigenvalue of the pencil
C             aS - bH, in the form lambda = alpha/beta. Since lambda may
C             overflow, the ratios should not, in general, be computed.
C             Due to the skew-Hamiltonian/Hamiltonian structure of the
C             pencil, for every eigenvalue lambda, -lambda is also an
C             eigenvalue, and thus it has only to be saved once in
C             ALPHAR, ALPHAI and BETA.
C             Specifically, only eigenvalues with imaginary parts
C             greater than or equal to zero are stored; their conjugate
C             eigenvalues are not stored. If imaginary parts are zero
C             (i.e., for real eigenvalues), only positive eigenvalues
C             are stored. The remaining eigenvalues have opposite signs.
C             As a consequence, pairs of complex eigenvalues, stored in
C             consecutive locations, are not complex conjugate.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             On exit, if INFO = -20, IWORK(1) returns the minimum value
C             of LIWORK.
C
C     LIWORK  INTEGER
C             The dimension of the array IWORK.
C             LIWORK >= N + 18,      if COMPQ = 'N' and COMPU = 'N';
C             LIWORK >= MAX( 2*N+1, 48 ), otherwise.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C             On exit, if INFO = -22, DWORK(1) returns the minimum value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= b*N*N + 3*N*N/2 + MAX( 6*N, 54 ),
C                                       if COMPQ = 'N' and COMPU = 'N';
C             LDWORK >= d*N*N + MAX( N/2+252, 432 ), otherwise, where
C                       b = a,   d = c,   if COMPU = 'N',
C                       b = a+1, d = c+1, if COMPU = 'C', and
C                       a = 2,   c = 7,   if COMPQ = 'N',
C                       a = 4,   c = 10,  if COMPQ = 'C'.
C             For good performance LDWORK should be generally larger.
C
C             If LDWORK = -1  a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message is issued by XERBLA.
C
C     BWORK   LOGICAL array, dimension (N/2)
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0: no warning;
C             = 1: some eigenvalues might be unreliable. More details
C                  can be obtained by running the SLICOT routine MB04AD.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             < 0: if INFO = -i, the i-th argument had an illegal value;
C             = 1: periodic QZ iteration failed in the SLICOT Library
C                  routines MB04AD, MB04CD or MB03BB (QZ iteration did
C                  not converge or computation of the shifts failed);
C             = 2: standard QZ iteration failed in the SLICOT Library
C                  routines MB04CD or MB03CD (called by MB03ID);
C             = 3: a numerically singular matrix was found in the SLICOT
C                  Library routine MB03GD (called by MB03ID);
C             = 4: the singular value decomposition failed in the LAPACK
C                  routine DGESVD (for ORTH = 'S').
C
C     METHOD
C
C     First, the decompositions of S and H are computed via orthogonal
C     matrices Q1 and Q2 and orthogonal symplectic matrices U1 and U2,
C     such that
C
C                                   ( T11  T12 )
C       Q1' T U1 = Q1' J Z' J' U1 = (          ),
C                                   (  0   T22 )
C
C                  ( Z11  Z12 )
C       U2' Z Q2 = (          ),                                     (2)
C                  (  0   Z22 )
C
C                  ( H11  H12 )
C       Q1' H Q2 = (          ),
C                  (  0   H22 )
C
C     where T11, T22', Z11, Z22', H11 are upper triangular and H22' is
C     upper quasi-triangular.
C
C     Then, orthogonal matrices Q3, Q4 and U3 are found, for the
C     matrices
C
C       ~     ( T22'  0  )  ~     ( T11'  0  )  ~   (   0   H11 )
C       Z11 = (          ), Z22 = (          ), H = (           ),
C             (  0   Z11 )        (  0   Z22 )      ( -H22'  0  )
C
C               ~          ~       ~          ~
C     such that Z11 := U3' Z11 Q4, Z22 := U3' Z22 Q3 are upper
C                    ~          ~
C     triangular and H11 := Q3' H Q4 is upper quasi-triangular. The
C     following matrices are computed:
C
C       ~          ( -T12'  0  )        ~          (  0   H12 )
C       Z12 := U3' (           ) Q3 and H12 := Q3' (          ) Q3.
C                  (  0    Z12 )                   ( H12'  0  )
C
C     Then, an orthogonal matrix Q and an orthogonal symplectic matrix U
C     are found such that the eigenvalues with strictly negative real
C     parts of the pencil
C
C             ~    ~          ~    ~           ~    ~
C           ( Z11  Z12 )'   ( Z11  Z12 )     ( H11  H12  )
C       a J (      ~   ) J' (      ~   ) - b (      ~    )           (3)
C           (  0   Z22 )    (  0   Z22 )     (  0  -H11' )
C
C     are moved to the top of this pencil.
C
C     Finally, an orthogonal basis of the right deflating subspace
C     and an orthogonal basis of the companion subspace corresponding to
C     the eigenvalues with strictly negative real part are computed.
C     See also page 11 in [1] for more details.
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
C         Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
C         Eigenproblems.
C         Tech. Rep., Technical University Chemnitz, Germany,
C         Nov. 2007.
C
C     NUMERICAL ASPECTS
C                                                               3
C     The algorithm is numerically backward stable and needs O(N )
C     floating point operations.
C
C     FURTHER COMMENTS
C
C     This routine does not perform any scaling of the matrices. Scaling
C     might sometimes be useful, and it should be done externally.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Jan. 2011.
C
C     REVISIONS
C
C     V. Sima, Feb. 2011, Aug. 2011, Nov. 2011, Oct. 2012, July 2013,
C     July 2014, May 2020.
C     M. Voigt, Jan. 2012, July 2013.
C
C     KEYWORDS
C
C     Deflating subspace, embedded pencil, skew-Hamiltonian/Hamiltonian
C     pencil, structured Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
C
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPU, ORTH
      INTEGER            INFO, IWARN, LDB, LDFG, LDQ, LDU, LDWORK, LDZ,
     $                   LIWORK, N, NEIG
C
C     .. Array Arguments ..
      LOGICAL            BWORK( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   ALPHAI( * ), ALPHAR( * ), B( LDB, * ),
     $                   BETA( * ), DWORK( * ), FG( LDFG, * ),
     $                   Q( LDQ, * ), U( LDU, * ), Z( LDZ, * )
C
C     .. Local Scalars ..
      LOGICAL            LCMP, LCMPQ, LCMPU, LQUERY, QR, QRP, SVD
      CHARACTER*14       CMPI, CMQI, CMUI, JOB
      INTEGER            I, IH, IH12, IQ1, IQ2, IQ3, IQ4, IS, IT, IU11,
     $                   IU12, IU21, IU22, IU3, IW, IWRK, IZ12, J, M,
     $                   MINDB, MINDW, MINIW, MM, MP1, N2, NM, NMM, NN,
     $                   NP1, OPTDW
C
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM( 7 )
C
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, LSAME
C
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMM, DGEQP3, DGEQRF, DGESVD,
     $                   DLACPY, DORGQR, DSWAP, MA02ED, MB03ID, MB04AD,
     $                   MB04CD, XERBLA
C
C     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MOD, SQRT
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C     Using ORTH = 'Q' is not safe, but sometimes gives better results.
C
      M  = N/2
      N2 = N*2
      NN = N*N
C
      NEIG  = 0
      LCMPQ = LSAME( COMPQ, 'C' )
      LCMPU = LSAME( COMPU, 'C' )
      LCMP  = LCMPQ .OR. LCMPU
      IF( LCMP ) THEN
         QR    = LSAME( ORTH, 'Q' )
         QRP   = LSAME( ORTH, 'P' )
         SVD   = LSAME( ORTH, 'S' )
         MINIW = MAX( N2 + 1, 48 )
      ELSE
         QR    = .FALSE.
         QRP   = .FALSE.
         SVD   = .FALSE.
         MINIW = N + 18
      END IF
      IF( N.EQ.0 ) THEN
         MINIW = 1
         MINDW = 1
      ELSE
         IF( LCMPQ ) THEN
            I = 4
            J = 10
         ELSE
            I = 2
            J = 7
         END IF
         IF( LCMPU ) THEN
            I = I + 1
            J = J + 1
         END IF
         MINDB = I*NN
         IF( LCMP ) THEN
            MINDW = J*NN + MAX( M + 252, 432 )
         ELSE
            MINDW = MINDB + 3*( NN/2 ) + MAX( 6*N, 54 )
         END IF
      END IF
      LQUERY = LDWORK.EQ.-1
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LSAME( COMPU, 'N' ) .OR. LCMPU ) ) THEN
         INFO = -2
      ELSE IF( LCMP .AND. .NOT. ( QR .OR. QRP .OR. SVD ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -4
      ELSE IF(  LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF(  LDB.LT.MAX( 1, M ) ) THEN
         INFO = -8
      ELSE IF( LDFG.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF(  LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N2 ) ) THEN
         INFO = -13
      ELSE IF(  LDU.LT.1 .OR. ( LCMPU .AND. LDU.LT.N  ) ) THEN
         INFO = -15
      ELSE IF( LIWORK.LT.MINIW ) THEN
         IWORK( 1 ) = MINIW
         INFO = -20
      ELSE IF( .NOT.LQUERY ) THEN
         IF( LDWORK.LT.MINDW ) THEN
            DWORK( 1 ) = MINDW
            INFO = -22
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03LF', -INFO )
         RETURN
      ELSE IF( N.GT.0 ) THEN
C
C        Compute optimal workspace.
C
         CMPI = 'Initialize'
         IF( LCMPQ ) THEN
            CMQI = CMPI
         ELSE
            CMQI = 'No Computation'
         END IF
C
         IF( LCMPU ) THEN
            CMUI = CMPI
         ELSE
            CMUI = 'No Computation'
         END IF
C
         IF( LCMP ) THEN
            JOB = 'Triangularize'
         ELSE
            JOB = 'Eigenvalues'
         END IF
C
         IF( LQUERY ) THEN
            CALL MB04AD( JOB, CMQI, CMQI, CMUI, CMUI, N, DWORK, N,
     $                   DWORK, N, DWORK, N, DWORK, N, DWORK, M, DWORK,
     $                   M, DWORK, M, DWORK, M, DWORK, N, DWORK, DWORK,
     $                   DWORK, IWORK, LIWORK, DUM, -1, INFO )
C
            IF( LCMP ) THEN
               IW    = MINDB
               MINDB = MINDB + 2*NN
               IF( LCMPQ ) THEN
                  IW    = IW    + NN
                  MINDB = MINDB + NN
               ELSE
                  IW    = 0
               END IF
               CALL MB04CD( CMQI, CMPI, CMPI, N, DWORK, N, DWORK, N,
     $                      DWORK, N, DWORK, N, DWORK, N, DWORK, N,
     $                      IWORK, LIWORK, DUM( 2 ), -1, BWORK, INFO )
               IF( SVD ) THEN
                  CALL DGESVD( 'O', 'N', N, N, Q, LDQ, DWORK, DWORK,
     $                         LDQ, DWORK, 1, DUM( 3 ), -1, INFO )
                  J = N + INT( DUM( 3 ) )
               ELSE
                  I = MAX( LDQ, LDU )
                  IF( QR ) THEN
                     CALL DGEQRF( N, M, Q, I, DWORK, DUM( 3 ), -1,
     $                            INFO )
                     J = M
                  ELSE
                     CALL DGEQP3( N, N, Q, I, IWORK, DWORK, DUM( 3 ),
     $                            -1, INFO )
                     J = N
                  END IF
                  CALL DORGQR( N, J, J, Q, I, DWORK, DUM( 4 ), -1,
     $                         INFO )
                  J = J + IW + MAX( INT( DUM( 3 ) ), INT( DUM( 4 ) ) )
               END IF
               OPTDW = MAX( MINDB + INT( DUM( 2 ) ), J )
            ELSE
               OPTDW = 0
            END IF
            OPTDW = MAX( MINDW, OPTDW, MINDB + INT( DUM( 1 ) ) )
            DWORK( 1 ) = OPTDW
            RETURN
         END IF
      END IF
C
C     Quick return if possible.
C
      IWARN = 0
      IF( N.EQ.0 ) THEN
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
C     STEP 1: Apply MB04AD to compute the generalized symplectic
C             URV decomposition.
C
C     Set the pointers for the inputs and outputs of MB04AD.
C
C     Real workspace:     need   w1 + w, where
C                         w1 = 2*N**2, if COMPQ = 'N' and COMPU = 'N';
C                         w1 = 3*N**2, if COMPQ = 'N' and COMPU = 'C';
C                         w1 = 4*N**2, if COMPQ = 'C' and COMPU = 'N';
C                         w1 = 5*N**2, if COMPQ = 'C' and COMPU = 'C';
C                         w  = 3/2*N**2+MAX(6*N, 54), if  COMPQ = 'N'
C                                                     and COMPU = 'N';
C                         w  =   3*N**2+MAX(6*N, 54), otherwise;
C                         prefer larger.
C     Integer workspace:  need   N + 18.
C
      MM  = M*M
      NM  = N*M
      NMM = NM + M
      NP1 = N  + 1
      MP1 = M  + 1
      IQ1 = 1
      IF( LCMPQ ) THEN
         IQ2  = IQ1 + NN
         IU11 = IQ2 + NN
         IH   = IU11
      ELSE
         IQ2  = 1
         IU11 = 1
         IH   = 1
      END IF
C
      IF( LCMPU ) THEN
         IU12 = IU11 + MM
         IU21 = IU12 + MM
         IU22 = IU21 + MM
         IH   = IU22 + MM
      ELSE
         IU12 = 1
         IU21 = 1
         IU22 = 1
      END IF
C
C     Build the matrix H.
C
      IW = IH
      IS = IH + M + N
      DO 10 J = 1, M
         CALL DCOPY( M, B( 1, J ), 1, DWORK( IW ), 1 )
         IW = IW + M + J - 1
         CALL DCOPY( M-J+1, FG( J, J ),  1, DWORK( IW ), 1 )
         CALL DCOPY( M-J, DWORK( IW+1 ), 1, DWORK( IS ), N )
         IW = IW + MP1 - J
         IS = IS + NP1
   10 CONTINUE
C
      IW = IH + NM
      IS = IW
      DO 30 J = 1, M
         CALL DCOPY( J, FG( 1, J+1 ),  1, DWORK( IW ), 1 )
         CALL DCOPY( J-1, DWORK( IW ), 1, DWORK( IS ), N )
         IW = IW + M
         IS = IS + 1
         DO 20 I = 1, M
            DWORK( IW ) = -B( J, I )
            IW = IW + 1
   20    CONTINUE
   30 CONTINUE
C
      IT   = IH + NN
      IWRK = IT + NN
C
      CALL MB04AD( JOB, CMQI, CMQI, CMUI, CMUI, N, Z, LDZ, DWORK( IH ),
     $             N, DWORK( IQ1 ), N, DWORK( IQ2 ), N, DWORK( IU11 ),
     $             M, DWORK( IU12 ), M, DWORK( IU21 ), M, DWORK( IU22 ),
     $             M, DWORK( IT ), N, ALPHAR, ALPHAI, BETA, IWORK,
     $             LIWORK, DWORK( IWRK ), LDWORK-IWRK+1, INFO )
C
      IF( INFO.EQ.3 ) THEN
         IWARN = 1
      ELSE IF( INFO.GT.0 ) THEN
         INFO = 1
         RETURN
      END IF
      OPTDW = MAX( MINDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
      IF( .NOT.LCMP ) THEN
         DWORK( 1 ) = OPTDW
         RETURN
      END IF
C                                                    ~    ~        ~
C     STEP 2: Build the needed parts of the matrices Z11, Z22' and H,
C     and compute the transformed matrices and the orthogonal matrices
C     Q3, Q4 and U3. (Q4 might not be required.)
C
C     Real workspace:     need   w1 + w2 + 3*N*N + MAX( M+252, 432 ),
C                                w2 = 2*N**2, if COMPQ = 'N';
C                                w2 = 3*N**2, if COMPQ = 'C';
C                         prefer larger.
C     Integer workspace:  need   MAX( N/2+1, 48 ).
C     Logical workspace:  need   M.
C
C     Save Z12, T12, and H12, since they are overwritten by MB04CD.
C
      IW = IT + NM
      IS = IH + NM
      IF( LCMPU ) THEN
         DO 40 J = 1, M
            CALL DCOPY( M, Z( 1, M+J ), 1, U(   1, J ), 1 )
            CALL DCOPY( M, DWORK( IW ), 1, U( MP1, J ), 1 )
            IW = IW + N
   40    CONTINUE
         DO 50 J = 1, M
            CALL DCOPY( M, DWORK( IS ), 1, U( 1, M+J ), 1 )
            IS = IS + N
   50    CONTINUE
      ELSE
         DO 60 J = 1, M
            CALL DCOPY( M, Z( 1, M+J ), 1, Q(   1, J ), 1 )
            CALL DCOPY( M, DWORK( IW ), 1, Q( MP1, J ), 1 )
            IW = IW + N
   60    CONTINUE
         DO 70 J = 1, M
            CALL DCOPY( M, DWORK( IS ), 1, Q( 1, M+J ), 1 )
            IS = IS + N
   70    CONTINUE
      END IF
C
      IU3 = IWRK
      IQ3 = IU3 + NN
      IQ4 = IQ3 + NN
      IF( LCMPQ ) THEN
         IWRK = IQ4 + NN
      ELSE
         IWRK = IQ4
      END IF
C
      IW = IH
      DO 90 J = 1, M
         IS = IW + NM
         CALL DCOPY( M, DWORK( IW ), 1, DWORK( IS ), 1 )
         IW = IW + M
         IS = IH + NMM + J - 1
         DO 80 I = 1, M
            DWORK( IW ) = -DWORK( IS )
            IW = IW + 1
            IS = IS + N
   80    CONTINUE
   90 CONTINUE
C
      IS = IT + NMM
      DO 100 J = 1, M
         CALL DSWAP( M, Z( 1, J ), 1, Z( MP1, M+J ), 1 )
         CALL DSWAP( M, Z( 1, J ), 1, DWORK( IS ), N )
         IS = IS + 1
  100 CONTINUE
C
      CALL MB04CD( CMQI, CMPI, CMPI, N, DWORK( IT ), N, Z, LDZ,
     $             DWORK( IH ), N, DWORK( IQ4 ), N, DWORK( IU3 ), N,
     $             DWORK( IQ3 ), N, IWORK, LIWORK, DWORK( IWRK ),
     $             LDWORK-IWRK+1, BWORK, INFO )
      IF( INFO.GT.0 ) THEN
         IF( INFO.GT.2 )
     $      INFO = 2
         RETURN
      END IF
      OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
C                     ~                                    ~
C     STEP 3: Compute Z12 and the upper triangular part of H12,
C     exploiting the structure.
C
C     Real workspace:     need   w1 + w2 + w3, where
C                                w3 = 2*N**2.
C
      IZ12 = IWRK
      IH12 = IZ12 + NN
      IWRK = IH12 + NN
C
C             ~           [ -T12'  0  ]                   [ Qa  Qc ]
C     Compute Z12 = U3' * [           ] * Q3, where Q3 =: [        ].
C                         [   0   Z12 ]                   [ Qb  Qd ]
C
C     Part of the arrays U or Q and DWORK(IH12) are used as workspace.
C
      IF( LCMPU ) THEN
         CALL DGEMM( 'Transpose', 'No Transpose', M, N, M, -ONE,
     $               U( MP1, 1 ), LDU, DWORK( IQ3 ), N, ZERO,
     $               DWORK( IH12 ), N )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, N, M, ONE,
     $               U, LDU, DWORK( IQ3+M ), N, ZERO, DWORK( IH12+M ),
     $               N )
      ELSE
         CALL DGEMM( 'Transpose', 'No Transpose', M, N, M, -ONE,
     $               Q( MP1, 1 ), LDQ, DWORK( IQ3 ), N, ZERO,
     $               DWORK( IH12 ), N )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, N, M, ONE,
     $               Q, LDQ, DWORK( IQ3+M ), N, ZERO, DWORK( IH12+M ),
     $               N )
      END IF
      CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE,
     $            DWORK( IU3 ), N, DWORK( IH12 ), N, ZERO,
     $            DWORK( IZ12 ), N )
C
C             ~           [  0   H12 ]
C     Compute H12 = Q3' * [          ] * Q3.
C                         [ H12'  0  ]
C
C     The (2,1) block of Z is used as workspace.
C
C     Compute Qb'*H12'*Qa + Qa'*H12*Qb.
C
      IF( LCMPU ) THEN
         CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $               U( 1, MP1 ), LDU, DWORK( IQ3+M ), N, ZERO,
     $               Z( MP1, 1 ), LDZ )
      ELSE
         CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $               Q( 1, MP1 ), LDQ, DWORK( IQ3+M ), N, ZERO,
     $               Z( MP1, 1 ), LDZ )
      END IF
      CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $            DWORK( IQ3 ), N, Z( MP1, 1 ), LDZ, ZERO,
     $            DWORK( IH12 ), N )
      IS = 0
      DO 110 J = 0, M - 1
         CALL DAXPY( J+1, ONE, DWORK( IH12+J ), N, DWORK( IH12+IS ), 1 )
         IS = IS + N
  110 CONTINUE
C
C     Compute Qb'*H12'*Qc + Qa'*H12*Qd.
C
      CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $            Z( MP1, 1 ), LDZ, DWORK( IQ3+NM ), N, ZERO,
     $            DWORK( IH12+NM ), N )
      IF( LCMPU ) THEN
         CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $              U( 1, MP1 ), LDU, DWORK( IQ3+NMM ), N, ZERO,
     $              Z( MP1, 1 ), LDZ )
      ELSE
         CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $              Q( 1, MP1 ), LDQ, DWORK( IQ3+NMM ), N, ZERO,
     $              Z( MP1, 1 ), LDZ )
      END IF
      CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $            DWORK( IQ3 ), N, Z( MP1, 1 ), LDZ, ONE,
     $            DWORK( IH12+NM ), N )
C
C     Compute Qd'*H12'*Qc + Qc'*H12*Qd.
C
      CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $            Z( MP1, 1 ), LDZ, DWORK( IQ3+NM ), N, ZERO,
     $            DWORK( IH12+NMM ), N )
      IS = 0
      DO 120 J = 0, M - 1
         CALL DAXPY( J+1, ONE, DWORK( IH12+NMM+J ), N,
     $               DWORK( IH12+NMM+IS ), 1 )
         IS = IS + N
  120 CONTINUE
C
C     STEP 4: Apply MB03ID to reorder the eigenvalues with strictly
C             negative real part to the top.
C
C     Real workspace:     need   w1 + w2 + w3 + w4;
C                                w4 = MAX(4*N+48,171), if COMPQ = 'N';
C                                w4 = MAX(8*N+48,171), if COMPQ = 'C'.
C     Integer workspace:  need   2*N + 1.
C
      CALL MA02ED( 'Upper', N, DWORK( IT ), N )
C
      CALL MB03ID( CMQI, CMUI, N2, Z, LDZ, DWORK( IT ), N,
     $             DWORK( IZ12 ), N, DWORK( IH ), N, DWORK( IH12 ), N,
     $             Q, LDQ, U, LDU, U( 1, NP1 ), LDU, NEIG, IWORK,
     $             LIWORK, DWORK( IWRK ), LDWORK-IWRK+1, INFO )
      IF( INFO.GT.0 )
     $   RETURN
C
      IF( QR )
     $   NEIG = NEIG/2
C
      IWRK = IZ12
C
      IF( LCMPQ ) THEN
C
C        STEP 5: Compute the deflating subspace corresponding to the
C                eigenvalues with strictly negative real part.
C
C        Real workspace:     need   w1 + w2 +   N**2, if ORTH = 'QR'.
C                                   w1 + w2 + 2*N**2, otherwise.
C
C        The workspace used before for storing H and T is reused.
C
C        Compute [ J*Q1*J' Q2 ].
C
         CALL DLACPY( 'Full', M, M, DWORK( IQ1+NMM ), N, DWORK( IH ),
     $                N )
         IW = IH  + M
         IS = IQ1 + NM
         DO 140 J = 1, M
            DO 130 I = 1, M
               DWORK( IW ) = -DWORK( IS )
               IW = IW + 1
               IS = IS + 1
  130       CONTINUE
            IW = IW + M
            IS = IS + M
  140    CONTINUE
C
         IW = IH  + NM
         IS = IQ1 + M
         DO 160 J = 1, M
            DO 150 I = 1, M
               DWORK( IW ) = -DWORK( IS )
               IW = IW + 1
               IS = IS + 1
  150       CONTINUE
            IW = IW + M
            IS = IS + M
  160    CONTINUE
         CALL DLACPY( 'Full', M, M, DWORK( IQ1 ), N, DWORK( IH+NMM ),
     $                N )
C
         CALL DLACPY( 'Full', N, N, DWORK( IQ2 ), N, DWORK( IT ), N )
C
C        Compute the first NEIG columns of P*[ Q4  0; 0 Q3 ]*Q.
C
         CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE,
     $               DWORK( IQ4 ), N, Q, LDQ, ZERO, DWORK( IWRK ), N2 )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE,
     $               DWORK( IQ3 ), N, Q( NP1, 1 ), LDQ, ZERO,
     $               DWORK( IWRK+M ), N2 )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE,
     $               DWORK( IQ4+M ), N, Q, LDQ, ZERO, DWORK( IWRK+N ),
     $               N2 )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE,
     $               DWORK( IQ3+M ), N, Q( NP1, 1 ), LDQ, ZERO,
     $               DWORK( IWRK+N+M ), N2 )
C
C        Compute the deflating subspace.
C
         CALL DGEMM( 'No Transpose', 'No Transpose', N, NEIG, N2,
     $               SQRT( TWO )/TWO, DWORK( IH ), N, DWORK( IWRK ), N2,
     $               ZERO, Q, LDQ )
C
C        Orthogonalize the basis given in Q(1:n,1:neig).
C
         IF( LCMPU ) THEN
            IWRK = IQ3
         ELSE
            IWRK = NEIG + 1
         END IF
         IF( SVD ) THEN
C
C           Real workspace:     need   w5 + N + MAX(1,5*N);
C                                      w5 = 0,        if COMPU = 'N';
C                                      w5 = w1 + N*N, if COMPU = 'C'.
C                               prefer larger.
C
            CALL DGESVD( 'Overwrite', 'No V', N, NEIG, Q, LDQ, DWORK,
     $                   DWORK, 1,  DWORK, 1, DWORK( IWRK ),
     $                   LDWORK-IWRK+1, INFO )
            IF( INFO.GT.0 ) THEN
               INFO = 4
               RETURN
            END IF
            OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
            IF( .NOT.LCMPU )
     $         NEIG = NEIG/2
C
         ELSE
            IF( QR ) THEN
C
C              Real workspace:     need   w5 + N;
C                                  prefer w5 + M + M*NB, where NB is the
C                                                  optimal blocksize.
C
               CALL DGEQRF( N, NEIG, Q, LDQ, DWORK, DWORK( IWRK ),
     $                      LDWORK-IWRK+1, INFO )
            ELSE
C
C              Real workspace:     need   w5 + 4*N + 1;
C                                  prefer w5 + 3*N + (N+1)*NB.
C
               DO 170 J = 1, NEIG
                  IWORK( J ) = 0
  170          CONTINUE
               CALL DGEQP3( N, NEIG, Q, LDQ, IWORK, DWORK,
     $                      DWORK( IWRK ), LDWORK-IWRK+1, INFO )
            END IF
            OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
C           Real workspace:     need   w5 + 2*NEIG;
C                               prefer w5 + NEIG + NEIG*NB.
C
            CALL DORGQR( N, NEIG, NEIG, Q, LDQ, DWORK, DWORK( IWRK ),
     $                   LDWORK-IWRK+1, INFO )
            OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
            IF( QRP .AND. .NOT.LCMPU )
     $         NEIG = NEIG/2
         END IF
C
      END IF
C
      IF( LCMPU ) THEN
C
C        STEP 6: Compute the companion subspace corresponding to the
C                eigenvalues with strictly negative real part.
C
C        Real workspace:     need   w1 + w2 +   N**2, if ORTH = 'QR'.
C                                   w1 + w2 + 2*N**2, otherwise.
C
C        The workspace used before for storing H and T is reused.
C
C        Set [ U1 U2 ].
C
         CALL DLACPY( 'Full', M, N, DWORK( IU11 ), M, DWORK( IH ), N )
         IW = IH + M
         IS = IU12
         DO 190 J = 1, M
            DO 180 I = 1, M
               DWORK( IW ) = -DWORK( IS )
               IW = IW + 1
               IS = IS + 1
  180       CONTINUE
            IW = IW + M
  190    CONTINUE
         CALL DLACPY( 'Full', M, M, DWORK( IU11 ), M, DWORK( IH+NMM ),
     $                N )
         CALL DLACPY( 'Full', M, N, DWORK( IU21 ), M, DWORK( IT ), N )
         IW = IT + M
         IS = IU22
         DO 210 J = 1, M
            DO 200 I = 1, M
               DWORK( IW ) = -DWORK( IS )
               IW = IW + 1
               IS = IS + 1
  200       CONTINUE
            IW = IW + M
  210    CONTINUE
         CALL DLACPY( 'Full', M, M, DWORK( IU21 ), M, DWORK( IT+NMM ),
     $                N )
C
C        Compute the first NEIG columns of P*[ U3  0; 0 U3 ]*U.
C
         CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE,
     $               DWORK( IU3 ), N, U, LDU, ZERO, DWORK( IWRK ), N2 )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, -ONE,
     $               DWORK( IU3 ), N, U( 1, NP1 ), LDU, ZERO,
     $               DWORK( IWRK+M ), N2 )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE,
     $               DWORK( IU3+M ), N, U, LDU, ZERO, DWORK( IWRK+N ),
     $               N2 )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, -ONE,
     $               DWORK( IU3+M ), N, U( 1, NP1 ), LDU, ZERO,
     $               DWORK( IWRK+N+M ), N2 )
C
C        Compute the companion subspace.
C
         CALL DGEMM( 'No Transpose', 'No Transpose', N, NEIG, N2,
     $               SQRT( TWO )/TWO, DWORK( IH ), N, DWORK( IWRK ), N2,
     $               ZERO, U, LDU )
C
C        Orthogonalize the basis given in U(1:n,1:neig).
C
         IWRK = NEIG + 1
         IF( SVD ) THEN
C
C           Real workspace:     need   N + MAX(1,5*N);
C                               prefer larger.
C
            CALL DGESVD( 'Overwrite', 'No V', N, NEIG, U, LDU, DWORK,
     $                   DWORK, 1,  DWORK, 1, DWORK( IWRK ),
     $                   LDWORK-IWRK+1, INFO )
            IF( INFO.GT.0 ) THEN
               INFO = 4
               RETURN
            END IF
            OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
            NEIG = NEIG/2
C
         ELSE
            IF( QR ) THEN
C
C              Real workspace:     need   N;
C                                  prefer M + M*NB, where NB is the
C                                                   optimal blocksize.
C
               CALL DGEQRF( N, NEIG, U, LDU, DWORK, DWORK( IWRK ),
     $                      LDWORK-IWRK+1, INFO )
            ELSE
C
C              Real workspace:     need   4*N + 1;
C                                  prefer 3*N + (N+1)*NB.
C
               DO 220 J = 1, NEIG
                  IWORK( J ) = 0
  220          CONTINUE
               CALL DGEQP3( N, NEIG, U, LDU, IWORK, DWORK,
     $                      DWORK( IWRK ), LDWORK-IWRK+1, INFO )
            END IF
            OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
C           Real workspace:     need   2*NEIG;
C                               prefer NEIG + NEIG*NB.
C
            CALL DORGQR( N, NEIG, NEIG, U, LDU, DWORK, DWORK( IWRK ),
     $                   LDWORK-IWRK+1, INFO )
            OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
            IF( QRP )
     $         NEIG = NEIG/2
         END IF
C
      END IF
C
      DWORK( 1 ) = OPTDW
      RETURN
C *** Last line of MB03LF ***
      END


module m_prem

  implicit none
  integer, parameter :: DP = 8

contains

  !! ------------------------------------------------------------------------------------------ !!
  !> Return the modified PREM 1D velocity structure
  !!
  !! Compared to the original model of the Diewonski and Anderson (1981), the seawater layer is
  !! substituted to a crustal structure:
  !! rho=2.6 g/cm^3, vp=5.8 km/s, vs=3.2 km/s qmu=600, qkappa = 57823
  !!
  !! This routine returns Q_P and Q_S rather than Q_kappa and Q_mu, by converting using
  !! a formula of (9.59) & (9.60) of Dahlen and Tromp (1998)
  !--
  subroutine prem(z, rho, vp, vs, qp, qs)

    real(DP), intent(in)  :: z      ! depth
    real(DP), intent(out) :: rho    ! density [g/cm^3]
    real(DP), intent(out) :: vp     ! P wavespeed [km/s]
    real(DP), intent(out) :: vs     ! S wavespped [km/s]
    real(DP), intent(out) :: qp     ! Qp
    real(DP), intent(out) :: qs     ! Qs
    !--
    real(DP)              :: r, x   ! Radius, Normalized Radius
    real(DP) :: qk, qm ! Q_kappa, Q_mu
    real(DP) :: qki, qmi, qpi, qsi
    !----

    r = 6371.0_DP - z
    x = r / 6371.0_DP

    if( 0.0 <= r ) then

      if      ( r <= 1221.5_DP ) then                          ! Inner Core
        rho = 13.0885_DP              -  8.8381_DP*x*x
        vp  = 11.2622_DP              -  6.3640_DP*x*x
        vs  =  3.6678_DP              -  4.4475_DP*x*x
        qm  = 84.6_DP
        qk  = 1327.7_DP
      else if ( r <= 3480.0_DP ) then                                ! Outer Core
        rho = 12.5815_DP -  1.2638_DP*x -  3.6426_DP*x*x -  5.5281_DP*x*x*x
        vp  = 11.0487_DP -  4.0362_DP*x +  4.8023_DP*x*x - 13.5732_DP*x*x*x
        vs  = 0.0_DP
        qm  = 1d100
        qk  = 57823_DP
      else if ( r <= 3630.0_DP ) then                            ! Lower Mantle 1
        rho =  7.9565_DP -  6.4761_DP*x +  5.5283_DP*x*x -  3.0807_DP*x*x*x
        vp  = 15.3891_DP -  5.3181_DP*x +  5.5242_DP*x*x -  2.5514_DP*x*x*x
        vs  =  6.9254_DP +  1.4672_DP*x -  2.0834_DP*x*x +  0.9783_DP*x*x*x
        qm  = 312_DP
        qk  = 57823_DP
      else if ( r <= 5600.0_DP ) then                            ! Lower Mantle 2
        rho =  7.9565_DP -  6.4761_DP*x +  5.5283_DP*x*x -  3.0807_DP*x*x*x
        vp  = 24.9520_DP - 40.4673_DP*x + 51.4832_DP*x*x - 26.6419_DP*x*x*x
        vs  = 11.1671_DP - 13.7818_DP*x + 17.4575_DP*x*x -  9.2777_DP*x*x*x
        qm  = 312_DP
        qk  = 57823_DP
      else if ( r <= 5701.0_DP ) then                            ! Lower Mantle 3
        rho =  7.9565_DP -  6.4761_DP*x +  5.5283_DP*x*x -  3.0807_DP*x*x*x
        vp  = 29.2766_DP - 23.6027_DP*x +  5.5242_DP*x*x -  2.5514_DP*x*x*x
        vs  = 22.3459_DP - 17.2473_DP*x -  2.0834_DP*x*x +  0.9783_DP*x*x*x
        qm  = 312_DP
        qk  = 57823_DP
      else if ( r <= 5771.0_DP ) then                         ! Transition zone 1
        rho =  5.3197_DP -  1.4836_DP*x
        vp  = 19.0957_DP -  9.8672_DP*x
        vs  =  9.9839_DP -  4.9324_DP*x
        qm  = 143_DP
        qk  = 57823_DP
      else if ( r <= 5971.0_DP ) then                         ! Transition zone 2
        rho = 11.2494_DP -  8.0298_DP*x
        vp  = 39.7027_DP - 32.6166_DP*x
        vs  = 22.3512_DP - 18.5856_DP*x
        qm  = 143_DP
        qk  = 57823_DP
      else if ( r <= 6151.0_DP ) then                         ! Transition zone 3
        rho =  7.1089_DP -  3.8045_DP*x
        vp  = 20.3926_DP - 12.2569_DP*x
        vs  =  8.9496_DP -  4.4597_DP*x
        qm  = 143_DP
        qk  = 57823_DP
      else if ( r <= 6346.6_DP ) then                                       ! LVZ
        rho =  2.6910_DP +  0.6924_DP*x
        vp  =  4.1875_DP +  3.9382_DP*x
        vs  =  2.1519_DP +  2.3481_DP*x
        qm  = 80_DP
        qk  = 57823_DP
      else if ( r <= 6346.6_DP ) then                                       ! LID
        rho =  2.6910_DP +  0.6924_DP*x
        vp  =  4.1875_DP +  3.9382_DP*x
        vs  =  2.1519_DP +  2.3481_DP*x
        qm  =  600_DP
        qk  =  57823_DP
      else if ( r <= 6356.0_DP ) then                                   ! Crust 1
        rho =  2.900_DP
        vp  =  6.800_DP
        vs  =  3.900_DP
        qm  =  600_DP
        qk  =  57823_DP
      else if ( r <= 6368.0_DP ) then                                   ! Crust 2
        rho =  2.600_DP
        vp  =  5.800_DP
        vs  =  3.200_DP
        qm  =  600_DP
        qk  =  57823_DP
      else if ( r <= 6371.0_DP ) then                                   ! Crust 3
        rho =  2.600_DP
        vp  =  5.800_DP
        vs  =  3.200_DP
        qm  =  600_DP
        qk  =  57823_DP
      end if

    else
      rho = 0.0_DP
      vp  = 0.0_DP
      vs  = 0.0_DP                            ! for illegal value
      qm  = 0.0_DP
      qk  = 0.0_DP
    end if

    ! atetnuation
    qmi = 1._dp / qm
    qki = 1._dp / qm
    qpi = ( 1.0_dp - (4.0_dp/3.0_dp)*vs*vs/vp/vp ) * qki &
        + 4.0_dp/3.0_dp * vs*vs/vp/vp * qmi
    qsi = qmi
    qp = 1.0_dp / qpi
    qs = 1.0_dp / qsi

  end subroutine prem

end module m_prem


subroutine ztz(z1,z2,nz,z,t)
   implicit none;
 integer*4::i,nz,Lt;
 real*8,dimension(nz)::z,t;
 real*8::tt1,tt2,z1,z2;

tt1=-1.240191545d10*z1+4.703083872d7+68927.1838&
&*sqrt(3.240302366d10*z1**2-1.868729701d9*z1+3.940756737d10);
tt2=-1.240191545d10*z2+4.703083872d7+68927.1838&
&*sqrt(3.240302366d10*z2**2-1.868729701d9*z2+3.940756737d10);

t=(/((tt1-(tt1-tt2)/(nz-1)*Lt),Lt=0,nz-1)/);

!z=(1.083246344d-7*t+30.42868464-5.196107687d-16&
!&*(4.349933656d16*t**2+2.431136021d25*t-2.567258996d33)**.5);

z=8.996389210d-8*t+27.97049162-&
&sqrt(8.100755915d-15*t**2+5.031986252d-6*t-5.757618738d2);

z(1)=z1;
   return;
end subroutine


submodule(euler_interface_m) euler_prob_0047_m
    implicit none

contains

    module character(len=20) function euler0047()
        write (euler0047, "(i20)") ans(1000000)
    end function euler0047

    integer function ans(n)
        integer, intent(in) :: n
        integer :: i, j, n_factor(n), goal(4)

        n_factor = 0

        outer: do i = 2, n - 1

            if (n_factor(i) == 0) then
                inner: do j = 2*i, n - 1, i
                    n_factor(j) = n_factor(j) + 1
                end do inner
            end if

        end do outer

        goal = [4, 4, 4, 4]

        do i = 2, n - 1
            if (all(n_factor(i:i + 3) == goal(:))) exit
        end do

        ans = i
    end function ans
end submodule euler_prob_0047_m


c
c     Calculate inverse of square matrix
c     Author: Pearu Peterson, March 2002
c
c     prefixes: d,z,s,c   (double,complex double,float,complex float)
c     suffixes: _c,_r     (column major order,row major order)

      subroutine dinv_c(a,n,piv,work,lwork,info)
      integer n,piv(n),lwork

      double precision a(n,n),work(lwork)
cf2py callprotoargument double*,int*,int*,double*,int*,int*

cf2py intent(in,copy,out,out=inv_a) :: a
cf2py intent(out) :: info
cf2py integer intent(hide,cache),depend(n),dimension(n) :: piv
cf2py integer intent(hide),depend(a) :: n = shape(a,0)
cf2py check(shape(a,0)==shape(a,1)) :: a
cf2py intent(hide,cache) :: work
cf2py depend(lwork) :: work
cf2py integer intent(hide),depend(n) :: lwork = 30*n
      external dgetrf,dgetri
      call dgetrf(n,n,a,n,piv,info)
      if (info.ne.0) then
         return
      endif
      call dgetri(n,a,n,piv,work,lwork,info)
      end

      subroutine dinv_r(a,n,piv,info)
      integer n,piv(n)
      double precision a(n,n)
cf2py callprotoargument double*,int*,int*,int*

cf2py intent(c,in,copy,out,out=inv_a) :: a
cf2py intent(out) :: info
cf2py integer intent(hide,cache),depend(n),dimension(n) :: piv
cf2py integer intent(hide),depend(a) :: n = shape(a,0)
cf2py check(shape(a,0)==shape(a,1)) :: a
      external flinalg_dinv_r
      call flinalg_dinv_r(a,n,piv,info)
      end


!! # check to see if value exceeds threshold

logical function transport_exceeds_th(blockno,qval,qmin,qmax,quad, &
                                      dx,dy,xc,yc,threshhold)
    implicit none

    double precision :: qval,qmin,qmax,threshhold, quad(-1:1,-1:1)
    double precision :: dx,dy, xc, yc
    integer :: blockno
    logical :: refine

    double precision :: dx2, dy2, dqx,dqy, ds, d, nx, ny
    double precision :: xp,yp,zp,xpm, xpp, ypm, ypp

    integer*8 cont, get_context
    logical fclaw2d_map_is_used

    cont = get_context()

!!    IF (fclaw2d_map_is_used(cont)) THEN
!!        CALL fclaw2d_map_c2m(cont,blockno,xc,yc,xp,yp,zp)
!!        CALL fclaw2d_map_c2m(cont,blockno,xc+dx,yc,xpp,yp,zp)
!!        CALL fclaw2d_map_c2m(cont,blockno,xc-dx,yc,xpm,yp,zp)
!!        CALL fclaw2d_map_c2m(cont,blockno,xc,yc+dy,xp,ypp,zp)
!!        CALL fclaw2d_map_c2m(cont,blockno,xc,yc-dy,xp,ypm,zp)
!!        dx2 = xpp - xpm
!!        dy2 = ypp - ypm
!!    ELSE
!!        dx2 = 2*dx
!!        dy2 = 2*dy
!!        xp = xc
!!        yp = yc
!!    ENDIF

    refine = .false.

!!     dqx = abs(quad(1,0) - quad(-1,0))/dx2
!!     dqy = abs(quad(0,1) - quad(0,-1))/dy2
!!     d = sqrt(xp**2 + yp**2)
!!     nx = xp/d
!!     ny = yp/d
!!     ds = abs(dqx*nx + dqy*ny)

    ds = qval
    if (ds .gt. threshhold) then
        refine = .true.
    endif

    transport_exceeds_th = refine

end function transport_exceeds_th


           SUBROUTINE RK41(Y1,DYDX1,N1,X1,H1,YOUT1)
           PARAMETER(BIG1=1.00E+03,SMALL1=1.00E-03)
           DIMENSION Y1(N1),DYDX1(N1),YOUT1(N1),YT1(N1),DYT1(N1),
     > DYM1(N1)
         HH1=H1*0.5
         H61=H1/6.00
         XH1=X1+HH1
c		 write(*,*) 'in rk41, N1',N1
          DO 11 I=1,N1
           YT1(I)=Y1(I)+HH1*DYDX1(I)
 11        CONTINUE
           CALL derivs1(XH1,YT1,DYT1,N1)
           DO 12 I=1,N1
           YT1(I)=Y1(I)+HH1*DYT1(I)
 12         CONTINUE
           CALL derivs1(XH1,YT1,DYM1,N1)
           DO 13 I=1,N1
           YT1(I)=Y1(I)+H1*DYM1(I)
           DYM1(I)=DYT1(I)+DYM1(I)
 13         CONTINUE
           CALL derivs1(X1+H1,YT1,DYT1,N1)
           DO 14 I=1,N1
           YOUT1(I)=Y1(I)+H61*(DYDX1(I)+DYT1(I)+2.00*DYM1(I))
 14         CONTINUE
           RETURN
             END


PROGRAM LA_SSTEVR_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => SP
   USE F95_LAPACK, ONLY: LA_STEVR
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
   CHARACTER(LEN=*), PARAMETER :: FMTR = '(8(1X,F10.3))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
      INTEGER :: I, INFO, N, M, IL, IU, NNN
      REAL(WP) :: VL, VU
!  .. LOCAL ARRAYS ..
      INTEGER,ALLOCATABLE :: ISUPPZ(:)
   REAL(WP), ALLOCATABLE :: D(:), DD(:), E(:), EE(:), W(:), Z(:,:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'SSTEVR ET_Example Program Results.'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) N
      PRINT *, 'N = ', N
      NNN=2*MAX(1,N)
      ALLOCATE ( D(N), DD(N), E(N), EE(N), W(N), Z(N,N), ISUPPZ(NNN) )
      INFO = 0; M=N
!
      READ (NIN, *) DD
      READ (NIN, *) EE
   WRITE(NOUT,*) 'The matrix A:'
   WRITE (NOUT,*) 'D'; WRITE (NOUT,FMTR) DD
   WRITE (NOUT,*) 'E'; WRITE (NOUT,FMTR) EE
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_SSTEVR LAPACK Subroutine Results.'
   WRITE ( NOUT, * )
!
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_STEVR( D, E, W, INFO=INFO )'
      D=DD; E=EE
      CALL LA_STEVR( D, E, W, INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO, ' EIGENVALUES:'
      WRITE(NOUT,FMTR) W
!
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_STEVR( D, E, W, Z=Z, INFO=INFO )'
      D=DD; E=EE
      CALL LA_STEVR( D, E, W, Z=Z, INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO, ' EIGENVALUES:'
      WRITE(NOUT,FMTR) W
      WRITE(NOUT,*) 'EIGENVECTORS:'
      DO I = 1, M; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMTR) Z(:,I); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_STEVR( D, E, W, VL=3.0_WP, M=M, INFO=INFO )'
   D=DD; E=EE
      CALL LA_STEVR( D, E, W, VL=3.0_WP, M=M, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO, ' EIGENVALUES:'
   WRITE(NOUT,*) 'The total number of eigenvalues found is ', M
   WRITE(NOUT,FMTR) W(1:M)
!
      VL= -HUGE(1.0_WP); VU=HUGE(1.0_WP)
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_STEVR( D, E, W, Z, -HUGE(1.0_WP), HUGE(1.0_WP), M=M, ISUPPZ=ISUPPZ, INFO=INFO)'
      D=DD; E=EE; M=N; Z = HUGE(1.0_WP); W = HUGE(1.0_WP)
      CALL LA_STEVR( D, E, W, Z, -HUGE(1.0_WP), HUGE(1.0_WP), M=M, ISUPPZ=ISUPPZ, INFO=INFO)
      WRITE(NOUT,*) 'M, INFO, EIGENVALUES:', M, INFO
      WRITE(NOUT,FMTR) W
      WRITE(NOUT,*) 'EIGENVECTORS:'
      DO I = 1, M; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMTR) Z(:,I); END DO
        WRITE(NOUT,*) 'ISUPPZ:'; WRITE (NOUT,*) ISUPPZ
!
      IL=2; IU=N
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_STEVR( D, E, W, Z, IL=2, IU=N, M=M, ISUPPZ=ISUPPZ, INFO=INFO)'
      D=DD; E=EE; M=N; Z = HUGE(1.0_WP); W = HUGE(1.0_WP)
      CALL LA_STEVR( D, E, W, Z, IL=IL, IU=IU, M=M, ISUPPZ=ISUPPZ, INFO=INFO)
      WRITE(NOUT,*) 'M, INFO, EIGENVALUES:', M, INFO
      WRITE(NOUT,FMTR) W
      WRITE(NOUT,*) 'EIGENVECTORS:'
      DO I = 1, M; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMTR) Z(:,I); END DO
        WRITE(NOUT,*) 'ISUPPZ:'; WRITE (NOUT,*) ISUPPZ
! ERROR 2
      VL = 1; VU = 10;
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_STEVR( D, E(1:N+3), W, Z, VL, VU, M=M, ISUPPZ=ISUPPZ, INFO=INFO )'
      D=DD; E=EE; Z = HUGE(1.0_WP)
      CALL LA_STEVR(  D, E(1:N+3), W, Z, VL, VU, M=M, ISUPPZ=ISUPPZ, INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 3
      VL = 1; VU = 10;
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_STEVR( D, E, W(1:N-1), Z, VL, VU, M=M, ISUPPZ=ISUPPZ, INFO=INFO )'
      D=DD; E=EE; Z = HUGE(1.0_WP)
      CALL LA_STEVR(  D, E, W(1:N-1), Z, VL, VU, M=M, ISUPPZ=ISUPPZ, INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 4
      VL = 1; VU = 10;
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_STEVR( D, E, W, Z(:,1:N-1), VL, VU, M=M, ISUPPZ=ISUPPZ, INFO=INFO )'
      D=DD; E=EE; Z = HUGE(1.0_WP)
      CALL LA_STEVR(  D, E, W, Z(:,1:N-1), VL, VU, M=M, ISUPPZ=ISUPPZ, INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 4
      VL = 1; VU = 10;
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_STEVR( D, E, W, Z(1:N-1,:), VL, VU, M=M, ISUPPZ=ISUPPZ, INFO=INFO )'
      D=DD; E=EE; Z = HUGE(1.0_WP)
      CALL LA_STEVR(  D, E, W, Z(1:N-1,:), VL, VU, M=M, ISUPPZ=ISUPPZ, INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 5
      VL = 1; VU = 10;
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_STEVR( D, E, W, VL=VL, VU=VU, M=M, ISUPPZ=ISUPPZ, INFO=INFO )'
      D=DD; E=EE; Z = HUGE(1.0_WP)
      CALL LA_STEVR(  D, E, W, VL=VL, VU=VU, M=M, ISUPPZ=ISUPPZ, INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 5
      VL = 1; VU = 10;
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_STEVR( D, E, W, Z, VL, VU, M=M, ISUPPZ=ISUPPZ(1:MAX(1,N)-3), INFO=INFO )'
      D=DD; E=EE; Z = HUGE(1.0_WP)
      CALL LA_STEVR(  D, E, W, Z, VL, VU, M=M, ISUPPZ=ISUPPZ(1:MAX(1,N)-3), INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 6
      VL = 2; VU = VL-1;
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_STEVR( D, E, W, Z, VL, VU, M=M, ISUPPZ=ISUPPZ, INFO=INFO )'
      D=DD; E=EE; Z = HUGE(1.0_WP)
      CALL LA_STEVR(  D, E, W, Z, VL, VU, M=M, ISUPPZ=ISUPPZ, INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 7
      IL = 1; IU = N; VL = 1; VU =10;
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_STEVR( D, E, W, Z, VL, VU, IL, IU, M, ISUPPZ=ISUPPZ, INFO=INFO )'
      D=DD; E=EE; Z = HUGE(1.0_WP)
      CALL LA_STEVR(  D, E, W, Z, VL, VU, IL, IU, M, ISUPPZ=ISUPPZ, INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 8
      IL=1; IU=IL-1
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_STEVR( D, E, W, Z, IL=IL, IU=IU, M=M, ISUPPZ=ISUPPZ, INFO=INFO )'
      D=DD; E=EE; Z = HUGE(1.0_WP)
      CALL LA_STEVR(  D, E, W, Z, IL=IL, IU=IU, M=M, ISUPPZ=ISUPPZ, INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 8
      IL=-1; IU=N
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_STEVR( D, E, W, Z, ISUPPZ, IL=IL, IU=IU, M=M, INFO=INFO )'
      D=DD; E=EE; Z = HUGE(1.0_WP)
      CALL LA_STEVR(  D, E, W, Z, IL=IL, IU=IU, M=M, ISUPPZ=ISUPPZ, INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 9
      IL=1; IU=N+1
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_STEVR( D, E, W, Z, IL=IL, IU=IU, M=M, ISUPPZ=ISUPPZ, INFO=INFO )'
      D=DD; E=EE; Z = HUGE(1.0_WP)
      CALL LA_STEVR(  D, E, W, Z, IL=IL, IU=IU, M=M, ISUPPZ=ISUPPZ, INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
END!PROGRAM LA_SSTEVR_ET_EXAMPLE


        subroutine iddp_aid1(eps,n2,n,kranki,proj,krank,list,rnorms)
c
c       IDs the uppermost kranki x n block of the n2 x n matrix
c       input as proj.
c
c       input:
c       eps -- precision of the decomposition to be constructed
c       n2 -- first dimension of proj as input
c       n -- second dimension of proj as input
c       kranki -- number of rows to extract from proj
c       proj -- matrix containing the kranki x n block to be ID'd
c
c       output:
c       proj -- matrix of coefficients needed to interpolate
c               from the selected columns to the other columns
c               in the original matrix being ID'd
c       krank -- numerical rank of the ID
c       list -- indices of the columns in the ID
c
c       work:
c       rnorms -- must be at least n real*8 elements long
c
        implicit none
        integer n,n2,kranki,krank,list(n),j,k
        real*8 eps,proj(n2*n),rnorms(n)
c
c
c       Move the uppermost kranki x n block of the n2 x n matrix proj
c       to the beginning of proj.
c
        do k = 1,n
          do j = 1,kranki
            proj(j+kranki*(k-1)) = proj(j+n2*(k-1))
          enddo ! j
        enddo ! k
c
c
c       ID proj.
c
        call iddp_id(eps,kranki,n,proj,krank,list,rnorms)
c
c
        return
        end
c
c
c
c


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
!  Module containting some physical and precision constants.
!===============================================================================
   module constants
!===============================================================================
      implicit none

!  ** size constants
      integer, parameter :: i4 = selected_int_kind(9) ; ! long int
      integer, parameter :: r4 = selected_real_kind(6,37) ; ! SP
      integer, parameter :: r8 = selected_real_kind(15,307) ; ! DP

!  ** precision selector
      integer, parameter, public :: rs = r8

!  ** maths constants and other useful things
      real(r8), parameter :: pi = 3.141592653589793238462643d0 ;
      real(r8), parameter :: to_rad = 1.74532925199433D-002 ;
      real(r8), parameter :: to_deg = 57.2957795130823d0 ;
      real(r8), parameter :: to_km = 111.194926644559 ;

      real(r8), parameter :: big_number = 10.d36 ;
      real(r8), parameter :: Earth_radius = 6371.d0 ;

!  ** IO direction
      integer, parameter :: lu_stderr = 0
      integer, parameter :: lu_stdin  = 5
      integer, parameter :: lu_stdout = 6

   end module constants
!===============================================================================


! PR15619
! Check that random_seed works as expected.
! Does not check the quality of random numbers, hence should never fail.
program test_random
  implicit none
  integer, allocatable :: seed(:)
  real, dimension(10) :: a, b
  integer n;

  call random_seed (size=n)
  allocate (seed(n))

  ! Exercise the generator a bit.
  call random_number (a)

  ! Remeber the seed and get 10 more.
  call random_seed (get=seed)
  call random_number (a)

  ! Get the same 10 numbers in two blocks, remebering the seed in the middle
  call random_seed (put=seed)
  call random_number (b(1:5))
  call random_seed(get=seed)
  call random_number (b(6:10))
  if (any (a .ne. b)) call abort

  ! Get the last 5 numbers again.
  call random_seed (put=seed)
  call random_number (b(6:10))
  if (any (a .ne. b)) call abort
end program


      PROGRAM LA_SSBGVX_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_SBGVX
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, M, N, KD
      REAL(WP) :: VL, VU
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: A(:,:), B(:,:), W(:), Z(:,:), Q(:,:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_SBGVX Example Program Results'
      N = 5; KD = 2;
      ALLOCATE( A(KD+1,N), B(KD+1,N), W(N), Z(N,N), Q(N,N) )

      OPEN(UNIT=21,FILE='sbgvu.ma',STATUS='UNKNOWN')
      DO I=1,KD+1
         DO J=1,N
            READ(21,*) A(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      WRITE(*,*)'Matrix A : '
      DO I=1,KD+1;
         WRITE(*,"(5(I3,1X))") INT(A(I,:));
      ENDDO

      OPEN(UNIT=21,FILE='sbgvu.mb',STATUS='UNKNOWN')
      DO I=1,KD+1
         DO J=1,N
            READ(21,*) B(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      WRITE(*,*)'Matrix B : '
      DO I=1,KD+1;
         WRITE(*,"(5(I3,1X))") INT(B(I,:));
      ENDDO

      WRITE(*,*)
      WRITE(*,*) 'CALL LA_SBGVX( A, B, W, Z=Z, VL=0.0_WP, VU=100.0_WP, M=M, Q=Q )'
      VL=0; VU=100
      CALL LA_SBGVX(  A, B, W, Z=Z, VL=0.0_WP, VU=100.0_WP, M=M, Q=Q )

      WRITE(*,*) ' W on exit : '
      DO I=1,N
      WRITE(*,"(5(E14.6,1X))") W(I)
      ENDDO

      WRITE(*,*) ' M = ',M

      WRITE(*,*) ' Matrix Q on exit : '
      DO I=1,N
         WRITE(*,'(5(E14.6,1X))') Q(I,:)
      ENDDO

      END PROGRAM LA_SSBGVX_EXAMPLE