      DOUBLE PRECISION FUNCTION D1MACH(I)
C
C  Double-precision machine constants.
C  This implementation for use in MATLAB Fortran Mex-files.
C
C  D1MACH(1) = realmin = B**(EMIN-1), the smallest positive magnitude.
C  D1MACH(2) = realmax = B**EMAX*(1 - B**(-T)), the largest magnitude.
C  D1MACH(3) = eps/2 = B**(-T), the smallest relative spacing.
C  D1MACH(4) = eps = B**(1-T), the largest relative spacing.
C  D1MACH(5) = LOG10(B)
C
c  DLAMCH
*          = 'E' or 'e',   DLAMCH := eps
*          = 'S' or 's ,   DLAMCH := sfmin
*          = 'B' or 'b',   DLAMCH := base
*          = 'P' or 'p',   DLAMCH := eps*base
*          = 'N' or 'n',   DLAMCH := t
*          = 'R' or 'r',   DLAMCH := rnd
*          = 'M' or 'm',   DLAMCH := emin
*          = 'U' or 'u',   DLAMCH := rmin
*          = 'L' or 'l',   DLAMCH := emax
*          = 'O' or 'o',   DLAMCH := rmax
*
*          where
*
*          eps   = relative machine precision
*          sfmin = safe minimum, such that 1/sfmin does not overflow
*          base  = base of the machine
*          prec  = eps*base
*          t     = number of (base) digits in the mantissa
*          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise
*          emin  = minimum exponent before (gradual) underflow
*          rmin  = underflow threshold - base**(emin-1)
*          emax  = largest exponent before overflow
*          rmax  = overflow threshold  - (base**emax)*(1-eps)
*

      double precision DLAMCH
      IF (I .EQ. 1) D1MACH = DLAMCH('U')
      IF (I .EQ. 2) D1MACH = DLAMCH('O')
      IF (I .EQ. 3) D1MACH = DLAMCH('E')
      IF (I .EQ. 4) D1MACH = DLAMCH('P')
      IF (I .EQ. 5) D1MACH = log10(DLAMCH('B'))
      RETURN
      END


       SUBROUTINE HANGLE (E,Y,D,BHA,H,HA,I)
C              HANGLE COMPUTES THE HOUR ANGLE (RAD) FROM THE MEAN
C              EQUINOX AT THE BEGINNING OF THE NEAREST BESSELIAN
C              YEAR TO GREENWICH
C
C              E    EPOCH YEAR
C              Y    YEAR
C              D    DAY
C              BHA  HOUR ANGLE AT MIDNIGHT OF INITIALIZATION DAY
C              H    HOURS FROM MIDNIGHT OF INITIALIZATION DAY
C              HA    HOUR ANGLE OF GREENWICH AT H
C              I    ZERO FOR INITIALIZATION , ONE AFTER
       DOUBLE PRECISION BHA,DELTA,W1,W2,HA,PI2,H,XN,C,B,A,T,DE,YRS
       DATA W1/1.720217954160054D-2/,
     1 W2/2.625151452800495D-1/,
     2 A/0.0929D0/,
     3 B/8640184.542D0/,
     4 PI2/6.2831853071795865D0/
       IF (I.EQ.1) GO TO 10
       YRS = E -1900.
      IIN=(E-1901.)/4.
      XN=IIN
       C   =  -86400.0D00*  YRS -74.164D00
       T   =  2.0D00 * C / (-8 -DSQRT( B*8 - 4.0D00*A *C))
C      T IS THE SOLUTION TO NEWCOMB'S EQN. FOR THE BEGINNING OF
C      THE BESSELIAN YEAR IN JULIAN CENTURIES - EXP. SUP. EPH P.30.73
       DE  = 36525.0D00* t - 365.0D00* YRS -XN +.5D00
C      DE IS JULIAN CENTURIES CONVERTED TO DAYS FROM JAN 0.0
       X   = AMOD (Y,4.)
       DI  = D
       IF(Y.NE.E.AND.X.EQ.0.)DI=D-366.0D00
       IF(Y.NE.E.AND.X.NE.0.)DI=D-365.0D00
       DELTA = DI-DE
       BHA   = PI2/3.6D00 + W1 * DELTA
   10  HA    =  DMOD (BHA + W2 * H , PI2)
       RETURN
       END


!> 计算人工热量的子程序。详见 Monaghan (1992), Fulk (1994) 或第 4 章中的论述。
!> subroutine to calculate the artificial heat(fulk, 1994, p, a-17)
!> see equ.(4.74)
subroutine art_heat(ntotal, hsml, mass, x, vx, niac, rho, u, c, pair_i, pair_j, w, dwdx, dedt)

    use sph_kind, only: rk
    use parameter
    implicit none

    !> 在模拟中所使用的粒子总数
    !> number of particles in simulation
    integer, intent(in) :: ntotal
    !> 光滑长度
    !> smoothing length
    real(rk), intent(in) :: hsml(maxn)
    !> 粒子的质量
    !> particle masses
    real(rk), intent(in) :: mass(maxn)
    !> 粒子的坐标
    !> particle coordinates
    real(rk), intent(in) :: x(dim, maxn)
    !> 粒子的速度
    !> particle velocities
    real(rk), intent(in) :: vx(dim, maxn)
    !> 粒子的密度
    !> particle density
    real(rk), intent(in) :: rho(maxn)
    !> 粒子的特殊内部能量
    !> particle specific internal energy
    real(rk), intent(in) :: u(maxn)
    !> 粒子的声速
    !> particle sound velocity
    real(rk), intent(in) :: c(maxn)
    !> 粒子之间的互动对数
    !> number of interaction pairs
    integer, intent(in) :: niac
    !> 粒子之间的互动对的第一个粒子
    !> first partner of interaction pair
    integer, intent(in) :: pair_i(max_interaction)
    !> 粒子之间的互动对的第二个粒子
    !> second partner of interaction pair
    integer, intent(in) :: pair_j(max_interaction)
    !> 互动对的核函数
    !> kernel for all interaction pairs
    real(rk), intent(in) :: w(max_interaction)
    !> 互动对的核函数的导数
    !> derivative of kernel with respect to x, y and z
    real(rk), intent(in) :: dwdx(dim, max_interaction)
    !> 生成的人工热量
    !> produced artificial heat, adding to energy eq.
    real(rk), intent(out) :: dedt(maxn)

    integer :: i, j, k, d
    real(rk) :: dx, dvx(dim), vr, rr, h, mc, mrho, mhsml, vcc(maxn), hvcc, mui, muj, muij, rdwdx, g1, g2

    !---  parameter for the artificial heat conduction:

    g1 = 0.1_rk
    g2 = 1.0_rk
    do i = 1, ntotal
        vcc(i) = 0._rk
        dedt(i) = 0._rk
    end do

    do k = 1, niac

        i = pair_i(k)
        j = pair_j(k)
        do d = 1, dim
            dvx(d) = vx(d, j) - vx(d, i)
        end do
        hvcc = dvx(1)*dwdx(1, k)
        do d = 2, dim
            hvcc = hvcc + dvx(d)*dwdx(d, k)
        end do
        vcc(i) = vcc(i) + mass(j)*hvcc/rho(j)
        vcc(j) = vcc(j) + mass(i)*hvcc/rho(i)

    end do

    do k = 1, niac

        i = pair_i(k)
        j = pair_j(k)
        mhsml = (hsml(i) + hsml(j))/2._rk
        mrho = 0.5_rk*(rho(i) + rho(j))
        rr = 0._rk
        rdwdx = 0._rk
        do d = 1, dim
            dx = x(d, i) - x(d, j)
            rr = rr + dx*dx
            rdwdx = rdwdx + dx*dwdx(d, k)
        end do
        mui = g1*hsml(i)*c(i) + g2*hsml(i)**2*(abs(vcc(i)) - vcc(i))
        muj = g1*hsml(j)*c(j) + g2*hsml(j)**2*(abs(vcc(j)) - vcc(j))
        muij = 0.5_rk*(mui + muj)
        h = muij/(mrho*(rr + 0.01_rk*mhsml**2))*rdwdx
        dedt(i) = dedt(i) + mass(j)*h*(u(i) - u(j))
        dedt(j) = dedt(j) + mass(i)*h*(u(j) - u(i))

    end do

    do i = 1, ntotal
        dedt(i) = 2.0_rk*dedt(i)
    end do

end subroutine art_heat


!==========================================================================
module gsw_mod_sp_coefficients
!==========================================================================
!
!--------------------------------------------------------------------------

use gsw_mod_kinds

implicit none

real (r8), parameter :: a0 =  0.0080_r8
real (r8), parameter :: a1 = -0.1692_r8
real (r8), parameter :: a2 = 25.3851_r8
real (r8), parameter :: a3 = 14.0941_r8
real (r8), parameter :: a4 = -7.0261_r8
real (r8), parameter :: a5 =  2.7081_r8

real (r8), parameter :: b0 =  0.0005_r8
real (r8), parameter :: b1 = -0.0056_r8
real (r8), parameter :: b2 = -0.0066_r8
real (r8), parameter :: b3 = -0.0375_r8
real (r8), parameter :: b4 =  0.0636_r8
real (r8), parameter :: b5 = -0.0144_r8

real (r8), parameter :: c0 =  0.6766097_r8
real (r8), parameter :: c1 =  2.00564e-2_r8
real (r8), parameter :: c2 =  1.104259e-4_r8
real (r8), parameter :: c3 = -6.9698e-7_r8
real (r8), parameter :: c4 =  1.0031e-9_r8

real (r8), parameter :: d1 =  3.426e-2_r8
real (r8), parameter :: d2 =  4.464e-4_r8
real (r8), parameter :: d3 =  4.215e-1_r8
real (r8), parameter :: d4 = -3.107e-3_r8

real (r8), parameter :: e1 =  2.070e-5_r8
real (r8), parameter :: e2 = -6.370e-10_r8
real (r8), parameter :: e3 =  3.989e-15_r8

real (r8), parameter :: k  =  0.0162_r8

end module

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


module name1

      use stel_kinds, only: dp

      implicit none

      integer, parameter :: nsd     = 10 ! 41       ! number of flux surfaces
      integer, parameter :: mpol    =  7 ! 9        ! number of poloidal modes incl. 0
      integer, parameter :: nmax    =  6 ! 13       ! number of toroidal modes 2*nmax+1 (?)
      integer, parameter :: ntheta  = 32 ! 36       ! number of poloidal grid points
      integer, parameter :: nzeta   = 22 ! 44       ! number of toroidal grid points
      integer, parameter :: nvac    =  0            ! fixed-boundary (0) or free-boundary (1)

      integer, parameter :: nsd1    = nsd+1         ! number of flux surfaces + 1
      integer, parameter :: ntheta1 = 2*(ntheta/2)  ! even version of ntheta
      integer, parameter :: ntheta2 = 1+ntheta1/2   ! stellarator-symmetric reduction of ntheta1
      integer, parameter :: nznt    = nzeta*ntheta2 ! number of surface grid points
      integer, parameter :: nrztd   = nznt*nsd+1    ! number of grid points in volume (+1 ?)
      integer, parameter :: mpol1   = mpol-1        ! highest occuring poloidal mode number
      integer, parameter :: nmax1   = nmax+1        ! number of toroidal coefficients per set of basis functions
      integer, parameter :: mnd     = mpol*nmax1    ! total number of Fourier coefficients per set of basis functions
      integer, parameter :: mnd1    = mnd-1         ! total number of Fourier coefficients per set of basis functions - 1
      integer, parameter :: mnd2    = 2*mnd         ! 2 x total number of Fourier coefficients per set of basis functions
      integer, parameter :: mnmax   = nmax1+mpol1*(1+2*nmax) ! total number of Fourier coefficients per surface
      integer, parameter :: neq     = 6*nsd*mnd     ! total number of free parameters

end module name1


	INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44
