! This file is part of NHDS
! Copyright (C) 2020 Daniel Verscharen (d.verscharen@ucl.ac.uk)
!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.
!
!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 OWNER 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.
!
!The views and conclusions contained in the software and documentation are those
!of the authors and should not be interpreted as representing official policies,
!either expressed or implied, of the NHDS project.

subroutine disptensor(D,x,kz,kperp)
use input_params
implicit none
double complex :: ep(3,3),D(3,3),chi(3,3)
double precision :: kz,kperp
double complex :: x
integer :: i,k,j

do i=1,3
 do k=1,3
  ep(i,k)=0.d0
 enddo
enddo

do j=1,numspec
  call calc_chi(chi,j,kz,kperp,x)
  do i=1,3
    do k=1,3
      ep(i,k)=ep(i,k)+chi(i,k)
    enddo
  enddo
enddo

!vAc is the Alfven speed in units of speed of light
do i=1,3
  ep(i,i)=ep(i,i)+vAc*vAc*x*x
enddo

do i=1,3
  do k=1,3
    D(i,k)=ep(i,k)
  enddo
enddo

D(1,1)=D(1,1)-kz*kz
D(1,3)=D(1,3)+kz*kperp
D(2,2)=D(2,2)-(kperp*kperp+kz*kz)
D(3,1)=D(3,1)+kz*kperp
D(3,3)=D(3,3)-Kperp*kperp

!now the tensor has been determined, the determinant has to vanish!

end subroutine


      SUBROUTINE MB03BZ( JOB, COMPQ, K, N, ILO, IHI, S, A, LDA1, LDA2,
     $                   Q, LDQ1, LDQ2, ALPHA, BETA, SCAL, DWORK,
     $                   LDWORK, ZWORK, LZWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To find the eigenvalues of the complex generalized matrix product
C
C                  S(1)           S(2)                 S(K)
C          A(:,:,1)     * A(:,:,2)     * ... * A(:,:,K)    ,  S(1) = 1,
C
C     where A(:,:,1) is upper Hessenberg and A(:,:,i) is upper
C     triangular, i = 2, ..., K, using a single-shift version of the
C     periodic QZ method. In addition, A may be reduced to periodic
C     Schur form by unitary transformations: all factors A(:,:,i) become
C     upper triangular.
C
C     If COMPQ = 'V' or COMPQ = 'I', then the unitary factors are
C     computed and stored in the array Q so that for S(I) = 1,
C
C                         H
C             Q(:,:,I)(in)   A(:,:,I)(in)   Q(:,:,MOD(I,K)+1)(in)
C                          H                                        (1)
C         =   Q(:,:,I)(out)  A(:,:,I)(out)  Q(:,:,MOD(I,K)+1)(out),
C
C     and for S(I) = -1,
C
C                                  H
C             Q(:,:,MOD(I,K)+1)(in)   A(:,:,I)(in)   Q(:,:,I)(in)
C                                   H                               (2)
C         =   Q(:,:,MOD(I,K)+1)(out)  A(:,:,I)(out)  Q(:,:,I)(out).
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; A will not
C                    necessarily be put into periodic Schur form;
C             = 'S': put A into periodic Schur form, and return the
C                    eigenvalues in ALPHA, BETA, and SCAL.
C
C     COMPQ   CHARACTER*1
C             Specifies whether or not the unitary transformations
C             should be accumulated in the array Q, as follows:
C             = 'N': do not modify Q;
C             = 'V': modify the array Q by the unitary transformations
C                    that are applied to the matrices in the array A to
C                    reduce them to periodic Schur form;
C             = 'I': like COMPQ = 'V', except that each matrix in the
C                    array Q will be first initialized to the identity
C                    matrix.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of factors.  K >= 1.
C
C     N       (input)  INTEGER
C             The order of each factor in the array A.  N >= 0.
C
C     ILO     (input)  INTEGER
C     IHI     (input)  INTEGER
C             It is assumed that each factor in A is already upper
C             triangular in rows and columns 1:ILO-1 and IHI+1:N.
C             1 <= ILO <= IHI <= N, if N > 0;
C             ILO = 1 and IHI  = 0, if N = 0.
C
C     S       (input)  INTEGER array, dimension (K)
C             The leading K elements of this array must contain the
C             signatures of the factors. Each entry in S must be either
C             1 or -1. By definition, S(1) must be set to 1.
C
C     A       (input/output) COMPLEX*16 array, dimension (LDA1,LDA2,K)
C             On entry, the leading N-by-N-by-K part of this array
C             must contain the factors in upper Hessenberg-triangular
C             form, that is, A(:,:,1) is upper Hessenberg and the other
C             factors are upper triangular.
C             On exit, if JOB = 'S' and INFO = 0, the leading
C             N-by-N-by-K part of this array contains the factors of
C             A in periodic Schur form. All factors are reduced to
C             upper triangular form and, moreover, A(:,:,2), ...,
C             A(:,:,K) are normalized so that their diagonals contain
C             nonnegative real numbers.
C             On exit, if JOB = 'E', then the leading N-by-N-by-K part
C             of this array contains meaningless elements.
C
C     LDA1    INTEGER
C             The first leading dimension of the array A.
C             LDA1 >= MAX(1,N).
C
C     LDA2    INTEGER
C             The second leading dimension of the array A.
C             LDA2 >= MAX(1,N).
C
C     Q       (input/output) COMPLEX*16 array, dimension (LDQ1,LDQ2,K)
C             On entry, if COMPQ = 'V', the leading N-by-N-by-K part
C             of this array must contain the initial unitary factors
C             as described in (1) and (2).
C             On exit, if COMPQ = 'V' or COMPQ = 'I', the leading
C             N-by-N-by-K part of this array contains the modified
C             unitary factors as described in (1) and (2).
C             This array is not referenced if COMPQ = 'N'.
C
C     LDQ1    INTEGER
C             The first leading dimension of the array Q.  LDQ1 >= 1,
C             and, if COMPQ <> 'N', LDQ1 >= MAX(1,N).
C
C     LDQ2    INTEGER
C             The second leading dimension of the array Q.  LDQ2 >= 1,
C             and, if COMPQ <> 'N', LDQ2 >= MAX(1,N).
C
C     ALPHA   (output) COMPLEX*16 array, dimension (N)
C             On exit, if INFO = 0, the leading N elements of this
C             array contain the scaled eigenvalues of the matrix
C             product A. The i-th eigenvalue of A is given by
C
C             ALPHA(I) / BETA(I) * BASE**(SCAL(I)),
C
C             where ABS(ALPHA(I)) = 0.0 or 1.0 <= ABS(ALPHA(I)) < BASE,
C             and BASE is the machine base (normally 2.0).
C
C     BETA    (output) COMPLEX*16 array, dimension (N)
C             On exit, if INFO = 0, the leading N elements of this
C             array contain indicators for infinite eigenvalues. That
C             is, if BETA(I) = 0.0, then the i-th eigenvalue is
C             infinite. Otherwise BETA(I) is set to 1.0.
C
C     SCAL    (output) INTEGER array, dimension (N)
C             On exit, if INFO = 0, the leading N elements of this
C             array contain the scaling parameters for the eigenvalues
C             of A.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the minimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,N).
C
C     ZWORK   COMPLEX*16 array, dimension (LZWORK)
C             On exit, if INFO = 0, ZWORK(1) returns the minimal value
C             of LZWORK.
C
C     LZWORK  INTEGER
C             The length of the array ZWORK.  LZWORK >= MAX(1,N).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0      :  succesful exit;
C             < 0      :  if INFO = -i, the i-th argument had an illegal
C                         value;
C             = 1,..,N :  the periodic QZ iteration did not converge.
C                         A is not in periodic Schur form, but
C                         ALPHA(I), BETA(I), and SCAL(I), for
C                         I = INFO+1,...,N should be correct.
C
C     METHOD
C
C     A slightly modified version of the periodic QZ algorithm is
C     used. For more details, see [2].
C
C     REFERENCES
C
C     [1] Bojanczyk, A., Golub, G. H. and Van Dooren, P.
C         The periodic Schur decomposition: algorithms and applications.
C         In F.T. Luk (editor), Advanced Signal Processing Algorithms,
C         Architectures, and Implementations III, Proc. SPIE Conference,
C         vol. 1770, pp. 31-42, 1992.
C
C     [2] Kressner, D.
C         An efficient and reliable implementation of the periodic QZ
C         algorithm. IFAC Workshop on Periodic Control Systems (PSYCO
C         2001), Como (Italy), August 27-28 2001. Periodic Control
C         Systems 2001 (IFAC Proceedings Volumes), Pergamon.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically backward stable.
C                                 3
C     The algorithm requires 0(K N ) floating point operations.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, Dec. 2002.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Aug. 2009, SLICOT Library version of the routine ZPGEQZ.
C     V. Sima, Nov. 2011, July 2012.
C
C     KEYWORDS
C
C     Eigenvalues, periodic QZ algorithm, periodic Schur form, unitary
C     equivalence transformations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      COMPLEX*16        CONE, CZERO
      PARAMETER         ( CONE  = ( 1.0D+0, 0.0D+0 ),
     $                    CZERO = ( 0.0D+0, 0.0D+0 ) )
C     .. Scalar Arguments ..
      CHARACTER         COMPQ, JOB
      INTEGER           IHI, ILO, INFO, K, LDA1, LDA2, LDQ1, LDQ2,
     $                  LDWORK, LZWORK, N
C     .. Array Arguments ..
      INTEGER           S(*), SCAL(*)
      DOUBLE PRECISION  DWORK(*)
      COMPLEX*16        A(LDA1, LDA2, *), ALPHA(*), BETA(*),
     $                  Q(LDQ1, LDQ2, *), ZWORK(*)
C     .. Local Scalars ..
      LOGICAL           LINIQ, LSCHR, SOK, WANTQ
      INTEGER           IFIRST, IFRSTM, IITER, ILAST, ILASTM, IN, J, J1,
     $                  JDEF, JITER, JLO, L, LDEF, LN, MAXIT, NTRA,
     $                  ZITER
      DOUBLE PRECISION  ABST, BASE, CS, SAFMAX, SAFMIN, SMLNUM, TOL, ULP
      COMPLEX*16        SN, TEMP
C     .. Local Arrays ..
      INTEGER           ISEED(4)
      COMPLEX*16        RND(4)
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, ZLANHS, ZLANTR
      EXTERNAL          DLAMCH, LSAME, ZLANHS, ZLANTR
C     .. External Subroutines ..
      EXTERNAL          DLABAD, MA01BZ, XERBLA, ZLARNV, ZLARTG, ZLASET,
     $                  ZROT, ZSCAL
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, DCMPLX, DCONJG, INT, LOG, MAX, MIN,
     $                  MOD
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      LSCHR = LSAME( JOB,   'S' )
      LINIQ = LSAME( COMPQ, 'I' )
      WANTQ = LSAME( COMPQ, 'V' ) .OR. LINIQ
C
C     Check the scalar input parameters.
C
      INFO = 0
      IF ( .NOT. ( LSCHR .OR. LSAME( JOB, 'E' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.WANTQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN
         INFO = -2
      ELSE IF ( K.LT.0 ) THEN
         INFO = -3
      ELSE IF ( N.LT.0 ) THEN
         INFO = -4
      ELSE IF ( ILO.LT.1 ) THEN
         INFO = -5
      ELSE IF ( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
         INFO = -6
      ELSE
         SOK = S(1).EQ.1
         DO 10  L = 2, K
            SOK = SOK .AND. ( S(L).EQ.1 .OR. S(L).EQ.-1 )
   10    CONTINUE
         IF ( .NOT.SOK ) THEN
            INFO = -7
         ELSE IF ( LDA1.LT.MAX( 1, N ) ) THEN
            INFO = -9
         ELSE IF ( LDA2.LT.MAX( 1, N ) ) THEN
            INFO = -10
         ELSE IF ( LDQ1.LT.1 .OR. ( WANTQ .AND. LDQ1.LT.N ) ) THEN
            INFO = -12
         ELSE IF ( LDQ2.LT.1 .OR. ( WANTQ .AND. LDQ2.LT.N ) ) THEN
            INFO = -13
         ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN
            INFO = -18
         ELSE IF ( LZWORK.LT.MAX( 1, N ) ) THEN
            INFO = -20
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03BZ', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         DWORK(1) = ONE
         ZWORK(1) = CONE
         RETURN
      END IF
C
C     Initialize Q.
C
      IF ( LINIQ ) THEN
         DO 20  L = 1, K
            CALL ZLASET( 'Full', N, N, CZERO, CONE, Q(1,1,L), LDQ1 )
   20    CONTINUE
      END IF
C
C     Machine Constants.
C
      IN = IHI + 1 - ILO
      SAFMIN = DLAMCH( 'SafeMinimum' )
      SAFMAX = ONE / SAFMIN
      ULP = DLAMCH( 'Precision' )
      CALL DLABAD( SAFMIN, SAFMAX )
      SMLNUM = SAFMIN*( IN / ULP )
      BASE = DLAMCH( 'Base' )
      IF ( K.GE.INT( LOG( DLAMCH( 'Underflow' ) ) / LOG( ULP ) ) ) THEN
C
C        Start Iteration with a controlled zero shift.
C
         ZITER = -1
      ELSE
         ZITER = 0
      END IF
C
C     Set Eigenvalues IHI+1:N.
C
      DO 30  J = IHI + 1, N
         CALL MA01BZ( BASE, K, S, A(J,J,1), LDA1*LDA2, ALPHA(J),
     $                BETA(J), SCAL(J) )
   30 CONTINUE
C
C     If IHI < ILO, skip QZ steps.
C
      IF ( IHI.LT.ILO )
     $   GO TO 460
C
C     MAIN PERIODIC QZ ITERATION LOOP.
C
C     Initialize dynamic indices.
C
C     Eigenvalues ILAST+1:N have been found.
C        Column operations modify rows IFRSTM:whatever.
C        Row operations modify columns whatever:ILASTM.
C
C     If only eigenvalues are being computed, then
C        IFRSTM is the row of the last splitting row above row ILAST;
C        this is always at least ILO.
C     IITER counts iterations since the last eigenvalue was found,
C        to tell when to use an observed zero or random shift.
C     MAXIT is the maximum number of QZ sweeps allowed.
C
      ILAST = IHI
      IF ( LSCHR ) THEN
         IFRSTM = 1
         ILASTM = N
      ELSE
         IFRSTM = ILO
         ILASTM = IHI
      END IF
      IITER = 0
      ISEED(1) = 1
      ISEED(2) = 0
      ISEED(3) = 0
      ISEED(4) = 1
      MAXIT = 30 * IN
C
      DO  450 JITER = 1, MAXIT
C
C        Special Case: ILAST = ILO.
C
         IF ( ILAST.EQ.ILO )
     $      GO TO 390
C
C        **************************************************************
C        *                     CHECK FOR DEFLATION                    *
C        **************************************************************
C
C        Test 1:  Deflation in the Hessenberg matrix.
C
         JLO = ILO
         DO 40  J = ILAST, ILO + 1, -1
            TOL = ABS( A(J-1,J-1,1) ) + ABS( A(J,J,1) )
            IF ( TOL.EQ.ZERO )
     $         TOL = ZLANHS( '1', J-ILO+1, A(ILO,ILO,1), LDA1, DWORK )
            TOL = MAX( ULP*TOL, SMLNUM )
            IF ( ABS( A(J,J-1,1) ).LE.TOL ) THEN
               A(J,J-1,1) = CZERO
               JLO = J
               IF ( J.EQ.ILAST )
     $            GO TO 390
               GO TO 50
            END IF
   40    CONTINUE
C
   50    CONTINUE
C
C        Test 2:  Deflation in the triangular matrices with index 1.
C
         DO 70  LDEF = 2, K
            IF ( S(LDEF).EQ.1 ) THEN
               DO 60  J = ILAST, JLO, -1
                  IF ( J.EQ.ILAST ) THEN
                     TOL = ABS( A(J-1,J,LDEF) )
                  ELSE IF ( J.EQ.JLO ) THEN
                     TOL = ABS( A(J,J+1,LDEF) )
                  ELSE
                     TOL = ABS( A(J-1,J,LDEF) ) + ABS( A(J,J+1,LDEF) )
                  END IF
                  IF ( TOL.EQ.ZERO )
     $               TOL = ZLANTR( '1', 'Upper', 'Non-unit', J-JLO+1,
     $                             J-JLO+1, A(JLO,JLO,LDEF), LDA1,
     $                             DWORK )
                  TOL = MAX( ULP*TOL, SMLNUM )
                  IF ( ABS( A(J,J,LDEF) ).LE.TOL ) THEN
                     A(J,J,LDEF) = CZERO
                     GO TO 170
                  END IF
   60          CONTINUE
            END IF
   70    CONTINUE
C
C        Test 3:  Deflation in the triangular matrices with index -1.
C
         DO 90  LDEF = 2, K
            IF ( S(LDEF).EQ.-1 ) THEN
               DO 80  J = ILAST, JLO, -1
                  IF ( J.EQ.ILAST ) THEN
                     TOL = ABS( A(J-1,J,LDEF) )
                  ELSE IF ( J.EQ.JLO ) THEN
                     TOL = ABS( A(J,J+1,LDEF) )
                  ELSE
                     TOL = ABS( A(J-1,J,LDEF) ) + ABS( A(J,J+1,LDEF) )
                  END IF
                  IF ( TOL.EQ.ZERO )
     $               TOL = ZLANTR( '1', 'Upper', 'Non-unit', J-JLO+1,
     $                             J-JLO+1, A(JLO,JLO,LDEF), LDA1,
     $                             DWORK )
                  TOL = MAX( ULP*TOL, SMLNUM )
                  IF ( ABS( A(J,J,LDEF) ).LE.TOL ) THEN
                     A(J,J,LDEF) = CZERO
                     GO TO 320
                  END IF
   80          CONTINUE
            END IF
   90    CONTINUE
C
C        Test 4:  Controlled zero shift.
C
         IF ( ZITER.GE.7 .OR. ZITER.LT.0 ) THEN
C
C           Make Hessenberg matrix upper triangular.
C
            DO 100 J = JLO, ILAST - 1
               TEMP = A(J,J,1)
               CALL ZLARTG( TEMP, A(J+1,J,1), CS, SN, A(J,J,1) )
               A(J+1,J,1) = CZERO
               CALL ZROT( ILASTM-J, A(J,J+1,1), LDA1,
     $                    A(J+1,J+1,1), LDA1, CS, SN )
               DWORK(J) = CS
               ZWORK(J) = SN
  100       CONTINUE
            IF ( WANTQ ) THEN
               DO 110  J = JLO, ILAST - 1
                  CALL ZROT( N, Q(1,J,1), 1, Q(1,J+1,1), 1, DWORK(J),
     $                       DCONJG( ZWORK(J) ) )
  110          CONTINUE
            END IF
C
C           Propagate Transformations back to A_1.
C
            DO 150  L = K, 2, -1
               IF ( S(L).EQ.1 ) THEN
                  DO 120  J = JLO, ILAST - 1
                     SN = ZWORK(J)
                     IF ( SN.NE.CZERO ) THEN
                        CS = DWORK(J)
                        CALL ZROT( J+2-IFRSTM, A(IFRSTM,J,L), 1,
     $                             A(IFRSTM,J+1,L), 1, CS,
     $                             DCONJG( SN ) )
C
C                       Check for deflation.
C
                        TOL = ABS( A(J,J,L) ) + ABS( A(J+1,J+1,L) )
                        IF ( TOL.EQ.ZERO )
     $                     TOL = ZLANHS( '1', J-JLO+2, A(JLO,JLO,L),
     $                                   LDA1, DWORK )
                        TOL = MAX( ULP*TOL, SMLNUM )
                        IF ( ABS( A(J+1,J,L) ).LE.TOL ) THEN
                           CS = ONE
                           SN = CZERO
                           A(J+1,J,L) = CZERO
                        ELSE
C
                           TEMP = A(J,J,L)
                           CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN,
     $                                  A(J,J,L) )
                           A(J+1,J,L) = CZERO
                           CALL ZROT( ILASTM-J, A(J,J+1,L), LDA1,
     $                                A(J+1,J+1,L), LDA1, CS, SN )
                        END IF
                        DWORK(J) = CS
                        ZWORK(J) = SN
                     END IF
  120             CONTINUE
               ELSE
                  DO 130  J = JLO, ILAST - 1
                     SN = ZWORK(J)
                     IF ( SN.NE.CZERO ) THEN
                        CS = DWORK(J)
                        CALL ZROT( ILASTM-J+1, A(J,J,L), LDA1,
     $                             A(J+1,J,L), LDA1, CS, SN )
C
C                       Check for deflation.
C
                        TOL = ABS( A(J,J,L) ) + ABS( A(J+1,J+1,L) )
                        IF ( TOL.EQ.ZERO )
     $                     TOL = ZLANHS( '1', J-JLO+2, A(JLO,JLO,L),
     $                                   LDA1, DWORK )
                        TOL = MAX( ULP*TOL, SMLNUM )
                        IF ( ABS( A(J+1,J,L) ).LE.TOL ) THEN
                           CS = ONE
                           SN = CZERO
                           A(J+1,J,L) = CZERO
                        ELSE
C
                           TEMP = A(J+1,J+1,L)
                           CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN,
     $                                  A(J+1,J+1,L) )
                           A(J+1,J,L) = CZERO
                           CALL ZROT( J+1-IFRSTM, A(IFRSTM,J+1,L), 1,
     $                                A(IFRSTM,J,L), 1, CS, SN )
                        END IF
                        DWORK(J) =  CS
                        ZWORK(J) = -SN
                     END IF
  130             CONTINUE
               END IF
C
               IF ( WANTQ ) THEN
                  DO 140  J = JLO, ILAST - 1
                     CALL ZROT( N, Q(1,J,L), 1, Q(1,J+1,L), 1, DWORK(J),
     $                          DCONJG( ZWORK(J) ) )
  140             CONTINUE
               END IF
  150       CONTINUE
C
C           Apply the transformations to the right hand side of the
C           Hessenberg factor.
C
            ZITER = 0
            DO 160  J = JLO, ILAST - 1
               CS = DWORK(J)
               SN = ZWORK(J)
               CALL ZROT( J+2-IFRSTM, A(IFRSTM,J,1), 1,
     $                    A(IFRSTM,J+1,1), 1, CS, DCONJG( SN ) )
               IF ( SN.EQ.CZERO )
     $            ZITER = 1
  160       CONTINUE
C
C           No QZ iteration.
C
            GO TO 440
         END IF
C
C        **************************************************************
C        *                     HANDLE DEFLATIONS                      *
C        **************************************************************
C
C        Case I: Deflation occurs in the Hessenberg matrix. The QZ
C                iteration is only applied to the JLO:ILAST part.
C
         IFIRST = JLO
C
C        Go to the periodic QZ steps.
C
         GO TO 400
C
C        Case II: Deflation occurs in a triangular matrix with index 1.
C
C        Do an unshifted periodic QZ step.
C
  170    CONTINUE
         JDEF = J
         DO 180  J = JLO, JDEF - 1
            TEMP = A(J,J,1)
            CALL ZLARTG( TEMP, A(J+1,J,1), CS, SN, A(J,J,1) )
            A(J+1,J,1) = CZERO
            CALL ZROT( ILASTM-J, A(J,J+1,1), LDA1, A(J+1,J+1,1), LDA1,
     $                 CS, SN )
            DWORK(J) = CS
            ZWORK(J) = SN
  180    CONTINUE
         IF ( WANTQ ) THEN
            DO 190  J = JLO, JDEF - 1
               CALL ZROT( N, Q(1,J,1), 1, Q(1,J+1,1), 1, DWORK(J),
     $                    DCONJG( ZWORK(J) ) )
  190       CONTINUE
         END IF
C
C        Propagate the transformations through the triangular matrices.
C        Due to the zero element on the diagonal of the LDEF-th factor,
C        the number of transformations drops by one.
C
         DO 230  L = K, 2, -1
            IF ( L.LT.LDEF ) THEN
               NTRA = JDEF - 2
            ELSE
               NTRA = JDEF - 1
            END IF
            IF ( S(L).EQ.1 ) THEN
               DO 200  J = JLO, NTRA
                  CALL ZROT( J+2-IFRSTM, A(IFRSTM,J,L), 1,
     $                       A(IFRSTM,J+1,L), 1, DWORK(J),
     $                       DCONJG( ZWORK(J) ) )
                  TEMP = A(J,J,L)
                  CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J,J,L) )
                  A(J+1,J,L) = CZERO
                  CALL ZROT( ILASTM-J, A(J,J+1,L), LDA1,
     $                       A(J+1,J+1,L), LDA1, CS, SN )
                  DWORK(J) = CS
                  ZWORK(J) = SN
  200          CONTINUE
            ELSE
               DO 210  J = JLO, NTRA
                  CALL ZROT( ILASTM-J+1, A(J,J,L), LDA1, A(J+1,J,L),
     $                       LDA1, DWORK(J), ZWORK(J) )
                  TEMP = A(J+1,J+1,L)
                  CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J+1,J+1,L) )
                  A(J+1,J,L) = CZERO
                  CALL ZROT( J+1-IFRSTM, A(IFRSTM,J+1,L), 1,
     $                       A(IFRSTM,J,L), 1, CS, SN )
                  DWORK(J) =  CS
                  ZWORK(J) = -SN
  210          CONTINUE
            END IF
            IF ( WANTQ ) THEN
               DO 220  J = JLO, NTRA
                  CALL ZROT( N, Q(1,J,L), 1, Q(1,J+1,L), 1, DWORK(J),
     $                       DCONJG( ZWORK(J) ) )
  220          CONTINUE
            END IF
  230    CONTINUE