C-----THIS IS A TEST PROGRAM FOR MODULES  dfft AND REALTR
C-----THESE MODULES ARE USED TOGETHER SO ARE TESTED TOGETHER.
C-----A REAL*4 IMAGE IS INPUT (CREATED WITH GEN.
      DIMENSION A(16,18)

	M = 16
	N = 16
        CALL XVUNIT(IUNIT,'INP',1,STAT, ' ')
        CALL XVOPEN(IUNIT,STAT,' ')
	DO I=1,M
           CALL XVREAD(IUNIT,A(1,I),STAT,'LINE',I,'NSAMPS',N, ' ')
        END DO
	M2 = M/2
      IF ( 2*M2 .NE. M ) GO TO 930
C THAT BECAUSE THE DIMENSION MUST BE EVEN IN THE REAL TRANSFORM
C DIRECTION.
      MP2=M + 2
      N2 = 2*N
C
C FORWARD TRANSFORM..
	DO 110 I=1,M
110	CALL PRNT(7,N,A(1,I), 'BEFORE.')
C
      DO 120 I=1,N
      CALL dfft(A(I,1),A(I,2),M2,M2,M2,N2,&950,&960)
      CALL REALTR(A(I,1),A(I,2),M2,N2)
120   CONTINUE
      DO 140 I=2,MP2,2
      CALL dfft(A(1,I-1),A(1,I),N,N,N,1,&950,&960)
140   CONTINUE
	CALL XVMESSAGE( 'THE RESULTING TRANSFORM', ' ')
	DO 130 I=1,MP2
130	CALL PRNT(7,N,A(1,I), 'TRANSFORM.')
C
C THE INVERSE TRANSFORM..
C
      DO 220 I=2,MP2,2
      CALL dfft(A(1,I-1),A(1,I),N,N,N,-1,&950,&960)
220   CONTINUE
      DO 240 I=1,N
      CALL REALTR(A(I,1),A(I,2),M2,-N2)
      CALL dfft(A(I,1),A(I,2),M2,M2,M2,-N2,&950,&960)
240   CONTINUE
	CALL XVMESSAGE( 'REVERSE THE TRANSFORM', ' ')
	S = 2*M*N
	DO 160 I=1,M
        DO J = 1, N
           A(J,I) = A(J,I)/S
        END DO
160	CALL PRNT(7,N,A(1,I), 'AFTER.')
      CALL XVCLOSE(IUNIT,STAT, ' ')
      RETURN
C
930 	CALL XVMESSAGE( 'NUMBER OF LINES MUST BE EVEN', ' ')
	RETURN
C
950 	CALL XVMESSAGE( 'M OR N HAS TOO LARGE A PRIME FACTOR', ' ')
	RETURN
C
960	CALL XVMESSAGE(
     +  'PRODUCT OF SQUARE-FREE FACTORS OF M OR N TOO BIG',' ')
	RETURN

      END
C************************* START PDF *************************
CPROCESS
CPARM 	INP	TYPE=STRING
CEND-PROC
C**************************** END PDF ***************************


*------------------------------------------------------------------------*
      subroutine inv_pack_op(mel_in,mel_out,ndim)
*------------------------------------------------------------------------*
*     Diagonalise a "packed" operator
*
*     mel_in -> contains a "packed" operator of dimension ndim
*     mel_out -> return the "packed" inverse
*
*     See file prod_packed_op.f for a description on how the elements
*     are packed.
*
*     yuri, set 2015
*------------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'
      include 'def_filinf.h'
      include 'def_operator.h'
      include 'def_me_list.h'
      include 'def_orbinf.h'

      type(me_list), intent(inout) ::
     &     mel_in, mel_out
      integer, intent(in) ::
     &     ndim

      type(operator), pointer ::
     &     op
      type(filinf), pointer ::
     &     ffop
      logical ::
     &     closeit
      integer ::
     &     ic, il, irec, ioff, irec_ini
      real(8), allocatable ::
     &     M_ini(:,:), M_inv(:,:),M(:,:)

      real(8) ::
     &     det, A, B, C, D, E, F, G, H, I

      real(8), parameter ::
     &     zero_thr = 1d-10

      allocate(M(ndim,ndim),
     &     M_ini(ndim,ndim),
     &     M_inv(ndim,ndim))

      ffop => mel_in%fhand
      op => mel_in%op
      if (.not.associated(ffop))
     &     call quit(1,'inv_packed_op','No file assigned to list: '//
     &     trim(mel_in%label))
      if (ffop%unit.le.0) then
       call file_open(ffop)
       closeit = .true.
      else
       closeit = .false.
      end if
      if(ndim*ndim.ne.
     &     (ffop%active_records(2)-ffop%active_records(1)+1))
     &     call quit(1,'inv_packed_op',
     &     'inconsistent number of records in input list!'//
     &     ' It must be equal the square ndim')

!--------------------
!     Get matrix
      irec_ini = ffop%current_record
      il = 1
      ic = 1
      do irec = ffop%active_records(1),ffop%active_records(2)
       call switch_mel_record(mel_in,irec)
       ioff = ffop%length_of_record*(ffop%current_record-1)
       call get_vec(ffop,M_ini(il:il,ic:ic),ioff+1,ioff+1)
       if(mod(irec - ffop%active_records(1) + 1,ndim).eq.0)then
        il = 1
        ic = ic+1
       else
        il = il+1
       end if
      end do
      call switch_mel_record(mel_in,irec_ini)
      if (closeit)
     &     call file_close_keep(ffop)

! ndim = 2, 3 can be directly
      if (ndim.EQ.2) then
       det = M_ini(1,1)*M_ini(2,2) - M_ini(1,2)*M_ini(2,1)

       M_inv(1,1) =  M_ini(2,2)/det
       M_inv(2,1) = -M_ini(1,2)/det
       M_inv(1,2) = -M_ini(2,1)/det
       M_inv(2,2) =  M_ini(1,1)/det

      elseif (ndim.EQ.3) then

       A = M_ini(2,2)*M_ini(3,3) - M_ini(2,3)*M_ini(3,2)
       B = M_ini(2,1)*M_ini(3,3) - M_ini(2,3)*M_ini(3,1)
       C = M_ini(2,1)*M_ini(3,2) - M_ini(2,2)*M_ini(3,1)

       D = M_ini(1,2)*M_ini(3,3) - M_ini(1,3)*M_ini(3,2)
       E = M_ini(1,1)*M_ini(3,3) - M_ini(1,3)*M_ini(3,1)
       F = M_ini(1,1)*M_ini(3,2) - M_ini(1,2)*M_ini(3,1)

       G = M_ini(1,2)*M_ini(2,3) - M_ini(1,3)*M_ini(2,2)
       H = M_ini(1,1)*M_ini(2,3) - M_ini(1,3)*M_ini(2,1)
       I = M_ini(1,1)*M_ini(2,2) - M_ini(1,2)*M_ini(2,1)

       B = -B
       D = -D
       F = -F
       H = -H

       det = M_ini(1,1)*A + M_ini(1,2)*B + M_ini(1,3)*C

       M_inv(1,1) = A/det
       M_inv(2,1) = B/det
       M_inv(3,1) = C/det

       M_inv(1,2) = D/det
       M_inv(2,2) = E/det
       M_inv(3,2) = F/det

       M_inv(1,3) = G/det
       M_inv(2,3) = H/det
       M_inv(3,3) = I/det

      else

       M = M_ini
       call gaussj(M, ndim, ndim)
       M_inv = M

      end if

c     dbg
c      call check_inv(ndim, M_ini, M_inv)

!--------------------
!     Put inverse
      ffop => mel_out%fhand
      op => mel_out%op
      if (.not.associated(ffop))
     &     call quit(1,'inv_packed_op','No file assigned to list: '//
     &     trim(mel_out%label))
      if (ffop%unit.le.0) then
       call file_open(ffop)
       closeit = .true.
      else
       closeit = .false.
      end if
      if(ndim*ndim.ne.
     &     (ffop%active_records(2)-ffop%active_records(1)+1))
     &     call quit(1,'inv_packed_op',
     &     'inconsistent number of records in input list!'//
     &     ' It must be equal the square of ndim')

      irec_ini = ffop%current_record
      il = 1
      ic = 1
      do irec = ffop%active_records(1),ffop%active_records(2)
       call switch_mel_record(mel_out,irec)
       ioff = ffop%length_of_record*(ffop%current_record-1)
       call put_vec(ffop,M_inv(il:il,ic:ic),ioff+1,ioff+1)
       if(mod(irec - ffop%active_records(1) + 1,ndim).eq.0)then
        il = 1
        ic = ic+1
       else
        il = il+1
       end if
      end do
      call switch_mel_record(mel_out,irec_ini)
      if (closeit)
     &     call file_close_keep(ffop)

      end


      subroutine flood(zslice, dry, wet_mask, delta,
     &                 flooded_zslice, im, jm, nbdry)

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

      implicit none

!-----------------------------------------------------------------------
!
!     input arrays
!
!-----------------------------------------------------------------------

      integer, intent(in) :: delta

      integer, dimension(nbdry, 2), intent(in) :: dry

      real*8, dimension(jm, im), intent(in) :: zslice, wet_mask

!-----------------------------------------------------------------------
!
!     output variables
!
!-----------------------------------------------------------------------

      real*8, dimension(jm, im), intent(out) :: flooded_zslice

!-----------------------------------------------------------------------
!
!     local variables
!
!-----------------------------------------------------------------------

      integer :: im, jm, nbdry, n
      integer :: imin, imax, jmin, jmax, dxy
      integer :: idry, jdry
      integer :: is, ie, js, je

      real*8 :: wet_sum

      real*8, dimension(jm,im) :: binom_coef, mycoef

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

      flooded_zslice = zslice

      ! loop over the dry point that need to be flooded
      do n=1,nbdry
        idry = dry(n,2)
        jdry = dry(n,1)
        ! compute wet point distance
        dxy = 0
        wet_sum = 0
        do while (wet_sum .eq. 0)
          dxy =  dxy + delta
          imin = MAX(idry-dxy,1)
          imax = MIN(idry+dxy,im)
          jmin = MAX(jdry-dxy,1)
          jmax = MIN(jdry+dxy,jm)
          wet_sum = SUM(wet_mask(jmin:jmax,imin:imax))
        enddo
        binom_coef = 0.
        mycoef = 0.
        binom_coef(1:2*dxy+1,1:2*dxy+1) = binc(2*dxy)
        is = dxy - (idry-imin) + 1
        ie = is + (imax-imin)
        js = dxy - (jdry-jmin) + 1
        je = js + (jmax-jmin)
        mycoef(1:jmax-jmin+1,1:imax-imin+1) = binom_coef(js:je,is:ie)
        flooded_zslice(jdry,idry) =
     &       SUM(zslice(jmin:jmax,imin:imax)
     &         * wet_mask(jmin:jmax,imin:imax)
     &         *  mycoef(1:jmax-jmin+1,1:imax-imin+1))
     &     / SUM(wet_mask(jmin:jmax,imin:imax)
     &         * mycoef(1:jmax-jmin+1,1:imax-imin+1))
      enddo

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

      contains

          function bin(n, k)

              implicit none
              integer, intent (in) :: n
              integer, intent (in) :: k
              integer :: i
              real*8 :: bin

              bin = 1

              do i=1,k
                  bin = bin * (n - i + 1) / i
              enddo

              return

          end function bin

          function binc(n)

              implicit none
              integer, intent (in) :: n
              integer :: i,j
              real*8, dimension(:,:), allocatable :: binc

              allocate(binc(n+1,n+1))

              do j=0,n
                  do i=0,n
                      binc(i+1,j+1) = bin(n,j) * bin(n,i)
                  enddo
              enddo

              return

          end function binc

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

      end subroutine flood

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


Real Function eetorr(srt)
  Parameter (etam=0.5475, arho=0.77)
  Common /ppb1/ene, factr2(6), fsum, ppinnb, s, wtot
  Common /ppmm/pprr, ppee, pppe, rpre, xopoe, rree
  Save
  s2 = srt**2
  eetorr = 81.*(s2-4*arho**2)/(s2-4*etam**2)*rrtoee(srt)
  Return
End Function eetorr


      SUBROUTINE MB04ED( JOB, COMPQ, COMPU, N, Z, LDZ, B, LDB, FG, LDFG,
     $                   Q, LDQ, U1, LDU1, U2, LDU2, ALPHAR, ALPHAI,
     $                   BETA, IWORK, LIWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the eigenvalues of a real N-by-N skew-Hamiltonian/
C     skew-Hamiltonian pencil aS - bT with
C
C                             (  B  F  )            (  0  I  )
C       S = J Z' J' Z and T = (        ), where J = (        ).      (1)
C                             (  G  B' )            ( -I  0  )
C
C     Optionally, if JOB = 'T', the pencil aS - bT will be transformed
C     to the structured Schur form: an orthogonal transformation matrix
C     Q and an orthogonal symplectic transformation matrix U are
C     computed, such that
C
C                (  Z11  Z12  )
C       U' Z Q = (            ) = Zout, and
C                (   0   Z22  )
C                                                                    (2)
C                     (  Bout  Fout  )
C       J Q' J' T Q = (              ),
C                     (   0    Bout' )
C
C     where Z11 and Z22' are upper triangular and Bout is upper quasi-
C     triangular. The notation M' denotes the transpose of the matrix M.
C     Optionally, if COMPQ = 'I', the orthogonal transformation matrix Q
C     will be computed.
C     Optionally, if COMPU = 'I' or COMPU = 'U', the orthogonal
C     symplectic transformation matrix
C
C           (  U1  U2  )
C       U = (          )
C           ( -U2  U1  )
C
C     will be computed.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the computation to be performed, as follows:
C             = 'E':  compute the eigenvalues only; Z and T will not
C                     necessarily be put into the forms in (2);
C             = 'T':  put Z and T into the forms in (2), and return the
C                     eigenvalues in ALPHAR, ALPHAI and BETA.
C
C     COMPQ   CHARACTER*1
C             Specifies whether to compute the orthogonal transformation
C             matrix Q as follows:
C             = 'N':  Q is not computed;
C             = 'I':  the array Q is initialized internally to the unit
C                     matrix, and the orthogonal matrix Q is returned.
C
C     COMPU   CHARACTER*1
C             Specifies whether to compute the orthogonal symplectic
C             transformation matrix U as follows:
C             = 'N':  U is not computed;
C             = 'I':  the array U is initialized internally to the unit
C                     matrix, and the orthogonal matrix U is returned;
C             = 'U':  the arrays U1 and U2 contain the corresponding
C                     submatrices of an orthogonal symplectic matrix U0
C                     on entry, and the updated submatrices U1 and U2
C                     of the matrix product U0*U are returned, where U
C                     is the product of the orthogonal symplectic
C                     transformations that are applied to the pencil
C                     aS - bT to reduce Z and T to the forms in (2), for
C                     COMPU = 'I'.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the pencil aS - bT.  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 matrix Z.
C             On exit, if JOB = 'T', the leading N-by-N part of this
C             array contains the matrix Zout; otherwise, it contains the
C             matrix Z just before the application of the periodic QZ
C             algorithm. The entries in the rows N/2+1 to N and the
C             first N/2 columns are unchanged.
C
C     LDZ     INTEGER
C             The leading dimension of the array Z.  LDZ >= MAX(1, N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C                            (LDB, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix B.
C             On exit, if JOB = 'T', the leading N/2-by-N/2 part of this
C             array contains the matrix Bout; otherwise, it contains the
C             matrix B just before the application of the periodic QZ
C             algorithm.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1, N/2).
C
C     FG      (input/output) DOUBLE PRECISION array, dimension
C                            (LDFG, N/2+1)
C             On entry, the leading N/2-by-N/2 strictly lower triangular
C             part of this array must contain the strictly lower
C             triangular part of the skew-symmetric matrix G, and the
C             N/2-by-N/2 strictly upper triangular part of the submatrix
C             in the columns 2 to N/2+1 of this array must contain the
C             strictly upper triangular part of the skew-symmetric
C             matrix F.
C             On exit, if JOB = 'T', the leading N/2-by-N/2 strictly
C             upper triangular part of the submatrix in the columns 2 to
C             N/2+1 of this array contains the strictly upper triangular
C             part of the skew-symmetric matrix Fout.
C             If JOB = 'E', the leading N/2-by-N/2 strictly upper
C             triangular part of the submatrix in the columns 2 to N/2+1
C             of this array contains the strictly upper triangular part
C             of the skew-symmetric matrix F just before the application
C             of the QZ algorithm.
C             The entries on the diagonal and the first superdiagonal of
C             this array are not referenced, but are assumed to be zero.
C             Moreover, the diagonal and the first subdiagonal of this
C             array on exit coincide to the corresponding diagonals of
C             this array on entry.
C
C     LDFG    INTEGER
C             The leading dimension of the array FG.
C             LDFG >= MAX(1, N/2).
C
C     Q       (output) DOUBLE PRECISION array, dimension (LDQ, N)
C             On exit, if COMPQ = 'I', the leading N-by-N part of this
C             array contains the orthogonal transformation matrix Q.
C             On exit, if COMPQ = 'N', the leading N-by-N part of this
C             array contains the orthogonal matrix Q1, such that
C
C                      (  Z11  Z12  )
C               Z*Q1 = (            ),
C                      (   0   Z22  )
C
C             where Z11 and Z22' are upper triangular (the first step
C             of the algorithm).
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.  LDQ >= MAX(1, N).
C
C     U1      (input/output) DOUBLE PRECISION array, dimension
C                            (LDU1, N/2)
C             On entry, if COMPU = 'U', then the leading N/2-by-N/2 part
C             of this array must contain the upper left block of a
C             given matrix U0, and on exit, the leading N/2-by-N/2 part
C             of this array contains the updated upper left block U1 of
C             the product of the input matrix U0 and the transformation
C             matrix U used to transform the matrices Z and T.
C             On exit, if COMPU = 'I', then the leading N/2-by-N/2 part
C             of this array contains the upper left block U1 of the
C             orthogonal symplectic transformation matrix U.
C             If COMPU = 'N' this array is not referenced.
C
C     LDU1    INTEGER
C             The leading dimension of the array U1.
C             LDU1 >= 1,           if COMPU = 'N';
C             LDU1 >= MAX(1, N/2), if COMPU = 'I' or COMPU = 'U'.
C
C     U2      (input/output) DOUBLE PRECISION array, dimension
C                            (LDU2, N/2)
C             On entry, if COMPU = 'U', then the leading N/2-by-N/2 part
C             of this array must contain the upper right block of a
C             given matrix U0, and on exit, the leading N/2-by-N/2 part
C             of this array contains the updated upper right block U2 of
C             the product of the input matrix U0 and the transformation
C             matrix U used to transform the matrices Z and T.
C             On exit, if COMPU = 'I', then the leading N/2-by-N/2 part
C             of this array contains the upper right block U2 of the
C             orthogonal symplectic transformation matrix U.
C             If COMPU = 'N' this array is not referenced.
C
C     LDU2    INTEGER
C             The leading dimension of the array U2.
C             LDU2 >= 1,           if COMPU = 'N';
C             LDU2 >= MAX(1, N/2), if COMPU = 'I' or COMPU = 'U'.
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 - bT.
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 - bT.
C             If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
C             positive, then the j-th and (j+1)-st eigenvalues are a
C             complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).
C
C     BETA    (output) DOUBLE PRECISION array, dimension (N/2)
C             The scalars beta that define the eigenvalues of the pencil
C             aS - bT.
C             Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
C             beta = BETA(j) represent the j-th eigenvalue of the pencil
C             aS - bT, 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/skew-Hamiltonian structure of
C             the pencil, every eigenvalue occurs twice and thus it has
C             only to be saved once in ALPHAR, ALPHAI and BETA.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             On exit, if INFO = 3, IWORK(1) contains the number of
C             (pairs of) possibly inaccurate eigenvalues, q <= N/2, and
C             IWORK(2), ..., IWORK(q+1) indicate their indices.
C             Specifically, a positive value is an index of a real or
C             purely imaginary eigenvalue, corresponding to a 1-by-1
C             block, while the absolute value of a negative entry in
C             IWORK is an index to the first eigenvalue in a pair of
C             consecutively stored eigenvalues, corresponding to a
C             2-by-2 block. A 2-by-2 block may have two complex, two
C             real, two purely imaginary, or one real and one purely
C             imaginary eigenvalue.
C             For i = q+2, ..., 2*q+1, IWORK(i) contains a pointer to
C             the starting location in DWORK of the i-th triplet of
C             1-by-1 blocks, if IWORK(i-q) > 0, or 2-by-2 blocks,
C             if IWORK(i-q) < 0, defining unreliable eigenvalues.
C             IWORK(2*q+2) contains the number of the 1-by-1 blocks, and
C             IWORK(2*q+3) contains the number of the 2-by-2 blocks,
C             corresponding to unreliable eigenvalues. IWORK(2*q+4)
C             contains the total number t of the 2-by-2 blocks.
C             If INFO = 0, then q = 0, therefore IWORK(1) = 0.
C
C     LIWORK  INTEGER
C             The dimension of the array IWORK.  LIWORK >= N+9.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0 or INFO = 3, DWORK(1) returns the
C             optimal LDWORK, and DWORK(2), ..., DWORK(4) contain the
C             Frobenius norms of the factors of the formal matrix
C             product used by the algorithm. In addition, DWORK(5), ...,
C             DWORK(4+3*s) contain the s triplet values corresponding
C             to the 1-by-1 blocks. Their eigenvalues are real or purely
C             imaginary. Such an eigenvalue is obtained as a1/a2/a3,
C             where a1, ..., a3 are the corresponding triplet values.
C             Moreover, DWORK(5+3*s), ..., DWORK(4+3*s+12*t) contain the
C             t groups of triplet 2-by-2 matrices corresponding to the
C             2-by-2 blocks. Their eigenvalue pairs are either complex,
C             or placed on the real and imaginary axes. Such an
C             eigenvalue pair is the spectrum of the matrix product
C             A1*inv(A2)*inv(A3), where A1, ..., A3 define the
C             corresponding 2-by-2 matrix triplet.
C             On exit, if INFO = -23, DWORK(1) returns the minimum value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             If JOB = 'E' and COMPQ = 'N' and COMPU = 'N',
C                   LDWORK >= 3/4*N**2+MAX(3*N, 27);
C             else, LDWORK >= 3/2*N**2+MAX(3*N, 27).
C             For good performance LDWORK should generally be larger.
C
C             If LDWORK = -1, then 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 related to LDWORK is issued by
C             XERBLA.
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: problem during computation of the eigenvalues;
C             = 2: periodic QZ algorithm did not converge in the SLICOT
C                  Library subroutine MB03BD;
C             = 3: some eigenvalues might be inaccurate, and details can
C                  be found in IWORK and DWORK. This is a warning.
C
C     METHOD
C
C     The algorithm uses Givens rotations and Householder reflections to
C     annihilate elements in Z and T such that Z is in a special block
C     triangular form and T is in skew-Hamiltonian Hessenberg form:
C
C         (  Z11  Z12  )      (  B1  F1  )
C     Z = (            ), T = (          ),
C         (   0   Z22  )      (   0  B1' )
C
C     with Z11 and Z22' upper triangular and B1 upper Hessenberg.
C     Subsequently, the periodic QZ algorithm is applied to the pencil
C     aZ22' Z11 - bB1 to determine orthogonal matrices Q1, Q2 and U such
C     that U' Z11 Q1, Q2' Z22' U are upper triangular and Q2' B1 Q1 is
C     upper quasi-triangular. See also page 35 in [1] for more details.
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
C         Numerical Computation of Deflating Subspaces of Embedded
C         Hamiltonian Pencils.
C         Tech. Rep. SFB393/99-15, Technical University Chemnitz,
C         Germany, June 1999.
C
C     NUMERICAL ASPECTS
C                                                               3
C     The algorithm is numerically backward stable and needs O(N ) real
C     floating point operations.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, April 22, 2009.
C     V. Sima, Aug. 2009 (SLICOT version of the routine ZSHFTR).
C
C     REVISIONS
C
C     V. Sima, Dec. 2010, Jan. 2011, Aug. 2011, Nov. 2011, July 2012,
C     July 2013, Jan. 2017, Mar. 2020, Apr. 2020.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Periodic QZ algorithm, upper (quasi-)triangular matrix,
C     skew-Hamiltonian/skew-Hamiltonian pencil.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, FOUR
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, FOUR = 4.0D+0 )
C
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPU, JOB
      INTEGER            INFO, LDB, LDFG, LDQ, LDU1, LDU2, LDWORK, LDZ,
     $                   LIWORK, N
C
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   ALPHAI( * ), ALPHAR( * ), B( LDB, * ),
     $                   BETA( * ), DWORK( * ), FG( LDFG, * ),
     $                   Q( LDQ, * ), U1( LDU1, * ), U2( LDU2, * ),
     $                   Z( LDZ, * )
C
C     .. Local Scalars ..
      LOGICAL            LCMPQ, LCMPU, LINIU, LQUERY, LTRI, LUPDU, UNREL
      CHARACTER*16       CMPQ, CMPSC
      INTEGER            EMAX, EMIN, I, I11, I22, I2X2, IB1, ICF, ICG,
     $                   IQ1, IQ2, ITAU, IU, IW, IWARN, IWRK, IZ11,
     $                   IZ22, J, K, L, M, MINDW, MJ1, MJ2, MJ3, MM,
     $                   NBETA0, NINF, OPTDW, P
      DOUBLE PRECISION   BASE, CO, SI, TEMP, TMP1, TMP2
C
C     .. Local Arrays ..
      INTEGER            IDUM( 1 )
      DOUBLE PRECISION   DUM(  4 )
C
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DLANTR, DLAPY2
      EXTERNAL           DLAMCH, DLANTR, DLAPY2, IDAMAX, LSAME
C
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DGEQRF, DGERQF, DLACPY, DLARTG,
     $                   DLASET, DORMQR, DORMRQ, DROT, DSWAP, MA02AD,
     $                   MB01KD, MB01LD, MB01MD, MB03BD, XERBLA
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, MAX, MIN, MOD
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C
      M  = N/2
      MM = M*M
      LTRI  = LSAME( JOB,   'T' )
      LCMPQ = LSAME( COMPQ, 'I' )
      LINIU = LSAME( COMPU, 'I' )
      LUPDU = LSAME( COMPU, 'U' )
      LCMPU = LINIU .OR. LUPDU
      IF( N.EQ.0 ) THEN
         MINDW = 4
      ELSE IF( LTRI .OR. LCMPQ .OR. LCMPU ) THEN
         MINDW = 6*MM + MAX( 3*N, 27 )
      ELSE
         MINDW = 3*MM + MAX( 3*N, 27 )
      END IF
      LQUERY = LDWORK.EQ.-1
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( JOB, 'E' ) .OR. LTRI ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( LSAME( COMPU, 'N' ) .OR. LCMPU ) ) 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.MAX( 1, N ) ) THEN
         INFO = -12
      ELSE IF( LDU1.LT.1 .OR. ( LCMPU .AND. LDU1.LT.M ) ) THEN
         INFO = -14
      ELSE IF( LDU2.LT.1 .OR. ( LCMPU .AND. LDU2.LT.M ) ) THEN
         INFO = -16
      ELSE IF( LIWORK.LT.N+9 ) THEN
         INFO = -21
      ELSE IF( .NOT. LQUERY .AND. LDWORK.LT.MINDW ) THEN
         DWORK( 1 ) = MINDW
         INFO = -23
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04ED', -INFO )
         RETURN
      ELSE IF( N.GT.0 ) THEN
         IF( LQUERY ) THEN
C
C           Compute optimal workspace.
C
            CALL DGEQRF( N, M, DWORK, N, DWORK, DUM, -1, INFO )
            CALL DORMQR( 'Right', 'No Transpose', N, N, M, DWORK, N,
     $                   DWORK, Q, LDQ, DUM( 2 ), -1, INFO )
            CALL DGERQF( M, M, Z, LDZ, DWORK, DUM( 3 ), -1, INFO )
            CALL DORMRQ( 'Right', 'Transpose', N, M, M, Z, LDZ, DWORK,
     $                   Q, LDQ, DUM( 4 ), -1, INFO )
            J = MAX( MAX( N*M + MAX( INT( DUM( 1 ) ), INT( DUM( 2 ) ) ),
     $                    INT( DUM( 3 ) ), INT( DUM( 4 ) ) ) + M, 3*MM )
            DWORK( 1 ) = MAX( MINDW, J )
            RETURN
         END IF
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         IWORK( 1 ) = 0
         DWORK( 1 ) = FOUR
         DWORK( 2 ) = ZERO
         DWORK( 3 ) = ZERO
         DWORK( 4 ) = ZERO
         RETURN
      END IF
C
C     Determine machine constants.
C
      BASE = DLAMCH( 'Base' )
      EMIN = INT( DLAMCH( 'Minimum Exponent' ) )
      EMAX = INT( DLAMCH( 'Largest Exponent' ) )
C
C     Find half of the number of infinite eigenvalues if Z is diagonal.
C     Otherwise, find a lower bound of this number.
C
      NINF = 0
      IF( N.EQ.1 ) THEN
         IF( Z( 1, 1 ).EQ.ZERO )
     $      NINF = 1
      ELSE
         IF( DLANTR( 'Max', 'Lower', 'No-diag', N-1, N-1, Z( 2, 1 ),
     $                                LDZ, DWORK ).EQ.ZERO .AND.
     $       DLANTR( 'Max', 'Upper', 'No-diag', N-1, N-1, Z( 1, 2 ),
     $                                LDZ, DWORK ).EQ.ZERO ) THEN
            DO 10 J = 1, M
               IF( Z( J, J ).EQ.ZERO .OR. Z( J+M, J+M ).EQ.ZERO )
     $            NINF = NINF + 1
   10       CONTINUE
         ELSE
            DO 20 J = 1, M
               I = IDAMAX( N, Z( 1, J ),   1 )
               K = IDAMAX( N, Z( 1, M+J ), 1 )
               L = IDAMAX( N, Z( J, 1 ),   LDZ )
               P = IDAMAX( N, Z( M+J, 1 ), LDZ )
               IF( Z( I, J ).EQ.ZERO .OR. Z( K, M+J ).EQ.ZERO .OR.
     $             Z( J, L ).EQ.ZERO .OR. Z( M+J, P ).EQ.ZERO )
     $            NINF = NINF + 1
   20       CONTINUE
         END IF
      END IF
C
C     Initializations.
C
      CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
C
      IF( LINIU ) THEN
         CALL DLASET( 'Full', M, M, ZERO, ONE,  U1, LDU1 )
         CALL DLASET( 'Full', M, M, ZERO, ZERO, U2, LDU2 )
      END IF
C
C     STEP 1: By changing the elimination order in the classical RQ
C             decomposition, determine an orthogonal matrix Q1 such that
C
C                 (  Z11  Z12  )
C             Z = (            ) Q1',
C                 (   0   Z22  )
C
C             where Z11 and Z22' are upper triangular.
C             Update Q and T subsequently.
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      ITAU = N*M  + 1
      IWRK = ITAU + M
      CALL MA02AD( 'Full', M, N, Z( M+1, 1 ), LDZ, DWORK, N )
C
C     Perform a QR decomposition ( Z21  Z22 )' = Q1*R1, and
C     update ( Z11  Z12 ).
C
C     Workspace:     need   N*M+N;
C                    prefer N*M+M+M*NB, where NB is the optimal
C                                       blocksize.
C
      CALL DGEQRF( N, M, DWORK, N, DWORK( ITAU ), DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO )
      OPTDW = MAX( MINDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
      CALL DORMQR( 'Right', 'No Transpose', M, N, M, DWORK, N,
     $             DWORK( ITAU ), Z, LDZ, DWORK( IWRK ), LDWORK-IWRK+1,
     $             INFO )
C
C     Copy R1' to Z22 and set the strictly upper triangular part of Z22
C     to zero.
C
      CALL MA02AD( 'Upper', M, M, DWORK, N, Z( M+1, M+1 ), LDZ )
      IF( M.GT.1 )
     $   CALL DLASET( 'Upper', M-1, M-1, ZERO, ZERO, Z( M+1, M+2 ),
     $                LDZ )
C
C     Update Q.
C
      CALL DORMQR( 'Right', 'No Transpose', N, N, M, DWORK, N,
     $             DWORK( ITAU ), Q, LDQ, DWORK( IWRK ), LDWORK-IWRK+1,
     $             INFO )
      OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
      DO 30 I = 1, M
         CALL DSWAP( N, Q( 1, I ), 1, Q( 1, M+I ), 1 )
   30 CONTINUE
C
      ITAU = 1
      IWRK = ITAU + M
C
C     Perform an RQ decomposition Z12 = R2*Q2.
C
C     Workspace:     need   N;
C                    prefer M+M*NB, where NB is the optimal blocksize.
C
      CALL DGERQF( M, M, Z( 1, M+1 ), LDZ, DWORK( ITAU ), DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO )
      OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
C     Update Q.
C
      CALL DORMRQ( 'Right', 'Transpose', N, M, M, Z( 1, M+1 ), LDZ,
     $             DWORK( ITAU ), Q, LDQ, DWORK( IWRK ), LDWORK-IWRK+1,
     $             INFO )
      OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
C     Exchange Z11 and Z12 and set the strictly lower triangular part
C     of Z11 to zero.
C
      DUM( 1 ) = ZERO
      DO 40 J = 1, M - 1
         CALL DSWAP(  M, Z( 1, J ), 1, Z( 1, M+J ), 1 )
         CALL DCOPY( M-J, DUM( 1 ), 0, Z( J+1, J ), 1 )
   40 CONTINUE
C
      CALL DSWAP( M, Z( 1, M ), 1, Z( 1, N ), 1 )
C
C     Apply the transformations to B and FG.
C
C     Workspace:     need   3*M*M.
C
C     Copy the strictly upper triangular part of F and the transpose of
C     the strictly lower triangular part of G to appropriate locations
C     in DWORK.
C
      ICF  = 1
      ICG  = ICF + MM
      IWRK = ICG + MM
      IF( M.GT.1 ) THEN
         CALL DLACPY( 'Upper', M-1, M-1, FG( 1, 3 ), LDFG,
     $                DWORK( ICF+M ), M )
         CALL MA02AD( 'Lower', M-1, M-1, FG( 2, 1 ), LDFG,
     $                DWORK( ICG+M ), M )
      END IF
C
C     Skew-symmetric updates to determine the new F.
C
C       Fnew :=   Q(m+1:n,m+1:n)'*B *Q(1:m,m+1:n)
C               - Q(1:m,m+1:n)'  *B'*Q(m+1:n,m+1:n)
C               + Q(m+1:n,m+1:n)'*F *Q(m+1:n,m+1:n)
C               - Q(1:m,m+1:n)'  *G *Q(1:m,m+1:n).
C
      CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, DWORK( ICF ),
     $             M, Q( M+1, M+1 ), LDQ, DWORK( ICF ), M,
     $             DWORK( IWRK ), LDWORK-IWRK+1, INFO )
      CALL MB01LD( 'Upper', 'Transpose', M, M, ONE, ONE, DWORK( ICF ),
     $             M, Q( 1, M+1 ), LDQ, DWORK( ICG ), M, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO )
      CALL DGEMM(  'No Transpose', 'No Transpose', M, M, M, ONE, B, LDB,
     $             Q( 1, M+1 ), LDQ, ZERO, DWORK( IWRK ), M )
      CALL MB01KD( 'Upper', 'Transpose', M, M, ONE, Q( M+1, M+1 ), LDQ,
     $             DWORK( IWRK ), M, ONE, DWORK( ICF ), M, INFO )
C
C     Copy the strictly lower triangular part of G and the transpose of
C     the strictly upper triangular part of F to appropriate locations
C     in DWORK.
C
      IF( M.GT.1 ) THEN
         CALL DLACPY( 'Lower', M-1, M-1, FG( 2, 1 ), LDFG,
     $                DWORK( ICG+1 ), M )
         CALL MA02AD( 'Upper', M-1, M-1, FG( 1, 3 ), LDFG,
     $                DWORK( ICF+1 ), M )
      END IF
C
C     Skew-symmetric updates to determine the new G.
C
C       Gnew :=   Q(1:m,1:m)'  *B'*Q(m+1:n,1:m)
C               - Q(m+1:n,1:m)'*B *Q(1:m,1:m)
C               + Q(1:m,1:m)'  *G *Q(1:m,1:m)
C               - Q(m+1:n,1:m)'*F *Q(m+1:n,1:m).
C
      CALL MB01LD( 'Lower', 'Transpose', M, M, ZERO, ONE, DWORK( ICG ),
     $             M, Q, LDQ, DWORK( ICG ), M, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO )
      CALL MB01LD( 'Lower', 'Transpose', M, M, ONE, ONE, DWORK( ICG ),
     $             M, Q( M+1, 1 ), LDQ, DWORK( ICF ), M, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO )
      CALL DGEMM(  'Transpose', 'No Transpose', M, M, M, ONE, B, LDB,
     $             Q( M+1, 1 ), LDQ, ZERO, DWORK( IWRK ), M )
      CALL MB01KD( 'Lower', 'Transpose', M, M, ONE, Q, LDQ,
     $             DWORK( IWRK ), M, ONE, DWORK( ICG ), M, INFO )
C
C     Determine the new B.
C
C       Bnew :=   Q(m+1:n,m+1:n)'*B *Q(1:m,1:m)
C               - Q(1:m,m+1:n)'  *B'*Q(m+1:n,1:m)
C               + Q(m+1:n,m+1:n)'*F *Q(m+1:n,1:m)
C               - Q(1:m,m+1:n)'  *G *Q(1:m,1:m).
C
      DO 50 I = 1, M
         CALL MB01MD( 'Upper', M, ONE, FG( 1, 2 ), LDFG, Q( M+1, I ), 1,
     $                ZERO, DWORK( IWRK+( I-1 )*M ), 1 )
   50 CONTINUE
      IF( M.GT.1 )
     $   CALL DLACPY( 'Upper', M-1, M-1, DWORK( ICF+M ), M, FG( 1, 3 ),
     $                LDFG )
      CALL DGEMM(  'No Transpose', 'No Transpose', M, M, M, ONE, B, LDB,
     $             Q, LDQ, ONE, DWORK( IWRK ), M )
      CALL DGEMM(  'Transpose', 'No Transpose', M, M, M, ONE,
     $             Q( M+1, M+1 ), LDQ, DWORK( IWRK ), M, ZERO,
     $             DWORK( ICF ), M )
      DO 60 I = 1, M
         CALL MB01MD( 'Lower', M, ONE, FG, LDFG, Q( 1, I ), 1, ZERO,
     $                DWORK( IWRK+( I-1 )*M ), 1 )
   60 CONTINUE
      CALL DGEMM(  'Transpose', 'No Transpose', M, M, M, ONE, B, LDB,
     $             Q( M+1, 1 ), LDQ, ONE, DWORK( IWRK ), M )
      CALL DGEMM(  'Transpose', 'No Transpose', M, M, M, -ONE,
     $             Q( 1, M+1 ), LDQ, DWORK( IWRK ), M, ONE,
     $             DWORK( ICF ), M )
      IF( M.GT.1 )
     $   CALL DLACPY( 'Lower', M-1, M-1, DWORK( ICG+1 ), M, FG( 2, 1 ),
     $                LDFG )
      CALL DLACPY( 'Full', M, M, DWORK( ICF ), M, B, LDB )
C
C     STEP 2: Reduce T to skew-Hamiltonian Hessenberg form.
C
      DO 90 K = 1, M - 1
C
C        I. Annihilate T(m+k, k+1:m-1) as well as T(m+k+1:n-1, k),
C           i.e., G(k+1:m-1, k).
C
         DO 70 J = K + 1, M - 1
            MJ2 = MIN( J+2, M )
            MJ3 = MJ2 + 1
C
C           Determine a Givens rotation to annihilate G(j,k) from the
C           left.
C
            CALL DLARTG( FG( J+1, K ), FG( J, K ), CO, SI, TMP1 )
C
C           Update B and G.
C
            CALL DROT( M, B( 1, J+1 ), 1, B( 1, J ), 1, CO, SI )
            CALL DROT( M-J-1, FG( MJ2, J+1 ), 1, FG( MJ2, J ), 1, CO, SI
     $                  )
            FG( J+1, K ) = TMP1
            CALL DROT( J-K-1, FG( J+1, K+1 ), LDFG, FG( J, K+1 ), LDFG,
     $                 CO, SI )
C
C           Update Z.
C
            CALL DROT( J, Z( 1, J+1 ), 1, Z( 1, J ), 1, CO, SI )
            TMP1          = -SI*Z( J+1, J+1 )
            Z( J+1, J+1 ) =  CO*Z( J+1, J+1 )
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C
               CALL DROT( N, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate Z(j+1,j) from the
C           left.
C
            CALL DLARTG( Z( J, J ), TMP1, CO, SI, TMP2 )
C
C           Update Z.
C
            Z(   J, J ) = TMP2
            Z( J+1, J ) = ZERO
            CALL DROT( N-J, Z( J, J+1 ), LDZ, Z( J+1, J+1 ), LDZ, CO,
     $                 SI )
            CALL DROT( J, Z( M+J, M+1 ), LDZ, Z( M+J+1, M+1 ), LDZ,
     $                 CO, SI )
            TMP1              = SI*Z( M+J+1, M+J+1 )
            Z( M+J+1, M+J+1 ) = CO*Z( M+J+1, M+J+1 )
C
            IF( LCMPU ) THEN
C
C              Update U1 and U2.
C
               CALL DROT( M, U1( 1, J ), 1, U1( 1, J+1 ), 1, CO, SI )
               CALL DROT( M, U2( 1, J ), 1, U2( 1, J+1 ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate Z(m+j,m+j+1) from
C           the right.
C
            CALL DLARTG( Z( M+J, M+J ), TMP1, CO, SI, TMP2 )
C
C           Update Z.
C
            CALL DROT( M, Z( 1, M+J ), 1, Z( 1, M+J+1 ), 1, CO, SI )
            Z( M+J, M+J ) = TMP2
            CALL DROT( M-J, Z( M+J+1, M+J ), 1, Z( M+J+1, M+J+1 ), 1,
     $                 CO, SI )
C
C           Update B and F.
C
            CALL DROT( M-K+1, B( J, K ), LDB, B( J+1, K ), LDB, CO, SI )
            CALL DROT( J-1, FG( 1, J+1 ), 1, FG( 1, J+2 ), 1, CO, SI )
            CALL DROT( M-J-1, FG( J, MJ3 ), LDFG, FG( J+1, MJ3 ), LDFG,
     $                 CO, SI )
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C
               CALL DROT( N, Q( 1, M+J ), 1, Q( 1, M+J+1 ), 1, CO, SI )
            END IF
   70    CONTINUE
C
C        II. Annihilate G(k,m) (and also G(m,k)).
C
C        Determine a Givens rotation to annihilate G(m,k) from the
C        left.
C
         CALL DLARTG( B( M, K ), -FG( M, K ), CO, SI, TMP1 )
C
C        Update B, F and G.
C
         CALL DROT( M-1, FG( 1, M+1 ), 1, B( 1, M ), 1, CO, SI )
         B( M, K ) = TMP1
         CALL DROT( M-K-1, FG( M, K+1 ), LDFG, B( M, K+1 ), LDB, CO,
     $              SI )
C
C        Update Z.
C
         CALL DROT( M, Z( 1, N ), 1, Z( 1, M ), 1, CO, SI )
         TMP1      = -SI*Z( N, N )
         Z( N, N ) =  CO*Z( N, N )
C
         IF( LCMPQ ) THEN
C
C           Update Q.
C
            CALL DROT( N, Q( 1, N ), 1, Q( 1, M ), 1, CO, SI )
         END IF
C
C        Determine a Givens rotation to annihilate Z(n,m) from the left.
C
         CALL DLARTG( Z( M, M ), TMP1, CO, SI, TMP2 )
C
C        Update Z.
C
         Z( M, M ) = TMP2
         CALL DROT( M, Z( M, M+1 ), LDZ, Z( N, M+1 ), LDZ, CO, SI )
C
         IF( LCMPU ) THEN
C
C           Update U1 and U2.
C
            CALL DROT( M, U1( 1, M ), 1, U2( 1, M ), 1, CO, SI )
         END IF
C
C        III. Annihilate B(k+2:m,k).
C
         DO 80 J = M, K + 2, -1
            MJ1 = MIN( J+1, M )
            MJ2 = MJ1 + 1
C
C           Determine a Givens rotation to annihilate B(j,k) from the
C           left.
C
            CALL DLARTG( B( J-1, K ), B( J, K ), CO, SI, TMP1 )
C
C           Update B and F.
C
            CALL DROT( J-2, FG( 1, J ), 1, FG( 1, J+1 ), 1, CO, SI )
            B( J-1, K ) = TMP1
            B(   J, K ) = ZERO
            CALL DROT( M-K, B( J-1, K+1 ), LDB, B( J, K+1 ), LDB, CO,
     $                 SI )
            CALL DROT( M-J, FG( J-1, MJ2 ), LDFG, FG( J, MJ2 ), LDFG,
     $                 CO, SI )
C
C           Update Z.
C
            CALL DROT( M, Z( 1, M+J-1 ), 1, Z( 1, M+J ), 1, CO, SI )
            TMP1              = -SI*Z( M+J-1, M+J-1 )
            Z( M+J-1, M+J-1 ) =  CO*Z( M+J-1, M+J-1 )
            CALL DROT( M-J+1, Z( M+J, M+J-1 ), 1, Z( M+J, M+J ), 1, CO,
     $                 SI )
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C
               CALL DROT( N, Q( 1, M+J-1 ), 1, Q( 1, M+J ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate Z(m+j-1,m+j) from
C           the left.
C
            CALL DLARTG( Z( M+J, M+J ), TMP1, CO, SI, TMP2 )
C
C           Update Z.
C
            TMP1          = SI*Z( J-1, J-1 )
            Z( J-1, J-1 ) = CO*Z( J-1, J-1 )
            CALL DROT( N-J+1, Z( J, J ), LDZ, Z( J-1, J ), LDZ, CO, SI )
            CALL DROT( J-1, Z( M+J, M+1 ), LDZ, Z( M+J-1, M+1 ), LDZ,
     $                 CO, SI )
            Z( M+J, M+J ) = TMP2
C
            IF( LCMPU ) THEN
C
C              Update U1 and U2.
C
               CALL DROT( M, U1( 1, J ), 1, U1( 1, J-1 ), 1, CO, SI )
               CALL DROT( M, U2( 1, J ), 1, U2( 1, J-1 ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate Z(j,j-1) from the
C           right.
C
            CALL DLARTG( Z( J, J ), TMP1, CO, SI, TMP2 )
C
C           Update Z.
C
            Z( J, J ) = TMP2
            CALL DROT( J-1, Z( 1, J ), 1, Z( 1, J-1 ), 1, CO, SI )
C
C           Update B and G.
C
            CALL DROT( M, B( 1, J ), 1, B( 1, J-1 ), 1, CO, SI )
            CALL DROT( J-K-1, FG( J, K ), LDFG, FG( J-1, K ), LDFG, CO,
     $                 SI )
            CALL DROT( M-J, FG( MJ1, J ), 1, FG( MJ1, J-1 ), 1, CO, SI )
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C
               CALL DROT( N, Q( 1, J ), 1, Q( 1, J-1 ), 1, CO, SI )
            END IF
   80    CONTINUE
   90 CONTINUE
C
C             (  Z11  Z12  )      (  B1  F1  )
C     Now Z = (            ), T = (          ),
C             (   0   Z22  )      (   0  B1' )
C
C     where Z11 and Z22' are upper triangular and B1 upper Hessenberg.
C
C     STEP 3: Apply the periodic QZ algorithm to the pencil
C             aZ22' Z11 - bB1 to determine orthogonal matrices
C             Q1, Q2 and U such that U' Z11 Q1 and Q2' Z22' U are upper
C             triangular, and Q2' B1 Q1 is upper quasi-triangular.
C
C     Determine the mode of computations.
C
      IQ2  = 1
      IF( LTRI .OR. LCMPQ .OR. LCMPU ) THEN
         CMPQ = 'Initialize'
         IQ1  = IQ2 + MM
         IU   = IQ1 + MM
         IB1  = IU  + MM
      ELSE
         CMPQ = 'No Computation'
         IB1  = 1
      END IF
      IZ11 = IB1  + MM
      IZ22 = IZ11 + MM
      IWRK = IZ22 + MM
C
      IF( LTRI ) THEN
         CMPSC = 'Schur Form'
      ELSE
         CMPSC = 'Eigenvalues Only'
      END IF
C
      IWORK( 1 ) =  1
      IWORK( 2 ) = -1
      IWORK( 3 ) = -1
C
      CALL DLACPY( 'Full', M, M, B, LDB, DWORK( IB1 ),  M )
      CALL DLACPY( 'Full', M, M, Z, LDZ, DWORK( IZ11 ), M )
      CALL MA02AD( 'Full', M, M, Z( M+1, M+1 ), LDZ, DWORK( IZ22 ), M )
C
C     Periodic QZ iteration.
C
C     Real workspace:    need   w1 + MAX( N,24 ) + 3, where
C                               w1 = 6*M**2, if JOB = 'T', or
C                                            COMPQ = 'I' or COMPU <>'N';
C                               w1 = 3*M**2, otherwise.
C     Integer workspace: need   N + 9.
C
      CALL MB03BD( CMPSC, 'Careful', CMPQ, IDUM, 3, M, 1, 1, M, IWORK,
     $             DWORK( IB1 ), M, M, DWORK( IQ2 ), M, M, ALPHAR,
     $             ALPHAI, BETA, IWORK( 4 ), IWORK( M+4 ),
     $             LIWORK-( M+3 ), DWORK( IWRK ), LDWORK-IWRK+1, IWARN,
     $             INFO )
      IF( IWARN.GT.0 .AND. IWARN.LT.M ) THEN
         INFO = 1
         RETURN
      ELSE IF( IWARN.EQ.M+1 ) THEN
         INFO = 3
      ELSE IF( INFO.GT.0 ) THEN
         INFO = 2
         RETURN
      END IF
C
C     Compute the eigenvalues of the pencil aS - bT.
C
      NBETA0 = 0
      I11    = 0
      I22    = 0
      I2X2   = 0
C
C     Compute the eigenvalues with nonnegative imaginary parts of the
C     pencil aS - bH. Also, count the number of 2-by-2 diagonal blocks,
C     I2X2, and the number of 1-by-1 and 2-by-2 blocks with unreliable
C     eigenvalues, I11 and I22, respectively.
C
      I = 1
C     WHILE( I.LE.M ) DO
  100 CONTINUE
      IF( I.LE.M ) THEN
         IF( NINF.GT.0 ) THEN
            IF( BETA( I ).EQ.ZERO )
     $         NBETA0 = NBETA0 + 1
         END IF
         IF( IWORK( I+3 ).GE.EMIN .AND. IWORK( I+3 ).LE.EMAX ) THEN
C
C           b = BASE**IWORK(i+3) is between underflow and overflow
C           threshold, BETA(i) is divided by b.
C
            BETA( I ) = BETA( I )/BASE**IWORK( I+3 )
            IF( BETA( I ).NE.ZERO ) THEN
               IF( IWORK( M+I+4 ).LT.0 ) THEN
                  I22 = I22 + 1
               ELSE IF( IWORK( M+I+4 ).GT.0 ) THEN
                  I11 = I11 + 1
               END IF
               IF( ALPHAI( I ).LT.ZERO )
     $             ALPHAI( I ) = -ALPHAI( I )
               IF( ALPHAR( I ).NE.ZERO .AND. ALPHAI( I ).NE.ZERO ) THEN
                  ALPHAI( I+1 ) = -ALPHAI( I )
                  BETA(   I+1 ) =  BETA(   I )
                  I2X2 = I2X2 + 1
                  I    = I    + 1
               END IF
            END IF
         ELSE IF( IWORK( I+3 ).LT.EMIN ) THEN
C
C           Set to zero the numerator part of the eigenvalue.
C
            ALPHAR( I ) = ZERO
            ALPHAI( I ) = ZERO
            I11 = I11 + 1
         ELSE
C
C           Set an infinite eigenvalue.
C
            IF( NINF.GT.0 )
     $         NBETA0 = NBETA0 + 1
            BETA( I ) = ZERO
            I11 = I11 + 1
         END IF
         I = I + 1
         GO TO 100
      END IF
C     END WHILE 100
C
      IWORK( 1 ) = I11 + I22
C
C     Set to infinity the largest eigenvalues, if necessary.
C
      L = 0
      IF( NINF.GT.0 ) THEN
         DO 120  J = 1, NINF - NBETA0
            TMP1 = ZERO
            TMP2 = ONE
            P    = 1
            DO 110 I = 1, M
               IF( BETA( I ).GT.ZERO ) THEN
                  TEMP = DLAPY2( ALPHAR( I ), ALPHAI( I ) )
                  IF( TEMP.GT.TMP1 .AND. TMP2.GE.BETA( I ) ) THEN
                     TMP1 = TEMP
                     TMP2 = BETA( I )
                     P    = I
                  END IF
               END IF
  110       CONTINUE
            L = L + 1
            BETA( P ) = ZERO
  120    CONTINUE
C
         IF( L.EQ.IWORK( 1 ) ) THEN
C
C           All unreliable eigenvalues found have been set to infinity.
C
            INFO = 0
            I11  = 0
            I22  = 0
            IWORK( 1 ) = 0
         END IF
      END IF
C
C     Save the norms of the factors.
C
      CALL DCOPY( 3, DWORK( IWRK+1 ), 1, DUM, 1 )
C
C     Save the triplets of the 1-by-1 and 2-by-2 diagonal blocks.
C     All 1-by-1 diagonal blocks come first.
C     Save also information about blocks with possible loss of accuracy.
C
C     Workspace:  IWRK+w-1, where w = 3 if M = 1, or w = 3*N, otherwise.
C
      K  = IWRK
      P  = IWRK
      IW = IWORK( 1 )
      I  = 1
      J  = 1
      L  = 3*( M - 2*I2X2 ) + K
C
C     WHILE( I.LE.N ) DO
      UNREL = .FALSE.
  130 CONTINUE
      IF( I.LE.M ) THEN
         IF( J.LE.IW )
     $      UNREL = I.EQ.ABS( IWORK( M+I+4 ) )
         IF( ALPHAR( I ).NE.ZERO .AND. BETA( I ).NE.ZERO .AND.
     $       ALPHAI( I ).NE.ZERO ) THEN
            IF( UNREL ) THEN
               J = J + 1
               IWORK( J )    = IWORK( M+I+4 )
               IWORK( IW+J ) = L - IWRK + 1
               UNREL = .FALSE.
            END IF
            CALL DLACPY( 'Full', 2, 2, DWORK( IB1+(M+1)*(I-1) ), M,
     $                   DWORK( L ), 2 )
            CALL DLACPY( 'Full', 2, 2, DWORK( IB1+(M+1)*(I-1)+MM ),
     $                   M, DWORK( L+4 ), 2 )
            CALL DLACPY( 'Full', 2, 2, DWORK( IB1+(M+1)*(I-1)+2*MM ),
     $                   M, DWORK( L+8 ), 2 )
            L = L + 12
            I = I + 2
         ELSE
            IF ( UNREL ) THEN
               J = J + 1
               IWORK( J )    = I
               IWORK( IW+J ) = K - IWRK + 1
               UNREL = .FALSE.
            END IF
            CALL DCOPY( 3, DWORK( IB1+(M+1)*(I-1) ), MM, DWORK( K ),
     $                  1 )
            K = K + 3
            I = I + 1
         END IF
         GO TO 130
      END IF
C     END WHILE 130
C
      IWORK( 2*IW+2 ) = I11
      IWORK( 2*IW+3 ) = I22
      IWORK( 2*IW+4 ) = I2X2
C
      IF( LTRI ) THEN
C
C        Update Z.
C
C        Workspace:     need   w2 = 5*M**2, if JOB = 'T';
C                              w2 = 2*M**2, otherwise.
C
         IWRK = IZ11
         CALL DLACPY( 'Upper', M, M, DWORK( IZ11 ), M, Z, LDZ )
         CALL DGEMM(  'Transpose', 'No Transpose', M, M, M, ONE,
     $                DWORK( IU ), M, Z( 1, M+1 ), LDZ, ZERO,
     $                DWORK( IWRK ), M )
         CALL DGEMM(  'No Transpose', 'No Transpose', M, M, M, ONE,
     $                DWORK( IWRK ), M, DWORK( IQ2 ), M, ZERO,
     $                Z( 1, M+1 ), LDZ )
         CALL MA02AD( 'Upper', M, M, DWORK( IZ22 ), M, Z( M+1, M+1 ),
     $                LDZ )
C
C        Update B.
C
         CALL DLACPY( 'Full', M, M, DWORK( IB1 ), M, B, LDB )
         IWRK = IB1
C
C        Skew-symmetric update of F.
C
C        Workspace:     need   w3 + M, where
C                              w3 = 3*M**2, if JOB = 'T', or
C                                           COMPQ = 'I' or COMPU <>'N';
C                              w3 = 0,      otherwise;
C                       prefer w3 + M*(M-1).
C
         CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, FG( 1, 2 ),
     $                LDFG, DWORK( IQ2 ), M, FG( 1, 2 ), LDFG,
     $                DWORK( IWRK ), LDWORK-IWRK+1, ITAU )
C
         IF( LCMPQ ) THEN
C
C           Update Q.
C
C           Workspace:     need   w3 + N*M.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', N, M, M, ONE,
     $                   Q, LDQ, DWORK( IQ1 ), M, ZERO, DWORK( IWRK ),
     $                   N )
            CALL DLACPY( 'Full', N, M, DWORK( IWRK ), N, Q, LDQ )
            CALL DGEMM(  'No Transpose', 'No Transpose', N, M, M, ONE,
     $                   Q( 1, M+1 ), LDQ, DWORK( IQ2 ), M, ZERO,
     $                   DWORK( IWRK ), N )
            CALL DLACPY( 'Full', N, M, DWORK( IWRK ), N, Q( 1, M+1 ),
     $                   LDQ )
         END IF
C
         IF( LCMPU ) THEN
C
C           Update U.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', M, M, M, ONE,
     $                   U1, LDU1, DWORK( IU ), M, ZERO, DWORK( IWRK ),
     $                   M )
            CALL DLACPY( 'Full', M, M, DWORK( IWRK ), M, U1, LDU1 )
            CALL DGEMM(  'No Transpose', 'No Transpose', M, M, M, ONE,
     $                   U2, LDU2, DWORK( IU ), M, ZERO, DWORK( IWRK ),
     $                   M )
            CALL DLACPY( 'Full', M, M, DWORK( IWRK ), M, U2, LDU2 )
         END IF
      END IF
C
C     Move the norms, and the triplets of 1-by-1 and 2-by-2 blocks in
C     front.
C
      K = 3*( M - 2*I2X2 ) + 12*I2X2
      CALL DCOPY( K, DWORK( P ), 1, DWORK( 5 ), 1 )
      CALL DCOPY( 3, DUM, 1, DWORK( 2 ), 1 )
C
      DWORK( 1 ) = OPTDW
      RETURN
C *** Last line of MB04ED ***
      END


PROGRAM FIZZBUZZ

  IMPLICIT NONE

  INTEGER :: i, max_num, i3, i5

  max_num = 100  ! Classic FizzBuzz runs from 1 to 100

  ! This approach uses two counters. This is a solution you
  ! might try if the MOD function wasn't available, or you might
  ! come up with it if you're not sure how to check "divides-by" mathematically
  ! You could combine this approach with the string-building approach
  ! in the v2 model.

  ! I chose to have my counters count down, but they could go up
  i3 = 3
  i5 = 5

  DO i = 1, max_num

    i3 = i3 - 1
    i5 = i5 - 1

    IF((i3 == 0) .AND. (i5 == 0)) THEN
      PRINT*, "Fizzbuzz"
      i3 = 3
      i5 = 5
    ELSE IF(i3 == 0) THEN
      PRINT*, "Fizz"
      i3 = 3
    ELSE IF(i5 == 0) THEN
      PRINT*, "Buzz"
      i5 = 5
    ELSE
      PRINT '(i8)', i
    END IF

  ENDDO

END PROGRAM


SUBROUTINE clawpack5_qinit(meqn,mbc,mx,my, &
     xlower,ylower,dx,dy,q,maux,aux)
    IMPLICIT NONE

    INTEGER meqn,mbc,mx,my,maux
    DOUBLE PRECISION xlower,ylower,dx,dy

    DOUBLE PRECISION    q(meqn,1-mbc:mx+mbc, 1-mbc:my+mbc)
    DOUBLE PRECISION  aux(maux,1-mbc:mx+mbc, 1-mbc:my+mbc)

    INTEGER blockno, fc2d_clawpack5_get_block

    DOUBLE PRECISION hin,hout
    COMMON /comic/ hin,hout

    INTEGER i,j
    DOUBLE PRECISION xlow,ylow, win

    blockno = fc2d_clawpack5_get_block()

    DO i = 1-mbc,mx+mbc
        xlow = xlower + (i-1.d0)*dx
        DO j = 1-mbc,my+mbc
            ylow = ylower + (j-1.d0)*dy
            CALL cellave2(blockno,xlow,ylow,dx,dy,win)
            q(1,i,j) = hin*win + hout*(1.d0-win)
            q(2,i,j) = 0.d0
            q(3,i,j) = 0.d0
            if (meqn .eq. 4) then
                q(4,i,j) = 0
            endif
        END DO
    END DO
END SUBROUTINE clawpack5_qinit


      SUBROUTINE TTHREE	(IERROR)
C
C LATEST REVISION	 JULY, 1984
C
C PURPOSE		 TO PROVIDE A SIMPLE DEMONSTRATION OF
C			 THE ROUTINE THREED.
C
C USAGE			 CALL TTHREE (IERROR)
C
C ARGUMENTS
C
C ON OUTPUT		 IERROR
C			   AN INTEGER VARIABLE
C			   =0 IF THERE IS A NORMAL EXIT	FROM THE
C			      ROUTINE THREED.
C			   =1 OTHERWISE
C
C I/O			 IF THERE IS A NORMAL EXIT FROM	THE ROUTINE
C			 THREED	THE MESSAGE
C			   THREED TEST SUCCESSFUL . . .	SEE PLOT TO
C			   VERIFY PERFORMANCE
C			 IS PRINTED.
C
C PRECISION		 SINGLE
C
C LANGUAGE		 FORTRAN
C
C HISTORY		 ORIGINALLY WRITTEN NOVEMBER 1976
C			 CONVERTED TO GKS AND FORTRAN 77 JULY 1984
C
C ALGORITHM		 ROUTINE TTHREE	CALLS SET3 TO ESTABLISH	A
C			 MAPPING BETWEEN THE PLOTTER ADDRESSES AND
C			 THE USER'S VOLUME, AND	TO INDICATE THE
C			 COORDINATES OF	THE EYE	POSITION FROM
C			 WHICH THE LINES TO BE DRAWN ARE VIEWED.
C			 NEXT, THE VOLUME PERIMETERS AND ASSOCIATED
C			 TICK MARKS ARE	DRAWN BY CALLS TO PERIM3.
C			 THEN THE LINES	ARE DRAWN.  THESE ARE
C			 CERTAIN LATITUDES AND LONGITUDES OF A
C			 SPHERE.
C
C PORTABILITY		 ANSI FORTRAN 77
C
C
C
C
      REAL EYE(3),X(31),Y(31),Z(31)
C
C SPECIFY ARGUMENT VALUES TO BE	USED BY	ROUTINE	SET3.  ON AN
C ABSTRACT PLOTTER WITH	AN ADDRESS RANGE OF 0. TO 1. IN	EACH
C COORDINATE DIRECTION,	THE VALUES  RXA, RXB, RYA, AND RYB
C DEFINE THE PORTION OF	THE ADDRESS SPACE TO BE	USED IN	MAKING
C THE PLOT.  UC, UD, VC, VD, WC, WD  DEFINE A VOLUME IN	USER
C COORDINATES WHICH IS TO BE MAPPED ONTO THE PORTION OF	THE
C VIEWING SURFACE AS SPECIFIED BY  RXA,	RXB, RYA, AND RYB.
C
      DATA RXA/0.097656/, RXB/0.90236/,	RYA/0.097656/, RYB/0.90236/
      DATA UC/-1./, UD/1./, VC/-1./, VD/1./, WC/-1./, WD/1./
      DATA EYE(1),EYE(2),EYE(3)/10.,6.,3./
      DATA TX/0.4374/, TY/0.9570/
C
C DEFINE PI
      DATA PI/3.1415926535898/
C
C
C SELECT NORMALIZATION TRANSFORMATION 0
C
      CALL GSELNT (0)
C
C CALL SET3 TO ESTABLISH A MAPPING BETWEEN THE PLOTTER ADDRESSES
C AND THE USER'S VOLUME, AND TO	INDICATE THE COORDINATES OF THE
C EYE POSITION FROM WHICH THE LINES TO BE DRAWN	ARE VIEWED.
C
      CALL SET3(RXA,RXB,RYA,RYB,UC,UD,VC,VD,WC,WD,EYE)
C
C CALL PERIM3 TO DRAW PERIMETER	LINES AND TICK MARKS
C
      CALL PERIM3(2,5,1,10,1,-1.)
      CALL PERIM3(4,2,1,1,2,-1.)
      CALL PERIM3(2,10,4,5,3,-1.)
C
C DEFINE AND DRAW LATITUDINAL LINES ON THE SPHERE OF RADIUS ONE
C HAVING CENTER	(0.,0.,0.)
C
      DO 10 J=1,18
      THETA = FLOAT(J)*PI/9.
      CT = COS(THETA)
      ST = SIN(THETA)
      DO 20 K=1,31
      PHI = FLOAT(K-16)*PI/30.
      Z(K) = SIN(PHI)
      CP = COS(PHI)
      X(K) = CT*CP
      Y(K) = ST*CP
   20 CONTINUE
      CALL CURVE3(X,Y,Z,31)
   10 CONTINUE
C
C DEFINE AND DRAW LONGITUDINAL LINES ON	THE SPHERE OF RADIUS ONE
C HAVING CENTER	(0.,0.,0.)
C
      DO 30 K=1,5
      PHI = FLOAT(K-3)*PI/6.
      SP = SIN(PHI)
      CP = COS(PHI)
      DO 40 J=1,31
      TUETA = FLOAT(J-1)*PI/15.
      X(J) = COS(TUETA)*CP
      Y(J) = SIN(TUETA)*CP
      Z(J) = SP
   40 CONTINUE
      CALL CURVE3(X,Y,Z,31)
   30 CONTINUE
C
C CALL WTSTR FOR THREED	PLOT TITLE
C
      CALL WTSTR(TX,TY,'DEMONSTRATION PLOT FOR ROUTINE THREED',2,0,0)
      call pwrzt (1.,0.,-1.,'DEMONSTRATION PLOT FOR ROUTINE THREED', 37,
     * 2, 2, 3, 0)
C
c     CALL NEWFM
C
      IERROR = 0
c     WRITE(6,1001)
      RETURN
C
c1001 FORMAT('	   THREED TEST SUCCESSFUL', 24X,
c    1	     'SEE PLOT TO VERIFY PERFORMANCE')
      END


program main
	implicit none
	real :: income
	real :: tax = 0
	write (*,'(A)') 'Please input your income(yuan) per month:'
	read  (*,*) income
	if (income < 1000) then
		tax = income * 0.03
	else if (income < 5000) then
			tax = 1000 * 0.03 + (income - 1000) * 0.1
	else
			tax = 1000 * 0.03 + 4000 * 0.1 + (income - 5000) * 0.15
	end if
	write (*,'(A,F0.2,A)') 'Your tax is ', tax, 'yuan.'
	pause
end program main


c=======================================================================
c
c     GENPRM
c
c     Generate random permutation of array
c
c-----------------------------------------------------------------------
c
c-----------------------------------------------------------------------
      SUBROUTINE genprm(array, larray)
c-----------------------------------------------------------------------
c
c     INPUT :
c     ARRAY <--> On output ARRAY is a random permutation of its
c                 value on input
c                         DOUBLE PRECISION ARRAY( LARRAY )
c     LARRAY <--> Length of ARRAY    integer
c
c-----------------------------------------------------------------------
c
      implicit none
c
c     scalar arguments
      INTEGER larray
c
c     array arguments
      DOUBLE PRECISION array(larray)
c
c     local scalars
      INTEGER i, iwhich
      DOUBLE PRECISION elt, llarray
c
c     external functions
      DOUBLE PRECISION ignuin
      EXTERNAL ignuin
c
c     executable statements
      llarray = dble(larray)
      DO i = 1,larray
         iwhich = int(ignuin(dble(i),llarray))
         elt = array(iwhich)
         array(iwhich) = array(i)
         array(i) = elt
      END DO
      END


submodule (m_searching) sm_intervalSearch

implicit none

contains

  !====================================================================!
  module procedure intervalSearch_i1D!(this,v,imin,imax) result(iout)
    !! Perform a binary search on an integer vector
    !! Returns a length 3 integer(i32) vector where the last two entries are the left and right neighbours
    !! The first entry of iout is -1 if the value is not present in the vector
    !! Assumes this is sorted!
  !====================================================================!
!  integer(i32) :: this(:) !! Vector to search within
!  integer(i32) :: v !! Number to find in the vector
!  integer(i32) :: imin !! Left integer
!  integer(i32) :: imax !! Right integer
!  integer(i32) :: iout(3) !! Location of i in this. iout(1) = -1 if not present with iout(2-3) as the interval

  if (imax < imin) then
    iout(2)=imax;iout(3)=imin
    iout(1)=-1
    return
  else
    ! Cut the search in half
    iout(1)=(imax+imin)/2
    ! Three-Way Comparison
    if (this(iout(1)) > v) then
      ! Result is in lower subset
      iout(2)=imin;iout(3)=imax
      iout=intervalSearch_i1D(this,v,imin,iout(1)-1)
    elseif (this(iout(1)) < v) then
      ! Result is in upper subset
      iout(2)=imin;iout(3)=imax
      iout=intervalSearch_i1D(this,v,iout(1)+1,imax)
    else
      ! Result has been found
      iout(2)=iout(1)-1
      iout(2)=max(1,iout(2))
      iout(3)=iout(1)+1
      iout(3)=min(size(this),iout(3))
      return
    endif
  endif
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure intervalSearch_id1D!(this,v,imin,imax) result(iout)
    !! Perform a binary search on an integer vector
    !! Returns a length 3 integer(i32) vector where the last two entries are the left and right neighbours
    !! The first entry of iout is -1 if the value is not present in the vector
    !! Assumes this is sorted!
  !====================================================================!
!  integer(i64) :: this(:) !! Vector to search within
!  integer(i64) :: v !! Number to find in the vector
!  integer(i32) :: imin !! Left integer
!  integer(i32) :: imax !! Right integer
!  integer(i32) :: iout(3) !! Location of i in this. iout(1) = -1 if not present with iout(2-3) as the interval

  if (imax < imin) then
    iout(2)=imax;iout(3)=imin
    iout(1)=-1
    return
  else
    ! Cut the search in half
    iout(1)=(imax+imin)/2
    ! Three-Way Comparison
    if (this(iout(1)) > v) then
      ! Result is in lower subset
      iout(2)=imin;iout(3)=imax
      iout=intervalSearch_id1D(this,v,imin,iout(1)-1)
    elseif (this(iout(1)) < v) then
      ! Result is in upper subset
      iout(2)=imin;iout(3)=imax
      iout=intervalSearch_id1D(this,v,iout(1)+1,imax)
    else
      ! Result has been found
      iout(2)=iout(1)-1
      iout(2)=max(1,iout(2))
      iout(3)=iout(1)+1
      iout(3)=min(size(this),iout(3))
      return
    endif
  endif

  end procedure
  !====================================================================!
  !====================================================================!
  module procedure intervalSearch_r1D!(this,v,imin,imax) result(iout)
  !! Perform a binary search on a double precision vector
  !! Returns a length 3 integer(i32) vector where the last two entries are the left and right neighbours
  !! The first entry of iout is -1 if the value is not present in the vector
  !! Assumes this is sorted!
  !====================================================================!
!  real(r32) :: this(:) !! Vector to search within
!  real(r32) :: v !! Number to find in the vector
!  integer(i32) :: imin !! Left integer
!  integer(i32) :: imax !! Right integer
!  integer(i32) :: iout(3) !! Location of i in this. iout(1) = -1 if not present with iout(2-3) as the interval

  if (imax < imin) then
    iout(2)=imax;iout(3)=imin
    iout(1)=-1
    return
  else
    ! Cut the search in half
    iout(1)=(imax+imin)/2
    ! Three-Way Comparison
    if (this(iout(1)) > v) then
      ! Result is in lower subset
      iout(2)=imin;iout(3)=imax
      iout=intervalSearch_r1D(this,v,imin,iout(1)-1)
    elseif (this(iout(1)) < v) then
      ! Result is in upper subset
      iout(2)=imin;iout(3)=imax
      iout=intervalSearch_r1D(this,v,iout(1)+1,imax)
    else
      ! Result has been found
      iout(2)=iout(1)-1
      iout(2)=max(1,iout(2))
      iout(3)=iout(1)+1
      iout(3)=min(size(this),iout(3))
      return
    endif
  endif

  end procedure
  !====================================================================!
  !====================================================================!
  module procedure intervalSearch_d1D!(this,v,imin,imax) result(iout)
  !! Perform a binary search on a double precision vector
  !! Returns a length 3 integer(i32) vector where the last two entries are the left and right neighbours
  !! The first entry of iout is -1 if the value is not present in the vector
  !! Assumes this is sorted!
  !====================================================================!
!  real(r64) :: this(:) !! Vector to search within
!  real(r64) :: v !! Number to find in the vector
!  integer(i32) :: imin !! Left integer
!  integer(i32) :: imax !! Right integer
!  integer(i32) :: iout(3) !! Location of i in this. iout(1) = -1 if not present with iout(2-3) as the interval

  if (imax < imin) then
    iout(2)=imax;iout(3)=imin
    iout(1)=-1
    return
  else
    ! Cut the search in half
    iout(1)=(imax+imin)/2
    ! Three-Way Comparison
    if (this(iout(1)) > v) then
      ! Result is in lower subset
      iout(2)=imin;iout(3)=imax
      iout=intervalSearch_d1D(this,v,imin,iout(1)-1)
    elseif (this(iout(1)) < v) then
      ! Result is in upper subset
      iout(2)=imin;iout(3)=imax
      iout=intervalSearch_d1D(this,v,iout(1)+1,imax)
    else
      ! Result has been found
      iout(2)=iout(1)-1
      iout(2)=max(1,iout(2))
      iout(3)=iout(1)+1
      iout(3)=min(size(this),iout(3))
      return
    endif
  endif

  end procedure
  !====================================================================!
end submodule


double precision function dnrm2(n, x, incx)
    integer n, incx
    double precision x(n)
    !     **********
    !
    !     Function dnrm2
    !
    !     Given a vector x of length n, this function calculates the
    !     Euclidean norm of x with stride incx.
    !
    !     The function statement is
    !
    !       double precision function dnrm2(n,x,incx)
    !
    !     where
    !
    !       n is a positive integer input variable.
    !
    !       x is an input array of length n.
    !
    !       incx is a positive integer variable that specifies the
    !         stride of the vector.
    !
    !     Subprograms called
    !
    !       FORTRAN-supplied ... abs, max, sqrt
    !
    !     MINPACK-2 Project. February 1991.
    !     Argonne National Laboratory.
    !     Brett M. Averick.
    !
    !     **********
    integer i
    double precision scale

    dnrm2 = 0.0d0
    scale = 0.0d0

    do 10 i = 1, n, incx
        scale = max(scale, abs(x(i)))
    10 continue

    if (scale .eq. 0.0d0) return

    do 20 i = 1, n, incx
        dnrm2 = dnrm2 + (x(i) / scale)**2
    20 continue

    dnrm2 = scale * sqrt(dnrm2)

    return

end

!====================== The end of dnrm2 ===============================

subroutine daxpy(n, da, dx, incx, dy, incy)
    !
    !     constant times a vector plus a vector.
    !     uses unrolled loops for increments equal to one.
    !     jack dongarra, linpack, 3/11/78.
    !
    double precision dx(*), dy(*), da
    integer i, incx, incy, ix, iy, m, mp1, n
    !
    if(n.le.0)return
    if (da .eq. 0.0d0) return
    if(incx.eq.1.and.incy.eq.1)go to 20
    !
    !        code for unequal increments or equal increments
    !          not equal to 1
    !
    ix = 1
    iy = 1
    if(incx.lt.0)ix = (-n + 1) * incx + 1
    if(incy.lt.0)iy = (-n + 1) * incy + 1
    do 10 i = 1, n
        dy(iy) = dy(iy) + da * dx(ix)
        ix = ix + incx
        iy = iy + incy
    10 continue
    return
    !
    !        code for both increments equal to 1
    !
    !
    !        clean-up loop
    !
    20 m = mod(n, 4)
    if(m .eq. 0) go to 40
    do 30 i = 1, m
        dy(i) = dy(i) + da * dx(i)
    30 continue
    if(n .lt. 4) return
    40 mp1 = m + 1
    do 50 i = mp1, n, 4
        dy(i) = dy(i) + da * dx(i)
        dy(i + 1) = dy(i + 1) + da * dx(i + 1)
        dy(i + 2) = dy(i + 2) + da * dx(i + 2)
        dy(i + 3) = dy(i + 3) + da * dx(i + 3)
    50 continue
    return
end

!====================== The end of daxpy ===============================

subroutine dcopy(n, dx, incx, dy, incy)
    !
    !     copies a vector, x, to a vector, y.
    !     uses unrolled loops for increments equal to one.
    !     jack dongarra, linpack, 3/11/78.
    !
    double precision dx(*), dy(*)
    integer i, incx, incy, ix, iy, m, mp1, n
    !
    if(n.le.0)return
    if(incx.eq.1.and.incy.eq.1)go to 20
    !
    !        code for unequal increments or equal increments
    !          not equal to 1
    !
    ix = 1
    iy = 1
    if(incx.lt.0)ix = (-n + 1) * incx + 1
    if(incy.lt.0)iy = (-n + 1) * incy + 1
    do 10 i = 1, n
        dy(iy) = dx(ix)
        ix = ix + incx
        iy = iy + incy
    10 continue
    return
    !
    !        code for both increments equal to 1
    !
    !
    !        clean-up loop
    !
    20 m = mod(n, 7)
    if(m .eq. 0) go to 40
    do 30 i = 1, m
        dy(i) = dx(i)
    30 continue
    if(n .lt. 7) return
    40 mp1 = m + 1
    do 50 i = mp1, n, 7
        dy(i) = dx(i)
        dy(i + 1) = dx(i + 1)
        dy(i + 2) = dx(i + 2)
        dy(i + 3) = dx(i + 3)
        dy(i + 4) = dx(i + 4)
        dy(i + 5) = dx(i + 5)
        dy(i + 6) = dx(i + 6)
    50 continue
    return
end

!====================== The end of dcopy ===============================

double precision function ddot(n, dx, incx, dy, incy)
    !
    !     forms the dot product of two vectors.
    !     uses unrolled loops for increments equal to one.
    !     jack dongarra, linpack, 3/11/78.
    !
    double precision dx(*), dy(*), dtemp
    integer i, incx, incy, ix, iy, m, mp1, n
    !
    ddot = 0.0d0
    dtemp = 0.0d0
    if(n.le.0)return
    if(incx.eq.1.and.incy.eq.1)go to 20
    !
    !        code for unequal increments or equal increments
    !          not equal to 1
    !
    ix = 1
    iy = 1
    if(incx.lt.0)ix = (-n + 1) * incx + 1
    if(incy.lt.0)iy = (-n + 1) * incy + 1
    do 10 i = 1, n
        dtemp = dtemp + dx(ix) * dy(iy)
        ix = ix + incx
        iy = iy + incy
    10 continue
    ddot = dtemp
    return
    !
    !        code for both increments equal to 1
    !
    !
    !        clean-up loop
    !
    20 m = mod(n, 5)
    if(m .eq. 0) go to 40
    do 30 i = 1, m
        dtemp = dtemp + dx(i) * dy(i)
    30 continue
    if(n .lt. 5) go to 60
    40 mp1 = m + 1
    do 50 i = mp1, n, 5
        dtemp = dtemp + dx(i) * dy(i) + dx(i + 1) * dy(i + 1) + &
                dx(i + 2) * dy(i + 2) + dx(i + 3) * dy(i + 3) + dx(i + 4) * dy(i + 4)
    50 continue
    60 ddot = dtemp
    return
end

!====================== The end of ddot ================================

subroutine  dscal(n, da, dx, incx)
    !
    !     scales a vector by a constant.
    !     uses unrolled loops for increment equal to one.
    !     jack dongarra, linpack, 3/11/78.
    !     modified 3/93 to return if incx .le. 0.
    !
    double precision da, dx(*)
    integer i, incx, m, mp1, n, nincx
    !
    if(n.le.0 .or. incx.le.0)return
    if(incx.eq.1)go to 20
    !
    !        code for increment not equal to 1
    !
    nincx = n * incx
    do 10 i = 1, nincx, incx
        dx(i) = da * dx(i)
    10 continue
    return
    !
    !        code for increment equal to 1
    !
    !
    !        clean-up loop
    !
    20 m = mod(n, 5)
    if(m .eq. 0) go to 40
    do 30 i = 1, m
        dx(i) = da * dx(i)
    30 continue
    if(n .lt. 5) return
    40 mp1 = m + 1
    do 50 i = mp1, n, 5
        dx(i) = da * dx(i)
        dx(i + 1) = da * dx(i + 1)
        dx(i + 2) = da * dx(i + 2)
        dx(i + 3) = da * dx(i + 3)
        dx(i + 4) = da * dx(i + 4)
    50 continue
    return
end

!====================== The end of dscal ===============================


!-------------------------------------------------------------------------------
! Copyright (c) 2021, Whitman T. Dailey
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
! 1. Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
! 3. Neither the name of the copyright holder nor the names of its
!    contributors may be used to endorse or promote products derived from
!    this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!-------------------------------------------------------------------------------
Module Legendre_Utilities

    Implicit None
    Private
    Public :: Legendre_P     ! Call Subroutine Legendre_P(x, n, P)
        ! If P is a scalar, it is set to Legendre_P[n,x] (Mathematica notation)
        ! If P is a vector, P(0:n), it is set to P(j) = LegendreP[j,x] for j = 0,..,n
    Public :: Legendre_pdf   ! (x, a, n)
        ! Returns the pdf f(x) = Sum[a[j] * Legendre_P[j],{j,0,n}]
    Public :: Legendre_CDF   ! (x, a, n)
        ! Returns the value of the CDF of that pdf
    Public :: Legendre_CDF_Coefficients ! (a, n)
        ! Returns the vector b(0:n+1) of coefficients of the Legendre series for the CDF
    Public :: Legendre_Derivative_Coefficients ! (a, n)
        ! Returns the vector c(0:n-1) of coefficients of the Legendre series of the derivative
        !   f'(x)  = Sum(c(0:n-1)*P(0:n-1)) = df(x)/dx
        !   where f(x) is the Legendre series f(x) = Sum(a(0:n)*P(0:n))

    ! The variables in the arguments are
        ! x is the independent (distributed) variable
        ! a(0:n) is the vector of Legendre expansion coefficients of the pdf
        ! n is the order of the expansion
        ! b(0:n+1) is the vector of Legendre expansion coefficients of the CDF,
        !   obtained from a(0:n)
        !   Note that, for efficiency, a(j) includes the factor (2j+1)/2,
        !   so that the pdf is simply  Dot_Product(a(0:n), LegendreP(0:n,x))

    Interface Legendre_P
        Module Procedure LegendreP_Scalar
        Module Procedure LegendreP_Vector
        Module Procedure LegendreP_Matrix
    End Interface Legendre_P

Contains

Function Legendre_pdf(x,n,a) Result(f)
    ! Evaluates f(x) = Dot_Product(a(0:n), LegendreP(0:n,x))
    Use Kinds, Only: dp
    Implicit None
    Real(dp):: f
    Real(dp), Intent(In):: x        ! independent variable of pdf, usually the cosine of an angle
    Integer,  Intent(In):: n        ! Order of the (truncated) series
    Real(dp), Intent(In):: a(0:n)   ! Coefficients of Legendre series for pdf
    Real(dp):: P(0:n)

    Call Legendre_P(x,n,P)
    f = Dot_Product(a, P)
End Function Legendre_pdf

Function Legendre_CDF(x,n,a) Result(F)
    ! Evaluates f(x) = Dot_Product(a(0:n), LegendreP(0:n,x))
    Use Kinds, Only: dp
    Implicit None
    Real(dp):: F
    Real(dp), Intent(In):: x        ! independent variable of pdf,  usually the cosine of an angle
    Integer,  Intent(In):: n        ! Order of the (truncated) series
    Real(dp), Intent(In):: a(0:n)   ! Coefficients of Legendre series for pdf, Note that these include the factor (2j+1)/2
    Real(dp):: P(0:n+1)             ! Legendre polynomials evaluated at x
    Real(dp):: b(0:n+1)             ! Coefficients of Legendre series for CDF

    Call Legendre_P(x, n+1, P)
    b = Legendre_CDF_Coefficients(n,a)
    F = Dot_Product(b, P)
End Function Legendre_CDF

Function Legendre_CDF_Coefficients(n,a) Result (b)
    Use Kinds, Only: dp
    Implicit None
    Integer, Intent(In):: n         ! Order of pdf. Order of CDF is n+1 due to integration
    Real(dp), Intent(In):: a(0:n)   ! Coefficients of Legendre series of order n of a pdf
    Real(dp):: b(0:n+1)             !
    Real(dp):: c(0:n)               ! working vector, to avoid changing the argument a
    Integer:: j                     ! Do loop counter

    ! Set up coefficients of CDF
    Do j = 0,n
        c(j) = a(j) / Real(2*j+1,dp)
    End do
    b(0) = c(0) - c(1)
    b(1:n-1) = c(0:n-2) - c(2:n)
    b(n:n+1) = c(n-1:n)
End Function Legendre_CDF_Coefficients

Function Legendre_Derivative_Coefficients(n,a) Result(c)
    ! This function produces the coefficients c(0:n-1) of the derivative f'(x)
    !   given the coefficients a(0:n) of f(x)
    !   where f(x) = Dot_Product(a(0:n), LegendreP(0:n,x))
    !   and f'(x) = Dot_Product(c(0:n-1), LegendreP(0:n-1,x))
    Use Kinds, Only: dp
    Implicit None
    Integer,  Intent(In):: n
    Real(dp), Intent(In):: a(0:n)
    Real(dp):: c(0:n-1)
    Integer:: j

    Do j = 0,n-1
        c(j) = Real(2*j+1,dp) * Sum(a(j+1:n:2))
    End do
    ! Note: this approach entails redundant additions
    !   but this should be justified by its elegance
End Function Legendre_Derivative_Coefficients

Subroutine LegendreP_Scalar(x, n, P)
    ! This routine computes LegendreP(n,x) recursively
    !   discarding all the Legendre polynomials of lower order than L
    ! It is very inefficient to call it repeatedly to get P(0,x) through P(n,X)
    !   Use the vector routine which does not waste work.
    ! Better, use the matrix routine,
    !   which vectorizes the arithmetic for multiple arguments x(1:N)
    Use Kinds, Only: dp
    Implicit None
    Real(dp), Intent(In) :: x            ! Argument
    Integer, Intent(In) :: n             ! Order of Legendre Polynomial
    Real(dp), Intent(Out) :: P           ! P = LegendreP(L, x)
    Integer :: j
    Real(dp) :: P_prior
    Real(dp) :: P_current

    Select Case (n)
        Case(2:)
            P = 1.0_dp
            P_current = P
            P = x
            Do j = 1,n-1
                P_prior = P_current
                P_current = P
                P = (Real(2*j+1,dp)/Real(j+1,dp)) * x * P_current - (Real(j,dp)/Real(j+1,dp)) * P_prior
            End do
        Case (1)
            P = x
        Case(0)
            P = 1.0_dp
        End Select
End Subroutine LegendreP_Scalar

Subroutine LegendreP_Vector(x, n, P)
    ! More efficient to use the matrix version rather than calling this repeatedly,
    !   because it vectorizes and this is sequential.
    Use Kinds, Only: dp
    Implicit None
    Real(dp), Intent(In) :: x            ! Argument
    Integer, Intent(In) :: n             ! Max order of Legendre Polynomials
    Real(dp), Intent(Out) :: P(0:n)      ! P(j) = LegendreP(j, x)
    Integer :: j

    Select Case (n)
        Case (2:)
            P(0) = 1._dp
            P(1) = x
            Do j = 1,n-1
                P(j+1) = (Real(2*j+1,dp)/Real(j+1,dp)) * x * P(j) - (Real(j,dp)/Real(j+1,dp)) * P(j-1)
            End do
        Case(1)
            P(0) = 1._dp
            P(1) = x
        Case(0)
            P = 1._dp
        End Select
End Subroutine LegendreP_Vector

Subroutine LegendreP_Matrix(nx, x, n, P)
    Use Kinds, Only: dp
    Implicit None
    Integer, Intent(In) :: nx            ! Number of arguments
    Real(dp), Intent(In) :: x(1:nx)       ! Arguments
    Integer, Intent(In) :: n     ! Max order of Legendre Polynomials
    Real(dp), Intent(Out) :: P(1:nx,0:n)  ! P(k,j) = LegendreP(j, x(k))
           ! The inconvenient subscript order is required so that the vector operations are on P(:,j), not P(j,:),
           !  for sequential storage of vector arithmetic arguments.
    Integer :: j

    Select Case (n)
        Case (2:)
            P(:,0) = 1._dp
            P(:,1) = x
            Do j = 1,n-1
                P(:,j+1) = (Real(2*j+1,dp)/Real(j+1,dp)) * x(:) * P(:,j) - (Real(j,dp)/Real(j+1,dp)) * P(:,j-1)
            End do
        Case(1)
            P(:,0) = 1._dp
            P(:,1) = x
        Case(0)
            P = 1._dp
        End Select
End Subroutine LegendreP_Matrix

End Module Legendre_Utilities


 PROGRAM Area
  DO
   PRINT*, "Type in the radius, a negative value will terminate"
   READ*, radius
   IF (radius .LT. 0) EXIT
    ... area calculation
    PRINT*, "Area of circle with radius ",&
            radius, " is ", area
    PRINT*, "Volume of sphere with radius ",&
            radius, " is ", volume
  END DO
  END PROGRAM Area


	FUNCTION PR_WTND ( ctend )
C************************************************************************
C* PR_WTND								*
C*									*
C* This subroutine translates a WMO pressure tendency code into a	*
C* pressure change in millibars.					*
C*									*
C* REAL PR_WTND ( CTEND )						*
C*									*
C* Input parameters:							*
C*	CTEND		CHAR*		WMO pressure tendency code	*
C*									*
C* Output parameters:							*
C*	PR_WTND		REAL		Pressure change in mb		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 2/88						*
C* K. Brill/NMC		12/90	Documentation				*
C* M. Linda/GSC		10/97	Corrected the prologue format		*
C* J. Wu/GSC            07/00   Moved INCLUDE 'ERMISS.FNC' before the   *
C*                              DATA statement                          *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	ctend
C*
	CHARACTER	c*1
	REAL		psign ( 9 )
	INCLUDE		'ERMISS.FNC'
	DATA		psign / 4 * 1., 0., 4 * -1. /
C*
C------------------------------------------------------------------------
	PR_WTND = RMISSD
C
C*	Get pressure tendency characteristic.
C
	c = ctend ( 1:1 )
	IF  ( ( c .ge. '0' ) .and. ( c .le. '8' ) ) THEN
	    CALL ST_INTG ( c, itendc, ier )
	    IF  ( ctend ( 2:4 ) .ne. '999' ) THEN
		CALL ST_CRNM ( ctend ( 2:4 ), ptend, ier )
		IF  ( .not. ERMISS ( ptend ) ) THEN
		    PR_WTND = psign ( itendc + 1 ) * ptend / 10.
		END IF
	    END IF
	END IF
C*
	RETURN
	END


!	Compute inverse for n by n matrix with modified Cholesky
!	decomposition tri.
function invert(tri)
implicit none
real(kind=8),intent(in)::tri(:,:)
real(kind=8)::invert(size(tri,1),size(tri,1))
integer::row,col,n
n=size(tri,1)
!	Invert diagonals.
do  row=1,n
	if(tri(row,row)>0.0_8) invert(row,row) = 1.0_8/tri(row,row)
	if(tri(row,row)<=0.0) invert(row,row) = 0.0_8
end do
if(n==1) return
!	Off-diagonals.
do  row=2,n
	do  col=1,row-1
		invert(row,col) = -tri(row,col)
	 	if(col<row-1)invert(row,col)=invert(row,col)-dot_product(tri(row,col+1:row-1),invert(col+1:row-1,col))
		invert(col,row) = invert(row,col)*invert(row,row)
	end do
end do
!	Full inverse
do  row=1,n
	do  col=1,row
		invert(row,col) = invert(col,row)
		if(row<n) invert(row,col)=invert(row,col)+dot_product(invert(row+1:n,row),invert(col,row+1:n))
	end do
end do
do row=2,n
	do col=1,row-1
		invert(col,row) = invert(row,col)
	end do
end do
return
end function invert


 subroutine steady_solver_sg
USE global_Variables
 USE parameters
 USE multigrid_levels
 USE parallel_variables
use kind_parameters
 implicit none
  include "mpif.h"

        call reset_pressure(pc, ipmax, jpmax, start_x, end_x)

        call velocity_coefficients(aw, ae, as, an, ap, ap_zero, d_u, d_v, uf, vf, rho_uf, mu_uf, rho_vf, mu_vf, gammat_uf, gammat_vf, dx, dy, delx, dely, ipmax, jpmax, start_x, end_x)
        call source_terms(u0, v0, uf0, vf0, ap_zero, f_uvel, f_vvel, su, sv, bu, bv, s_uf, s_vf, rho_vf, p_uf, p_vf, dx, dy, ipmax, jpmax, start_x, end_x)
        call line_gs_solver(u, ap, aw, ae, as, an, bu, fu, ipmax, jpmax, alphau, start_x, end_x)
        call line_gs_solver(v, ap, aw, ae, as, an, bv, fv, ipmax, jpmax, alphav, start_x, end_x)

        call  momentum_interpolation(u, v, p, aw, ae, as, an, ap, su, sv, f_uf, f_vf, s_uf, s_vf, res_uf, res_vf, auf_bar, avf_bar, uf, vf, dx, dy, ipmax, jpmax, start_x, end_x)

        call pcoefficients(uf, vf, auf_bar, avf_bar, awp, aep, asp, anp, app, bp, dx, dy, ipmax, jpmax, start_x, end_x)

        call line_gs_solver(pc, app, awp, aep, asp, anp, bp, fp, ipmax, jpmax, alphapc, start_x, end_x)

        call correction(u, v, uf, vf, pc, p, auf_bar, avf_bar, p_uf, p_vf, d_u, d_v, dx, dy, ipmax, jpmax, start_x, end_x, alphap)

        call convergence(u, aw, ae, as, an, ap, bu, fu, dx, dy, ipmax, jpmax, start_x, end_x, residualu)
        call convergence(v, aw, ae, as, an, ap, bv, fv, dx, dy, ipmax, jpmax, start_x, end_x, residualv)
        call convergencep(bp, fp, dx, dy, ipmax, jpmax, start_x, end_x, residualp)
        !call convergencet

end subroutine


      module populations
        use, intrinsic :: iso_fortran_env, only : REAL64, INT16, INT32, INT64
        use eedf, only : Ntimes
        use physics, only : NCollProc, n
        use fparser

        implicit none
        private

        real(REAL64), allocatable :: A(:)
        real(REAL64), allocatable :: Q(:)

        real(REAL64), allocatable, public :: pops(:,:)
        integer, parameter      :: Nsteps = 1000
        real(REAL64) h

        character(len=120), public :: neexpr

        integer, public :: Npops

        public :: init_pops, calculate_pops, print_pops, clean_up_pops

      contains

        subroutine init_pops()
          use io, only : Araw, Qraw
          implicit none

          allocate(A(Npops))
          allocate(Q(Npops))

          A = Araw
          Q = Qraw*1e-6 ! convert to m^3 s^-1 (was cm^3 s^-1)

          call initf(1)
          call parsef(1, neexpr, (/ 't' /))

        end subroutine init_pops

        subroutine calculate_pops()
          use physics, only : tfin

          implicit none

          ! Runge-Kutta parameters
          real(REAL64)             :: k1(Npops), k2(Npops), k3(Npops), k4(Npops)
          ! time variables
          real(REAL64)             :: t
          integer it

          ! select step size
          h = tfin/real(Nsteps, REAL64)

          allocate(pops(0:Nsteps+1, Npops))

          pops = 0.
          t = 0
          it = 0

          do while (t .le. tfin)

            k1 = h*f(t, pops(it,:))
            k2 = h*f(t+h/2., pops(it,:) + k1/2.)
            k3 = h*f(t+h/2., pops(it,:) + k2/2.)
            k4 = h*f(t+h, pops(it,:) + k3)

            pops(it+1,:) = pops(it,:) + 1/6. * (k1+2*k2+2*k3+k4)

            t = t+h
            it = it+1
          end do
        end subroutine calculate_pops

        subroutine print_pops()
          use io, only : pops_f
          implicit none

          integer it

          open(pops_f,file='pops.dat')

          do it=0, Nsteps
            write(pops_f,*) it*h, pops(it,:)
          end do

          close(pops_f)
        end subroutine print_pops

        function f(t,pops)
          use ratecoeffs, only : ratecoeff
          implicit none

          real(REAL64), intent(in) :: t, pops(Npops)
          ! return values
          real(REAL64)             :: f(Npops)
          real(REAL64)             :: ne
          integer ip

          ne = evalf(1, (/ t /))

          f = ne*(/ (ratecoeff(t, ip),ip=2,Npops+1) /)*n - (Q*n+A)*pops
        end function f

        subroutine clean_up_pops()
          implicit none
          deallocate(pops,A,Q)
        end subroutine clean_up_pops
      end module populations