C
C        Apply the transformations to the right hand side of the
C        Hessenberg factor.
C
         DO 240  J = JLO, JDEF - 2
            CALL ZROT( J+2-IFRSTM, A(IFRSTM,J,1), 1, A(IFRSTM,J+1,1),
     $                 1, DWORK(J), DCONJG( ZWORK(J) ) )
  240    CONTINUE
C
C        Do an unshifted periodic QZ step.
C
         DO 250  J = ILAST, JDEF + 1, -1
            TEMP = A(J,J,1)
            CALL ZLARTG( TEMP, A(J,J-1,1), CS, SN, A(J,J,1) )
            A(J,J-1,1) = CZERO
            CALL ZROT( J-IFRSTM, A(IFRSTM,J,1), 1,
     $                 A(IFRSTM,J-1,1), 1, CS, SN )
            DWORK(J) =  CS
            ZWORK(J) = -SN
  250    CONTINUE
         IF ( WANTQ ) THEN
            DO 260  J = ILAST, JDEF + 1, -1
               CALL ZROT( N, Q(1,J-1,2), 1, Q(1,J,2),
     $                    1, DWORK(J), DCONJG( ZWORK(J) ) )
  260       CONTINUE
         END IF
C
C        Propagate the transformations through the triangular matrices.
C
         DO 300  L = 2, K
            IF ( L.GT.LDEF ) THEN
               NTRA = JDEF + 2
            ELSE
               NTRA = JDEF + 1
            END IF
            IF ( S(L).EQ.-1 ) THEN
               DO 270  J = ILAST, NTRA, -1
                  CS = DWORK(J)
                  SN = ZWORK(J)
                  CALL ZROT( J+1-IFRSTM, A(IFRSTM,J-1,L), 1,
     $                       A(IFRSTM,J,L), 1, CS, DCONJG( SN ) )
                  TEMP = A(J-1,J-1,L)
                  CALL ZLARTG( TEMP, A(J,J-1,L), CS, SN, A(J-1,J-1,L) )
                  A(J,J-1,L) = CZERO
                  CALL ZROT( ILASTM-J+1, A(J-1,J,L), LDA1, A(J,J,L),
     $                       LDA1, CS, SN )
                  DWORK(J) = CS
                  ZWORK(J) = SN
  270          CONTINUE
            ELSE
               DO 280  J = ILAST, NTRA, -1
                  CALL ZROT( ILASTM-J+2, A(J-1,J-1,L), LDA1,
     $                       A(J,J-1,L), LDA1, DWORK(J), ZWORK(J) )
                  TEMP = A(J,J,L)
                  CALL ZLARTG( TEMP, A(J,J-1,L), CS, SN, A(J,J,L) )
                  A(J,J-1,L) = CZERO
                  CALL ZROT( J-IFRSTM, A(IFRSTM,J,L), 1,
     $                       A(IFRSTM,J-1,L), 1, CS, SN )
                  DWORK(J) =  CS
                  ZWORK(J) = -SN
  280          CONTINUE
            END IF
            IF ( WANTQ ) THEN
               IF ( L.EQ.K ) THEN
                  LN = 1
               ELSE
                  LN = L + 1
               END IF
               DO 290  J = ILAST, NTRA, -1
                  CALL ZROT( N, Q(1,J-1,LN), 1, Q(1,J,LN), 1, DWORK(J),
     $                       DCONJG( ZWORK(J) ) )
  290          CONTINUE
            END IF
  300    CONTINUE
C
C        Apply the transformations to the left hand side of the
C        Hessenberg factor.
C
         DO 310  J = ILAST, JDEF + 2, -1
            CALL ZROT( ILASTM-J+2, A(J-1,J-1,1), LDA1, A(J,J-1,1),
     $                 LDA1, DWORK(J), ZWORK(J) )
  310    CONTINUE
C
C        No QZ iteration.
C
         GO TO 440
C
C        Case III: Deflation occurs in a triangular matrix with
C                  index -1.
C
  320    CONTINUE
         JDEF = J
         IF ( JDEF.GT.( ( ILAST - JLO + 1 )/2 ) ) THEN
C
C           Chase the zero downwards to the last position.
C
            DO 340  J1 = JDEF, ILAST - 1
               J = J1
               TEMP = A(J,J+1,LDEF)
               CALL ZLARTG( TEMP, A(J+1,J+1,LDEF), CS, SN,
     $                      A(J,J+1,LDEF) )
               A(J+1,J+1,LDEF) = CZERO
               CALL ZROT( ILASTM-J-1, A(J,J+2,LDEF), LDA1,
     $                    A(J+1,J+2,LDEF), LDA1, CS, SN )
               IF ( LDEF.EQ.K ) THEN
                  LN = 1
               ELSE
                  LN = LDEF + 1
               END IF
               IF ( WANTQ ) THEN
                  CALL ZROT( N, Q(1,J,LN), 1, Q(1,J+1,LN), 1, CS,
     $                       DCONJG( SN ) )
               END IF
               DO 330  L = 1, K - 1
                  IF ( LN.EQ.1 ) THEN
                     CALL ZROT( ILASTM-J+2, A(J,J-1,LN), LDA1,
     $                          A(J+1,J-1,LN), LDA1, CS, SN )
                     TEMP = A(J+1,J,LN)
                     CALL ZLARTG( TEMP, A(J+1,J-1,LN), CS, SN,
     $                            A(J+1,J,LN) )
                     A(J+1,J-1,LN) = CZERO
                     CALL ZROT( J-IFRSTM+1, A(IFRSTM,J,LN), 1,
     $                          A(IFRSTM,J-1,LN), 1, CS, SN )
                     SN = -SN
                     J  = J - 1
                  ELSE IF ( S(LN).EQ.1 ) THEN
                     CALL ZROT( ILASTM-J+1, A(J,J,LN), LDA1,
     $                          A(J+1,J,LN), LDA1, CS, SN )
                     TEMP = A(J+1,J+1,LN)
                     CALL ZLARTG( TEMP, A(J+1,J,LN), CS, SN,
     $                            A(J+1,J+1,LN) )
                     A(J+1,J,LN) = CZERO
                     CALL ZROT( J-IFRSTM+1, A(IFRSTM,J+1,LN), 1,
     $                          A(IFRSTM,J,LN), 1, CS, SN )
                     SN = -SN
                  ELSE
                     CALL ZROT( J-IFRSTM+2, A(IFRSTM,J,LN), 1,
     $                          A(IFRSTM,J+1,LN), 1, CS, DCONJG( SN ) )
                     TEMP = A(J,J,LN)
                     CALL ZLARTG( TEMP, A(J+1,J,LN), CS, SN, A(J,J,LN) )
                     A(J+1,J,LN) = CZERO
                     CALL ZROT( ILASTM-J, A(J,J+1,LN), LDA1,
     $                          A(J+1,J+1,LN), LDA1, CS, SN )
                  END IF
                  LN = LN + 1
                  IF ( LN.GT.K )
     $               LN = 1
                  IF ( WANTQ ) THEN
                     CALL ZROT( N, Q(1,J,LN), 1, Q(1,J+1,LN), 1, CS,
     $                          DCONJG( SN ) )
                  END IF
  330          CONTINUE
               CALL ZROT( J-IFRSTM+1, A(IFRSTM,J,LDEF), 1,
     $                    A(IFRSTM,J+1,LDEF), 1, CS, DCONJG( SN ) )
  340       CONTINUE
C
C           Deflate the last element in the Hessenberg matrix.
C
            J = ILAST
            TEMP = A(J,J,1)
            CALL ZLARTG( TEMP, A(J,J-1,1), CS, SN, A(J,J,1) )
            A(J,J-1,1) = CZERO
            CALL ZROT( J-IFRSTM, A(IFRSTM,J,1), 1,
     $                 A(IFRSTM,J-1,1), 1, CS, SN )
            SN = -SN
            IF ( WANTQ ) THEN
               CALL ZROT( N, Q(1,J-1,2), 1, Q(1,J,2), 1, CS,
     $                    DCONJG( SN ) )
            END IF
            DO 350  L = 2, LDEF - 1
               IF ( S(L).EQ.-1 ) THEN
                  CALL ZROT( J+1-IFRSTM, A(IFRSTM,J-1,L), 1,
     $                       A(IFRSTM,J,L), 1, CS, DCONJG( SN ) )
                  TEMP = A(J-1,J-1,L)
                  CALL ZLARTG( TEMP, A(J,J-1,L), CS, SN,
     $                         A(J-1,J-1,L) )
                  A(J,J-1,L) = CZERO
                  CALL ZROT( ILASTM-J+1, A(J-1,J,L), LDA1,
     $                       A(J,J,L), LDA1, CS, SN )
               ELSE
                  CALL ZROT( ILASTM-J+2, A(J-1,J-1,L), LDA1,
     $                       A(J,J-1,L), LDA1, CS, SN )
                  TEMP = A(J,J,L)
                  CALL ZLARTG( TEMP, A(J,J-1,L), CS, SN,
     $                         A(J,J,L) )
                  A(J,J-1,L) = CZERO
                  CALL ZROT( J-IFRSTM, A(IFRSTM,J,L), 1,
     $                       A(IFRSTM,J-1,L), 1, CS, SN )
                  SN = -SN
               END IF
               IF ( WANTQ ) THEN
                  IF ( L.EQ.K ) THEN
                     LN = 1
                  ELSE
                     LN = L + 1
                  END IF
                  CALL ZROT( N, Q(1,J-1,LN), 1, Q(1,J,LN), 1, CS,
     $                       DCONJG( SN ) )
               END IF
  350       CONTINUE
            CALL ZROT( J+1-IFRSTM, A(IFRSTM,J-1,LDEF), 1,
     $                 A(IFRSTM,J,LDEF), 1, CS, DCONJG( SN ) )
         ELSE
C
C           Chase the zero upwards to the first position.
C
            DO 370  J1 = JDEF, JLO + 1, -1
               J = J1
               TEMP = A(J-1,J,LDEF)
               CALL ZLARTG( TEMP, A(J-1,J-1,LDEF), CS, SN,
     $                      A(J-1,J,LDEF) )
               A(J-1,J-1,LDEF) = CZERO
               CALL ZROT( J-IFRSTM-1, A(IFRSTM,J,LDEF), 1,
     $                    A(IFRSTM,J-1,LDEF), 1, CS, SN )
               SN = -SN
               IF ( WANTQ ) THEN
                  CALL ZROT( N, Q(1,J-1,LDEF), 1, Q(1,J,LDEF), 1, CS,
     $                       DCONJG( SN ) )
               END IF
               LN = LDEF - 1
               DO 360  L = 1, K - 1
                  IF ( LN.EQ.1 ) THEN
                     CALL ZROT( J-IFRSTM+2, A(IFRSTM,J-1,LN), 1,
     $                          A(IFRSTM,J,LN), 1, CS, DCONJG( SN ) )
                     TEMP = A(J,J-1,LN)
                     CALL ZLARTG( TEMP, A(J+1,J-1,LN), CS, SN,
     $                            A(J,J-1,LN) )
                     A(J+1,J-1,LN) = CZERO
                     CALL ZROT( ILASTM-J+1, A(J,J,LN), LDA1,
     $                          A(J+1,J,LN), LDA1, CS, SN )
                     J = J + 1
                  ELSE IF ( S(LN).EQ.-1 ) THEN
                     CALL ZROT( ILASTM-J+2, A(J-1,J-1,LN), LDA1,
     $                          A(J,J-1,LN), LDA1, CS, SN )
                     TEMP = A(J,J,LN)
                     CALL ZLARTG( TEMP, A(J,J-1,LN), CS, SN,
     $                            A(J,J,LN) )
                     A(J,J-1,LN) = CZERO
                     CALL ZROT( J-IFRSTM, A(IFRSTM,J,LN), 1,
     $                          A(IFRSTM,J-1,LN), 1, CS, SN )
                     SN = -SN
                  ELSE
                     CALL ZROT( J-IFRSTM+1, A(IFRSTM,J-1,LN), 1,
     $                          A(IFRSTM,J,LN), 1, CS, DCONJG( SN ) )
                     TEMP = A(J-1,J-1,LN)
                     CALL ZLARTG( TEMP, A(J,J-1,LN), CS, SN,
     $                            A(J-1,J-1,LN) )
                     A(J,J-1,LN) = CZERO
                     CALL ZROT( ILASTM-J+1, A(J-1,J,LN), LDA1,
     $                          A(J,J,LN), LDA1, CS, SN )
                  END IF
                  IF ( WANTQ ) THEN
                     CALL ZROT( N, Q(1,J-1,LN), 1, Q(1,J,LN), 1, CS,
     $                          DCONJG( SN ) )
                  END IF
                  LN = LN - 1
                  IF ( LN.LE.0 )
     $               LN = K
  360          CONTINUE
               CALL ZROT( ILASTM-J+1, A(J-1,J,LDEF), LDA1, A(J,J,LDEF),
     $                    LDA1, CS, SN )
  370       CONTINUE
C
C           Deflate the first element in the Hessenberg matrix.
C
            J = JLO
            TEMP = A(J,J,1)
            CALL ZLARTG( TEMP, A(J+1,J,1), CS, SN, A(J,J,1) )
            A(J+1,J,1) = CZERO
            CALL ZROT( ILASTM-J, A(J,J+1,1), LDA1, A(J+1,J+1,1),
     $                 LDA1, CS, SN )
            IF ( WANTQ ) THEN
               CALL ZROT( N, Q(1,J,1), 1, Q(1,J+1,1), 1, CS,
     $                    DCONJG( SN ) )
            END IF
            DO 380  L = K, LDEF + 1, -1
               IF ( S(L).EQ.1 ) THEN
                  CALL ZROT( J+2-IFRSTM, A(IFRSTM,J,L), 1,
     $                       A(IFRSTM,J+1,L), 1, CS, DCONJG( SN ) )
                  TEMP = A(J,J,L)
                  CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J,J,L) )
                  A(J+1,J,L) = CZERO
                  CALL ZROT( ILASTM-J, A(J,J+1,L), LDA1,
     $                       A(J+1,J+1,L), LDA1, CS, SN )
               ELSE
                  CALL ZROT( ILASTM-J+1, A(J,J,L), LDA1,
     $                       A(J+1,J,L), LDA1, CS, SN )
                  TEMP = A(J+1,J+1,L)
                  CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN,
     $                         A(J+1,J+1,L) )
                  A(J+1,J,L) = CZERO
                  CALL ZROT( J+1-IFRSTM, A(IFRSTM,J+1,L), 1,
     $                       A(IFRSTM,J,L), 1, CS, SN )
                  SN = -SN
               END IF
               IF ( WANTQ ) THEN
                  CALL ZROT( N, Q(1,J,L), 1, Q(1,J+1,L), 1, CS,
     $                       DCONJG( SN ) )
               END IF
  380       CONTINUE
            CALL ZROT( ILASTM-J, A(J,J+1,LDEF), LDA1, A(J+1,J+1,LDEF),
     $                 LDA1, CS, SN )
         END IF
C
C        No QZ iteration.
C
         GO TO 440
C
C        Special case: A 1x1 block splits off at the bottom.
C
  390    CONTINUE
         CALL MA01BZ( BASE, K, S, A(ILAST,ILAST,1), LDA1*LDA2,
     $                ALPHA(ILAST), BETA(ILAST), SCAL(ILAST) )
C
C        Go to next block - exit if finished.
C
         ILAST = ILAST - 1
         IF ( ILAST.LT.ILO )
     $      GO TO 460
C
C        Reset iteration counters.
C
         IITER = 0
         IF ( ZITER.NE.-1 )
     $      ZITER = 0
         IF ( .NOT.LSCHR ) THEN
            ILASTM = ILAST
            IF ( IFRSTM.GT.ILAST )
     $         IFRSTM = ILO
         END IF
C
C        No QZ iteration.
C
         GO TO 440
C
C        **************************************************************
C        *                      PERIODIC QZ STEP                      *
C        **************************************************************
C
C        It is assumed that IFIRST < ILAST.
C
  400    CONTINUE
C
         IITER = IITER + 1
         ZITER = ZITER + 1
         IF( .NOT.LSCHR )
     $      IFRSTM = IFIRST
C
C        Complex single shift.
C
         IF ( MOD( IITER, 10 ).EQ.0 ) THEN
C
C           Exceptional shift.
C
            CALL ZLARNV( 2, ISEED, 2, RND )
            CALL ZLARTG( RND(1), RND(2), CS, SN, TEMP )
         ELSE
            CALL ZLARTG( CONE, CONE, CS, SN, TEMP )
            DO 410  L = K, 2, -1
               IF ( S(L).EQ.1 ) THEN
                  CALL ZLARTG( A(IFIRST,IFIRST,L)*CS,
     $                         A(ILAST,ILAST,L)*DCONJG( SN ),
     $                         CS, SN, TEMP )
               ELSE
                  CALL ZLARTG( A(ILAST,ILAST,L)*CS,
     $                         -A(IFIRST,IFIRST,L)*DCONJG( SN ),
     $                         CS, SN, TEMP )
                  SN = -SN
               END IF
  410       CONTINUE
            CALL ZLARTG( A(IFIRST,IFIRST,1)*CS
     $                   -A(ILAST,ILAST,1)*DCONJG( SN ),
     $                   A(IFIRST+1,IFIRST,1)*CS, CS, SN, TEMP )
         END IF
C
C        Do the sweeps.
C
         DO 430  J1 = IFIRST - 1, ILAST - 2
            J = J1 + 1
C
C           Create a bulge if J1 = IFIRST - 1, otherwise chase the
C           bulge.
C
            IF ( J1.GE.IFIRST ) THEN
               TEMP = A(J,J-1,1)
               CALL ZLARTG( TEMP, A(J+1,J-1,1), CS, SN, A(J,J-1,1) )
               A(J+1,J-1,1) = CZERO
            END IF
            CALL ZROT( ILASTM-J+1, A(J,J,1), LDA1, A(J+1,J,1), LDA1,
     $                 CS, SN )
            IF ( WANTQ ) THEN
               CALL ZROT( N, Q(1,J,1), 1, Q(1,J+1,1), 1, CS,
     $                    DCONJG( SN ) )
            END IF
C
C           Propagate rotation through AK, ..., A2 to A1.
C
            DO 420  L = K, 2, -1
               IF ( S(L).EQ.1 ) THEN
                  CALL ZROT( J+2-IFRSTM, A(IFRSTM,J,L), 1,
     $                       A(IFRSTM,J+1,L), 1, CS, DCONJG( SN ) )
                  TEMP = A(J,J,L)
                  CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J,J,L) )
                  A(J+1,J,L) = CZERO
                  CALL ZROT( ILASTM-J, A(J,J+1,L), LDA1,
     $                       A(J+1,J+1,L), LDA1, CS, SN )
               ELSE
                  CALL ZROT( ILASTM-J+1, A(J,J,L), LDA1, A(J+1,J,L),
     $                       LDA1, CS, SN )
                  TEMP = A(J+1,J+1,L)
                  CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J+1,J+1,L) )
                  A(J+1,J,L) = CZERO
                  CALL ZROT( J+1-IFRSTM, A(IFRSTM,J+1,L), 1,
     $                       A(IFRSTM,J,L), 1, CS, SN )
                  SN = -SN
               END IF
               IF ( WANTQ ) THEN
                  CALL ZROT( N, Q(1,J,L), 1, Q(1,J+1,L), 1, CS,
     $                       DCONJG( SN ) )
               END IF
  420       CONTINUE
            CALL ZROT( MIN( J+2, ILASTM )-IFRSTM+1, A(IFRSTM,J,1), 1,
     $                 A(IFRSTM,J+1,1), 1, CS, DCONJG( SN ) )
  430    CONTINUE
C
C        End of iteration loop.
C
  440    CONTINUE
  450 CONTINUE
C
C     Drop through = non-convergence.
C
      INFO = ILAST
      GO TO 540
C
C     Successful completion of all QZ steps.
C
  460 CONTINUE
C
C     Set eigenvalues 1:ILO-1.
C
      DO 470  J = 1, ILO - 1
         CALL MA01BZ( BASE, K, S, A(J,J,1), LDA1*LDA2, ALPHA(J),
     $                BETA(J), SCAL(J) )
  470 CONTINUE
      IF ( LSCHR ) THEN
C
C        Scale A(2,:,:), ..., A(K,:,:).
C
         DO 530  L = K, 2, -1
            IF ( S(L).EQ.1 )  THEN
               DO 480  J = 1, N
                  ABST = ABS( A(J,J,L) )
                  IF ( ABST.GT.SAFMIN ) THEN
                     TEMP = DCONJG( A(J,J,L) / ABST )
                     A(J,J,L ) = ABST
                     IF ( J.LT.N )
     $                  CALL ZSCAL( N-J, TEMP, A(J,J+1,L), LDA1 )
                  ELSE
                     TEMP = CONE
                  END IF
                  ZWORK(J) = TEMP
  480          CONTINUE
            ELSE
               DO 490  J = 1, N
                  ABST = ABS( A(J,J,L) )
                  IF ( ABST.GT.SAFMIN ) THEN
                     TEMP = DCONJG( A(J,J,L) / ABST )
                     A(J,J,L ) = ABST
                     CALL ZSCAL( J-1, TEMP, A(1,J,L), 1 )
                  ELSE
                     TEMP = CONE
                  END IF
                  ZWORK(J) = DCONJG( TEMP )
  490          CONTINUE
            END IF
            IF ( WANTQ ) THEN
               DO 500  J = 1, N
                  CALL ZSCAL( N, DCONJG( ZWORK(J) ), Q(1,J,L), 1 )
  500          CONTINUE
            END IF
            IF ( S(L-1).EQ.1 )  THEN
               DO 510  J = 1, N
                  CALL ZSCAL( J, DCONJG( ZWORK(J) ), A(1,J,L-1), 1 )
  510          CONTINUE
            ELSE
               DO 520  J = 1, N
                  CALL ZSCAL( N-J+1, ZWORK(J), A(J,J,L-1), LDA1 )
  520          CONTINUE
            END IF
  530    CONTINUE
      END IF
C
  540 CONTINUE
C
      DWORK(1) = DBLE( N )
      ZWORK(1) = DCMPLX( N, 0 )
      RETURN
C *** Last line of MB03BZ ***
      END


*> \brief \b CGETSQRHRT
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CGETSQRHRT + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE CGETSQRHRT( M, N, MB1, NB1, NB2, A, LDA, T, LDT, WORK,
*      $                       LWORK, INFO )
*       IMPLICIT NONE
*
*       .. Scalar Arguments ..
*       INTEGER           INFO, LDA, LDT, LWORK, M, N, NB1, NB2, MB1
*       ..
*       .. Array Arguments ..
*       COMPLEX*16        A( LDA, * ), T( LDT, * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CGETSQRHRT computes a NB2-sized column blocked QR-factorization
*> of a complex M-by-N matrix A with M >= N,
*>
*>    A = Q * R.
*>
*> The routine uses internally a NB1-sized column blocked and MB1-sized
*> row blocked TSQR-factorization and perfors the reconstruction
*> of the Householder vectors from the TSQR output. The routine also
*> converts the R_tsqr factor from the TSQR-factorization output into
*> the R factor that corresponds to the Householder QR-factorization,
*>
*>    A = Q_tsqr * R_tsqr = Q * R.
*>
*> The output Q and R factors are stored in the same format as in CGEQRT
*> (Q is in blocked compact WY-representation). See the documentation
*> of CGEQRT for more details on the format.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A. M >= N >= 0.
*> \endverbatim
*>
*> \param[in] MB1
*> \verbatim
*>          MB1 is INTEGER
*>          The row block size to be used in the blocked TSQR.
*>          MB1 > N.
*> \endverbatim
*>
*> \param[in] NB1
*> \verbatim
*>          NB1 is INTEGER
*>          The column block size to be used in the blocked TSQR.
*>          N >= NB1 >= 1.
*> \endverbatim
*>
*> \param[in] NB2
*> \verbatim
*>          NB2 is INTEGER
*>          The block size to be used in the blocked QR that is
*>          output. NB2 >= 1.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension (LDA,N)
*>
*>          On entry: an M-by-N matrix A.
*>
*>          On exit:
*>           a) the elements on and above the diagonal
*>              of the array contain the N-by-N upper-triangular
*>              matrix R corresponding to the Householder QR;
*>           b) the elements below the diagonal represent Q by
*>              the columns of blocked V (compact WY-representation).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*>          T is COMPLEX array, dimension (LDT,N))
*>          The upper triangular block reflectors stored in compact form
*>          as a sequence of upper triangular blocks.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*>          LDT is INTEGER
*>          The leading dimension of the array T.  LDT >= NB2.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          (workspace) COMPLEX array, dimension (MAX(1,LWORK))
*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          The dimension of the array WORK.
*>          LWORK >= MAX( LWT + LW1, MAX( LWT+N*N+LW2, LWT+N*N+N ) ),
*>          where
*>             NUM_ALL_ROW_BLOCKS = CEIL((M-N)/(MB1-N)),
*>             NB1LOCAL = MIN(NB1,N).
*>             LWT = NUM_ALL_ROW_BLOCKS * N * NB1LOCAL,
*>             LW1 = NB1LOCAL * N,
*>             LW2 = NB1LOCAL * MAX( NB1LOCAL, ( N - NB1LOCAL ) ),
*>          If LWORK = -1, then a workspace query is assumed.
*>          The routine only calculates the optimal size of the WORK
*>          array, returns this value as the first entry of the WORK
*>          array, and no error message related to LWORK is issued
*>          by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2020
*
*> \ingroup comlpexOTHERcomputational
*
*> \par Contributors:
*  ==================
*>
*> \verbatim
*>
*> November 2020, Igor Kozachenko,
*>                Computer Science Division,
*>                University of California, Berkeley
*>
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE CGETSQRHRT( M, N, MB1, NB1, NB2, A, LDA, T, LDT, WORK,
     $                       LWORK, INFO )
      IMPLICIT NONE
*
*  -- LAPACK computational routine (version 3.10.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2020
*
*     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDT, LWORK, M, N, NB1, NB2, MB1
*     ..
*     .. Array Arguments ..
      COMPLEX           A( LDA, * ), T( LDT, * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX            CONE
      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IINFO, J, LW1, LW2, LWT, LDWT, LWORKOPT,
     $                   NB1LOCAL, NB2LOCAL, NUM_ALL_ROW_BLOCKS
*     ..
*     .. External Subroutines ..
      EXTERNAL           CCOPY, CLATSQR, CUNGTSQR_ROW, CUNHR_COL,
     $                   XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CEILING, REAL, CMPLX, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      LQUERY  = LWORK.EQ.-1
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 .OR. M.LT.N ) THEN
         INFO = -2
      ELSE IF( MB1.LE.N ) THEN
         INFO = -3
      ELSE IF( NB1.LT.1 ) THEN
         INFO = -4
      ELSE IF( NB2.LT.1 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -7
      ELSE IF( LDT.LT.MAX( 1,  MIN( NB2, N ) ) ) THEN
         INFO = -9
      ELSE
*
*        Test the input LWORK for the dimension of the array WORK.
*        This workspace is used to store array:
*        a) Matrix T and WORK for CLATSQR;
*        b) N-by-N upper-triangular factor R_tsqr;
*        c) Matrix T and array WORK for CUNGTSQR_ROW;
*        d) Diagonal D for CUNHR_COL.
*
         IF( LWORK.LT.N*N+1 .AND. .NOT.LQUERY ) THEN
            INFO = -11
         ELSE
*
*           Set block size for column blocks
*
            NB1LOCAL = MIN( NB1, N )
*
            NUM_ALL_ROW_BLOCKS = MAX( 1,
     $                   CEILING( REAL( M - N ) / REAL( MB1 - N ) ) )
*
*           Length and leading dimension of WORK array to place
*           T array in TSQR.
*
            LWT = NUM_ALL_ROW_BLOCKS * N * NB1LOCAL

            LDWT = NB1LOCAL
*
*           Length of TSQR work array
*
            LW1 = NB1LOCAL * N
*
*           Length of CUNGTSQR_ROW work array.
*
            LW2 = NB1LOCAL * MAX( NB1LOCAL, ( N - NB1LOCAL ) )
*
            LWORKOPT = MAX( LWT + LW1, MAX( LWT+N*N+LW2, LWT+N*N+N ) )
*
            IF( ( LWORK.LT.MAX( 1, LWORKOPT ) ).AND.(.NOT.LQUERY) ) THEN
               INFO = -11
            END IF
*
         END IF
      END IF
*
*     Handle error in the input parameters and return workspace query.
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGETSQRHRT', -INFO )
         RETURN
      ELSE IF ( LQUERY ) THEN
         WORK( 1 ) = CMPLX( LWORKOPT )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( MIN( M, N ).EQ.0 ) THEN
         WORK( 1 ) = CMPLX( LWORKOPT )
         RETURN
      END IF
*
      NB2LOCAL = MIN( NB2, N )
*
*
*     (1) Perform TSQR-factorization of the M-by-N matrix A.
*
      CALL CLATSQR( M, N, MB1, NB1LOCAL, A, LDA, WORK, LDWT,
     $              WORK(LWT+1), LW1, IINFO )
*
*     (2) Copy the factor R_tsqr stored in the upper-triangular part
*         of A into the square matrix in the work array
*         WORK(LWT+1:LWT+N*N) column-by-column.
*
      DO J = 1, N
         CALL CCOPY( J, A( 1, J ), 1, WORK( LWT + N*(J-1)+1 ), 1 )
      END DO
*
*     (3) Generate a M-by-N matrix Q with orthonormal columns from
*     the result stored below the diagonal in the array A in place.
*

      CALL CUNGTSQR_ROW( M, N, MB1, NB1LOCAL, A, LDA, WORK, LDWT,
     $                   WORK( LWT+N*N+1 ), LW2, IINFO )
*
*     (4) Perform the reconstruction of Householder vectors from
*     the matrix Q (stored in A) in place.
*
      CALL CUNHR_COL( M, N, NB2LOCAL, A, LDA, T, LDT,
     $                WORK( LWT+N*N+1 ), IINFO )
*
*     (5) Copy the factor R_tsqr stored in the square matrix in the
*     work array WORK(LWT+1:LWT+N*N) into the upper-triangular
*     part of A.
*
*     (6) Compute from R_tsqr the factor R_hr corresponding to
*     the reconstructed Householder vectors, i.e. R_hr = S * R_tsqr.
*     This multiplication by the sign matrix S on the left means
*     changing the sign of I-th row of the matrix R_tsqr according
*     to sign of the I-th diagonal element DIAG(I) of the matrix S.
*     DIAG is stored in WORK( LWT+N*N+1 ) from the CUNHR_COL output.
*
*     (5) and (6) can be combined in a single loop, so the rows in A
*     are accessed only once.
*
      DO I = 1, N
         IF( WORK( LWT+N*N+I ).EQ.-CONE ) THEN
            DO J = I, N
               A( I, J ) = -CONE * WORK( LWT+N*(J-1)+I )
            END DO
         ELSE
            CALL CCOPY( N-I+1, WORK(LWT+N*(I-1)+I), N, A( I, I ), LDA )
         END IF
      END DO
*
      WORK( 1 ) = CMPLX( LWORKOPT )
      RETURN
*
*     End of CGETSQRHRT
*
      END


      subroutine exconv (omega, nk, efermi, s02, erelax, wp, xmu)
      parameter (nfinex = 601)
c     convolution of xmu(e) with excitation spectrum, which is modeled
c     by: f(e) = s02*delta(e) + theta(e)*exp(-e/ed)*x1 + fp(e)
c     plasmon contribution modeled by fp(e) = theta(e-wp)*exp(-e/wp)*x2
c     normalization factors x1, x2 and distribution parameter ed are
c     found from conditions: 1) integral d(e)*f(e) = 1
c     2) integral d(e)*fp(e) = wwp  0<=wwp<1  s02+wwp<=1
c     3) integral d(e)*e*f(e) = erelax
c     Input:
c       omega - enrgy grid (e)
c       nk    - number of points in energy grid
c       efermi- fermi level
c       s02   - overlap with fully relaxed orbitals
c       erelax- relaxation energy
c       wp    - plasmon frequency
c       xmu   - original absorption coefficient
c     Output
c       xmu  - result of convolution, rewritten at the end.
c     This subroutine uses the fact, that if convolution is made for
c     e(i), then for e(i+1), the convolution integral with exp(-e/ed)
c     for e<e(i) is simply scaled by exp((e(i)-e(i+1)) / ed). This makes
c     this convolution fast.
c     written by ala. december 1995
c
      implicit double precision (a-h,o-z)
      dimension  omega(nk), xmu(nk)
c     work space
      dimension  slope(nfinex), dmu(nfinex), xmup(nfinex)

      if (s02 .ge. 0.999) return
      if (wp .le. 0.0) wp = 0.00001
      if (nk .gt. nfinex) then
         call par_stop('check nfinex in subroutine exconv')
      endif
c     change weight for plasmon excitation here
      wwp = 0.00
c     sm1 - weight for shake up (off) processes
      sm1 = 1.0 - s02 - wwp
      edp = wp
      ed = (erelax - wwp * (wp + edp)) / sm1
      i0 = locat (efermi, nk, omega)
      do 10 i = 1, i0
         slope(i) = 0.0
         dmu(i) = 0.0
 10   continue
      do 20 i = i0, nk - 1
 20     slope(i) = ed * (xmu(i+1) - xmu(i)) / (omega(i+1) - omega(i))
      call terp (omega, xmu, nk, 1, efermi, xmuf)

c     start induction
      xmult = exp ((efermi - omega(i0+1)) / ed)
      dmu(i0+1) = xmu(i0+1) - slope(i0) - xmult * (xmuf - slope(i0))
      do 50 i = i0 + 1, nk - 1
         xmult = exp ((omega(i) - omega(i+1)) / ed)
         dmu(i+1) = xmu(i+1) - slope(i) + xmult*(dmu(i)-xmu(i)+slope(i))
 50   continue
      do 55 i = 1, nk
 55   xmup(i) = s02 * xmu(i) + sm1 * dmu(i)

c     do convolution with plasmon pole
      do 60 i = i0, nk - 1
 60     slope(i) = slope(i) / ed * edp
      xmult = exp ((efermi - omega(i0+1)) / edp)
      dmu(i0+1) = xmu(i0+1) - slope(i0) - xmult * (xmuf - slope(i0))
      do 70 i = i0 + 1, nk - 1
         xmult = exp ((omega(i) - omega(i+1)) / edp)
         dmu(i+1) = xmu(i+1) - slope(i) + xmult*(dmu(i)-xmu(i)+slope(i))
 70   continue

      do 90 i = 1, nk
        en = omega(i) - wp
        j0 = locat(en, nk, omega)
        if (en .gt. efermi) then
           xmult = exp ((omega(j0) - en) / edp)
           dif = xmu(j0) - slope(j0)
           xmup(i) = xmup(i) + wwp * (xmult * (dmu(j0) - dif) + dif +
     1                            slope(j0) * (en - omega(j0)) / edp)
        endif
 90   continue

      do 200 i = 1, nk
 200  xmu(i) = xmup(i)

      return
      end


!! ------------------------------------------------------------------------- !!
!>
!!
!! Linear Dispersive Wave (LLW) for tsunami propagation in spherical coordinate system.
!! This code is modification of Maeda (2015) code which is written in
!! cartesian coordinate system.
!!
!! The governing equation of LDW is adopted from Nakamura's model.
!! This code is partially modified by A. Fauzi
!! Last modified on 2018.7.9
!!
!<
!! ------------------------------------------------------------------------- !!
program ldw

  implicit none

  !! fixed parameters
  integer, parameter :: STDERR  = 0            !< Standard Error
  integer, parameter :: STDOUT  = 6            !< Standard Output
  real,    parameter :: pi      = atan(1.0)*4
  real,    parameter :: g0      = 9.80665      !< gravity
  integer, parameter :: na      = 20           !< absorber thickness
  real,    parameter :: r       = 6371012.0    !< earth radius (m)
  real,    parameter :: omega   = 2.0 * acos(-1.0) / 86400 !< earth rotational velocity (rad/s)
  character(len=20)  :: fld

  !! control parameters
  integer            :: nx,  ny                !< model size
  integer            :: nt, tint               !< time step size
  real               :: dx,  dy                !< grid width
  real               :: dt                     !< time step
  integer            :: mov, zmax_out          !< snapshots

  !! derived global variables
  real               :: dxi, dyi               !< inverse grid width
  real               :: xbeg, ybeg             !< model edge
  integer            :: nst                    !< number of stations

  !! time
  integer            :: start, finish
  integer            :: clock_rate, clock_max

  !! arrays
  real,    allocatable :: eta(:,:)             !< tsunami height
  real,    allocatable :: zmax(:,:)            !< maximum tsunami height
  real,    allocatable :: mm(:,:)              !< tsunami vel
  real,    allocatable :: nn(:,:)              !< tsunami vel
  real,    allocatable :: hh(:,:)              !< bathymetry
  real,    allocatable :: hm(:,:)              !< x-averaged bathymetry
  real,    allocatable :: hn(:,:)              !< y-averaged bathymetry
  real,    allocatable :: fh(:,:)              !< land filter
  real,    allocatable :: fm(:,:)              !< land filter
  real,    allocatable :: fn(:,:)              !< land filter
  real,    allocatable :: x(:), y(:)           !< coordinate
  real,    allocatable :: g1x(:,:), g2x(:,:)   !< PML absorber
  real,    allocatable :: g1y(:,:), g2y(:,:)   !< PML absorber
  real,    allocatable :: eta_x(:,:)           !< PML eta(x)
  real,    allocatable :: dtm(:,:)             !< time deriv. of velocity
  real,    allocatable :: dtn(:,:)             !< time deriv. of velocity
  real,    allocatable :: dtm0(:,:)            !< time deriv. of velocity
  real,    allocatable :: dtn0(:,:)            !< time deriv. of velocity
  real,    allocatable :: wav(:,:)             !< waveform at stations
  integer, allocatable :: ist(:), jst(:)       !< station location (i,j)
  real,    allocatable :: xst(:), yst(:)       !< station location (x,y)
  real,    allocatable :: c1x(:,:), c1y(:,:)   !< coefs for LDW calculation
  real,    allocatable :: c2x(:,:), c2y(:,:)   !< coefs for LDW calculation
  real,    allocatable :: c3x(:,:), c3y(:,:)   !< coefs for LDW calculation
  real,    allocatable :: xw(:), yw(:)         !< PML weight function
  real,    allocatable :: theta(:), thetal(:)  !< latitude coordinate

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

  !! parameter input
  include "sub_param.f90"

  !! ----------------------------------------------------------------------- !!
  !>
  !! memory allocation
  !<
  !! --
  block

    integer :: i, j
    real    :: degrad, secrad

    allocate( eta(1:nx,1:ny) )
    allocate( zmax(1:nx,1:ny) )
    allocate( mm (1:nx,1:ny) )
    allocate( nn (1:nx,1:ny) )
    allocate( hh (1:nx,1:ny) )
    allocate( hm (1:nx,1:ny) )
    allocate( hn (1:nx,1:ny) )
    allocate( fh (1:nx,1:ny) )
    allocate( fm (1:nx,1:ny) )
    allocate( fn (1:nx,1:ny) )
    allocate( dtm(0:nx+1,0:ny+1) )
    allocate( dtn(0:nx+1,0:ny+1) )
    allocate( dtm0(0:nx+1,0:ny+1) )
    allocate( dtn0(0:nx+1,0:ny+1) )
    allocate( c1x(nx,ny), c2x(nx,ny), c3x(nx,ny) )
    allocate( c1y(nx,ny), c2y(nx,ny), c3y(nx,ny) )
    allocate( xw(nx), yw(ny) )
    allocate( g1x(2,nx), g2x(2,nx), g1y(2,ny), g2y(2,ny) )
    allocate( eta_x(nx,ny) )
    allocate( theta(ny), thetal(ny) )

    call system_clock(start,clock_rate,clock_max)
    eta(:,:) = 0.0
    mm (:,:) = 0.0
    nn (:,:) = 0.0
    dtm(0:nx+1,0:ny+1) = 0
    dtn(0:nx+1,0:ny+1) = 0

    allocate( x(nx), y(ny) )
    do i=1, nx
       x(i) = (i-1) * dx + xbeg
    end do
    do j=1, ny
       y(j) = (j-1) * dy + ybeg
    end do

    degrad = pi / 180.0
    secrad = pi / (180.0 * 3600)

    ybeg = ybeg * degrad

    dy   = dy * secrad
    dx   = dx * secrad
!$OMP PARALLEL PRIVATE(j)
!$OMP DO
    do j=1,ny
       theta (j) = ybeg + (j-1) * dy
       thetal(j) = ybeg + (j-1) * dy - (0.5 * dy)
    enddo
!$OMP END DO
!$OMP END PARALLEL

    dxi = 1.0 / dx
    dyi = 1.0 / dy

  end block

  include 'sub_initheight.f90'

  include 'sub_bathymetry.f90'

  include 'sub_station.f90'

!! Waveform at gages is set to be the same as initial deformation
  block
    integer :: i
!$OMP PARALLEL SHARED(wav) PRIVATE(i)
!$OMP DO
    do i=1, nst
       wav(0,i) = eta( ist(i), jst(i) )
    end do
!$OMP END DO
!$OMP END PARALLEL
  end block

  !! Create /out folder
  !! --
  if(mov.eq.0)then
     write(fld,'(a)')'out'
     call system("mkdir " // trim(adjustl(fld)))
  endif

  !! ----------------------------------------------------------------------- !!
  !>
  !! PML absorber settings
  !<
  !! --
  block

    real :: d1, d2, b1, b2
    integer :: i, j
    real :: d0, b0, R0
    real :: xxb, xxc
    real :: hx
    integer, parameter :: pd = 2
    integer, parameter :: pb = 2
    real,    parameter :: c0 = 500.0 !! assumed phase speed
    !! ----

    !! damping profile constants
    hx = na * dx * r
    R0 = 10**( - ( log10( real(na) ) - 1 ) / log10( 2.0 )  - 3.0 )
    d0 = - ( 1.0 / (2.0*hx) ) * ( pd +1 ) * c0 * log( R0 )
    b0 = 2.0

    !! initialize eta: assume initial amplitude wihtin PML layer is zero
    eta_x(1:nx,1:ny) = 0.0

    !! initialize
!$OMP PARALLEL SHARED (g1x,g2x,g1y,g2y) PRIVATE(i,j)
!$OMP DO
    do i=1, 2
       do j=1, nx
          g1x(i,j) = 1.0
          g2x(i,j) = 1.0
       end do
       do j=1, ny
          g1y(i,j) = 1.0
          g2y(i,j) = 1.0
       end do
    end do
!$OMP END DO
!$OMP END PARALLEL

    !! set absorber
    do i=1, na

       !! distance from PML boundary
       xxb = max(hx  - (i    ) * dx * r,0.)
       xxc = max(hx  - (i+0.5) * dx * r,0.)

       d1 = d0 * ( xxb / hx )**pd
       b1 = 1.0 + ( b0 - 1.0 ) * ( xxb / hx )**pb

       d2 = d0 * ( xxc / hx )**pd
       b2 = 1.0 + ( b0 - 1.0 ) * ( xxc / hx )**pb

       g1x(1,i) = (b1 - d1/2.0*dt) / (b1 + d1/2*dt)
       g1x(2,i) = (b1 - d2/2.0*dt) / (b1 + d2/2*dt)
       g2x(1,i) =  1.0             / (b1 + d1/2*dt)
       g2x(2,i) =  1.0             / (b1 + d2/2*dt)

       g1y(:,i) = g1x(:,i)
       g2y(:,i) = g2x(:,i)

       ! Opposite Side; Exchange Staggered Grid
       g1x(1,nx-i+1) = g1x(2,i)
       g1x(2,nx-i+1) = g1x(1,i)
       g2x(1,nx-i+1) = g2x(2,i)
       g2x(2,nx-i+1) = g2x(1,i)

       g1y(1,ny-i+1) = g1x(2,i)
       g1y(2,ny-i+1) = g1x(1,i)
       g2y(1,ny-i+1) = g2x(2,i)
       g2y(2,ny-i+1) = g2x(1,i)

    end do

  end block

  !! ----------------------------------------------------------------------- !!
  !>
  !! Use 10-m cut off for linear long wave
  !<
  block

    integer :: i, j
    real, parameter :: CUTOFF_DEPTH = 10.0
!$OMP PARALLEL SHARED(eta,hh) PRIVATE(i,j)
!$OMP DO
    do j=1, ny
       do i=1, nx
          if( hh(i,j) < 0.0 ) then
             eta(i,j) = 0.0
          else if ( hh(i,j) < CUTOFF_DEPTH ) then
             hh(i,j) = 10.0
          end if
       end do
    end do
!$OMP END DO
!$OMP END PARALLEL
  end block

  !! ----------------------------------------------------------------------- !!
  !>
  !! bathymetry averaging for staggered grid calculation
  !<
  block

    integer :: i, j

    ! x-averaged bathymetry
!$OMP PARALLEL SHARED(hm,hn) PRIVATE(i,j)
!$OMP DO
    do j=1, ny
       hm(1,j) = max( hh(1,j), 0.0 )
       do i=2, nx
          hm(i,j) = ( hh(i,j)+hh(i-1,j) ) / 2.0
          if( hh(i,j) <= 0.0  .or.  hh(i-1,j) <= 0.0 ) hm(i,j) = 0.0
       end do
    end do

    ! y-averaged bathymetry
!$OMP DO
    do i=1, nx
       do j=2, ny
          hn(i,j) = ( hh(i,j) + hh(i,j-1) ) / 2.0
          if( hh(i,j) <= 0.0  .or.  hh(i,j-1) <= 0.0 ) hn(i,j) = 0.0
       end do
       hn(i,1) = max( hh(i,1), 0.0 )
    end do
!$OMP END DO
!$OMP END PARALLEL
  end block

  !! ----------------------------------------------------------------------- !!
  !>
  !! define land-filter matrix for reflection boundaries
  !<
  block

    integer :: i, j

    fm(:,:) = 1.0
    fn(:,:) = 1.0
    fh(:,:) = 1.0
!$OMP PARALLEL SHARED(fm,fn,fh) PRIVATE(i,j)
!$OMP DO
    do j=1, ny
       do i=1, nx
          if( hm(i,j) < 0.0 ) fm(i,j) = 0.0
          if( hn(i,j) < 0.0 ) fn(i,j) = 0.0
          if( hh(i,j) < 0.0 ) fh(i,j) = 0.0
       end do
    end do
!$OMP END DO
!$OMP END PARALLEL
  end block

  !! ----------------------------------------------------------------------- !!
  !>
  !! CFL stability condition check
  !<
  block

    if( min(dx * r,dy * r)/dt < sqrt( 2*g0*maxval(hh(:,:)) ) ) then
       write(STDERR,*) "ERROR: stability condition is violated: ",  &
            min(dx * r,dy * r)/dt,  sqrt( 2*g0*maxval(hh(:,:)) )
       stop
    end if

  end block

  !! ----------------------------------------------------------------------- !!
  !>
  !! Dispersive tsunami coefficieints
  !<
  !! --
  block
    real :: xdiv, ydiv
    integer :: i, j

    do j=1, ny
       do i=1, nx
          xdiv = 3*dx*dx*r*cos(theta(j)) / (3*dx*dx*r*r*cos(theta(j))*cos(theta(j))+(2*hm(i,j)*hm(i,j)))
          ydiv = 3*r*dy*dy / (3*r*r*dy*dy+(2*hn(i,j)*hn(i,j)))
          c1x(i,j) = - xdiv  * g0 * hm(i,j)
          c2x(i,j) = xdiv * hm(i,j)*hm(i,j) / (3*r*cos(theta(j))*dx*dx)
          c3x(i,j) = xdiv * hm(i,j)*hm(i,j) / (3*r*cos(theta(j))*dx*dx)
          c1y(i,j) = - ydiv  * g0 * hn(i,j)
          c2y(i,j) = ydiv * hn(i,j)*hn(i,j)*(1/cos(thetal(j))) / (3*r*dy*dy)
          c3y(i,j) = ydiv * hn(i,j)*hn(i,j)*(1/cos(thetal(j))) / (3*r*dy*dy)
       end do
    end do

    ! PML weight
    xw(:) = 1.0
    yw(:) = 1.0

    do i=1, na
       xw(i) = sin( pi * i / na / 2 )

       xw(nx-i+1) = xw(i)
       yw(i)      = xw(i)
       yw(ny-i+1) = yw(i)
    end do

  end block

  !! ----------------------------------------------------------------------- !!
  !>
  !! time stepping
  !<
  block

    integer :: it
    real :: dxeta(nx,ny), dyeta(nx,ny)
    real :: dxm(nx,ny), dyn(nx,ny), ttt, elapsed, remaining, prog
    !! --

    nt = int(nt / dt)

    do it= 1, nt

       if (mod((real(it) / real(nt))*100, real(20)) == 0) then
!       if( mod(it*dt, real(60)) == 0 ) then
          ttt  = it * dt / 60.0
          prog = real(it) / real(nt)
          call system_clock(finish, clock_rate, clock_max)
          elapsed   = real(finish-start)/real(clock_rate)/60.0
          remaining = ((1 - prog) / prog) * elapsed !* clock_rate/60.0
          write(*,'(a, f7.2, a, a, f7.2, a, f7.2, a)')'Elapsed time = ',elapsed,&
                ' min; ', 'Remaining time = ', remaining, ' min; ', prog * 100, '/100%'
       end if

       !! ------------------------------------------------------------------ !!
       !>
       !! difference of eta with respect to x, y
       !<
       !! --
       block

         integer :: i, j
         !! --
!$OMP PARALLEL SHARED(dxeta,dyeta) PRIVATE(i,j)
!$OMP DO
         do j=1, ny
            do i=2, nx
               dxeta(i,j) = ( eta(i,j) - eta(i-1,j) ) * dxi
            end do
            dxeta(1,j) = ( eta(1,j) -        0.0 ) * dxi
         end do
!$OMP DO
         do i=1, nx
            do j=2, ny
               dyeta(i,j) = ( eta(i,j) - eta(i,j-1) ) * dyi
            end do
            dyeta(i,1) = ( eta(i,1) -        0.0 ) * dyi
         end do
!$OMP END DO
!$OMP END PARALLEL
       end block

       !! ------------------------------------------------------------------ !!
       block

         integer, parameter :: ITER_MAX = 1000
         real,    parameter :: TOR = 1e-5
         integer :: k
         integer :: i, j
         real :: err, amax

         !! --

         !! initial values of time-derivative of vel are
         !! approximated by long-wave theory
         if( it == 1 ) then
!$OMP PARALLEL SHARED(dtm,dtn) PRIVATE(i,j)
!$OMP DO
            do j=1, ny
               do i=1, nx

                  dtm(i,j) = - g0*hm(i,j)*dxeta(i,j)*dt*(1/(cos(theta(j)) * r))*fm(i,j)
                  dtn(i,j) = - g0*hn(i,j)*dyeta(i,j)*dt*(1/r)*fn(i,j)

               end do
            end do
!$OMP END DO
!$OMP END PARALLEL
         end if

         !! maximum value for conversion check
         amax =max( maxval( abs(dtm(2:nx-1,2:ny-1)) ), &
                    maxval( abs(dtn(2:nx-1,2:ny-1)) ) )
         if( amax < epsilon(1.0 ) ) amax = 1.0

         !! iteration for time-derivative of vel

         do k=1, ITER_MAX

            !! copy previous vel velocities
!$OMP PARALLEL SHARED(dtm0,dtn0) PRIVATE(i,j)
!$OMP DO
            do j=1, ny
               do i=1, nx
                  dtm0(i,j) = dtm(i,j)
                  dtn0(i,j) = dtn(i,j)
               end do
            end do
!$OMP END DO
!$OMP END PARALLEL
            err = -1e30
!$OMP PARALLEL SHARED(dtm,dtn) PRIVATE(i,j)
!$OMP DO
            do j=2, ny-1
               do i=2, nx-1
                  dtm(i,j) = c1x(i,j) * dxeta(i,j) &
                           + c2x(i,j) * ( dtm(i+1,j)+dtm(i-1,j) ) &
                           + c3x(i,j) * ( dtn(i,j+1)*cos(theta(j+1)) &
                           - dtn(i,j)*cos(theta(j))-dtn(i-1,j+1)*cos(theta(j+1)) &
                           + dtn(i-1,j)*cos(theta(j)) )
                  err = max( err,  abs( dtm(i,j) - dtm0(i,j) ) / amax )
               end do
            end do
!$OMP DO
            do j=2, ny-1
               do i=2, nx-1
                  dtn(i,j) = c1y(i,j) *  dyeta(i,j) &
                           + c2y(i,j) * ( dtn(i,j+1)*cos(thetal(j+1)) &
                           + dtn(i,j-1)*cos(thetal(j-1)) ) &
                           + c3y(i,j) * ( dtm(i+1,j)-dtm(i,j)-dtm(i+1,j-1)+dtm(i,j-1))
                  err = max( err,  abs( dtn(i,j) - dtn0(i,j) ) / amax )
               end do
            end do
!$OMP END DO
!$OMP END PARALLEL
!            write(*,*)dtm(1,100), dtm(780,382), dtn(100,1), dtn(780,382)

            if( err < TOR ) exit

         end do

         !! update tsunami velocity using dispersive terms
!$OMP PARALLEL SHARED(mm,nn) PRIVATE(i,j)
!$OMP DO
         do j=2, ny-1
            do i=2, nx-1
               mm(i,j) = g1x(1,i) * mm(i,j) &
                    + g2x(1,i) * ( ( xw(i) - 1 ) * g0 * hm(i,j) *(1/(cos(theta(j)) * r))* dxeta(i,j) &
                                 + xw(i)   * dtm(i,j)  ) * dt * fm(i,j)
               nn(i,j) = g1y(1,j) * nn(i,j) &
                    + g2y(1,j) * ( ( yw(j) - 1 ) * g0 * hn(i,j) * (1/r)*dyeta(i,j) &
                                 + yw(j)   * dtn(i,j) ) * dt * fn(i,j)
            end do
         end do
!$OMP END DO
!$OMP END PARALLEL
       end block

       !! ------------------------------------------------------------------ !!
       !>
       !! difference of velocities with respect to x, y
       !<
       !! --
       block

         integer :: i, j
         !! --
!$OMP PARALLEL SHARED(dxm,dyn) PRIVATE(i,j)
!$OMP DO
         do j=1, ny
            dxm(nx,j) = ( 0.0 - mm(nx,j)  ) * dxi
            do i=1, nx-1
               dxm(i,j) = ( mm(i+1,j) - mm(i,j) ) * dxi
            end do
         end do
!$OMP DO
         do i=1, nx
            dyn(i,ny) = ( 0.0 - nn(i,ny) ) * dyi
            do j=1, ny-1
               dyn(i,j) = ( nn(i,j+1)*cos(thetal(j+1))  - nn(i,j)*cos(thetal(j))  ) * dyi
            end do
         end do
!$OMP END DO
!$OMP END PARALLEL
!write(*,*)dxeta(1,100), dxeta(780,382), dyeta(100,1), dyeta(780,382)
!pause
       end block

       !! ------------------------------------------------------------------ !!
       block

         integer i, j
         real :: dtxi, dtyi
         !! --

         dtxi = dt * dxi
         dtyi = dt * dyi
!$OMP PARALLEL SHARED(eta) PRIVATE(i,j)
!$OMP DO
         do j=na+1, ny-na
            do i=na+1, nx-na
               eta(i,j) =  eta(i,j) - ( dxm(i,j) +  dyn(i,j) )*dt* (1/(cos(theta(j)) * r)) * fh(i,j)
            end do
         end do
!$OMP END DO
!$OMP END PARALLEL
       end block

       !! ------------------------------------------------------------------ !!
       block

         integer :: i, j
         real :: eta_y
         !! --
!$OMP PARALLEL SHARED(eta,eta_x) PRIVATE(i,j,eta_y)
!$OMP DO
         do j=1, na
            do i=1, nx
               eta_y = eta(i,j) - eta_x(i,j)

               eta_x(i,j) = g1x(2,i) * eta_x(i,j) - g2x(2,i) * dxm(i,j) * (1/(cos(theta(j)) * r))* dt
               eta_y      = g1y(2,j) * eta_y      - g2y(2,j) * dyn(i,j) * (1/(cos(thetal(j)) * r))* dt

               eta(i,j) = ( eta_x(i,j) + eta_y ) * fh(i,j)

            end do
         end do
!$OMP DO
         do j=ny-na+1,ny
            do i=1, nx
               eta_y = eta(i,j) - eta_x(i,j)

               eta_x(i,j) = g1x(2,i) * eta_x(i,j) - g2x(2,i) * dxm(i,j) * (1/(cos(theta(j)) * r))* dt
               eta_y      = g1y(2,j) * eta_y      - g2y(2,j) * dyn(i,j) * (1/(cos(thetal(j)) * r))* dt

               eta(i,j) = ( eta_x(i,j) + eta_y ) * fh(i,j)
            end do
         end do
!$OMP DO
         do j=na+1, ny-na
            do i=1, na
               eta_y = eta(i,j) - eta_x(i,j)

               eta_x(i,j) = g1x(2,i) * eta_x(i,j) - g2x(2,i) * dxm(i,j) * (1/(cos(theta(j)) * r))* dt
               eta_y      = g1y(2,j) * eta_y      - g2y(2,j) * dyn(i,j) * (1/(cos(thetal(j)) * r))* dt

               eta(i,j) = ( eta_x(i,j) + eta_y ) * fh(i,j)
            end do
         end do
!$OMP DO
         do j=na+1, ny-na
            do i=nx-na+1,nx
               eta_y = eta(i,j) - eta_x(i,j)

               eta_x(i,j) = g1x(2,i) * eta_x(i,j) - g2x(2,i) * dxm(i,j) * (1/(cos(theta(j)) * r))* dt
               eta_y      = g1y(2,j) * eta_y      - g2y(2,j) * dyn(i,j) * (1/(cos(thetal(j)) * r))* dt

               eta(i,j) = ( eta_x(i,j) + eta_y ) * fh(i,j)
            end do
         end do
!$OMP END DO
!$OMP END PARALLEL
       end block

       !! ------------------------------------------------------------------ !!
       ! To calculate maximum tsunami height
       block

          integer :: i,j

          if (zmax_out.eq.0) then
!$OMP PARALLEL SHARED(zmax) PRIVATE(i,j)
!$OMP DO
          do j=1, ny
             do i=1, nx
                if (eta(i,j).gt.zmax(i,j))then
                   zmax(i,j)= eta(i,j)
                endif
             enddo
          enddo
!$OMP END DO
!$OMP END PARALLEL
       endif
       end block

       !! ------------------------------------------------------------------ !!
       block

         integer :: i

         if (mod(dt*it, real(tint))==0.0) then
!$OMP PARALLEL SHARED(wav) PRIVATE(i)
!$OMP DO
            do i=1, nst
               wav(it,i) = eta( ist(i), jst(i) )
            end do
!$OMP END DO
!$OMP END PARALLEL
         endif

       end block

       !! ----------------------------
       !
       ! To create output file of eta
       block

          integer :: i,j
          character(len=20):: fileout

          if (mov.eq.0.0)then
          if(mod(int(it*dt), 60 )==0) then
             write(fileout,'(a, i5.5, a)')"outd/eta_", int(it*dt), ".dat"
             open(21,file=trim(fileout), status='unknown')

             do i=1,nx
                write(21,'(10000f9.2)')(eta(i,j), j=1,ny)
             enddo

             close(21)
         endif
         endif

       end block
      !! ----------------------------

    end do

  end block

  !! ----------------------------------------------------------------------- !!
  ! To write wave gauges records and maximum tsunami height
  block

    integer :: i, j, it
    character(256) :: fn
    integer, parameter :: io = 100
    !! --

    open(io, file='obswv_d.dat', status='unknown' )
    do it = 0, nt
      if (mod(it*dt, real(tint)) == 0.0) then
        write(io,'(f7.1, 10000f9.3)') it*dt, (wav(it,j), j=1, nst)
      endif
    enddo
    close(io)

    if (zmax_out.eq.0) then
    open(21, file='zmaxd.dat', status='unknown')
    do i=1,nx
       write(21,'(10000f9.2)')(zmax(i,j), j=1,ny)
    enddo
    close(21)
    endif

  end block

  !! ----------------------------------------------------------------------- !!
  block

    deallocate( eta )
    deallocate( zmax )
    deallocate( mm  )
    deallocate( nn  )
    deallocate( hh  )
    deallocate( hm  )
    deallocate( hn  )
    deallocate( fh  )
    deallocate( fm  )
    deallocate( fn  )
    deallocate( x, y )
    deallocate( ist, jst, xst, yst )
    deallocate( wav )
    deallocate( g1x, g2x, g1y, g2y )
    deallocate( eta_x )
    deallocate( c1x, c2x, c3x )
    deallocate( c1y, c2y, c3y )
    deallocate( theta, thetal )
  end block

end program ldw
!! ------------------------------------------------------------------------- !!


subroutine abcoefs

!      coefficients for the Adams-Bashforth scheme

use grid

implicit none

real alpha, beta

if(nstep.ge.3.and.nadams.eq.3.or.nrestart.eq.2) then
  alpha = dt3(nb) / dt3(na)
  beta = dt3(nc) / dt3(na)
  ct = (2.+3.* alpha) / (6.* (alpha + beta) * beta)
  bt = -(1.+2.*(alpha + beta) * ct)/(2. * alpha)
  at = 1. - bt - ct
else if(nstep.ge.2) then
  at = 3./2.
  bt = -1./2.
  ct = 0.
else
  at = 1.
  bt = 0.
  ct = 0.
end if

end subroutine abcoefs